diff --git a/CMakeLists.txt b/CMakeLists.txt index 21743620db..40a1b5c70a 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -3,8 +3,22 @@ # See https://llvm.org/LICENSE.txt for license information. # SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception # +# +# Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +# Notified per clause 4(b) of the license. +# +# Last Modified: May 2020 +# cmake_minimum_required(VERSION 2.8) +cmake_policy(SET CMP0057 NEW) + +if(${ENABLE_DEVEL_PACKAGE}) + set(DEVEL_PACKAGE "devel/") +endif() +if(${ENABLE_RUN_PACKAGE}) + set(RUN_PACKAGE "runtime/") +endif() # In order to bootstrap the runtime library we need to skip # CMake's Fortran tests @@ -53,7 +67,9 @@ set(CMAKE_HOST_SYSTEM_PROCESSOR ${TARGET_ARCHITECTURE}) # standalone project, using LLVM as an external library: if( CMAKE_SOURCE_DIR STREQUAL CMAKE_CURRENT_SOURCE_DIR ) project(Flang) - + # Set default libdir to be "lib" for ROCm, distros will override this anyway: + set(CMAKE_INSTALL_LIBDIR "lib" CACHE STRING "Library install directory") + include(GNUInstallDirs) # Rely on llvm-config. set(CONFIG_OUTPUT) @@ -68,8 +84,7 @@ if( CMAKE_SOURCE_DIR STREQUAL CMAKE_CURRENT_SOURCE_DIR ) "--bindir" "--libdir" "--includedir" - "--prefix" - "--src-root") + "--prefix") execute_process( COMMAND ${CONFIG_COMMAND} RESULT_VARIABLE HAD_ERROR @@ -133,6 +148,9 @@ if( CMAKE_SOURCE_DIR STREQUAL CMAKE_CURRENT_SOURCE_DIR ) option(LLVM_INSTALL_TOOLCHAIN_ONLY "Only include toolchain files in the 'install' target." OFF) + option(LLVM_INSTALL_RUNTIME + "Build and install the flang runtime. Do this last" OFF) + option(LLVM_FORCE_USE_OLD_HOST_TOOLCHAIN "Set to ON to force using an old, unsupported host toolchain." OFF) @@ -172,6 +190,8 @@ Please install Python or specify the PYTHON_EXECUTABLE CMake variable.") set(LLVM_UTILS_PROVIDED ON) endif() + if (NOT LLVM_INSTALL_RUNTIME) + if(EXISTS ${LLVM_MAIN_SRC_DIR}/utils/lit/lit.py) set(LLVM_LIT ${LLVM_MAIN_SRC_DIR}/utils/lit/lit.py) if(NOT LLVM_UTILS_PROVIDED) @@ -181,6 +201,7 @@ Please install Python or specify the PYTHON_EXECUTABLE CMake variable.") set(LLVM_UTILS_PROVIDED ON) set(FLANG_TEST_DEPS FileCheck count not) endif() + endif() #set(UNITTEST_DIR ${LLVM_MAIN_SRC_DIR}/utils/unittest) #if(EXISTS ${UNITTEST_DIR}/googletest/include/gtest/gtest.h # AND NOT EXISTS ${LLVM_LIBRARY_DIR}/${CMAKE_STATIC_LIBRARY_PREFIX}gtest${CMAKE_STATIC_LIBRARY_SUFFIX} @@ -276,12 +297,14 @@ else() set(FLANG_HAS_VERSION_PATCHLEVEL 0) endif() +set(CMAKE_C_FLAGS "${CMAKE_C_FLAGS} -fcommon -Wno-implicit-function-declaration -Wno-implicit-int -Wno-int-conversion -Wno-enum-constexpr-conversion -Wno-incompatible-function-pointer-types -w") + # Add appropriate flags for GCC if (LLVM_COMPILER_IS_GCC_COMPATIBLE) - set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} -std=c++11 -fno-common -Woverloaded-virtual -Wcast-qual -fno-strict-aliasing -pedantic -Wno-long-long -Wall -W -Wno-unused-parameter -Wwrite-strings") + set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} -std=c++11 -fno-common -Woverloaded-virtual -Wcast-qual -fno-strict-aliasing -pedantic -Wno-long-long -Wall -W -Wno-unused-parameter -Wwrite-strings -g -DOMP_OFFLOAD_LLVM -Wno-implicit-function-declaration -Wno-implicit-int -Wno-enum-constexpr-conversion -Wno-incompatible-function-pointer-types -w") option(WITH_WERROR "Compile with '-Werror' C compiler flag" ON) if (WITH_WERROR) - set(CMAKE_C_FLAGS "${CMAKE_C_FLAGS} -Werror") + # set(CMAKE_C_FLAGS "${CMAKE_C_FLAGS} -Werror") endif () endif () @@ -289,6 +312,8 @@ if (APPLE) set(CMAKE_MODULE_LINKER_FLAGS "-Wl,-flat_namespace -Wl,-undefined -Wl,suppress") endif () +find_library(LIBQUADMATH_LOC quadmath NAMES libquadmath.so libquadmath.so.0 REQUIRED) + macro(add_flang_library name) llvm_process_sources(srcs ${ARGN}) if (MODULE) @@ -305,13 +330,13 @@ macro(add_flang_library name) endif( LLVM_COMMON_DEPENDS ) llvm_config( ${name} ${LLVM_LINK_COMPONENTS} ) - target_link_libraries( ${name} ${LLVM_COMMON_LIBS} ) + target_link_libraries( ${name} ${LLVM_COMMON_LIBS} ${LIBQUADMATH_LOC}) # link_system_libs( ${name} ) # getd of cmake warning messages install(TARGETS ${name} - LIBRARY DESTINATION lib${LLVM_LIBDIR_SUFFIX} - ARCHIVE DESTINATION lib${LLVM_LIBDIR_SUFFIX} - RUNTIME DESTINATION bin) + LIBRARY DESTINATION ${RUN_PACKAGE}${CMAKE_INSTALL_LIBDIR} + ARCHIVE DESTINATION ${RUN_PACKAGE}${CMAKE_INSTALL_LIBDIR} + RUNTIME DESTINATION ${DEVEL_PACKAGE}${CMAKE_INSTALL_BINDIR}) set_target_properties(${name} PROPERTIES FOLDER "Flang libraries") endmacro(add_flang_library) @@ -328,16 +353,18 @@ include_directories(BEFORE # Direct module files to build include directory set(CMAKE_Fortran_MODULE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/include) +if (FLANG_BUILD_RUNTIME) # Install Fortran module files install(DIRECTORY ${CMAKE_Fortran_MODULE_DIRECTORY}/ - DESTINATION include + DESTINATION ${DEVEL_PACKAGE}${CMAKE_INSTALL_INCLUDEDIR} ) +endif() # Install Fortran OpenMP include file # Copy omp_lib.h file, not the symlink get_filename_component(OMP_LIB_H_PATH ${CMAKE_CURRENT_SOURCE_DIR}/include/omp_lib.h REALPATH) install(FILES ${OMP_LIB_H_PATH} - DESTINATION include + DESTINATION ${DEVEL_PACKAGE}${CMAKE_INSTALL_INCLUDEDIR} ) add_definitions( -D_GNU_SOURCE ) @@ -353,6 +380,22 @@ mark_as_advanced(FLANG_EXECUTABLE_VERSION LIBFLANG_LIBRARY_VERSION) option(FLANG_LLVM_EXTENSIONS "enable the Flang LLVM extensions" OFF) +if ( FLANG_EXECUTABLE_VERSION ) + add_definitions( -DFLANG_VERSION="${FLANG_EXECUTABLE_VERSION} " ) + add_definitions( -DFLANG_VERSION_MAJOR="${FLANG_VERSION_MAJOR} " ) + add_definitions( -DFLANG_VERSION_MINOR="${FLANG_VERSION_MINOR} " ) +endif() +execute_process(COMMAND git log -1 --format=format:%H WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR} OUTPUT_VARIABLE FLANG_SHA RESULT_VARIABLE rc) + +if(NOT rc EQUAL "0") + add_definitions( -DFLANG_SHA="Flang Sha NULL ") + message("Warning: Unable to get Flang Sha. Return Code: ${rc} Flang Sha: NULL!!!") +else() + string(STRIP ${FLANG_SHA} FLANG_SHA) + message(STATUS "MY_VAR=${FLANG_SHA}") + add_definitions( -DFLANG_SHA="Flang Sha ${FLANG_SHA} ") +endif() + option(FLANG_INCLUDE_TESTS "Generate build targets for the Flang unit tests." ${LLVM_INCLUDE_TESTS}) @@ -367,11 +410,14 @@ set(FLANG_LIB_DIR ${CMAKE_CURRENT_BINARY_DIR}/lib) set(FLANG_RTE_LIB_DIR ${CMAKE_CURRENT_BINARY_DIR}/lib) add_definitions( -DPGFLANG ) -add_subdirectory(lib) -add_subdirectory(runtime) -add_subdirectory(utils) -add_subdirectory(tools) -#add_subdirectory(test) +if (LLVM_INSTALL_RUNTIME) + add_subdirectory(runtime) +else() + add_subdirectory(lib) + add_subdirectory(utils) + add_subdirectory(tools) + #add_subdirectory(test) +endif() #option(FLANG_BUILD_EXAMPLES "Build FLANG example programs by default." OFF) #if (FLANG_BUILD_EXAMPLES) @@ -386,6 +432,17 @@ if (FLANG_OPENMP_GPU_NVIDIA) add_definitions("-DOMP_OFFLOAD_LLVM") endif() +# AOCC Begin +option(FLANG_OPENMP_GPU_AMD "Enable OpenMP AMD Accelerator Offload." OFF) +if (FLANG_OPENMP_GPU_AMD) + add_definitions("-DOMP_OFFLOAD_AMD") +endif() + +if (FLANG_OPENMP_GPU_NVIDIA OR FLANG_OPENMP_GPU_AMD) + set(OMP_OFFLOADING_BUILD 1) +endif() +# AOCC End + if( FLANG_INCLUDE_TESTS ) # if(EXISTS ${LLVM_MAIN_SRC_DIR}/utils/unittest/googletest/include/gtest/gtest.h) # add_subdirectory(unittests) diff --git a/docs/CMakeLists.txt b/docs/CMakeLists.txt index ec2bfd843d..6e9155e94e 100644 --- a/docs/CMakeLists.txt +++ b/docs/CMakeLists.txt @@ -93,7 +93,7 @@ if (LLVM_ENABLE_DOXYGEN) if (NOT LLVM_INSTALL_TOOLCHAIN_ONLY) install(DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/web/html - DESTINATION docs/html) + DESTINATION ${DEVEL_PACKAGE}docs/html) endif() endif() endif() diff --git a/include/flang/Error/errmsg-in.n b/include/flang/Error/errmsg-in.n index 28fa433202..2edb24d56b 100644 --- a/include/flang/Error/errmsg-in.n +++ b/include/flang/Error/errmsg-in.n @@ -4,6 +4,12 @@ .\" * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception .\" * .\" */ +.\"/* +.\" * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +.\" * Notified per clause 4(b) of the license. +.\" * +.\" * Last Modified: May 2020 +.\" */ .NS 23 "Error Messages" "Appendix II - " .af EN 001 \" define format for EN .de MS @@ -711,7 +717,7 @@ Messages 280-300 RESERVED for directive handling .MS W 281 "Directive ignored - $ $" .MS F 282 "#error $" This message appears when preprocessing a file and a #error line is reached. -.MS F 283 "#warning $" +.MS S 283 "#warning $" This message appears when preprocessing a file and a #warning line is reached. .MS W 284 "A statement with an HPF keyword must begin with $ - $" HPF keyword statements (like DISTRIBUTE, ALIGN) must appear on lines @@ -1333,6 +1339,8 @@ LAUNCH_BOUNDS is now allowed on ATTRIBUTES(DEVICE) or host subprograms. .MS E 552 "LAUNCH_BOUNDS() values must be positive" The LAUNCH_BOUNDS maximum number of threads and minimum grid size must be positive integer values. +.MS W 603 "Unsupported clause specified for the vector directive. Only the always/never clauses are supported." +.MS W 604 "Unsupported clause specified for the omp simd directive. The directive will be ignored." .MS S 901 "#elif after #else" A preprocessor #elif directive was found after a #else directive; only #endif is allowed in this context. @@ -1500,6 +1508,7 @@ A DO CONCURRENT or FORALL construct or statement may not specify an index name m .MS S 1061 "The definition of function return type of $ does not match its declaration type" .MS S 1062 "LOCAL_INIT variable does not have an outside variable of the same name - $" A DO CONCURRENT variable with LOCAL_INIT locality must have a host variable of the same name. +.MS S 1063 "Real number has a ‘q’ exponent and an explicit kind" Starting from 1100, Reserved for OpenMP GPU .MS S 1198 "OpenMP GPU - The feature is not implemented yet for the target device" .MS W 1199 "OpenMP GPU - \"$\" is ignored for the target device" @@ -1523,3 +1532,4 @@ Starting from 1100, Reserved for OpenMP GPU .MS S 1217 "Left hand side of polymorphic assignment must be allocatable - $" .MS S 1218 "$ statement may not appear in a BLOCK construct." .MS S 1219 "Unimplemented feature: $." +.MS W 1220 "$ is uninitialized at $" diff --git a/include/fp-folding.h b/include/fp-folding.h index 21b95fecb5..66279f74f2 100644 --- a/include/fp-folding.h +++ b/include/fp-folding.h @@ -23,6 +23,18 @@ * Note: The types have names like "float32_t" to distinguish them * from integers, while the routines use names like "real32" to * distinguish them from complex operations that might be added. + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * + * Added support for quad precision + * Last modified: Feb 2020 + * + * Support for nearest intrinsic + * Last modified: 01 March 2020 */ #ifndef FP_FOLDING_H_ @@ -72,7 +84,6 @@ enum fold_relation { enum fold_relation fold_real32_compare(const float32_t *x, const float32_t *y); enum fold_relation fold_real64_compare(const float64_t *x, const float64_t *y); -enum fold_relation fold_real128_compare(const float128_t *x, const float128_t *y); /* * Operations. These all return a status code. @@ -86,6 +97,8 @@ enum fold_status { FOLD_INEXACT = -4, }; +#ifdef FOLD_LDBL_128BIT +enum fold_relation fold_real128_compare(const float128_t *x, const float128_t *y); enum fold_status fold_int32_from_real32(int32_t *res, const float32_t *arg); enum fold_status fold_int64_from_real32(int64_t *res, const float32_t *arg); enum fold_status fold_uint64_from_real32(uint64_t *res, const float32_t *arg); @@ -104,6 +117,7 @@ enum fold_status fold_real32_divide(float32_t *res, const float32_t *x, const fl enum fold_status fold_real32_pow(float32_t *res, const float32_t *x, const float32_t *y); enum fold_status fold_real32_sin(float32_t *res, const float32_t *arg); enum fold_status fold_real32_cos(float32_t *res, const float32_t *arg); +enum fold_status fold_real32_cotan(float32_t *res, const float32_t *arg); enum fold_status fold_real32_tan(float32_t *res, const float32_t *arg); enum fold_status fold_real32_asin(float32_t *res, const float32_t *arg); enum fold_status fold_real32_acos(float32_t *res, const float32_t *arg); @@ -130,11 +144,17 @@ enum fold_status fold_real64_divide(float64_t *res, const float64_t *x, const fl enum fold_status fold_real64_pow(float64_t *res, const float64_t *x, const float64_t *y); enum fold_status fold_real64_sin(float64_t *res, const float64_t *arg); enum fold_status fold_real64_cos(float64_t *res, const float64_t *arg); +enum fold_status fold_real64_cotan(float64_t *res, const float64_t *arg); enum fold_status fold_real64_tan(float64_t *res, const float64_t *arg); enum fold_status fold_real64_asin(float64_t *res, const float64_t *arg); enum fold_status fold_real64_acos(float64_t *res, const float64_t *arg); enum fold_status fold_real64_atan(float64_t *res, const float64_t *arg); enum fold_status fold_real64_atan2(float64_t *res, const float64_t *x, const float64_t *y); +//AOCC Begin +enum fold_status fold_real32_nearest(float32_t *res, const float32_t *x, const float32_t *y); +enum fold_status fold_real64_nearest(float64_t *res, const float64_t *x, const float64_t *y); +enum fold_status fold_real128_nearest(float128_t *res, const float128_t *x, const float128_t *y); +//AOCC End enum fold_status fold_real64_exp(float64_t *res, const float64_t *arg); enum fold_status fold_real64_log(float64_t *res, const float64_t *arg); enum fold_status fold_real64_log10(float64_t *res, const float64_t *arg); @@ -156,6 +176,7 @@ enum fold_status fold_real128_divide(float128_t *res, const float128_t *x, const enum fold_status fold_real128_pow(float128_t *res, const float128_t *x, const float128_t *y); enum fold_status fold_real128_sin(float128_t *res, const float128_t *arg); enum fold_status fold_real128_cos(float128_t *res, const float128_t *arg); +enum fold_status fold_real128_cotan(float128_t *res, const float128_t *arg); enum fold_status fold_real128_tan(float128_t *res, const float128_t *arg); enum fold_status fold_real128_asin(float128_t *res, const float128_t *arg); enum fold_status fold_real128_acos(float128_t *res, const float128_t *arg); @@ -164,6 +185,40 @@ enum fold_status fold_real128_atan2(float128_t *res, const float128_t *x, const enum fold_status fold_real128_exp(float128_t *res, const float128_t *arg); enum fold_status fold_real128_log(float128_t *res, const float128_t *arg); enum fold_status fold_real128_log10(float128_t *res, const float128_t *arg); +// AOCC begin +// To support quad precision REAL128 type +#else +enum fold_relation fold_real128_compare(const __float128 *x, const __float128 *y); +enum fold_status fold_int32_from_real128(int32_t *res, const __float128 *arg); +enum fold_status fold_int64_from_real128(int64_t *res, const __float128 *arg); +enum fold_status fold_uint32_from_real128(uint32_t *res, const __float128 *arg); +enum fold_status fold_uint64_from_real128(uint64_t *res, const __float128 *arg); +enum fold_status fold_real128_from_int64(__float128 *res, const int64_t *arg); +enum fold_status fold_real128_from_uint64(__float128 *res, const uint64_t *arg); +enum fold_status fold_real128_from_real32(__float128 *res, const float32_t *arg); +enum fold_status fold_real128_from_real64(__float128 *res, const float64_t *arg); +enum fold_status fold_real128_negate(__float128 *res, const __float128 *arg); +enum fold_status fold_real128_abs(__float128 *res, const __float128 *arg); +enum fold_status fold_real128_sqrt(__float128 *res, const __float128 *arg); +enum fold_status fold_real128_add(__float128 *res, const __float128 *x, const __float128 *y); +enum fold_status fold_real128_subtract(__float128 *res, const __float128 *x, const __float128 *y); +enum fold_status fold_real128_multiply(__float128 *res, const __float128 *x, const __float128 *y); +enum fold_status fold_real128_divide(__float128 *res, const __float128 *x, const __float128 *y); +enum fold_status fold_real128_pow(__float128 *res, const __float128 *x, const __float128 *y); +enum fold_status fold_real128_sin(__float128 *res, const __float128 *arg); +enum fold_status fold_real128_cos(__float128 *res, const __float128 *arg); +enum fold_status fold_real128_cotan(__float128 *res, const __float128 *arg); +enum fold_status fold_real128_tan(__float128 *res, const __float128 *arg); +enum fold_status fold_real128_asin(__float128 *res, const __float128 *arg); +enum fold_status fold_real128_acos(__float128 *res, const __float128 *arg); +enum fold_status fold_real128_atan(__float128 *res, const __float128 *arg); +enum fold_status fold_real128_atan2(__float128 *res, const __float128 *x, const __float128 *y); +enum fold_status fold_real128_nearest(__float128 *res, const __float128 *x, const __float128 *y); +enum fold_status fold_real128_exp(__float128 *res, const __float128 *arg); +enum fold_status fold_real128_log(__float128 *res, const __float128 *arg); +enum fold_status fold_real128_log10(__float128 *res, const __float128 *arg); +#endif +// AOCC end #ifdef __cplusplus } diff --git a/include/legacy-folding-api.h b/include/legacy-folding-api.h index f636683c97..5318b9a387 100644 --- a/include/legacy-folding-api.h +++ b/include/legacy-folding-api.h @@ -4,6 +4,17 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * + * Added support for quad precision + * Last modified: Feb 2020 + * + * Support for "nearest" intrinsic + * Last modified: Feb 2020 + */ /** \file * \brief Legacy constant folding API. * @@ -58,6 +69,8 @@ void fperror(int errcode); #define mftof(mf,f) (*((float *)&(f))=(mf)) void xdtomd(IEEE64 d, double *md); void xmdtod(double md, IEEE64 d); +void xqtomq(IEEE128 q, __float128 *mq); +void xmqtoq(__float128 mq, IEEE128 q); int cmp64(DBLINT64 arg1, DBLINT64 arg2); int ucmp64(DBLUINT64 arg1, DBLUINT64 arg2); @@ -149,6 +162,7 @@ void xesub(IEEE80 e1, IEEE80 e2, IEEE80 r); void xddsub(IEEE6464 dd1, IEEE6464 dd2, IEEE6464 r); void xqsub(IEEE128 q1, IEEE128 q2, IEEE128 r); int xdisint(IEEE64 d, int *r); +int xqisint(IEEE64 d, int *r); // AOCC void xfneg(IEEE32 f1, IEEE32 *r); void xdneg(IEEE64 d1, IEEE64 r); void xeneg(IEEE80 e1, IEEE80 r); @@ -173,6 +187,7 @@ void xdabsv(IEEE64 f, IEEE64 r); void xeabsv(IEEE80 e, IEEE80 r); void xddabsv(IEEE6464 dd, IEEE6464 r); void xqabsv(IEEE128 f, IEEE128 r); +void xqsqrt(IEEE128 f, IEEE128 r); // AOCC void xdsqrt(IEEE64 f, IEEE64 r); void xfpow(IEEE32 f1, IEEE32 f2, IEEE32 *r); void xdpow(IEEE64 d1, IEEE64 d2, IEEE64 r); @@ -189,6 +204,9 @@ void xdcos(IEEE64 , IEEE64 ); void xecos(IEEE80 , IEEE80 ); void xddcos(IEEE6464, IEEE6464); void xqcos(IEEE128, IEEE128 ); +void xfcotan(IEEE32 , IEEE32 *); +void xdcotan(IEEE64 , IEEE64 ); +void xqcotan(IEEE128, IEEE128 ); void xftan(IEEE32 , IEEE32 *); void xdtan(IEEE64 , IEEE64 ); void xetan(IEEE80 , IEEE80 ); @@ -211,9 +229,11 @@ void xddatan(IEEE6464, IEEE6464); void xqatan (IEEE128, IEEE128 ); void xfatan2(IEEE32 , IEEE32 , IEEE32 *); void xdatan2(IEEE64 , IEEE64 , IEEE64 ); +void xdnearest(IEEE64 , IEEE64 , IEEE64); //AOCC void xeatan2(IEEE80 , IEEE80 , IEEE80 ); void xddatan2(IEEE6464, IEEE6464, IEEE6464); void xqatan2(IEEE128, IEEE128, IEEE128 ); +void xqnearest(IEEE128 , IEEE128 , IEEE128); //AOCC void xfexp (IEEE32 , IEEE32 *); void xdexp (IEEE64 , IEEE64 ); void xeexp (IEEE80 , IEEE80 ); @@ -229,6 +249,7 @@ void xdlog10 (IEEE64 , IEEE64 ); void xelog10 (IEEE80 , IEEE80 ); void xddlog10(IEEE6464, IEEE6464); void xqlog10 (IEEE128, IEEE128 ); +void xfnearest(IEEE32 , IEEE32 , IEEE32 *); //AOCC void xffloat(INT i, IEEE32 *f); void xdfloat(INT i, IEEE64 d); diff --git a/lib/ArgParser/arg_parser.c b/lib/ArgParser/arg_parser.c index 58301a4cb6..981faffe13 100644 --- a/lib/ArgParser/arg_parser.c +++ b/lib/ArgParser/arg_parser.c @@ -16,6 +16,7 @@ #include #include #include +#include /** \brief Internal representation of argument parser */ struct arg_parser_ { @@ -310,7 +311,12 @@ parse_arguments(const arg_parser_t *parser, int argc, char **argv) if (!parser->input_file_name_ptr) { interr("Input file name is not registered", 0, ERR_Fatal); } - + // Display version sha and exit + extern char *flang_version_sha; + if (argv[1] && strcmp(argv[1],"--version") == 0) { + fprintf(stderr, "%s\n", flang_version_sha); + exit(0); + } /* First grab the source file name */ if (*argv[1] != '-') { *parser->input_file_name_ptr = argv[1]; diff --git a/lib/scutil/host-fp-folding.c b/lib/scutil/host-fp-folding.c index c28a2dc855..17f182666e 100644 --- a/lib/scutil/host-fp-folding.c +++ b/lib/scutil/host-fp-folding.c @@ -4,6 +4,17 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * + * Added support for quad precision + * Last modified: Feb 2020 + * + * Support for "nearest" intrinsic + * Last modified: Feb 2020 + */ /** \file * \brief Implement floating-point folding with host arithmetic * @@ -116,11 +127,13 @@ fold_real64_compare(const float64_t *x, const float64_t *y) COMPARE_BODY } +#ifdef FOLD_LDBL_128BIT enum fold_relation fold_real128_compare(const float128_t *x, const float128_t *y) { COMPARE_BODY } +#endif /* * Set up the floating-point environment so that exceptional conditions @@ -248,15 +261,6 @@ fold_real32_from_real64(float32_t *res, const float64_t *arg) return check_and_restore_floating_point_environment(&saved_fenv); } -enum fold_status -fold_real32_from_real128(float32_t *res, const float128_t *arg) -{ - fenv_t saved_fenv; - set_up_floating_point_environment(&saved_fenv); - *res = *arg; - return check_and_restore_floating_point_environment(&saved_fenv); -} - enum fold_status fold_real32_negate(float32_t *res, const float32_t *arg) { @@ -347,6 +351,15 @@ fold_real32_cos(float32_t *res, const float32_t *arg) return check_and_restore_floating_point_environment(&saved_fenv); } +enum fold_status +fold_real32_cotan(float32_t *res, const float32_t *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = 1.0/tanf(*arg); + return check_and_restore_floating_point_environment(&saved_fenv); +} + enum fold_status fold_real32_tan(float32_t *res, const float32_t *arg) { @@ -418,7 +431,16 @@ fold_real32_log10(float32_t *res, const float32_t *arg) *res = log10f(*arg); return check_and_restore_floating_point_environment(&saved_fenv); } - +//AOCC Begin +enum fold_status +fold_real32_nearest(float32_t *res, const float32_t *x, const float32_t *y) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = (*x) + (*y * 1.0/100000.0); + return check_and_restore_floating_point_environment(&saved_fenv); +} +//AOCC End /* 64-bit */ enum fold_status @@ -484,15 +506,6 @@ fold_real64_from_real32(float64_t *res, const float32_t *arg) return check_and_restore_floating_point_environment(&saved_fenv); } -enum fold_status -fold_real64_from_real128(float64_t *res, const float128_t *arg) -{ - fenv_t saved_fenv; - set_up_floating_point_environment(&saved_fenv); - *res = *arg; - return check_and_restore_floating_point_environment(&saved_fenv); -} - enum fold_status fold_real64_negate(float64_t *res, const float64_t *arg) { @@ -583,6 +596,15 @@ fold_real64_cos(float64_t *res, const float64_t *arg) return check_and_restore_floating_point_environment(&saved_fenv); } +enum fold_status +fold_real64_cotan(float64_t *res, const float64_t *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = 1.0/tan(*arg); + return check_and_restore_floating_point_environment(&saved_fenv); +} + enum fold_status fold_real64_tan(float64_t *res, const float64_t *arg) { @@ -628,6 +650,17 @@ fold_real64_atan2(float64_t *res, const float64_t *x, const float64_t *y) return check_and_restore_floating_point_environment(&saved_fenv); } +//AOCC Begin +enum fold_status +fold_real64_nearest(float64_t *res, const float64_t *x, const float64_t *y) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = (*x) + (*y * 1.0/100000.0); + return check_and_restore_floating_point_environment(&saved_fenv); +} +//AOCC End + enum fold_status fold_real64_exp(float64_t *res, const float64_t *arg) { @@ -657,6 +690,7 @@ fold_real64_log10(float64_t *res, const float64_t *arg) /* 80, 64+64, or 128-bit */ +#ifdef FOLD_LDBL_128BIT enum fold_status fold_int32_from_real128(int32_t *res, const float128_t *arg) { @@ -819,6 +853,15 @@ fold_real128_cos(float128_t *res, const float128_t *arg) return check_and_restore_floating_point_environment(&saved_fenv); } +enum fold_status +fold_real128_cotan(float128_t *res, const float128_t *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = 1.0/tanl(*arg); + return check_and_restore_floating_point_environment(&saved_fenv); +} + enum fold_status fold_real128_tan(float128_t *res, const float128_t *arg) { @@ -863,6 +906,16 @@ fold_real128_atan2(float128_t *res, const float128_t *x, const float128_t *y) *res = atan2l(*x, *y); return check_and_restore_floating_point_environment(&saved_fenv); } +//AOCC Begin +enum fold_status +fold_real128_nearest(float128_t *res, const float128_t *x, const float128_t *y) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = (*x) + (*y * 1.0/100000.0); + return check_and_restore_floating_point_environment(&saved_fenv); +} +//AOCC End enum fold_status fold_real128_exp(float128_t *res, const float128_t *arg) @@ -890,3 +943,305 @@ fold_real128_log10(float128_t *res, const float128_t *arg) *res = log10l(*arg); return check_and_restore_floating_point_environment(&saved_fenv); } + +enum fold_status +fold_real32_from_real128(float32_t *res, const float128_t *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = *arg; + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_real64_from_real128(float64_t *res, const float128_t *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = *arg; + return check_and_restore_floating_point_environment(&saved_fenv); +} + +// AOCC begin +// To support quad precision REAL128 type +#else +enum fold_relation +fold_real128_compare(const __float128 *x, const __float128 *y) +{ + COMPARE_BODY +} + +enum fold_status +fold_int32_from_real128(int32_t *res, const __float128 *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = *arg; + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_int64_from_real128(int64_t *res, const __float128 *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = *arg; + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_uint32_from_real128(uint32_t *res, const __float128 *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = *arg; + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_uint64_from_real128(uint64_t *res, const __float128 *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = *arg; + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_real128_from_int64(__float128 *res, const int64_t *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = *arg; + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_real128_from_uint64(__float128 *res, const uint64_t *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = *arg; + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_real128_from_real32(__float128 *res, const float32_t *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = *arg; + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_real128_from_real64(__float128 *res, const float64_t *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = *arg; + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_real128_negate(__float128 *res, const __float128 *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = -*arg; + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_real128_abs(__float128 *res, const __float128 *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = fabsl(*arg); + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_real128_sqrt(__float128 *res, const __float128 *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = sqrtl(*arg); + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_real128_add(__float128 *res, const __float128 *x, const __float128 *y) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = *x + *y; + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_real128_subtract(__float128 *res, const __float128 *x, const __float128 *y) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = *x - *y; + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_real128_multiply(__float128 *res, const __float128 *x, const __float128 *y) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = *x * *y; + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_real128_divide(__float128 *res, const __float128 *x, const __float128 *y) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = *x / *y; + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_real128_pow(__float128 *res, const __float128 *x, const __float128 *y) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = powl(*x, *y); + return check_and_restore_floating_point_environment(&saved_fenv); +} +enum fold_status +fold_real128_sin(__float128 *res, const __float128 *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = sinl(*arg); + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_real128_cos(__float128 *res, const __float128 *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = cosl(*arg); + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_real128_cotan(__float128 *res, const __float128 *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = 1.0/tanl(*arg); + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_real128_tan(__float128 *res, const __float128 *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = tanl(*arg); + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_real128_asin(__float128 *res, const __float128 *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = asinl(*arg); + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_real128_acos(__float128 *res, const __float128 *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = acosl(*arg); + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_real128_atan(__float128 *res, const __float128 *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = atanl(*arg); + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_real128_atan2(__float128 *res, const __float128 *x, const __float128 *y) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = atan2l(*x, *y); + return check_and_restore_floating_point_environment(&saved_fenv); +} + +//AOCC Begin +enum fold_status +fold_real128_nearest(__float128 *res, const __float128 *x, const __float128 *y) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = *x + ((*y) * 1.0/10000000000000000000000.0); + return check_and_restore_floating_point_environment(&saved_fenv); +} +//AOCC End + +enum fold_status +fold_real128_exp(__float128 *res, const __float128 *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = expl(*arg); + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_real128_log(__float128 *res, const __float128 *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = logl(*arg); + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_real128_log10(__float128 *res, const __float128 *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = log10l(*arg); + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_real32_from_real128(float32_t *res, const __float128 *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = *arg; + return check_and_restore_floating_point_environment(&saved_fenv); +} + +enum fold_status +fold_real64_from_real128(float64_t *res, const __float128 *arg) +{ + fenv_t saved_fenv; + set_up_floating_point_environment(&saved_fenv); + *res = *arg; + return check_and_restore_floating_point_environment(&saved_fenv); +} + + +// AOCC end +#endif diff --git a/lib/scutil/legacy-folding-api.c b/lib/scutil/legacy-folding-api.c index 2b9c58317e..9281e4cbe4 100644 --- a/lib/scutil/legacy-folding-api.c +++ b/lib/scutil/legacy-folding-api.c @@ -4,6 +4,16 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + * Support for "nearest" intrinsic + * Last modified: 01 March 2020 + */ /** \file * \brief Implement legacy folding interfaces * @@ -21,6 +31,7 @@ * implementation is new, and comprises mostly conversions between * the operand and result types of these legacy interfaces and those * of the underlying integer and floating-point folding packages. + * */ #include "legacy-folding-api.h" @@ -32,6 +43,7 @@ #include #include #include +#include // AOCC #include #include #include @@ -690,6 +702,15 @@ xfcos(IEEE32 f, IEEE32 *r) wrap_f(r, &x); } +void +xfcotan(IEEE32 f, IEEE32 *r) +{ + float32_t x, y; + unwrap_f(&y, &f); + check(fold_real32_cotan(&x, &y)); + wrap_f(r, &x); +} + void xftan(IEEE32 f, IEEE32 *r) { @@ -762,7 +783,17 @@ xflog10(IEEE32 f, IEEE32 *r) check(fold_real32_log10(&x, &y)); wrap_f(r, &x); } - +//AOCC Begin +void +xfnearest(IEEE32 f1, IEEE32 f2, IEEE32 *r) +{ + float32_t x, y, z; + unwrap_f(&y, &f1); + unwrap_f(&z, &f2); + check(fold_real32_nearest(&x, &y, &z)); + wrap_f(r, &x); +} +//AOCC End int xfcmp(IEEE32 f1, IEEE32 f2) { @@ -814,6 +845,10 @@ get_literal(char *buffer, size_t length, const char *s, int n, bool is_hex) --n; if (!is_hex && (ch == 'd' || ch == 'D')) ch = 'e'; + // AOCC begin + if (!is_hex && (ch == 'q' || ch == 'Q')) + ch = 'e'; + // AOCC end *p++ = ch; --length; } @@ -1066,6 +1101,15 @@ xdcos(IEEE64 d, IEEE64 r) wrap_d(r, &x); } +void +xdcotan(IEEE64 d, IEEE64 r) +{ + float64_t x, y; + unwrap_d(&y, d); + check(fold_real64_cotan(&x, &y)); + wrap_d(r, &x); +} + void xdtan(IEEE64 d, IEEE64 r) { @@ -1112,6 +1156,18 @@ xdatan2(IEEE64 d1, IEEE64 d2, IEEE64 r) wrap_d(r, &x); } +//AOCC Begin +void +xdnearest(IEEE64 d1, IEEE64 d2, IEEE64 r) +{ + float64_t x, y, z; + unwrap_d(&y, d1); + unwrap_d(&z, d2); + check(fold_real64_nearest(&x, &y, &z)); + wrap_d(r, &x); +} +//AOCC End + void xdexp(IEEE64 d, IEEE64 r) { @@ -1881,7 +1937,7 @@ static void unwrap_q(float128_t *x, IEEE128 q) { union { - float128_t x; + float128_t x; uint32_t i[4]; } u; int le = (int) is_host_little_endian() * 3; @@ -2071,7 +2127,7 @@ xqdiv(IEEE128 q1, IEEE128 q2, IEEE128 r) } void -xqabs(IEEE128 q, IEEE128 r) +xqabsv(IEEE128 q, IEEE128 r) { float128_t x, y; unwrap_q(&y, q); @@ -2094,8 +2150,8 @@ xqpow(IEEE128 q1, IEEE128 q2, IEEE128 r) float128_t x, y, z; unwrap_q(&x, q1); unwrap_q(&y, q2); - check(fold_real128_pow(&x, &y, &z)); - wrap_q(r, &x); + check(fold_real128_pow(&z, &x, &y)); + wrap_q(r, &z); } void @@ -2116,6 +2172,15 @@ xqcos(IEEE128 q, IEEE128 r) wrap_q(r, &x); } +void +xqcotan(IEEE128 q, IEEE128 r) +{ + float128_t x, y; + unwrap_q(&y, q); + check(fold_real128_cotan(&x, &y)); + wrap_q(r, &x); +} + void xqtan(IEEE128 q, IEEE128 r) { @@ -2162,6 +2227,18 @@ xqatan2(IEEE128 q1, IEEE128 q2, IEEE128 r) wrap_q(r, &x); } +//AOCC Begin +void +xqnearest(IEEE128 q1, IEEE128 q2, IEEE128 r) +{ + float128_t x, y, z; + unwrap_q(&y, q1); + unwrap_q(&z, q2); + check(fold_real128_nearest(&x, &y, &z)); + wrap_q(r, &x); +} +//AOCC End + void xqexp(IEEE128 q, IEEE128 r) { @@ -2223,7 +2300,395 @@ hxatoxq(const char *s, IEEE128 q, int n) { return parse_q(s, q, n, true); } -#endif /* FOLD_LDBL_128BIT */ +#else /* FOLD_LDBL_128BIT */ +// AOCC begin +// To support quad precision REAL128 type +static void +unwrap_q(__float128 *x, IEEE128 q) +{ + union { + __float128 x; + uint32_t i[4]; + } u; + int le = (int) is_host_little_endian() * 3; + u.i[le ^ 0] = q[0]; /* big end */ + u.i[le ^ 1] = q[1]; + u.i[le ^ 2] = q[2]; + u.i[le ^ 3] = q[3]; + *x = u.x; +} + +static void +wrap_q(IEEE128 res, __float128 *x) +{ + union { + __float128 q; + uint32_t i[4]; + } u; + int le = (int) is_host_little_endian() * 3; + u.i[0] = 0; u.i[1] =0; u.i[2]=0; u.i[3]= 0; + u.q = *x; + res[0] = u.i[le ^ 0]; /* big end */ + res[1] = u.i[le ^ 1]; + res[2] = u.i[le ^ 2]; + res[3] = u.i[le ^ 3]; +} + +void +xqfix(IEEE128 q, INT *i) +{ + __float128 y; + unwrap_q(&y, q); + check(fold_int32_from_real128(i, &y)); +} + +void +xqfixu(IEEE128 q, UINT *u) +{ + __float128 y; + unwrap_q(&y, q); + check(fold_uint32_from_real128(u, &y)); +} + +void +xqfix64(IEEE128 q, DBLINT64 l) +{ + int64_t x; + __float128 y; + unwrap_q(&y, q); + check(fold_int64_from_real128(&x, &y)); + wrap_l(l, &x); +} + +void +xqfixu64(IEEE128 q, DBLUINT64 u) +{ + uint64_t x; + __float128 y; + unwrap_q(&y, q); + check(fold_uint64_from_real128(&x, &y)); + wrap_l(u, &x); +} + +void +xqflt64(DBLINT64 l, IEEE128 q) +{ + __float128 x; + int64_t y; + unwrap_l(&y, l); + check(fold_real128_from_int64(&x, &y)); + wrap_q(q, &x); +} + +void +xqfloat(INT i, IEEE128 q) +{ + __float128 x; + int64_t li = i; + check(fold_real128_from_int64(&x, &li)); + wrap_q(q, &x); +} + +void +xqfloatu(UINT u, IEEE128 q) +{ + __float128 x; + int64_t li = u; + check(fold_real128_from_int64(&x, &li)); + wrap_q(q, &x); +} + +void +xqfltu64(DBLUINT64 u, IEEE128 q) +{ + __float128 x; + uint64_t y; + unwrap_u(&y, u); + check(fold_real128_from_uint64(&x, &y)); + wrap_q(q, &x); +} + +void +xftoq(IEEE32 f, IEEE128 q) +{ + __float128 x; + float32_t y; + unwrap_f(&y, &f); + check(fold_real128_from_real32(&x, &y)); + wrap_q(q, &x); +} + +void +xdtoq(IEEE64 d, IEEE128 q) +{ + __float128 x; + float64_t y; + unwrap_d(&y, d); + check(fold_real128_from_real64(&x, &y)); + wrap_q(q, &x); +} + +void +xqtof(IEEE128 q, IEEE32 *r) +{ + float32_t x; + __float128 y; + unwrap_q(&y, q); + check(fold_real32_from_real128(&x, &y)); + wrap_f(r, &x); +} + +void +xqtod(IEEE128 q, IEEE64 d) +{ + float64_t x; + __float128 y; + unwrap_q(&y, q); + check(fold_real64_from_real128(&x, &y)); + wrap_d(d, &x); +} + +void +xqadd(IEEE128 q1, IEEE128 q2, IEEE128 r) +{ + __float128 x, y, z; + unwrap_q(&x, q1); + unwrap_q(&y, q2); + check(fold_real128_add(&z, &x, &y)); + wrap_q(r, &z); +} + +void +xqsub(IEEE128 q1, IEEE128 q2, IEEE128 r) +{ + __float128 x, y, z; + unwrap_q(&x, q1); + unwrap_q(&y, q2); + check(fold_real128_subtract(&z, &x, &y)); + wrap_q(r, &z); +} + +void +xqneg(IEEE128 q, IEEE128 r) +{ + __float128 x, y; + unwrap_q(&y, q); + check(fold_real128_negate(&x, &y)); + wrap_q(r, &x); +} + +void +xqmul(IEEE128 q1, IEEE128 q2, IEEE128 r) +{ + __float128 x, y, z; + unwrap_q(&x, q1); + unwrap_q(&y, q2); + check(fold_real128_multiply(&z, &x, &y)); + wrap_q(r, &z); +} + +void +xqdiv(IEEE128 q1, IEEE128 q2, IEEE128 r) +{ + __float128 x, y, z; + unwrap_q(&x, q1); + unwrap_q(&y, q2); + check(fold_real128_divide(&z, &x, &y)); + wrap_q(r, &z); +} + +void +xqabsv(IEEE128 q, IEEE128 r) +{ + __float128 x, y; + unwrap_q(&y, q); + check(fold_real128_abs(&x, &y)); + wrap_q(r, &x); +} + +void +xqpow(IEEE128 q1, IEEE128 q2, IEEE128 r) +{ + __float128 x, y, z; + unwrap_q(&y, q1); + unwrap_q(&z, q2); + check(fold_real128_pow(&x, &y, &z)); + wrap_q(r, &x); +} + +void +xqsqrt(IEEE128 q, IEEE128 r) +{ + __float128 x, y; + unwrap_q(&y, q); + check(fold_real128_sqrt(&x, &y)); + wrap_q(r, &x); +} + +void +xqexp(IEEE128 q, IEEE128 r) +{ + __float128 x, y; + unwrap_q(&y, q); + check(fold_real128_exp(&x, &y)); + wrap_q(r, &x); +} + +int +xqcmp(IEEE128 q1, IEEE128 q2) +{ + __float128 y, z; + unwrap_q(&y, q1); + unwrap_q(&z, q2); + return fold_real128_compare(&y, &z); +} + +void +xqsin(IEEE128 q, IEEE128 r) +{ + __float128 x, y; + unwrap_q(&y, q); + check(fold_real128_sin(&x, &y)); + wrap_q(r, &x); +} + +void +xqcos(IEEE128 q, IEEE128 r) +{ + __float128 x, y; + unwrap_q(&y, q); + check(fold_real128_cos(&x, &y)); + wrap_q(r, &x); +} + +void +xqcotan(IEEE128 q, IEEE128 r) +{ + __float128 x, y; + unwrap_q(&y, q); + check(fold_real128_cotan(&x, &y)); + wrap_q(r, &x); +} + +void +xqtan(IEEE128 q, IEEE128 r) +{ + __float128 x, y; + unwrap_q(&y, q); + check(fold_real128_tan(&x, &y)); + wrap_q(r, &x); +} + +void +xqasin(IEEE128 q, IEEE128 r) +{ + __float128 x, y; + unwrap_q(&y, q); + check(fold_real128_asin(&x, &y)); + wrap_q(r, &x); +} + +void +xqacos(IEEE128 q, IEEE128 r) +{ + __float128 x, y; + unwrap_q(&y, q); + check(fold_real128_acos(&x, &y)); + wrap_q(r, &x); +} + +void +xqatan(IEEE128 q, IEEE128 r) +{ + __float128 x, y; + unwrap_q(&y, q); + check(fold_real128_atan(&x, &y)); + wrap_q(r, &x); +} + +void +xqatan2(IEEE128 q1, IEEE128 q2, IEEE128 r) +{ + __float128 x, y, z; + unwrap_q(&x, q1); + unwrap_q(&y, q2); + check(fold_real128_atan2(&x, &y, &z)); + wrap_q(r, &x); +} + +void +xqlog(IEEE128 q, IEEE128 r) +{ + __float128 x, y; + unwrap_q(&y, q); + check(fold_real128_log(&x, &y)); + wrap_q(r, &x); +} + +void +xqlog10(IEEE128 q, IEEE128 r) +{ + __float128 x, y; + unwrap_q(&y, q); + check(fold_real128_log10(&x, &y)); + wrap_q(r, &x); +} + +static int +parse_q(const char *s, IEEE128 q, int n, bool is_hex) +{ + __float128 x; + char buffer[256], *end; + int errno_capture; + get_literal(buffer, sizeof buffer, s, n, is_hex); + errno = 0; + x = strtoflt128(buffer, &end); + errno_capture = errno; + wrap_q(q, &x); + return handle_parsing_errors(buffer, end, errno_capture, x == 0); +} + +int +atoxq(const char *s, IEEE128 q, int n) +{ + return parse_q(s, q, n, false); +} + +void +xqnearest(IEEE128 q1, IEEE128 q2, IEEE128 r) +{ + __float128 x, y, z; + unwrap_q(&y, q1); + unwrap_q(&z, q2); + check(fold_real128_nearest(&x, &y, &z)); + wrap_q(r, &x); +} + +int +xqisint(IEEE128 q, int *i) +{ + __float128 x, y; + int64_t k; + unwrap_q(&x, q); + check(fold_int32_from_real128(i, &x)); + k = *i; + check(fold_real128_from_int64(&y, &k)); + return fold_real128_compare(&x, &y) == FOLD_EQ; +} + +void +xqtomq(IEEE128 q, __float128 *mq) +{ + unwrap_q(mq, q); +} + +void +xmqtoq(__float128 mq, IEEE128 q) +{ + wrap_q(q, &mq); +} +// AOCC end +#endif /* * Miscellaneous, possibly unused diff --git a/lib/scutil/path-utils.c b/lib/scutil/path-utils.c index c293fc7db1..d59e1023a7 100644 --- a/lib/scutil/path-utils.c +++ b/lib/scutil/path-utils.c @@ -60,6 +60,17 @@ fndpath(const char *target, char *path, size_t max_length, const char *dirlist) if (target_length == 0) return -1; + // check for absolute path + if (target[0] == '/') { + if (access(target, 0) == 0) { + char *p = path; + memcpy(p, target, target_length); + p[target_length] = '\0'; + return 0; /* path exists */ + } + return -1; + } + /* The legacy fndpath supplies a default dirlist of '.', which seems * unsafe. */ diff --git a/runtime/flang/CMakeLists.txt b/runtime/flang/CMakeLists.txt index 448b7173e9..ae6c5e014c 100644 --- a/runtime/flang/CMakeLists.txt +++ b/runtime/flang/CMakeLists.txt @@ -1,11 +1,32 @@ + # # Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. # See https://llvm.org/LICENSE.txt for license information. # SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception # +# + +# +# Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +# Notified per clause 4(b) of the license. +# +# AMD Support for DNORM intrinsic +# Date of Modification: 21st February 2019 +# +# [AMD] Support for Bit Sequence Comparsion intrinsic +# Month of Modification: May 2019 +# +# [AMD] Support for Bit Masking intrinsics. +# Month of Modification: May 2019 +#===----------------------------------------------------------------------===# + enable_language(C ASM Fortran) # Enable assembly and Fortran +if(${ENABLE_DEVEL_PACKAGE}) + set(DEVEL_PACKAGE "/devel/") +endif() + SET(ASM_OPTIONS "-DLINUX_ELF") SET(CMAKE_ASM_FLAGS "${CFLAGS} ${ASM_OPTIONS}" ) SET(CMAKE_SHARED_LINKER_FLAGS "-no-flang-libs") @@ -40,6 +61,7 @@ SET(FTN_INTRINSICS_DESC_INDEP delfilesqq3f.c derf3f.c derfc3f.c + deviceio_lib.F95 drandm3f.c dsecnds3f.c dtime3f.c @@ -114,6 +136,8 @@ SET(FTN_INTRINSICS_DESC_INDEP isnand3f.c isnanf3f.c itime3f.c + itrailz.c + itrailzi.c kabs.c kidim.c kill3f.c @@ -123,6 +147,7 @@ SET(FTN_INTRINSICS_DESC_INDEP kmin.c kpopcnt.c kpoppar.c + ktrailz.c link3f.c lnblnk3f.c loc3f.c @@ -243,6 +268,7 @@ SET(FTN_SUPPORT_DESC_INDEP fpcvt.c ftn.c ftnexit.c + gather_cmplx32.F95 gather_cmplx16.F95 gather_cmplx8.F95 gather_real4.F95 @@ -257,26 +283,32 @@ SET(FTN_SUPPORT_DESC_INDEP linux_dummy.c malloc.c misc.c + mmcmplx32.c mmcmplx16.c mmcmplx8.c mmreal4.c mmreal8.c + mnaxnb_cmplx32.F95 mnaxnb_cmplx16.F95 mnaxnb_cmplx8.F95 mnaxnb_real4.F95 mnaxnb_real8.F95 + mnaxtb_cmplx32.F95 mnaxtb_cmplx16.F95 mnaxtb_cmplx8.F95 mnaxtb_real4.F95 mnaxtb_real8.F95 + mtaxnb_cmplx32.F95 mtaxnb_cmplx16.F95 mtaxnb_cmplx8.F95 mtaxnb_real4.F95 mtaxnb_real8.F95 + mtaxtb_cmplx32.F95 mtaxtb_cmplx16.F95 mtaxtb_cmplx8.F95 mtaxtb_real4.F95 mtaxtb_real8.F95 + mvmul_cmplx32.F95 mvmul_cmplx16.F95 mvmul_cmplx8.F95 mvmul_real4.F95 @@ -287,6 +319,7 @@ SET(FTN_SUPPORT_DESC_INDEP rw.c scalar_copy.c stat_linux.c + transpose_cmplx32.F95 transpose_cmplx16.F95 transpose_cmplx8.F95 transpose_real4.F95 @@ -295,6 +328,7 @@ SET(FTN_SUPPORT_DESC_INDEP utils.c utilsi64.c version.c + vmmul_cmplx32.F95 vmmul_cmplx16.F95 vmmul_cmplx8.F95 vmmul_real4.F95 @@ -303,11 +337,13 @@ SET(FTN_SUPPORT_DESC_INDEP xfer.c init.c xfer_rpm1.c + cmplx_intrinsic_wrapper.c ) SET(FTN_SUPPORT_DESC_DEP aligned.c allo.c + bitwise.c comm.c copy.c cshift.c @@ -317,6 +353,7 @@ SET(FTN_SUPPORT_DESC_DEP descFioUtil.c descIntrins.c dist.c + dnormreal.c dynam.c eoshift.c fill.c @@ -325,6 +362,13 @@ SET(FTN_SUPPORT_DESC_DEP mget.c miscsup_com.c mmul.c + mmulcplx32.c + mmul_cplx32contmxm.F95 + mmul_cplx32contmxv.F95 + mmul_cplx32contvxm.F95 + mmul_cplx32str1.F95 + mmul_cplx32str1_t.F95 + mmulcplx32_t.c mmulcplx16.c mmul_cplx16contmxm.F95 mmul_cplx16contmxv.F95 @@ -389,6 +433,13 @@ SET(FTN_SUPPORT_DESC_DEP mmul_real8str1.F95 mmul_real8str1_t.F95 mmulreal8_t.c + mmulreal16.c + mmul_real16contmxm.F95 + mmul_real16contmxv.F95 + mmul_real16contvxm.F95 + mmul_real16str1.F95 + mmul_real16str1_t.F95 + mmulreal16_t.c nmlread.c nmlwrite.c nmlutil.c @@ -409,6 +460,15 @@ SET(FTN_SUPPORT_DESC_DEP set(I8_FILES_DIR I8_sources) separate_arguments(SEPARATED_CMAKE_Fortran_FLAGS NATIVE_COMMAND ${CMAKE_Fortran_FLAGS}) +if(EXISTS bin/flang1) + set(FLANG1_DEP bin/flang1) + set(FLANG2_DEP bin/flang2) +else() + # when just building runtime, flang1 flang2 binaries should have been installed + set(FLANG1_DEP ${CMAKE_INSTALL_PREFIX}${DEVEL_PACKAGE}/bin/flang1) + set(FLANG2_DEP ${CMAKE_INSTALL_PREFIX}${DEVEL_PACKAGE}/bin/flang2) +endif() + # Fortran files with macros as module names need to be preprocessed. # CMake has an internal Fortran parser that parses the module name, but it doesn't # consider macros which results in wrong dependencies. @@ -419,7 +479,7 @@ add_custom_command( > "${I8_FILES_DIR}/ieee_arithmetic.F95" COMMENT "Preprocessing ieee_arithmetic.F95" VERBATIM - DEPENDS flang1 flang2 + DEPENDS ${FLANG1_DEP} ${FLANG2_DEP} ) add_custom_command( @@ -429,7 +489,7 @@ add_custom_command( > "${I8_FILES_DIR}/ieee_exceptions.F95" COMMENT "Preprocessing ieee_exceptions.F95" VERBATIM - DEPENDS flang1 flang2 + DEPENDS ${FLANG1_DEP} ${FLANG2_DEP} ) add_custom_command( @@ -439,7 +499,7 @@ add_custom_command( COMMAND "${CMAKE_Fortran_COMPILER}" -E -DPGFLANG -cpp ${SEPARATED_CMAKE_Fortran_FLAGS} ${CMAKE_CURRENT_SOURCE_DIR}/norm2.F95 > "norm2_1.F95" VERBATIM - DEPENDS flang1 flang2 + DEPENDS ${FLANG1_DEP} ${FLANG2_DEP} ) # The files lists FTN_INTRINSICS_DESC_DEP and FTN_SUPPORT_DESC_DEP need to be compiled twice (with and without 'DESC_I8' compile definition). So an actual copy is made in a temp file on which this is done. @@ -557,6 +617,13 @@ set_source_files_properties( ## we need to help it # State the module that the source is producing +set_source_files_properties( + omp_lib.F95 + PROPERTIES + OBJECT_DEPENDS ${CMAKE_Fortran_MODULE_DIRECTORY}/iso_c_binding.mod + OBJECT_OUTPUTS ${CMAKE_Fortran_MODULE_DIRECTORY}/omp_lib.mod + ) + set_source_files_properties( iso_c_bind.F95 PROPERTIES @@ -628,14 +695,15 @@ target_include_directories(flang_shared # Make sure the compiler is built before we bootstrap add_dependencies(flang_static - flang1 - flang2 + ${FLANG1_DEP} + ${FLANG2_DEP} ) # Make sure the compiler is built before we bootstrap add_dependencies(flang_shared - flang1 - flang2 + flang_static + ${FLANG1_DEP} + ${FLANG2_DEP} ) target_compile_options(flang_static PRIVATE -fPIC) diff --git a/runtime/flang/alarm3f.c b/runtime/flang/alarm3f.c index bf65ac96c0..227829966d 100644 --- a/runtime/flang/alarm3f.c +++ b/runtime/flang/alarm3f.c @@ -11,12 +11,12 @@ #ifndef WINNT #include +#include #include "ent3f.h" /* extern void (*signal(int, void (*)(int)))(int); */ -extern int alarm(); int ENT3F(ALARM, alarm)(int *time, void (*proc)()) { diff --git a/runtime/flang/allo.c b/runtime/flang/allo.c index 18480b2504..304c3a9b45 100644 --- a/runtime/flang/allo.c +++ b/runtime/flang/allo.c @@ -11,6 +11,16 @@ * Runtime memory allocation routines */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * + * Changes to return allocation status + * Date of Modification: February 2020 + */ + + #include #include #include "stdioInterf.h" @@ -921,8 +931,11 @@ ENTF90(ALLOC03_CHKA, alloc03_chka)(__INT_T *nelem, __INT_T *kind, __INT_T *len, } else if (ISPRESENT(stat) && *firsttime) { *stat = 0; } + // AOCC Begin + __INT_T first_time=0; ENTF90(ALLOC03,alloc03)(nelem, kind, len, stat, pointer, offset, - firsttime,CADR(errmsg), CLEN(errmsg)); + &first_time,CADR(errmsg), CLEN(errmsg)); + // AOCC End } /* 32 bit CLEN version */ @@ -944,7 +957,7 @@ ENTF90(ALLOC04A, alloc04a)(__NELEM_T *nelem, __INT_T *kind, __INT_T *len, { ALLHDR(); - if (ISPRESENT(stat) && *firsttime && *stat != 2) + if (ISPRESENT(stat) && *firsttime) *stat = 0; if (!ISPRESENT(stat) && !*align) { @@ -992,8 +1005,11 @@ ENTF90(ALLOC04_CHKA, alloc04_chka)(__NELEM_T *nelem, __INT_T *kind, } else if (ISPRESENT(stat) && *firsttime) { *stat = 0; } - ENTF90(ALLOC04,alloc04)(nelem, kind, len, stat, pointer, offset, firsttime, + // AOCC Begin + __INT_T first_time=0; + ENTF90(ALLOC04,alloc04)(nelem, kind, len, stat, pointer, offset, &first_time, align, CADR(errmsg), CLEN(errmsg)); + // AOCC End } /* 32 bit CLEN version */ diff --git a/runtime/flang/assign.c b/runtime/flang/assign.c index 9e5dbebb60..0efc433ec5 100644 --- a/runtime/flang/assign.c +++ b/runtime/flang/assign.c @@ -4,6 +4,15 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ #include "global.h" #include diff --git a/runtime/flang/bcopys.c b/runtime/flang/bcopys.c index f8d4a208c7..739d42c83a 100644 --- a/runtime/flang/bcopys.c +++ b/runtime/flang/bcopys.c @@ -41,11 +41,12 @@ __fort_bcopysl(char *to, char *fr, size_t cnt, size_t tostr, size_t frstr, if (to < fr) { if ((n & ALIGNMASK(double)) == 0) { if (len == 2 * sizeof(double)) { + /*AOCC Begin tostr *= 2; frstr *= 2; + AOCC End*/ for (i = j = 0; cnt > 0; cnt--, i += tostr, j += frstr) { - ((double *)to)[i] = ((double *)fr)[j]; - ((double *)to)[i + 1] = ((double *)fr)[j + 1]; + ((__float128 *)to)[i] = ((__float128 *)fr)[j]; } return; } @@ -109,13 +110,14 @@ __fort_bcopysl(char *to, char *fr, size_t cnt, size_t tostr, size_t frstr, if ((n & ALIGNMASK(double)) == 0) { if (len == 2 * sizeof(double)) { - tostr *= 2; + /*AOCC Begin + tostr *= 2; frstr *= 2; i *= 2; j *= 2; + AOCC End*/ for (; cnt > 0; cnt--, i -= tostr, j -= frstr) { - ((double *)to)[i + 1] = ((double *)fr)[j + 1]; - ((double *)to)[i] = ((double *)fr)[j]; + ((__float128 *)to)[i] = ((__float128 *)fr)[j]; } return; } diff --git a/runtime/flang/bitwise.c b/runtime/flang/bitwise.c new file mode 100644 index 0000000000..d33e7398d1 --- /dev/null +++ b/runtime/flang/bitwise.c @@ -0,0 +1,114 @@ + +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Support for Bit Sequence Comparsion intrinsics. + * Month of Modification: May 2019 + * + * Support for Bit Masking intrinsics. + * Month of Modification: May 2019 + * + */ + +/* clang-format off */ + +/** \file + * \brief F90 BITWISE intrinsics for INT types + */ + +/* AOCC begin */ +#include "FuncArgMacros.h" +#include "fioMacros.h" + +#include + +/* returns the zero-extended, unsigned long casted, value of i which has nbits. + * Only works for nbits as 8 or 16 or 32 or 64. */ +static unsigned long zext_to_ul(unsigned long i, int nbits) { + unsigned long mask; + + if (nbits == 8) { + mask = 0xff; + } else if (nbits == 16) { + mask = 0xffff; + } else if (nbits == 32) { + mask = 0xffffffff; + } else if (nbits == 64) { + return i; + } + return ((unsigned long)i & mask); +} + +int ENTF90(BITCMP, bitcmp)(long *ptr_a, long *ptr_b, int *ptr_a_nbits, int *ptr_b_nbits) +{ + long a = *ptr_a; + long b = *ptr_b; + int a_nbits = *ptr_a_nbits; + int b_nbits = *ptr_b_nbits; + + unsigned long unsigned_a = zext_to_ul((unsigned long)a, a_nbits); + unsigned long unsigned_b = zext_to_ul((unsigned long)b, b_nbits); + long signed_a = (long)unsigned_a; + long signed_b = (long)unsigned_b; + + /* if only a has most-significant-bit set */ + if (signed_a < 0 && signed_b > 0) + return 1; + + /* if only b has most-significant-bit set */ + if (signed_a > 0 && signed_b < 0) + return -1; + + /* Slighly hacky way to get an unsigned long with MSB unset and every other + * bit set without using literally hand-written numbers that could violate + * portability */ + unsigned long msb_mask = ((unsigned long ) ULONG_MAX & LONG_MAX); + /* Ignore the most-significant-bit since they are the same for a and b */ + unsigned_a = unsigned_a & msb_mask; + unsigned_b = unsigned_b & msb_mask; + + if (unsigned_a == unsigned_b) + return 0; + + return unsigned_a > unsigned_b ? 1 : -1; +} + +unsigned long ENTF90(BITMASK, bitmask)(unsigned int *ptr_n, int *ptr_kind, int *ptr_is_left) { + unsigned long n = *ptr_n; + int kind = *ptr_kind; + int is_left = *ptr_is_left; + unsigned long ret = 0; + unsigned long mask_n = 0; + + if (kind == 1) { + mask_n = 0xff; + } else if (kind == 2) { + mask_n = 0xffff; + } else if (kind == 4) { + mask_n = 0xffffffff; + } else if (kind == 8) { + mask_n = 0xffffffffffffff; + } + + n = n & mask_n; + if (is_left) { + for (unsigned long i = ((kind * 8) - 1), j = 0; j < n; i--, j++) { + ret |= ((unsigned long) 0x1 << i); + } + + } else { + for (unsigned long i = 0; i < n; i++) { + ret |= ((unsigned long) 0x1 << i); + } + } + + return ret; +} +/* AOCC end */ diff --git a/runtime/flang/cmplx_intrinsic_wrapper.c b/runtime/flang/cmplx_intrinsic_wrapper.c new file mode 100644 index 0000000000..98621b2bf5 --- /dev/null +++ b/runtime/flang/cmplx_intrinsic_wrapper.c @@ -0,0 +1,170 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * Last Modified: June 2020 + * + * Added complex quad support for asin, asinh, acos, acosh, atan, atanh + * Last modified: 19th August 2020 + * + */ + +#include +#include + +__complex128 cqsqrt(__complex128 res, __float128 real, __float128 imag) +{ + __complex128 val; + __real__ val = real; + __imag__ val = imag; + return csqrtq(val); +} + +__complex128 cqsin(__complex128 res, __float128 real, __float128 imag) +{ + __complex128 val; + __real__ val = real; + __imag__ val = imag; + return csinq(val); +} + +__complex128 cqasin(__complex128 res, __float128 real, __float128 imag) +{ + __complex128 val; + __real__ val = real; + __imag__ val = imag; + return casinq(val); +} + +__complex128 cqasinh(__complex128 res, __float128 real, __float128 imag) +{ + __complex128 val; + __real__ val = real; + __imag__ val = imag; + return casinhq(val); +} + +__complex128 cqcos(__complex128 res, __float128 real, __float128 imag) +{ + __complex128 val; + __real__ val = real; + __imag__ val = imag; + return ccosq(val); +} + +__complex128 cqacos(__complex128 res, __float128 real, __float128 imag) +{ + __complex128 val; + __real__ val = real; + __imag__ val = imag; + return cacosq(val); +} + +__complex128 cqacosh(__complex128 res, __float128 real, __float128 imag) +{ + __complex128 val; + __real__ val = real; + __imag__ val = imag; + return cacoshq(val); +} + +__complex128 cqtan(__complex128 res, __float128 real, __float128 imag) +{ + __complex128 val; + __real__ val = real; + __imag__ val = imag; + return ctanq(val); +} + +__complex128 cqcotan(__complex128 res, __float128 real, __float128 imag) +{ + __complex128 val; + __real__ val = real; + __imag__ val = imag; + return 1/ctanq(val); +} + +__complex128 cqatan(__complex128 res, __float128 real, __float128 imag) +{ + __complex128 val; + __real__ val = real; + __imag__ val = imag; + return catanq(val); +} + +__complex128 cqatanh(__complex128 res, __float128 real, __float128 imag) +{ + __complex128 val; + __real__ val = real; + __imag__ val = imag; + return catanhq(val); +} + +__complex128 cqsinh(__complex128 res, __float128 real, __float128 imag) +{ + __complex128 val; + __real__ val = real; + __imag__ val = imag; + return csinhq(val); +} + +__complex128 cqcosh(__complex128 res, __float128 real, __float128 imag) +{ + __complex128 val; + __real__ val = real; + __imag__ val = imag; + return ccoshq(val); +} + +__complex128 cqtanh(__complex128 res, __float128 real, __float128 imag) +{ + __complex128 val; + __real__ val = real; + __imag__ val = imag; + return ctanhq(val); +} + +__complex128 cqexp(__complex128 res, __float128 real, __float128 imag) +{ + __complex128 val; + __real__ val = real; + __imag__ val = imag; + return cexpq(val); +} + +__complex128 cqlog(__complex128 res, __float128 real, __float128 imag) +{ + __complex128 val; + __real__ val = real; + __imag__ val = imag; + return clogq(val); +} + +__complex128 cqconj(__complex128 res, __float128 real, __float128 imag) +{ + __complex128 val; + __real__ val = real; + __imag__ val = imag; + return conjq(val); +} + +__float128 cqabs( __float128 real, __float128 imag) +{ + return hypotq (real, imag); +} + +__complex128 cqpow(__complex128 res, __float128 real1, __float128 imag1, + __float128 real2, __float128 imag2) +{ + __complex128 val1, val2; + __real__ val1 = real1; + __imag__ val1 = imag1; + __real__ val2 = real2; + __imag__ val2 = imag2; + return cpowq(val1, val2); +} diff --git a/runtime/flang/cplxf.c b/runtime/flang/cplxf.c index c40ecc42b3..74351a587e 100644 --- a/runtime/flang/cplxf.c +++ b/runtime/flang/cplxf.c @@ -36,6 +36,11 @@ typedef struct { double imag; } dcmplx_t; +typedef struct { + __float128 real; + __float128 imag; +} qcmplx_t; + void ENTF90(MERGEC, mergec)(cmplx_t *res, cmplx_t *tsource, cmplx_t *fsource, void *mask, __INT_T *size) { @@ -60,3 +65,15 @@ void ENTF90(MERGEDC, mergedc)(dcmplx_t *res, dcmplx_t *tsource, } } +void ENTF90(MERGEQC, mergeqc)(qcmplx_t *res, qcmplx_t *tsource, + qcmplx_t *fsource, void *mask, __INT_T *size) +{ + if (I8(__fort_varying_log)(mask, size)) { + res->real = tsource->real; + res->imag = tsource->imag; + } else { + res->real = fsource->real; + res->imag = fsource->imag; + } +} + diff --git a/runtime/flang/cshift.c b/runtime/flang/cshift.c index e2929e7bb0..fc865e7a9c 100644 --- a/runtime/flang/cshift.c +++ b/runtime/flang/cshift.c @@ -203,7 +203,7 @@ void ENTFTN(CSHIFTSC, cshiftsc)(DCHAR(rb), /* result char base */ void I8(cshift_loop)(void *rb, /* result base */ void *ab, /* array base */ - __INT_T *sb, /* shift base */ + __INT4_T *sb, /* shift base */ __INT_T shift_dim, /* dimension to shift */ F90_Desc *rs, /* result descriptor */ F90_Desc *as, /* array descriptor */ diff --git a/runtime/flang/dattype.h b/runtime/flang/dattype.h index 73327f88f4..728f7d3085 100644 --- a/runtime/flang/dattype.h +++ b/runtime/flang/dattype.h @@ -4,6 +4,14 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ /** * \file @@ -28,8 +36,11 @@ #define TY_NCHAR 16 #define TY_INT8 17 #define TY_LOG8 18 +#define TY_QCMPLX 19 -#define Is_complex(parm) ((parm) == TY_CMPLX || (parm) == TY_DCMPLX) -#define Is_real(parm) ((parm) == TY_REAL || (parm) == TY_DBLE) +// AOCC : TY_QCMPLX +#define Is_complex(parm) ((parm) == TY_CMPLX || (parm) == TY_DCMPLX || (parm) == TY_QCMPLX) +// AOCC : TY_QUAD +#define Is_real(parm) ((parm) == TY_REAL || (parm) == TY_DBLE || (param) == TY_QUAD) #define REAL_ALLOWED(param) ((Is_complex(param)) || Is_real(param)) diff --git a/runtime/flang/deviceio_lib.F95 b/runtime/flang/deviceio_lib.F95 new file mode 100644 index 0000000000..abc0613f95 --- /dev/null +++ b/runtime/flang/deviceio_lib.F95 @@ -0,0 +1,31 @@ +! f90print f90printi f90printf f90printd interfaces +! in module file f90deviceio +module f90deviceio + interface + subroutine f90print(N) + character(*) :: N + !$omp declare target (f90print) + end subroutine f90print + subroutine f90printi(N,i) + character(*) :: N + integer :: i + !$omp declare target (f90printi) + end subroutine f90printi + subroutine f90printl(N,i) + character(*) :: N + integer(8) :: i + !$omp declare target (f90printl) + end subroutine f90printl + subroutine f90printf(N,f) + character(*) :: N + real(4) :: f + !$omp declare target (f90printf) + end subroutine f90printf + subroutine f90printd(N,d) + character(*) :: N + real(8) :: d + !$omp declare target (f90printd) + end subroutine f90printd + end interface +end module + diff --git a/runtime/flang/dist.c b/runtime/flang/dist.c index 603040560c..7d06313a34 100644 --- a/runtime/flang/dist.c +++ b/runtime/flang/dist.c @@ -1541,7 +1541,7 @@ void ENTFTN(SECT, sect)(F90_Desc *d, F90_Desc *a, /* determine section rank - popcnt of flags bits */ -#if MAXDIMS != 7 +#if MAXDIMS != 15 /* AOCC */ __fort_abort("SECT: need to recode for different MAXDIMS"); #endif rank = (flags & 0x55) + (flags >> 1 & 0x15); @@ -1675,7 +1675,7 @@ void ENTF90(SECT, sect)(F90_Desc *d, F90_Desc *a, __INT_T *prank, /* determine section rank - popcnt of flags bits */ -#if MAXDIMS != 7 +#if MAXDIMS != 15 /* AOCC */ __fort_abort("SECT: need to recode for different MAXDIMS"); #endif rank = (flags & 0x55) + (flags >> 1 & 0x15); @@ -1759,7 +1759,7 @@ void ENTF90(SECT1, sect1)(F90_Desc *d, F90_Desc *a, __INT_T *prank, flags = *bfg; -#if MAXDIMS != 7 +#if MAXDIMS != 15 /* AOCC */ __fort_abort("SECT: need to recode for different MAXDIMS"); #endif /* determine section rank - popcnt of flags bits */ @@ -1914,7 +1914,7 @@ void ENTF90(SECT2, sect2)(F90_Desc *d, F90_Desc *a, __INT_T *prank, flags = *bfg; -#if MAXDIMS != 7 +#if MAXDIMS != 15 /* AOCC */ __fort_abort("SECT: need to recode for different MAXDIMS"); #endif /* determine section rank - popcnt of flags bits */ @@ -2080,7 +2080,7 @@ void ENTF90(SECT3, sect3)(F90_Desc *d, F90_Desc *a, __INT_T *prank, flags = *bfg; -#if MAXDIMS != 7 +#if MAXDIMS != 15 /* AOCC */ __fort_abort("SECT: need to recode for different MAXDIMS"); #endif /* determine section rank - popcnt of flags bits */ @@ -2271,7 +2271,7 @@ void ENTFTN(SECT3, sect3)(F90_Desc *d, F90_Desc *a, flags = *bfg; -#if MAXDIMS != 7 +#if MAXDIMS != 15 /* AOCC */ __fort_abort("SECT: need to recode for different MAXDIMS"); #endif /* determine section rank - popcnt of flags bits */ diff --git a/runtime/flang/dnormreal.c b/runtime/flang/dnormreal.c new file mode 100644 index 0000000000..7ee067c905 --- /dev/null +++ b/runtime/flang/dnormreal.c @@ -0,0 +1,220 @@ + +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * + * Support for DNORM intrinsic + * Date of Modification: 21st February 2019 + * + */ + +/* clang-format off */ + +/** \file + * \brief F90 NORM2 intrinsics for real*4 type and real*8 + */ + +// AOCC Begin +#include "stdioInterf.h" +#include "fioMacros.h" +#include "matmul.h" +#include + +void ENTF90(NORM2_REAL4, norm2_real4)(char *dest_addr, char *s1_addr, + F90_Desc *dest_desc, + F90_Desc *s1_desc) +{ + + __INT_T d_rank = F90_RANK_G(dest_desc); + __INT_T s1_rank = F90_RANK_G(s1_desc); + + __REAL4_T *s1_base; + __REAL4_T *dest_base; + + __INT_T s1_d1_lstride; + __INT_T s1_d1_sstride; + __INT_T s1_d1_lb; + __INT_T s1_d1_ub; + __INT_T s1_d1_soffset = 0; + + __INT_T s1_d2_lstride = 1; + __INT_T s1_d2_sstride = 1; + __INT_T s1_d2_lb = 0; + __INT_T s1_d2_soffset = 0; + + __INT_T d_d1_lstride; + __INT_T d_d1_sstride; + __INT_T d_d1_lb; + __INT_T d_d1_soffset = 0; + + __INT_T d_d2_lstride = 1; + __INT_T d_d2_sstride = 1; + __INT_T d_d2_lb = 0; + __INT_T d_d2_soffset = 0; + + __INT_T i; + + // Step 1: Calculate the base, requires sizes of each dimension + // Step 2: Get all the elements, calculate the value and store + s1_d1_lstride = F90_DIM_LSTRIDE_G(s1_desc, 0); + s1_d1_sstride = F90_DIM_SSTRIDE_G(s1_desc, 0); + + s1_d1_lb = F90_DIM_LBOUND_G(s1_desc, 0); + s1_d1_ub = F90_DIM_UBOUND_G(s1_desc, 0); + + if (s1_d1_sstride != 1 || F90_DIM_SOFFSET_G(s1_desc, 0)) + s1_d1_soffset = F90_DIM_SOFFSET_G(s1_desc, 0) + s1_d1_sstride - s1_d1_lb; + + if (s1_rank == 2) { + s1_d2_lstride = F90_DIM_LSTRIDE_G(s1_desc, 1); + s1_d2_lb = F90_DIM_LBOUND_G(s1_desc, 1); + s1_d2_sstride = F90_DIM_SSTRIDE_G(s1_desc, 1); + if (s1_d2_sstride != 1 || F90_DIM_SOFFSET_G(s1_desc, 1)) + s1_d2_soffset = F90_DIM_SOFFSET_G(s1_desc, 1) + s1_d2_sstride - s1_d2_lb; + } + + d_d1_lstride = F90_DIM_LSTRIDE_G(dest_desc, 0); + d_d1_lb = F90_DIM_LBOUND_G(dest_desc, 0); + d_d1_sstride = F90_DIM_SSTRIDE_G(dest_desc, 0); + if (d_d1_sstride != 1 || F90_DIM_SOFFSET_G(dest_desc, 0)) + d_d1_soffset = F90_DIM_SOFFSET_G(dest_desc, 0) + d_d1_sstride - d_d1_lb; + + s1_base = (__REAL4_T *)s1_addr + F90_LBASE_G(s1_desc) - 1; + + __INT_T d_lb; + __INT_T d_lstride; + for (i = 0; i < s1_rank; i++) { + d_lb = F90_DIM_LBOUND_G(s1_desc, i); + d_lstride = F90_DIM_LSTRIDE_G(s1_desc, i); + s1_base += d_lb * d_lstride; + } + + dest_base = (__REAL4_T *)dest_addr; + __REAL4_T dnorm = 0; + + if (s1_rank == 1) { + for(i = 0; i < s1_d1_ub; ++i) { + dnorm += s1_base[i] * s1_base[i]; + } + dnorm = sqrt(dnorm); + *dest_base = dnorm; + return; + } + + __INT_T u_bound; + __INT_T num_elements = 1; + for (i = 0; i < s1_rank; ++i) { + u_bound = F90_DIM_UBOUND_G(s1_desc, i); + num_elements *= u_bound; + } + for(i = 0; i < num_elements; ++i) { + dnorm += s1_base[i] * s1_base[i]; + } + dnorm = sqrt(dnorm); + *dest_base = dnorm; + +} + +/* + * norm2 for real*8 type + */ +void ENTF90(NORM2_REAL8, norm2_real8)(char *dest_addr, char *s1_addr, + F90_Desc *dest_desc, + F90_Desc *s1_desc) +{ + + __INT_T d_rank = F90_RANK_G(dest_desc); + __INT_T s1_rank = F90_RANK_G(s1_desc); + + __REAL8_T *s1_base; + __REAL8_T *dest_base; + + __INT_T s1_d1_lstride; + __INT_T s1_d1_sstride; + __INT_T s1_d1_lb; + __INT_T s1_d1_ub; + __INT_T s1_d1_soffset = 0; + + __INT_T s1_d2_lstride = 1; + __INT_T s1_d2_sstride = 1; + __INT_T s1_d2_lb = 0; + __INT_T s1_d2_soffset = 0; + + __INT_T d_d1_lstride; + __INT_T d_d1_sstride; + __INT_T d_d1_lb; + __INT_T d_d1_soffset = 0; + + __INT_T d_d2_lstride = 1; + __INT_T d_d2_sstride = 1; + __INT_T d_d2_lb = 0; + __INT_T d_d2_soffset = 0; + + __INT_T i; + + s1_d1_lstride = F90_DIM_LSTRIDE_G(s1_desc, 0); + s1_d1_sstride = F90_DIM_SSTRIDE_G(s1_desc, 0); + + s1_d1_lb = F90_DIM_LBOUND_G(s1_desc, 0); + s1_d1_ub = F90_DIM_UBOUND_G(s1_desc, 0); + + if (s1_d1_sstride != 1 || F90_DIM_SOFFSET_G(s1_desc, 0)) + s1_d1_soffset = F90_DIM_SOFFSET_G(s1_desc, 0) + s1_d1_sstride - s1_d1_lb; + + if (s1_rank == 2) { + s1_d2_lstride = F90_DIM_LSTRIDE_G(s1_desc, 1); + s1_d2_lb = F90_DIM_LBOUND_G(s1_desc, 1); + s1_d2_sstride = F90_DIM_SSTRIDE_G(s1_desc, 1); + if (s1_d2_sstride != 1 || F90_DIM_SOFFSET_G(s1_desc, 1)) + s1_d2_soffset = F90_DIM_SOFFSET_G(s1_desc, 1) + s1_d2_sstride - s1_d2_lb; + } + + d_d1_lstride = F90_DIM_LSTRIDE_G(dest_desc, 0); + d_d1_lb = F90_DIM_LBOUND_G(dest_desc, 0); + d_d1_sstride = F90_DIM_SSTRIDE_G(dest_desc, 0); + if (d_d1_sstride != 1 || F90_DIM_SOFFSET_G(dest_desc, 0)) + d_d1_soffset = F90_DIM_SOFFSET_G(dest_desc, 0) + d_d1_sstride - d_d1_lb; + + s1_base = (__REAL8_T *)s1_addr + F90_LBASE_G(s1_desc) - 1; + + __INT_T d_lb; + __INT_T d_lstride; + for (i = 0; i < s1_rank; i++) { + d_lb = F90_DIM_LBOUND_G(s1_desc, i); + d_lstride = F90_DIM_LSTRIDE_G(s1_desc, i); + s1_base += d_lb * d_lstride; + } + + dest_base = (__REAL8_T *)dest_addr; + __REAL4_T dnorm = 0; + + if (s1_rank == 1) { + for(i = 0; i < s1_d1_ub; ++i) { + dnorm += s1_base[i] * s1_base[i]; + } + dnorm = sqrt(dnorm); + *dest_base = dnorm; + return; + } + + __INT_T u_bound; + __INT_T num_elements = 1; + for (i = 0; i < s1_rank; ++i) { + u_bound = F90_DIM_UBOUND_G(s1_desc, i); + num_elements *= u_bound; + } + for(i = 0; i < num_elements; ++i) { + dnorm += s1_base[i] * s1_base[i]; + } + dnorm = sqrt(dnorm); + *dest_base = dnorm; +} + +// AOCC End diff --git a/runtime/flang/eoshift.c b/runtime/flang/eoshift.c index 0c5309ef24..b9daa9c8c7 100644 --- a/runtime/flang/eoshift.c +++ b/runtime/flang/eoshift.c @@ -236,7 +236,7 @@ static void I8(eoshift_scalar)(char *rb, /* result base */ static void I8(eoshift_loop)(char *rb, /* result base */ char *ab, /* array base */ - __INT_T *sb, /* shift base */ + __INT4_T *sb, /* shift base */ char *bb, /* boundary base */ __INT_T shift_dim, /* dimension to shift */ F90_Desc *rs, /* result descriptor */ @@ -308,11 +308,10 @@ static void I8(eoshift_loop)(char *rb, /* result base */ if (loop_dim > 1) I8(eoshift_loop)(rb, ab, sb, bb, shift_dim, rs, as, ss, bs, rc, ac, soff, boff, loop_dim-1); - else - + else I8(eoshift_scalar)(rb, ab, sb[soff], bb + boff*F90_LEN_G(bs), shift_dim, rs, as, rc, ac, 1); - + /* restore descriptor fields */ F90_FLAGS_P(ac, aflags); diff --git a/runtime/flang/fioMacros.h b/runtime/flang/fioMacros.h index 57eb06f312..427b741489 100644 --- a/runtime/flang/fioMacros.h +++ b/runtime/flang/fioMacros.h @@ -4,6 +4,12 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified: May 2020 + */ /* clang-format off */ @@ -506,7 +512,7 @@ extern int __fort_entry_mflag; /* maximum number of fortran array dimensions */ -#define MAXDIMS 7 +#define MAXDIMS 15 /* AOCC */ /* generic all-dimensions bit mask */ diff --git a/runtime/flang/fmtconv.c b/runtime/flang/fmtconv.c index b572f583fc..c085211994 100644 --- a/runtime/flang/fmtconv.c +++ b/runtime/flang/fmtconv.c @@ -5,6 +5,15 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ + /** \file * \brief Utility module for converting the internal representation * of a data item to string form. @@ -142,8 +151,8 @@ __fortio_default_convert(char *item, int type, case __REAL16: width = REAL16_W; (void) - __fortio_fmt_g((__BIGREAL_T)PP_REAL16(item), width, REAL16_D, REAL16_E, - 1, __REAL16, plus_flag, TRUE, dc_flag, round); + __fortio_fmt_e((__BIGREAL16_T)PP_REAL16(item), width, REAL16_D, REAL16_E, + 1, __REAL16, plus_flag, TRUE, dc_flag, 0, round); break; case __WORD16: assert(0); @@ -189,16 +198,16 @@ __fortio_default_convert(char *item, int type, *p++ = '('; width = REAL16_W; (void) - __fortio_fmt_g((__BIGREAL_T)PP_REAL16(item), width, REAL16_D, REAL16_E, - 1, __REAL16, plus_flag, TRUE, dc_flag, round); + __fortio_fmt_e((__BIGREAL16_T)PP_REAL16(item), width, REAL16_D, REAL16_E, + 1, __REAL16, plus_flag, TRUE, dc_flag, 0, round); p = strip_blnk(p, conv_bufp); if (dc_flag == TRUE) *p++ = ';'; else *p++ = ','; (void) - __fortio_fmt_g((__BIGREAL_T)PP_REAL16(item + 16), width, REAL16_D, - REAL16_E, 1, __REAL16, plus_flag, TRUE, dc_flag, round); + __fortio_fmt_e((__BIGREAL16_T)PP_REAL16(item + 16), width, REAL16_D, + REAL16_E, 1, __REAL16, plus_flag, TRUE, dc_flag, 0, round); p = strip_blnk(p, conv_bufp); *p++ = ')'; *p++ = '\0'; @@ -682,7 +691,7 @@ __fortio_fmt_g(__BIGREAL_T val, int w, int d, int e, int sf, int type, } extern char * -__fortio_fmt_e(__BIGREAL_T val, int w, int d, int e, int sf, int type, +__fortio_fmt_e(__BIGREAL16_T val, int w, int d, int e, int sf, int type, bool plus_flag, bool e_flag, bool dc_flag, int code, int round) { int sign_char; @@ -709,8 +718,12 @@ __fortio_fmt_e(__BIGREAL_T val, int w, int d, int e, int sf, int type, newd = d + ((sf > 0) ? 1 : sf); newrnd = round; } - +#ifdef LONG_DOUBLE_FLOAT128 fpdat.cvtp = __io_ecvt(val, newd, &fpdat.exp, &fpdat.sign, newrnd); +#else + // AOCC + fpdat.cvtp = __io_qcvt(val, newd, &fpdat.exp, &fpdat.sign, newrnd); +#endif fpdat.ndigits = strlen(fpdat.cvtp); fpdat.curp = fpdat.buf; @@ -739,7 +752,16 @@ __fortio_fmt_e(__BIGREAL_T val, int w, int d, int e, int sf, int type, } else if (code == FED_ESw_d) { conv_es(d, e, e_flag); } else { + #ifdef LONG_DOUBLE_FLOAT128 conv_e(d, e, sf, e_flag); + #endif + // AOCC + if(fpdat.exp > 0 && fpdat.exp >= d) + conv_e(d, e, sf, e_flag); + else if(fpdat.exp < 0) + conv_e(d, e, sf, e_flag); + else + conv_e(d, e, fpdat.exp, e_flag); } if (fpdat.sign) /* must check after conv_e */ sign_char = '-'; diff --git a/runtime/flang/fmtwrite.c b/runtime/flang/fmtwrite.c index f140da77af..49c787a9a5 100644 --- a/runtime/flang/fmtwrite.c +++ b/runtime/flang/fmtwrite.c @@ -2,6 +2,14 @@ * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. * See https://llvm.org/LICENSE.txt for license information. * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + */ + +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 * */ @@ -1757,6 +1765,7 @@ fw_writenum(int code, char *item, int type) { __BIGINT_T ival; __BIGREAL_T dval; + __BIGREAL16_T qval; // AOCC #undef IS_INT DBLINT64 i8val; #define IS_INT(t) (t == __BIGINT || t == __INT8) @@ -1853,9 +1862,9 @@ fw_writenum(int code, char *item, int type) e = REAL8_E; } break; - case __REAL16: - dval = *(__REAL16_T *)item; + qval = *(__REAL16_T *)item; + dval = qval; ty = __REAL16; w = REAL16_W; d = REAL16_D; @@ -2837,6 +2846,14 @@ ENTF90IO(SC_D_FMT_WRITE, sc_d_fmt_write)(double item, int type) return __f90io_fmt_write(type, 1, 0, (char *)&item, 0); } +// AOCC begin +__INT_T +ENTF90IO(SC_Q_FMT_WRITE, sc_q_fmt_write)(__float128 item, int type) +{ + return __f90io_fmt_write(type, 1, 0, (char *)&item, 0); +} +// AOCC end + __INT_T ENTF90IO(SC_CF_FMT_WRITE, sc_cf_fmt_write)(float real, float imag, int type) { @@ -2857,6 +2874,17 @@ ENTF90IO(SC_CD_FMT_WRITE, sc_cd_fmt_write)(double real, double imag, int type) return __f90io_fmt_write(__REAL8, 1, 0, (char *)&imag, 0); } +// AOCC begin +__INT_T +ENTF90IO(SC_CQ_FMT_WRITE, sc_cq_fmt_write)(__float128 real, __float128 imag, int type) +{ + int err; + err = __f90io_fmt_write(__REAL16, 1, 0, (char *)&real, 0); + if (err) + return err; + return __f90io_fmt_write(__REAL16, 1, 0, (char *)&imag, 0); +} +// AOCC end /* --------------------------------------------------------------------- */ #define CHAR_ONLY 1 #define CHAR_AND_VLIST 2 diff --git a/runtime/flang/format-double.c b/runtime/flang/format-double.c index 5dc38b3bf0..3c50e45865 100644 --- a/runtime/flang/format-double.c +++ b/runtime/flang/format-double.c @@ -212,14 +212,17 @@ static inline uint64_t double_to_uint64 (double x) { #if defined(TARGET_LLVM) && defined(TARGET_LINUX_X8664) +static int t_t; /* * LLVM emulates 'vcvttsd2usi' (a new AVX-512F instruction) with 'vcvttsd2si' * on non AVX-512F machines to cast double to unsigned long. With -Ktrap=fp * option, this generates a floating point exception when the converted number * is >= 9223372036854775808 (1<<63). */ - if (x >= SIGN_BIT) + if (x >= SIGN_BIT) { + t_t++; // AOCC to avoid speculative execution of next line return (uint64_t) (x - SIGN_BIT) + SIGN_BIT; + } #endif return (uint64_t) x; } diff --git a/runtime/flang/format.h b/runtime/flang/format.h index d84ca918de..9e01741ae0 100644 --- a/runtime/flang/format.h +++ b/runtime/flang/format.h @@ -4,6 +4,14 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ /** \file * Macro definitions and function declarations for Fortran formatted IO. @@ -58,7 +66,7 @@ char *__fortio_fmt_g(__BIGREAL_T, int, int, int, int, int, bool, bool, bool, char *__fortio_fmt_f(__BIGREAL_T, int, int, int, bool, bool, int); /** \brief Generate a string for an 'E' format characer */ -char *__fortio_fmt_e(__BIGREAL_T, int, int, int, int, int, bool, bool, bool, +char *__fortio_fmt_e(__BIGREAL16_T, int, int, int, int, int, bool, bool, bool, int, int); /** \brief Convert REAL*4 to REAL4*8 */ diff --git a/runtime/flang/fortDt.h b/runtime/flang/fortDt.h index 28e1eb0c67..a38fd1a498 100644 --- a/runtime/flang/fortDt.h +++ b/runtime/flang/fortDt.h @@ -2,7 +2,11 @@ * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. * See https://llvm.org/LICENSE.txt for license information. * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * Last modified: July 2020 */ /** @@ -55,7 +59,7 @@ typedef enum { __REAL2 = 45, /**< Fortran real*2, half */ __REAL4 = 27, /**< Fortran real*4, real */ __REAL8 = 28, /**< Fortran real*8, double precision */ - __REAL16 = 29, /**< Fortran real*16 */ + __REAL16 = 29, /**< Fortran real*16 quad precision */ __CPLX32 = 30, /**< Fortran complex*32 (2x real*16) */ __WORD16 = 31, /**< Fortran quad typeless */ __INT1 = 32, /**< Fortran integer*1 */ @@ -148,8 +152,11 @@ typedef unsigned short __REAL2_T; /* 45 __REAL2 real*2 */ typedef float __REAL4_T; /* 27 __REAL4 real*4 */ typedef double __REAL8_T; /* 28 __REAL8 real*8 */ - +#ifdef LONG_DOUBLE_FLOAT128 typedef double __REAL16_T; /* 29 __REAL16 real*16 */ +#else +typedef __float128 __REAL16_T; /* 29 __REAL16 real*16 */ +#endif typedef struct { __REAL4_T r, i; @@ -260,6 +267,7 @@ typedef __LOG4_T __BIGLOG_T; #define __BIGREAL __REAL8 #define __BIGCPLX __CPLX16 typedef __REAL8_T __BIGREAL_T; +typedef __REAL16_T __BIGREAL16_T; // AOCC typedef __CPLX16_T __BIGCPLX_T; #define BIGREAL_IS_LONGDOUBLE 0 diff --git a/runtime/flang/fpcvt.c b/runtime/flang/fpcvt.c index d56366904f..7c60166b04 100644 --- a/runtime/flang/fpcvt.c +++ b/runtime/flang/fpcvt.c @@ -4,7 +4,15 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ - +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ +#include #include #include #if !defined(WIN64) @@ -31,6 +39,19 @@ union ieee { int i[2]; }; +// AOCC begin +union ieee128 { + __float128 q; + struct { + unsigned long lm : 64; + unsigned long hm : 48; + unsigned int e : 15; + unsigned int s : 1; + } v; + int i[4]; +}; +// AOCC end + typedef long INT; typedef unsigned long UINT; typedef double IEEE64; @@ -763,6 +784,41 @@ writefmt(char *fmt, int prec, char c) fmt[i++] = '\0'; } +// AOCC begin +// write format for quad precision +static void +writeqfmt(char *fmt, int prec, char c[2]) +{ + int i, hprec, mprec, lprec; + hprec = mprec = 0; + lprec = prec; + + while (lprec >= 100) { + hprec++; + lprec -= 100; + } + while (lprec >= 10) { + mprec++; + lprec -= 10; + } + + i = 0; + fmt[i++] = '%'; + fmt[i++] = '-'; + fmt[i++] = '.'; + if (hprec) { + fmt[i++] = '0' + hprec; + fmt[i++] = '0' + mprec; + } else if (mprec) { + fmt[i++] = '0' + mprec; + } + fmt[i++] = '0' + lprec; + fmt[i++] = c[0]; + fmt[i++] = c[1]; + fmt[i++] = '\0'; +} +// AOCC end + char * __fortio_ecvt(double value, int ndigit, int *decpt, int *sign, int round) { @@ -1550,6 +1606,344 @@ __fortio_fcvt(__BIGREAL_T v, int prec, int sf, int *decpt, int *sign, int round) return NULL; } +// AOCC begin + char * +__fortio_qcvt(__float128 value, int ndigit, int *decpt, int *sign, int round) +{ + char *s; + void ufptosci(); + UFP u; + int i, j, carry, n; + + union ieee128 ieee_v; + + static char tmp[512]; + static char fmt[16]; + int idx, fexp, kdz, engfmt; + int i0, i1; + + /* This block of stuff is under consideration */ + engfmt = 0; + if (round >= 256) { + round -= 256; + engfmt = 1; + } + + if (round == 0) + round = FIO_COMPATIBLE; + if (round == FIO_PROCESSOR_DEFINED) { + idx = __fenv_fegetround(); + if (idx == FE_TONEAREST) + round = FIO_NEAREST; + else if (idx == FE_DOWNWARD) + round = FIO_DOWN; + else if (idx == FE_UPWARD) + round = FIO_UP; + else if (idx == FE_TOWARDZERO) + round = FIO_ZERO; + /* Is there anything else? */ + } + + ieee_v.q = value; + fexp = ieee_v.v.e - 1023; + if (fexp == 1024) { + if (ieee_v.v.hm == 0 && ieee_v.v.lm == 0) { + strcpy(tmp, "Inf"); + *sign = ieee_v.v.s; + *decpt = 0; + return tmp; + } else { + strcpy(tmp, "NaN"); + *sign = 0; + *decpt = 0; + return tmp; + } + } + + *sign = ieee_v.v.s; + ieee_v.v.s = 0; + value = ieee_v.q; + + /* For compatible mode, round '5' away from zero */ + /* Compatible rounding, or compatible in number of good bits??? */ + + if (round == FIO_COMPATIBLE) { + writeqfmt(fmt, ndigit, "Qe"); + j = quadmath_snprintf(tmp, sizeof(tmp), fmt, value); + + if (ndigit) { + i0 = 1; + tmp[i0] = tmp[0]; + } else { + i0 = 0; + } + i = i0 + ndigit + 3; + kdz = 0; + while ((tmp[i] >= '0') && (tmp[i] <= '9')) + kdz = kdz * 10 + tmp[i++] - '0'; + if (tmp[i0 + ndigit + 2] == '-') + kdz = -kdz; + *decpt = kdz + 1; + if (ndigit) { + if (engfmt) { + /* if decpt is zero, or a multiple of 3, need to round a little + closer. Actual number of bits could be ndigit-2, ndigit-1, + or ndigit + */ + short ndigitadj; + ndigitadj = *decpt; + ndigitadj = (ndigitadj - 360) % 3; + ndigit += ndigitadj; + } + i1 = i0 + ndigit; + + /* We know sprintf is rounded, so get more bits */ + if (tmp[i1] == '5') { + writeqfmt(fmt, ndigit + 20, "Qe"); + j = quadmath_snprintf(tmp, sizeof(tmp), fmt, value); + i0 = 1; + tmp[i0] = tmp[0]; + } + if (tmp[i1] < '5') { + tmp[i1] = '\0'; + } else { + tmp[i1] = '\0'; + i1--; + while ((tmp[i1] == '9') && (i1 >= i0)) { + tmp[i1--] = '0'; + } + if (i1 >= i0) { + tmp[i1] = tmp[i1] + 1; + } else { + i0--; + tmp[i0] = '1'; + *decpt = kdz + 2; + } + } + return tmp + i0; + } else { + tmp[3] = '\0'; + return tmp + i0; + } + } + + if ((round == FIO_NEAREST) || (round == FIO_PROCESSOR_DEFINED)) { + /* Algorithm for round nearest: + Turns out that sprintf is nearest + */ + if (ndigit) { + writeqfmt(fmt, ndigit - 1, "Qe"); + j = quadmath_snprintf(tmp, sizeof(tmp), fmt, value); + if (ndigit > 1) { + i0 = 1; + tmp[i0] = tmp[0]; + } else { + i0 = 0; + } + i = i0 + ndigit + 2; + kdz = 0; + while ((tmp[i] >= '0') && (tmp[i] <= '9')) + kdz = kdz * 10 + tmp[i++] - '0'; + if (tmp[i0 + ndigit + 1] == '-') + kdz = -kdz; + *decpt = kdz + 1; + if (engfmt) { + /* if decpt is zero, or a multiple of 3, need to round a little + closer. Actual number of bits could be ndigit-2, ndigit-1, + or ndigit + */ + short ndigitadj; + ndigitadj = *decpt; + ndigitadj = (ndigitadj - 360) % 3; + ndigit += ndigitadj; + i1 = i0 + ndigit; + if (tmp[i1] == '5') { + /* Use sprintf to round again */ + writeqfmt(fmt, ndigit - 1, 'E'); + j = sprintf(tmp, fmt, value); + if (ndigit > 1) { + i0 = 1; + tmp[i0] = tmp[0]; + } else { + i0 = 0; + } + i = i0 + ndigit + 2; + kdz = 0; + while ((tmp[i] >= '0') && (tmp[i] <= '9')) + kdz = kdz * 10 + tmp[i++] - '0'; + if (tmp[i0 + ndigit + 1] == '-') + kdz = -kdz; + *decpt = kdz + 1; + i1 = i0 + ndigit; + tmp[i1] = '\0'; + return tmp + i0; + } else if ((tmp[i1] < '5') || (tmp[i1] == 'E')) { + /* These are rounded correctly */ + tmp[i1] = '\0'; + return tmp + i0; + } else { + /* These need to round up */ + tmp[i1] = '\0'; + i1--; + while ((tmp[i1] == '9') && (i1 >= 0)) { + tmp[i1--] = '0'; + } + if (i1 >= 0) { + tmp[i1] = tmp[i1] + 1; + return tmp + i0; + } else { + tmp[0] = '1'; + *decpt = *decpt + 1; + return tmp; + } + } + } else { + tmp[i0 + ndigit] = '\0'; + return tmp + i0; + } + } else { + tmp[0] = '0'; + tmp[1] = '\0'; + return tmp; + } + } + + if (((round == FIO_DOWN) && (*sign == 0)) || + ((round == FIO_UP) && (*sign == 1)) || ((round == FIO_ZERO))) { + /* Algorithm for round down, positive > 1.0: + Add 1 character to the format. + call sprintf. + Find the exponent sprintf gave, and adjust our approx if needed. + If the extra character(s) are 0, we need to do more work: + Get a whole bunch more characters. For now, 20 more + Round Down: + Lop everything extra off. + */ + writeqfmt(fmt, ndigit, "Qe"); + j = quadmath_snprintf(tmp, sizeof(tmp), fmt, value); + i0 = 1; + tmp[i0] = tmp[0]; + i = ndigit + 4; + kdz = 0; + while ((tmp[i] >= '0') && (tmp[i] <= '9')) + kdz = kdz * 10 + tmp[i++] - '0'; + if (tmp[ndigit + 3] == '-') + kdz = -kdz; + *decpt = kdz + 1; + if (engfmt) { + /* if decpt is zero, or a multiple of 3, need to round a little + closer. Actual number of bits could be ndigit-2, ndigit-1, + or ndigit + */ + short ndigitadj; + ndigitadj = *decpt; + ndigitadj = (ndigitadj - 360) % 3; + ndigit += ndigitadj; + } + if (ndigit) { + i = ndigit + 1; + if (tmp[i] == '0') { + writeqfmt(fmt, ndigit + 20, 'E'); + j = sprintf(tmp, fmt, value); + i0 = 1; + tmp[i0] = tmp[0]; + } + tmp[ndigit + 1] = '\0'; + } else { + tmp[2] = '\0'; + } + return tmp + 1; + } + + if (((round == FIO_UP) && (*sign == 0)) || + ((round == FIO_DOWN) && (*sign == 1))) { + /* Algorithm for round up, positive >= 1.0: + Add 1 character to the format. + call sprintf. + Find the exponent sprintf gave, and adjust our approx if needed. + If the extra character(s) are 0, we need to do more work: + Get a whole bunch more characters. For now, 20 more + Search through the extra characters to find something > 0. + If we found it, round up. Else return + Round Up: + If we find 9, set it to zero and keep looking to the left. + If we find a character other than 9, add 1 and we're done + If we went all the way, make tmp[0] 1, and return that. + */ + writeqfmt(fmt, ndigit, "Qe"); + j = quadmath_snprintf(tmp, sizeof(tmp), fmt, value); + i0 = 1; + tmp[i0] = tmp[0]; + i = ndigit + 4; + kdz = 0; + while ((tmp[i] >= '0') && (tmp[i] <= '9')) + kdz = kdz * 10 + tmp[i++] - '0'; + if (tmp[ndigit + 3] == '-') + kdz = -kdz; + *decpt = kdz + 1; + if (engfmt) { + /* if decpt is zero, or a multiple of 3, need to round a little + closer. Actual number of bits could be ndigit-2, ndigit-1, + or ndigit + */ + short ndigitadj; + ndigitadj = *decpt; + ndigitadj = (ndigitadj - 360) % 3; + ndigit += ndigitadj; + } + i = ndigit + 1; + if (ndigit) { + if (tmp[i] == '0') { + writeqfmt(fmt, ndigit + 20, "Qe"); + j = quadmath_snprintf(tmp, sizeof(tmp), fmt, value); + i0 = 1; + tmp[i0] = tmp[0]; + tmp[ndigit + 21] = '\0'; + for (i = ndigit + 1; tmp[i] != '\0'; i++) { + if (tmp[i] != '0') + break; + } + if (tmp[i] == '\0') { + tmp[ndigit + 1] = '\0'; + return tmp + 1; + } else { + i = ndigit; + while ((tmp[i] == '9') && (i >= 1)) { + tmp[i--] = '0'; + } + tmp[ndigit + 1] = '\0'; + if (i == 0) { + tmp[0] = '1'; + return tmp; + } else { + tmp[i] = tmp[i] + 1; + return tmp + 1; + } + } + } else { /* if (tmp[i] > '0') round up */ + i--; + while ((tmp[i] == '9') && (i >= 1)) { + tmp[i--] = '0'; + } + tmp[ndigit + 1] = '\0'; + if (i == 0) { + tmp[0] = '1'; + return tmp; + } else { + tmp[i] = tmp[i] + 1; + return tmp + 1; + } + } + } else { + tmp[2] = '\0'; + return tmp + 1; + } + } + mtherr("internal convert", FP_UNDEFINED_ERROR); + return NULL; +} +// AOCC end + /* Below is code that supports IEEE128 versions of ecvt and fcvt called * __fortio_lldecvt and __fortio_lldfcvt */ diff --git a/runtime/flang/ftnhdr.F b/runtime/flang/ftnhdr.F index a6e500f142..a0b8f0f938 100644 --- a/runtime/flang/ftnhdr.F +++ b/runtime/flang/ftnhdr.F @@ -2,7 +2,11 @@ ! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. ! See https://llvm.org/LICENSE.txt for license information. ! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! ! +! Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +! Notified per clause 4(b) of the license. +! #if !defined(PGDLL) diff --git a/runtime/flang/ftni64.h b/runtime/flang/ftni64.h index 49b80bc73b..5c43b4ce51 100644 --- a/runtime/flang/ftni64.h +++ b/runtime/flang/ftni64.h @@ -4,6 +4,10 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ #include "dblint64.h" @@ -27,7 +31,7 @@ typedef unsigned long long _ULONGLONG_T; #define I64_MSH(t) t[1] #define I64_LSH(t) t[0] -int __ftn_32in64_; +extern int __ftn_32in64_; #define VOID void diff --git a/runtime/flang/gather_cmplx32.F95 b/runtime/flang/gather_cmplx32.F95 new file mode 100644 index 0000000000..255b1a1f0b --- /dev/null +++ b/runtime/flang/gather_cmplx32.F95 @@ -0,0 +1,72 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + + +! directives.h -- contains preprocessor directives for F90 rte files + +#include "mmul_dir.h" + +subroutine ftn_gather_cmplx32( ta, a, lda, alpha, buffer, bufrows, bufcols ) + implicit none + + integer*8 lda + complex*32 :: a( lda,* ), alpha + integer :: bufrows, bufcols + integer :: i, j, ndx, ndxsave + complex*32 :: buffer(bufrows * bufcols) + integer :: ta + ! + ! This routine gathers the matrix into l1 chunks. The purpose is much as it + ! is for the transpose case, and works much like transpose_real8() + ! + ! What do the parameters mean? + ! buffer: buffer array + ! a: matrix to be gathered + ! bufcols: number of rows in matrix a to gather + ! bufrowss: number of cols in matrix a to gather + ! lda: number of rows in matrix a + ! Note that we don't care what the dimensions of a are. We assume that the + ! calling function has done this correctly + ! + + ndx = 0 + if( ta .eq. 2 )then ! conjugate the data + if( alpha .eq. ( 1.0, 0.0 ) ) then + do j = 1, bufcols + do i = 1, bufrows + buffer( ndx + i ) = conjg( a( i, j ) ) + enddo + ndx = ndx + bufrows + enddo + else + do j = 1, bufcols + do i = 1, bufrows + buffer( ndx + i ) = alpha * conjg( a( i, j ) ) + enddo + ndx = ndx + bufrows + enddo + endif + else + if( alpha .eq. ( 1.0, 0.0 ) ) then + do j = 1, bufcols + do i = 1, bufrows + buffer( ndx + i ) = a( i, j ) + enddo + ndx = ndx + bufrows + enddo + else + do j = 1, bufcols + do i = 1, bufrows + buffer( ndx + i ) = alpha * a( i, j ) + enddo + ndx = ndx + bufrows + enddo + endif + endif + ! write( *, * ) ( a(1, j ), j = 1, bufcols ) + ! write( *, * )( buffer( i ), i = 1, bufrows * bufcols ) + return +end subroutine ftn_gather_cmplx32 diff --git a/runtime/flang/global.h b/runtime/flang/global.h index 3157ce4b44..fb0fb33e39 100644 --- a/runtime/flang/global.h +++ b/runtime/flang/global.h @@ -4,6 +4,12 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified: May 2020 + */ /** \file * \brief Global definitions and declarations for Fortran I/O library @@ -12,7 +18,8 @@ #include "fioMacros.h" #include "stdioInterf.h" /* stubbed version of stdio.h */ #include "cnfg.h" /* declarations for configuration items */ - +#include +#include #define GBL_SIZE_T_FORMAT "zu" typedef int DBLINT64[2]; @@ -345,6 +352,7 @@ extern int __fortio_assign(char *, int, __CLEN_T, AVAL *); /***** fpcvt.c *****/ extern char *__fortio_ecvt(double, int, int *, int *, int); extern char *__fortio_fcvt(__BIGREAL_T, int, int, int *, int *, int); +extern char *__fortio_qcvt(__float128, int, int *, int *, int); // AOCC WIN_MSVCRT_IMP double WIN_CDECL strtod(const char *, char **); #define __fortio_strtod(x, y) strtod(x, y) diff --git a/runtime/flang/intrin.c b/runtime/flang/intrin.c index 9075318281..3c6f4b89f5 100644 --- a/runtime/flang/intrin.c +++ b/runtime/flang/intrin.c @@ -4,6 +4,10 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ int ftn_i_jishft(int x, int shift) @@ -125,3 +129,10 @@ ftn_i_ddim(double a, double b) return a - b; return 0.0; } +__float128 +ftn_i_qdim(__float128 a, __float128 b) +{ + if (a > b) + return a - b; + return 0.0; +} diff --git a/runtime/flang/iso_fortran_env.f90 b/runtime/flang/iso_fortran_env.f90 index 88ab2d9be1..8ed48e900f 100644 --- a/runtime/flang/iso_fortran_env.f90 +++ b/runtime/flang/iso_fortran_env.f90 @@ -10,6 +10,12 @@ ! FITNESS FOR A PARTICULAR PURPOSE. ! +! Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +! Notified per clause 4(b) of the license. +! +! Added support for quad precision +! Last modified: Feb 2020 + ! iso_fortran_env.f90 ! 32/64 bit linux and windows. Add further targets as required. @@ -59,14 +65,15 @@ module ISO_FORTRAN_ENV integer REAL64 parameter (REAL64 = 8) integer REAL128 - parameter (REAL128 = -1) + parameter (REAL128 = 16) integer INTEGER_KINDS(4) parameter (INTEGER_KINDS = (/INT8, INT16, INT32, INT64/)) integer LOGICAL_KINDS(4) + ! AOCC: REAL128 parameter (LOGICAL_KINDS = (/LOGICAL8, LOGICAL16, LOGICAL32, LOGICAL64/)) - integer REAL_KINDS(2) - parameter (REAL_KINDS = (/REAL32, REAL64/)) + integer REAL_KINDS(3) + parameter (REAL_KINDS = (/REAL32, REAL64, REAL128/)) end module ISO_FORTRAN_ENV diff --git a/runtime/flang/itrailz.c b/runtime/flang/itrailz.c new file mode 100644 index 0000000000..a74a61c7e6 --- /dev/null +++ b/runtime/flang/itrailz.c @@ -0,0 +1,21 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Support for TRAILZ intrinsic. + * Month of Modification: May 2019 + */ + +int +__mth_i_itrailz(int i) +{ + unsigned ui = (unsigned) i; + + return (ui) ? __builtin_ctz(ui) : 32; +} diff --git a/runtime/flang/itrailzi.c b/runtime/flang/itrailzi.c new file mode 100644 index 0000000000..4a4cf1894f --- /dev/null +++ b/runtime/flang/itrailzi.c @@ -0,0 +1,23 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Support for TRAILZ intrinsic. + * + * Month of Modification: May 2019 + */ + +int +__mth_i_itrailzi(int i, int size) +{ + unsigned ui = (unsigned) i; + + return (ui) ? __builtin_ctz(ui) : (size * 8); +} diff --git a/runtime/flang/ktrailz.c b/runtime/flang/ktrailz.c new file mode 100644 index 0000000000..0aff96f877 --- /dev/null +++ b/runtime/flang/ktrailz.c @@ -0,0 +1,32 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Support for TRAILZ intrinsic. + * + * Month of Modification: May 2019 + */ + +#include + +int64_t +__mth_i_ktrailz(int64_t i) +{ + uint64_t ui = (uint64_t) i; + + #if (defined(PGOCL) || defined(TARGET_LLVM_ARM)) && !defined(TARGET_LLVM_ARM64) + return (ui) ? __builtin_ctz(ui) : 64; + #else + if (!ui) + return 64; + + return ((int)(ui)) ? ( __builtin_ctz(ui)) : + (__builtin_ctz(ui >> 32)) + 32; + #endif +} diff --git a/runtime/flang/ldwrite.c b/runtime/flang/ldwrite.c index f436154c93..8199afcb78 100644 --- a/runtime/flang/ldwrite.c +++ b/runtime/flang/ldwrite.c @@ -5,6 +5,20 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Modification for output splitting + * + * Date of Modification: 17th July 2019 + * + * Added support for quad precision + * Last modified: Feb 2020 + * + * + */ + /* clang-format off */ /** \file @@ -167,6 +181,48 @@ free_gbl() /* list-directed external file write initialization */ /* **************************************************/ +// AOCC Begin +/* CPUPC-2012 - F2008 : Recursive I/O */ +#include "llcrit.h" +#include + +MP_SEMAPHORE(static, sem); + +#define NO_UNIT -9999 +#define MAX_UNITS 32 + +static int active_unit_list[MAX_UNITS]; +static int last_unit; + +static int +chk_unit(int unit) { + int i; + + MP_P(sem); + + if (DBGBIT(0x1)) { + printf("chk_unit: unit = %d\n", unit); + } + + for (i = 0; i < last_unit; i++) { + if (DBGBIT(0x1)) { + printf("chk_unit: active_unit = %d\n", active_unit_list[i]); + } + + if (unit == active_unit_list[i]) { + MP_V(sem); + return(1); + } + } + + MP_V(sem); + return(0); +} + +static int flang_recursive_io_support; +static int fris_checked; +// AOCC End + static int _f90io_ldw_init(__INT_T *unit, /* unit number */ __INT_T *rec, /* record number for direct access I/O */ @@ -177,6 +233,39 @@ _f90io_ldw_init(__INT_T *unit, /* unit number */ int i; save_gbl(); +// AOCC Begin + if (!fris_checked) { + char* fris; + fris = getenv("FLANG_RECURSIVE_IO_SUPPORT"); + if (fris && isdigit(fris[0])) { + flang_recursive_io_support = atoi(fris); + } + fris_checked = 1; + } + + if (flang_recursive_io_support >= 1) { + if (DBGBIT(0x1)) { + printf("_f90io_ldw_init: flang_recursive_io_support = %d\n", flang_recursive_io_support); + } + if (chk_unit(*unit)) { + char msg[256]; + sprintf(msg, "Detected Recursive-I/O on Unit-%d\n", *unit); + printf("%s", msg); + exit(127); +#if 0 +//TBD: + __fort_abort(msg); +#endif + } + + MP_P(sem); + active_unit_list[last_unit] = *unit; + last_unit++; + assert(last_unit < MAX_UNITS); + MP_V(sem); + } +// AOCC End + __fortio_errinit03(*unit, *bitv, iostat, "list-directed write"); allocate_new_gbl(); @@ -374,7 +463,7 @@ ENTF90IO(LDW_INIT03, ldw_init03) { return ENTF90IO(LDW_INIT03A, ldw_init03a) (istat, CADR(decimal), CADR(delim), CADR(sign), (__CLEN_T)CLEN(decimal), - (__CLEN_T)CLEN(delim), (__CLEN_T)CLEN(sign)); + (__CLEN_T)CLEN(delim), (__CLEN_T)CLEN(sign)); } /* **************************************************/ @@ -600,7 +689,7 @@ __f90io_ldw(int type, /* data type (as defined in pghpft.h) */ p = __fortio_default_convert(tmpitem, type, item_length, &width, FALSE, plus_sign, gbl->round); if (Is_complex(type) && byte_cnt > 0) { - /* complex is a bit strange since blanks are removed from + /* complex is a bit strange since blanks are removed from the beginning and end of the constant. A blank is needed at the beginning. */ ret_err = write_item(" ", 1); @@ -653,6 +742,7 @@ __f90io_ldw(int type, /* data type (as defined in pghpft.h) */ free_gbl(); restore_gbl(); __fortio_errend03(); + return (ret_err); } @@ -777,7 +867,7 @@ write_item(char *p, int len) record_written = FALSE; - /* compute the number of bytes written AFTER this item is written. + /* compute the number of bytes written AFTER this item is written. NOTE that ByteCnt is set after the item is written since we may split lines. */ @@ -815,19 +905,38 @@ write_item(char *p, int len) if (len && FWRITE(p, len, 1, fcb->fp) != 1) return __io_errno(); } else { /* sequential write */ - /* split lines if necessary; watch for the case where a long + /* split lines if necessary; watch for the case where a long character item is the first item for the record. */ - if (byte_cnt && ((fcb->reclen && newlen > fcb->reclen) || - (!fcb->reclen && newlen > 79))) { - ret_err = write_record(); - if (ret_err) - return ret_err; - if (FWRITE(" ", 1, 1, fcb->fp) != 1) - return __io_errno(); - newlen = len + 1; - record_written = FALSE; + // AOCC Begin + const char *wrap_output = getenv("FLANG_WRAP_MESSAGE_OUTPUT"); + if (wrap_output && strcmp(wrap_output, "no") == 0) { + if (byte_cnt && (fcb->reclen && newlen > fcb->reclen)) { + ret_err = write_record(); + if (ret_err) + return ret_err; + if (FWRITE(" ", 1, 1, fcb->fp) != 1) + return __io_errno(); + newlen = len + 1; + record_written = FALSE; + } + } + else { + // AOCC End + if (byte_cnt && ((fcb->reclen && newlen > fcb->reclen) || + (!fcb->reclen && newlen > 79))) { + ret_err = write_record(); + if (ret_err) + return ret_err; + if (FWRITE(" ", 1, 1, fcb->fp) != 1) + return __io_errno(); + newlen = len + 1; + record_written = FALSE; + } + // AOCC Begin } + // AOCC End + if (len && FWRITE(p, len, 1, fcb->fp) != 1) return __io_errno(); } @@ -890,6 +999,14 @@ write_record(void) static int _f90io_ldw_end() { +// AOCC Begin + if (flang_recursive_io_support >= 1) { + MP_P(sem); + last_unit--; + assert(last_unit > 0); + MP_V(sem); + } +// AOCC End if (internal_file && in_curp != in_recp) in_recp += rec_len; /* update internal file pointer */ @@ -1031,6 +1148,13 @@ ENTF90IO(SC_D_LDW, sc_d_ldw)(double item, int type) return __f90io_ldw(type, 1, 0, (char *)&item, 0); } +// AOCC begin +__INT_T +ENTF90IO(SC_Q_LDW, sc_q_ldw)(__float128 item, int type) +{ + return __f90io_ldw(type, 1, 0, (char*)&item, 0); +} +// AOCC end __INT_T ENTF90IO(SC_CF_LDW, sc_cf_ldw)(float real, float imag, int type) { @@ -1055,6 +1179,19 @@ ENTF90IO(SC_CD_LDW, sc_cd_ldw)(double real, double imag, int type) return __f90io_ldw(type, 1, 0, (char *)&dum, 0); } +// AOCC begin +ENTF90IO(SC_CQ_LDW, sc_cq_ldw)(__float128 real, __float128 imag, int type) +{ + struct { + __float128 real; + __float128 imag; + } dum; + dum.real = real; + dum.imag = imag; + return __f90io_ldw(type, 1, 0, (char *)&dum, 0); +} +// AOCC end + __INT_T ENTF90IO(SC_CH_LDW, sc_ch_ldw)(char *item, int type, int len) { diff --git a/runtime/flang/malloc.c b/runtime/flang/malloc.c index 78fc19cc1d..1ce0e17e49 100644 --- a/runtime/flang/malloc.c +++ b/runtime/flang/malloc.c @@ -4,6 +4,10 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ #include "stdioInterf.h" #include "fioMacros.h" @@ -27,9 +31,21 @@ __fort_malloc_without_abort(size_t n) if (n == 0) return ZIP; +#if 0 + // AOCC + // gcc combines following two constructs to calloc call. some of the applications + // depend on this behaviour. + // clang doesnt do this. + // forcing PGHPF_ZMEM results in call to malloc+memset that makes the application slower. p = malloc(n); if (__fort_zmem && (p != NULL)) memset(p, '\0', n); +#else + if (__fort_zmem) + p = calloc(n,sizeof(char)); + else + p = malloc(n); +#endif return p; } @@ -54,9 +70,21 @@ __fort_realloc(void *ptr, size_t n) if (ptr == (char *)0 | ptr == ZIP) { if (n == 0) return ZIP; - p = malloc(n); +#if 0 + // AOCC + // gcc combines following two constructs to calloc call. some of the applications + // depend on this behaviour. + // clang doesnt do this. + // forcing PGHPF_ZMEM results in call to malloc+memset that makes the application slower. + p = malloc(n); if (__fort_zmem && (p != NULL)) memset(p, '\0', n); +#else + if (__fort_zmem) + p = calloc(n,sizeof(char)); + else + p = malloc(n); +#endif } else { if (n == 0) { free(ptr); diff --git a/runtime/flang/matmul.h b/runtime/flang/matmul.h index 35c7e92518..0fc26dd9fc 100644 --- a/runtime/flang/matmul.h +++ b/runtime/flang/matmul.h @@ -2,12 +2,27 @@ * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. * See https://llvm.org/LICENSE.txt for license information. * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * Last Modified: Oct 2020 */ /** \file * \brief Matrix multiplication routines */ +// AOCC begin +void f90_mm_cplx32_str1_mxv_(__CPLX32_T *, __CPLX32_T *, __CPLX32_T *, + __INT_T *, __INT_T *, __INT_T *, __INT_T *); +void f90_mm_cplx32_str1_vxm_(__CPLX32_T *, __CPLX32_T *, __CPLX32_T *, + __INT_T *, __INT_T *, __INT_T *, __INT_T *); +void f90_mm_cplx32_str1_(__CPLX32_T *, __CPLX32_T *, __CPLX32_T *, __INT_T *, + __INT_T *, __INT_T *, __INT_T *, __INT_T *, + __INT_T *, __INT_T *); +void f90_mm_cplx32_str1_mxv_t_(__CPLX32_T *, __CPLX32_T *, __CPLX32_T *, + __INT_T *, __INT_T *, __INT_T *, __INT_T *); +// AOCC end void f90_mm_cplx16_str1_mxv_(__CPLX16_T *, __CPLX16_T *, __CPLX16_T *, __INT_T *, __INT_T *, __INT_T *, __INT_T *); void f90_mm_cplx16_str1_vxm_(__CPLX16_T *, __CPLX16_T *, __CPLX16_T *, @@ -79,3 +94,14 @@ void f90_mm_real8_str1_(__REAL8_T *, __REAL8_T *, __REAL8_T *, __INT_T *, __INT_T *); void f90_mm_real8_str1_mxv_t_(__REAL8_T *, __REAL8_T *, __REAL8_T *, __INT_T *, __INT_T *, __INT_T *, __INT_T *); +// AOCC begin +void f90_mm_real16_str1_mxv_(__REAL16_T *, __REAL16_T *, __REAL16_T *, __INT_T *, + __INT_T *, __INT_T *, __INT_T *); +void f90_mm_real16_str1_vxm_(__REAL16_T *, __REAL16_T *, __REAL16_T *, __INT_T *, + __INT_T *, __INT_T *, __INT_T *); +void f90_mm_real16_str1_(__REAL16_T *, __REAL16_T *, __REAL16_T *, __INT_T *, + __INT_T *, __INT_T *, __INT_T *, __INT_T *, __INT_T *, + __INT_T *); +void f90_mm_real16_str1_mxv_t_(__REAL16_T *, __REAL16_T *, __REAL16_T *, + __INT_T *, __INT_T *, __INT_T *, __INT_T *); +// AOCC end diff --git a/runtime/flang/miscsup_com.c b/runtime/flang/miscsup_com.c index 3920425a3d..19490063cc 100644 --- a/runtime/flang/miscsup_com.c +++ b/runtime/flang/miscsup_com.c @@ -5,6 +5,18 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Support for TRAILZ intrinsic. + * Month of Modification: July 2019 + * + * Support for REAL*16 intrinsics + * Date of Modification: 18th July 2020 + */ + + /* clang-format off */ /** \file @@ -27,6 +39,7 @@ MP_SEMAPHORE(static, sem); #include "type.h" extern double __fort_second(); +extern double __fort_sysclk_second(); /* AOCC */ extern long __fort_getoptn(char *, long); #define time(x) __fort_time(x) @@ -136,6 +149,7 @@ __LOG_T ENTF90(PRESENTC, presentc)(DCHAR(p) DCLEN(p)) { ENTF90(PRESENTCA, presentca)(CADR(p), (__CLEN_T)CLEN(p)); + return 0; } /** \brief @@ -569,6 +583,28 @@ ENTFTN(CPU_TIMED, cpu_timed)(__REAL8_T *x) *x = res; } +//AOCC Begin +void +ENTFTN(CPU_TIMEQ, cpu_timeq)(__REAL16_T *x) +{ + extern double __fort_second(); + double secs; + __REAL16_T res; + + secs = __fort_second(); + /* probably not necessary for this version, except that + user could mix real*4 and real*8 versions. + */ + if (secs > TIME_THRESHOLD2) + res = secs - TIME_THRESHOLD2; + else if (secs > TIME_THRESHOLD1) + res = secs - TIME_THRESHOLD1; + else + res = secs; + *x = res; +} +//AOCC End + __REAL4_T ENTFTN(SECNDS, secnds)(__REAL4_T *x, F90_Desc *xd) { @@ -837,7 +873,7 @@ ENTFTN(SYSCLK, sysclk)(__STAT_T *count, __STAT_T *count_rate, } } if (ISPRESENT(count)) { - double t = __fort_second(); + double t = __fort_sysclk_second(); /* AOCC */ MXINT_T mxt; mxt = mxint(countd); if (t * resol > mxt) { @@ -3330,6 +3366,16 @@ ENTFTN(LEADZ, leadz)(void *i, __INT_T *size) return nz; } +/* AOCC begin */ +__INT_T +ENTFTN(TRAILZ, trailz)(void *i, __INT_T *size) +{ + unsigned ui = (unsigned) I8(__fort_varying_int)(i, size); + + return (ui) ? __builtin_ctz(ui) : (*size * 8); +} +/* AOCC end */ + __INT_T ENTFTN(POPCNT, popcnt)(void *i, __INT_T *size) { @@ -3947,6 +3993,17 @@ ENTF90(DMODULO, dmodulo)(__DBLE_T *x, __DBLE_T *y) d += *y; return d; } +// AOCC Begin +__REAL16_T +ENTF90(QMODULO, qmodulo)(__REAL16_T *x, __REAL16_T *y) +{ + __REAL16_T d; + d = fmodq(*x, *y); + if (d != 0 && ((*x < 0 && *y > 0) || (*x > 0 && *y < 0))) + d += *y; + return d; +} +// AOCC End __INT4_T ENTF90(MODULOv, modulov)(__INT4_T a, __INT4_T p) @@ -3961,6 +4018,12 @@ ENTF90(MODULOv, modulov)(__INT4_T a, __INT4_T p) return r; } +__INT4_T +__ENTF90(MODULOv, modulov)(__INT4_T a, __INT4_T p) +{ + return ENTF90(MODULOv, modulov)(a, p); +} + __INT8_T ENTF90(I8MODULOv, i8modulov)(__INT8_T a, __INT8_T p) { @@ -3974,6 +4037,12 @@ ENTF90(I8MODULOv, i8modulov)(__INT8_T a, __INT8_T p) return r; } +__INT8_T +__ENTF90(I8MODULOv, i8modulov)(__INT8_T a, __INT8_T p) +{ + return ENTF90(I8MODULOv, i8modulov)(a, p); +} + __INT2_T ENTF90(IMODULOv, imodulov)(__INT2_T a, __INT2_T p) { @@ -3987,6 +4056,12 @@ ENTF90(IMODULOv, imodulov)(__INT2_T a, __INT2_T p) return r; } +__INT2_T +__ENTF90(IMODULOv, imodulov)(__INT2_T a, __INT2_T p) +{ + return ENTF90(IMODULOv, imodulov)(a, p); +} + __REAL_T ENTF90(AMODULOv, amodulov)(__REAL_T x, __REAL_T y) { @@ -3997,6 +4072,12 @@ ENTF90(AMODULOv, amodulov)(__REAL_T x, __REAL_T y) return d; } +__REAL_T +__ENTF90(AMODULOv, amodulov)(__REAL_T x, __REAL_T y) +{ + return ENTF90(AMODULOv, amodulov)(x, y); +} + __DBLE_T ENTF90(DMODULOv, dmodulov)(__DBLE_T x, __DBLE_T y) { @@ -4007,6 +4088,30 @@ ENTF90(DMODULOv, dmodulov)(__DBLE_T x, __DBLE_T y) return d; } +__DBLE_T +__ENTF90(DMODULOv, dmodulov)(__DBLE_T x, __DBLE_T y) +{ + return ENTF90(DMODULOv, dmodulov)(x, y); +} + +// AOCC Begin +__REAL16_T +ENTF90(QMODULOv, qmodulov)(__REAL16_T x, __REAL16_T y) +{ + __REAL16_T d; + d = fmodq(x, y); + if (d != 0 && ((x < 0 && y > 0) || (x > 0 && y < 0))) + d += y; + return d; +} + +__REAL16_T +__ENTF90(QMODULOv, qmodulov)(__REAL16_T x, __REAL16_T y) +{ + return ENTF90(QMODULOv, qmodulov)(x, y); +} +// AOCC End + __INT_T ENTF90(CEILING, ceiling)(__REAL_T *r) { @@ -4346,12 +4451,11 @@ __INT8_T ENTF90(KSEL_REAL_KIND, ksel_real_kind) (char *pb, char *rb, F90_Desc *pd, F90_Desc *rd) { - - /* + /* * -i8 variant of SEL_REAL_KIND */ - int p, r, e, k; + int p, r, e, k, prec, range, radix; e = 0; k = 0; @@ -4382,35 +4486,63 @@ ENTF90(KSEL_REAL_KIND, ksel_real_kind) __INT_T ENTF90(SEL_REAL_KIND, sel_real_kind) -(char *pb, char *rb, F90_Desc *pd, F90_Desc *rd) +(char *pb, char *rb, char *radixb, F90_Desc *pd, F90_Desc *rd, F90_Desc *radixd) { - int p, r, e, k; + int p, r, e, k, radix, range, prec; e = 0; k = 0; + range = 0; // AOCC + prec = 0; // AOCC if (ISPRESENT(pb)) { p = I8(__fort_fetch_int)(pb, pd); if (p <= 6) k = 4; else if (p <= 15) k = 8; - else + else if (p <= 31) + k = 16; + else { e -= 1; + prec = -1; + } } if (ISPRESENT(rb)) { r = I8(__fort_fetch_int)(rb, rd); if (r <= 37) { - if (k < 4) + if (k <= 4) k = 4; } else if (r <= 307) { - if (k < 8) + if (k <= 8) k = 8; } - - else + else if (r <= 4931) { + if (k <= 16) + k = 16; + } + else { e -= 2; + range = -2; + } + } + // AOCC begin + if (radixb && ISPRESENT(radixb)) { + radix = I8(__fort_fetch_int)(radixb, radixd); + if (radix == 2) { + if (k <= 4) + k = 4; + else if (k <= 8) + k = 8; + else if (k <= 16) + k = 16; + else if (prec < 0 && range < 0) + k = -3; + } + else if (radix != 2) + e -= 5; } + // AOCC end return e ? e : k; } @@ -4448,6 +4580,23 @@ ENTF90(EXPONDX, expondx)(__REAL8_T d) return ((g.i >> 52) & 0x7FF) - 1022; } +__INT_T +ENTF90(EXPONQX, exponqx)(__REAL16_T q) +{ + union { + struct { + __INT8_T lo; + __INT8_T hi; + } i; + __REAL16_T r; + } g; + g.r = q; + if ((((g.i.hi >> 32) & ~0x80000000) | (g.i.hi & 0xffffffff)) == 0) + return 0; + else + return ((g.i.hi >> 48) & 0x7FFF) - 16382; +} + __INT_T ENTF90(EXPOND, expond)(__REAL8_T *d) { @@ -4512,6 +4661,24 @@ ENTF90(FRACDX, fracdx)(__REAL8_T d) __REAL8_T ENTF90(FRACD, fracd)(__REAL8_T *d) { return ENTF90(FRACDX, fracdx)(*d); } +//AOCC Begin +__REAL16_T +ENTF90(FRACQX, fracqx)(__REAL16_T q) +{ + __REAL16_SPLIT x; + + x.q = q; + if (x.q != 0.0) { + x.i.h &= ~0x7FFD0000; + x.i.h |= 0x3FFE0000; + } + return x.q; +} + +__REAL16_T +ENTF90(FRACQ, fracq)(__REAL16_T *q) { return ENTF90(FRACQX, fracqx)(*q); } +//AOCC End + /** \brief NEAREST(X,S) has a value equal to the machine representable number * distinct from X and nearest to it in the direction of the infinity * with the same sign as S. @@ -4535,6 +4702,7 @@ ENTF90(NEARESTX, nearestx)(__REAL4_T f, __LOG_T sign) else --x.i; } + return x.f; } @@ -4561,6 +4729,7 @@ ENTF90(NEARESTDX, nearestdx)(__REAL8_T d, __LOG_T sign) --x.ll; } } + return x.d; } @@ -4569,7 +4738,35 @@ ENTF90(NEARESTD, nearestd)(__REAL8_T *d, __LOG_T *sign) { return ENTF90(NEARESTDX, nearestdx)(*d, *sign); } +//AOCC Begin +__REAL16_T +ENTF90(NEARESTQX, nearestqx)(__REAL16_T q, __LOG_T sign) +{ + __REAL16_SPLIT x; + __REAL16_SPLIT y; + x.q = q; + y.q = 1.0/100000.0; + if (x.q == 0.0) { + x.ll.h = (sign & 1) ? 0x0000000000000001 : 0x8000000000000001; + x.ll.l = 0; + } else { + if ((x.ll.h >> 112 & 0x7FFF) != 0x7FFF) { /* not nan or inf */ + if ((x.q < 0) ^ (sign & GET_DIST_MASK_LOG)) + x.q = x.q + y.q; + else + x.q = x.q - y.q; + } + } + + return x.q; +} +__REAL16_T +ENTF90(NEARESTQ, nearestq)(__REAL16_T *q, __LOG_T *sign) +{ + return ENTF90(NEARESTQX, nearestqx)(*q, *sign); +} +//AOCC End __REAL4_T ENTF90(RRSPACINGX, rrspacingx)(__REAL4_T f) { @@ -4621,6 +4818,38 @@ ENTF90(RRSPACINGD, rrspacingd)(__REAL8_T *d) return ENTF90(RRSPACINGDX, rrspacingdx)(*d); } +//AOCC Begin +__REAL16_T +ENTF90(RRSPACINGQX, rrspacingqx)(__REAL16_T q) +{ + __REAL16_SPLIT x, y; + int e; + + x.q = q; + if (x.q == 0) + return 0; + y.i.h = (x.i.h & 0x7FFF << 20) ^ 0x7FFF << 20; + y.i.l = 0; + y.i.j = 0; + y.i.k = 0; + x.q *= y.q; + if (x.q < 0) + x.q = -x.q; + e = 111 + 16383; + y.i.h = e << 16; + y.i.l = 0; + y.i.j = 0; + y.i.k = 0; + x.q *= y.q; + return x.q; +} + +__REAL16_T +ENTF90(RRSPACINGQ, rrspacingq)(__REAL16_T *q) +{ + return ENTF90(RRSPACINGQX, rrspacingqx)(*q); +} +//AOCC End __REAL4_T ENTF90(SCALEX, scalex)(__REAL4_T f, __INT_T i) { @@ -4689,6 +4918,44 @@ ENTF90(SCALED, scaled)(__REAL8_T *d, void *i, __INT_T *size) return *d * x.d; } +//AOCC Begin +__REAL16_T +ENTF90(SCALEQX, scaleqx)(__REAL16_T q, __INT_T i) +{ + int e; + __REAL16_SPLIT x; + + e = 16383 + i; + if (e < 0) + e = 0; + else if (e > 32767) + e = 32767; + x.i.h = e << 16; + x.i.l = 0; + x.i.j = 0; + x.i.k = 0; + return q * x.q; +} + +__REAL16_T +ENTF90(SCALEQ, scaleq)(__REAL16_T *q, void *i, __INT_T *size) +{ + int e; + __REAL16_SPLIT x; + + e = 16383 + I8(__fort_varying_int)(i, size); + if (e < 0) + e = 0; + else if (e > 32767) + e = 32767; + x.i.h = e << 16; + x.i.l = 0; + x.i.j = 0; + x.i.k = 0; + return *q * x.q; +} +//AOCC End + __REAL4_T ENTF90(SETEXPX, setexpx)(__REAL4_T f, __INT_T i) { @@ -4777,6 +5044,55 @@ ENTF90(SETEXPD, setexpd)(__REAL8_T *d, void *i, __INT_T *size) return x.d * y.d; } +//AOCC Begin +__REAL16_T +ENTF90(SETEXPQX, setexpqx)(__REAL16_T q, __INT_T i) +{ + int e; + __REAL16_SPLIT x, y; + + y.q = q; + if (y.q == 0.0) + return y.q; + y.i.h &= ~0x7FFF0000; + y.i.h |= 0x3FFF0000; + y.i.k = 0; + y.i.j = 0; + y.i.l = 0; + e = 16382 + i; + if (e < 0) + e = 0; + else if (e > 32767) + e = 32767; + x.i.h = e << 16; + x.i.l = 0; + x.i.k = 0; + x.i.j = 0; + return x.q * y.q; +} + +__REAL16_T +ENTF90(SETEXPQ, setexpq)(__REAL16_T *q, void *i, __INT_T *size) +{ + int e; + __REAL16_SPLIT x, y; + + y.q = *q; + if (y.q == 0.0) + return y.q; + y.i.h &= ~0x7FFF0000; + y.i.h |= 0x3FFF0000; + e = 16382 + I8(__fort_varying_int)(i, size); + if (e < 0) + e = 0; + else if (e > 32767) + e = 32767; + x.i.h = e << 16; + x.i.l = 0; + return x.q * y.q; +} +//AOCC End + __REAL4_T ENTF90(SPACINGX, spacingx)(__REAL4_T f) { @@ -4821,6 +5137,29 @@ ENTF90(SPACINGD, spacingd)(__REAL8_T *d) return ENTF90(SPACINGDX, spacingdx)(*d); } +//AOCC Begin +__REAL16_T +ENTF90(SPACINGQX, spacingqx)(__REAL16_T q) +{ + int e; + __REAL16_SPLIT x; + + x.q = q; + e = ((x.i.h >> 16) & 0x7FFF) - 112; + if (e < 1) + e = 1; + x.i.h = e << 16; + x.i.l = 0; + return x.q; +} + +__REAL16_T +ENTF90(SPACINGQ, spacingq)(__REAL16_T *q) +{ + return ENTF90(SPACINGQX, spacingqx)(*q); +} +//AOCC End + #ifndef DESC_I8 typedef __INT8_T SZ_T; @@ -4842,6 +5181,8 @@ _MZERO(4, int) _MZERO(8, long long) +_MZERO(16, __float128) + void ENTF90(MZEROZ8, mzeroz8)(void *d, SZ_T size) { @@ -4858,6 +5199,14 @@ ENTF90(MZEROZ16, mzeroz16)(void *d, SZ_T size) } } +void +ENTF90(MZEROZ32, mzeroz32)(void *d, SZ_T size) +{ + if (d && size > 0) { + __c_mzero16(d, size * 2); + } +} + #undef _MSET #define _MSET(n, t) \ void ENTF90(MSET##n, mset##n)(void *d, void *v, SZ_T size) \ @@ -4910,6 +5259,24 @@ ENTF90(MSETZ16, msetz16)(void *d, void *v, SZ_T size) } } +void +ENTF90(MSETZ32, msetz32)(void *d, void *v, SZ_T size) +{ + if (d) { + SZ_T i; + __float128 *pd; + __float128 v0, v1; + pd = (__float128 *)d; + v0 = ((__float128 *)v)[0]; + v1 = ((__float128 *)v)[1]; + for (i = 0; i < size; i++) { + pd[0] = v0; + pd[1] = v1; + pd += 2; + } + } +} + #undef _MCOPY #define _MCOPY(n, t) \ void ENTF90(MCOPY##n, mcopy##n)(void *d, void *v, SZ_T size) \ @@ -4926,6 +5293,8 @@ _MCOPY(4, int) _MCOPY(8, long long) +_MCOPY(16, __float128) + void ENTF90(MCOPYZ8, mcopyz8)(void *d, void *v, SZ_T size) { @@ -4942,6 +5311,14 @@ ENTF90(MCOPYZ16, mcopyz16)(void *d, void *v, SZ_T size) } } +void +ENTF90(MCOPYZ32, mcopyz32)(void *d, void *v, SZ_T size) +{ + if (d && v && size) { + __c_mcopy16(d, v, size * 2); + } +} + #endif /* #if !defined(DESC_I8) */ /** \brief diff --git a/runtime/flang/mmcmplx32.c b/runtime/flang/mmcmplx32.c new file mode 100644 index 0000000000..fb231345e5 --- /dev/null +++ b/runtime/flang/mmcmplx32.c @@ -0,0 +1,549 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + +/* clang-format off */ + +#include "stdioInterf.h" +#include "fioMacros.h" +#include "complex.h" + +#define SMALL_ROWSA 10 +#define SMALL_ROWSB 10 +#define SMALL_COLSB 10 + +void ENTF90(MMUL_cmplx32, + mmul_cmplx32)(int ta, int tb, __POINT_T mra, __POINT_T ncb, + __POINT_T kab, __float128 *alpha, + __float128 a[], __POINT_T lda, __float128 b[], + __POINT_T ldb, __float128 *beta, + __float128 c[], __POINT_T ldc) +{ + /* + * Notes on parameters + * ta, tb = 0 -> no transpose of matrix + * ta, tb = 1 -> transpose of matrix + * ta, tb = 2 -> conjugate of matrix + * mra = number of rows in matrices a and c ( = m ) + * ncb = number of columns in matrices b and c ( = n ) + * kab = shared dimension of matrices a and b ( = k, but need k elsewhere ) + * a = starting address of matrix a + * b = starting address of matrix b + * c = starting address of matric c + * lda = leading dimension of matrix a + * ldb = leading dimension of matrix b + * ldc = leading dimension of matrix c + * alpha = 1.0 + * beta = 0.0 + * Note that these last two conditions are inconsitent with the general + * case for dgemm. + * Taken together we have + * c = beta * c + alpha * ( (ta)a * (tb)*b ) + * where the meaning of (ta) and (tb) is that if ta = 0 a is not transposed + * and transposed otherwise and if tb = 0, b is not transpose and transposed + * otherwise. + */ + + // Local variables + + int colsa, rowsa, rowsb, colsb; + int ar, ac; + int ndx, ndxsav, colchunk, colchunks, rowchunk, rowchunks; + int colsb_chunks, colsb_end, colsb_strt; + int bufr, bufc, loc, lor; + int small_size = SMALL_ROWSA * SMALL_ROWSB * SMALL_COLSB; + int tindex = 0; + __float128 buffera[SMALL_ROWSA * SMALL_ROWSB]; + __float128 bufferb[SMALL_COLSB * SMALL_ROWSB]; + __float128 temp; + void ftn_mvmul_cmplx32_(), ftn_vmmul_cmplx32_(); + void ftn_mnaxnb_cmplx32_(), ftn_mnaxtb_cmplx32_(); + void ftn_mtaxnb_cmplx32_(), ftn_mtaxtb_cmplx32_(); + __float128 calpha, cbeta; + /* + * Small matrix multiply variables + */ + int i, ia, ja, j, k, bk; + int astrt, bstrt, cstrt, andx, bndx, cndx, indx, indx_strt; + /* + * We will structure this code a bit different from the real code + * since there are 9 cases rather than 4. + * We will switch on ta and then on tb. + */ + calpha = *alpha; + cbeta = *beta; + rowsa = mra; + colsa = kab; + rowsb = kab; + colsb = ncb; + if (calpha == 0.0) { + if (cbeta == 0.0) { + cndx = 0; + indx_strt = ldc; + for (j = 0; j < ncb; j++) { + for (i = 0; i < mra; i++) + c[cndx + i] = 0.0; + cndx = indx_strt; + indx_strt += ldc; + } + } else { + cndx = 0; + indx_strt = ldc; + for (j = 0; j < ncb; j++) { + for (i = 0; i < mra; i++) + c[cndx + i] = cbeta * c[cndx + i]; + cndx = indx_strt; + indx_strt += ldc; + } + } + return; + } + + /* if( ( tb != 1 ) && ( ncb == 1 ) && ( ldc == 1 ) ){ */ + if ((tb != 1) && (ncb == 1)) { + /* matrix vector multiply */ + ftn_mvmul_cmplx32_(&ta, &tb, &mra, &kab, alpha, a, &lda, b, beta, c); + return; + } + if ((ta != 1) && (mra == 1)) { + /* vector matrix multiply */ + ftn_vmmul_cmplx32_(&ta, &tb, &ncb, &kab, alpha, a, b, &ldb, beta, c); + return; + } + + // Check for really small matrix sizes + if ((colsb <= SMALL_COLSB) && (rowsa <= SMALL_ROWSA) && + (rowsb <= SMALL_ROWSB)) { + if (ta == 0) { /* a is normally oriented */ + if (tb == 0) { + astrt = 0; + cstrt = 0; + for (i = 0; i < rowsa; i++) { + /* Transpose the a row of the a matrix */ + bstrt = 0; + andx = astrt; + indx = 0; + for (ja = 0; ja < colsa; ja++) { + buffera[indx++] = calpha * a[andx]; + andx += lda; + } + astrt++; + cndx = cstrt; + /* Now use the transposed row on all of b */ + if (cbeta == 0.0) { + for (j = 0; j < colsb; j++) { + temp = 0.0; + bndx = bstrt; + for (k = 0; k < rowsb; k++) + temp += buffera[k] * b[bndx++]; + bstrt += ldb; + c[cndx] = temp; + cndx += ldc; + } + } else { + for (j = 0; j < colsb; j++) { + temp = 0.0; + bndx = bstrt; + for (k = 0; k < rowsb; k++) + temp += buffera[k] * b[bndx++]; + bstrt += ldb; + c[cndx] = temp + cbeta * c[cndx]; + cndx += ldc; + } + } + cstrt++; /* set index for next row of c */ + } + } else { + if (tb == 1) { /* b is transposed */ + indx_strt = 0; + bstrt = 0; + for (j = 0; j < rowsb; j++) { + indx = indx_strt; + bndx = bstrt; + for (i = 0; i < colsb; i++) { + bufferb[indx] = b[bndx++]; + // printf( "( %f, %f )\n", crealf( + // bufferb[indx] ), cimagf( bufferb[indx] ) ); + + indx += rowsb; + } + indx_strt++; + bstrt += ldb; + } + } else { /* b is conjugated */ + indx_strt = 0; + bstrt = 0; + for (j = 0; j < rowsb; j++) { + indx = indx_strt; + bndx = bstrt; + for (i = 0; i < colsb; i++) { + bufferb[indx] = conjf(b[bndx++]); + // printf( "( %f, %f )\n", crealf( bufferb[indx] ), + // cimagf( bufferb[indx] ) ); + indx += rowsb; + } + indx_strt++; + bstrt += ldb; + } + } + + /* Now muliply the transposed b matrix by a */ + + if (cbeta == 0.0) { /* beta == 0.0 */ + astrt = 0; + indx = 0; + cstrt = 0; + for (i = 0; i < rowsa; i++) { + /* Transpose the a row of the a matrix */ + andx = astrt; + indx = 0; /* indx will be used for accessing both buffera and + bufferb */ + for (ja = 0; ja < colsa; ja++) { + buffera[indx++] = a[andx]; + andx += lda; + } + astrt++; + cndx = cstrt; + indx = 0; + for (j = 0; j < colsb; j++) { + temp = 0.0; + for (k = 0; k < rowsb; k++) + temp += buffera[k] * bufferb[indx++]; + c[cndx] = calpha * temp; + cndx += ldc; + // printf( "( %f, %f )\n", crealf( c[cndx] ), cimagf( + // c[cndx] ) ); + } + cstrt++; /* set index for next row of c */ + indx_strt = 0; + } + } else { /* beta != 0.0 */ + astrt = 0; + indx = 0; + cstrt = 0; + for (i = 0; i < rowsa; i++) { + /* Transpose the a row of the a matrix */ + andx = astrt; + indx = 0; /* indx will be used for accessing both buffera and + bufferb */ + for (ja = 0; ja < colsa; ja++) { + buffera[indx++] = a[andx]; + andx += lda; + } + astrt++; + cndx = cstrt; + indx = 0; + for (j = 0; j < colsb; j++) { + temp = 0.0; + for (k = 0; k < rowsb; k++) + temp += buffera[k] * bufferb[indx++]; + c[cndx] = cbeta * c[cndx] + calpha * temp; + cndx += ldc; + } + cstrt++; /* set index for next row of c */ + indx_strt = 0; + } + } + } + } + + else if (ta == 1) { /* a is transposed */ + if (tb == 0) { + astrt = 0; + cstrt = 0; + if (cbeta == 0.0) { /* beta == 0 */ + for (i = 0; i < rowsa; i++) { + cndx = cstrt; + bstrt = 0; + for (j = 0; j < colsb; j++) { + temp = 0.0; + bndx = bstrt; + andx = astrt; + for (k = 0; k < rowsb; k++) + temp += a[andx++] * b[bndx++]; + c[cndx] = calpha * temp; + // printf( "( %f, %f )\n", crealf( c[cndx] ), cimagf( + // c[cndx] ) ); + + bstrt += ldb; + cndx += ldc; + } + cstrt++; + astrt += lda; + cstrt++; /* set index for next row of c */ + } + } else { /* beta != 0 */ + astrt = 0; + cstrt = 0; + for (i = 0; i < rowsa; i++) { + cndx = cstrt; + bstrt = 0; + ; + for (j = 0; j < colsb; j++) { + temp = 0.0; + bndx = bstrt; + andx = astrt; + for (k = 0; k < rowsb; k++) { + temp += a[andx] * b[bndx]; + andx++; + bndx++; + } + c[cndx] = cbeta * c[cndx] + calpha * temp; + // printf( "( %f, %f )\n", crealf( c[cndx] ), cimagf( c[cndx] ) ); + bstrt += ldb; + cndx += ldc; + } + cstrt++; + astrt += lda; + } + } + } else { + if (tb == 1) { /* b is transposed */ + indx_strt = 0; + bstrt = 0; + for (j = 0; j < rowsb; j++) { + indx = indx_strt; + bndx = bstrt; + for (i = 0; i < colsb; i++) { + bufferb[indx] = calpha * b[bndx++]; + // printf( "( %f, %f )\n", crealf( bufferb[indx] ), cimagf( + // bufferb[indx] ) ); + indx += rowsb; + } + indx_strt++; + bstrt += ldb; + } + } else { /* b is conjugated */ + indx_strt = 0; + bstrt = 0; + for (j = 0; j < rowsb; j++) { + indx = indx_strt; + bndx = bstrt; + for (i = 0; i < colsb; i++) { + bufferb[indx] = calpha * conjf(b[bndx++]); + // printf( "( %f, %f )\n", crealf( bufferb[indx] ), + // cimagf( bufferb[indx] ) ); + indx += rowsb; + } + indx_strt++; + bstrt += ldb; + } + } + + /* Now muliply the transposed b matrix by a, which is transposed */ + + if (cbeta == 0.0) { /* beta == 0.0 */ + astrt = 0; + indx = 0; + cstrt = 0; + for (i = 0; i < rowsa; i++) { + andx = astrt; + indx = 0; /* indx will be used for accessing both buffera and + bufferb */ + cndx = cstrt; + for (j = 0; j < colsb; j++) { + temp = 0.0; + andx = astrt; + for (k = 0; k < rowsb; k++) + temp += a[andx++] * bufferb[indx++]; + c[cndx] = temp; + cndx += ldc; + // printf( "( %f, %f )\n", crealf( c[cndx] ), cimagf( + // c[cndx] ) ); + } + cstrt++; /* set index for next row of c */ + astrt += lda; + } + } + + else { /* beta != 0.0 */ + astrt = 0; + indx = 0; + cstrt = 0; + for (i = 0; i < rowsa; i++) { + andx = astrt; + indx = 0; /* indx will be used for accessing both buffera and + bufferb */ + + cndx = cstrt; + for (j = 0; j < colsb; j++) { + temp = 0.0; + andx = astrt; + for (k = 0; k < rowsb; k++) + temp += a[andx++] * bufferb[indx++]; + c[cndx] = cbeta * c[cndx] + temp; + cndx += ldc; + // printf( "( %f, %f )\n", crealf( c[cndx] ), cimagf( + // c[cndx] ) ); + } + cstrt++; /* set index for next row of c */ + astrt += lda; + } + } + } + } else { /* a is conjugated */ + if (tb == 0) { + astrt = 0; + cstrt = 0; + for (i = 0; i < rowsa; i++) { + /* Transpose the a row of the a matrix */ + bstrt = 0; + andx = astrt; + indx = 0; + for (ja = 0; ja < colsa; ja++) { + buffera[indx++] = calpha * a[andx]; + andx += lda; + } + astrt++; + cndx = cstrt; + /* Now use the transposed row on all of b */ + if (cbeta == 0.0) { + for (j = 0; j < colsb; j++) { + temp = 0.0; + bndx = bstrt; + for (k = 0; k < rowsb; k++) + temp += buffera[k] * b[bndx++]; + bstrt += ldb; + c[cndx] = temp; + cndx += ldc; + } + cstrt++; /* set index for next row of c */ + } else { + for (j = 0; j < colsb; j++) { + temp = 0.0; + bndx = bstrt; + for (k = 0; k < rowsb; k++) + temp += buffera[k] * b[bndx++]; + bstrt += ldb; + c[cndx] = temp + cbeta * c[cndx]; + cndx += ldc; + } + cstrt++; /* set index for next row of c */ + } + } + } else { + if (tb == 1) { /* b is transposed */ + indx_strt = 0; + bstrt = 0; + for (j = 0; j < rowsb; j++) { + indx = indx_strt; + bndx = bstrt; + for (i = 0; i < colsb; i++) { + bufferb[indx] = calpha * b[bndx++]; + // printf( "( %f, %f )\n", crealf( + // bufferb[indx] ), cimagf( bufferb[indx] ) ); + + indx += rowsb; + } + indx_strt++; + bstrt += ldb; + } + } else { /* b is conjugated */ + indx_strt = 0; + bstrt = 0; + for (j = 0; j < rowsb; j++) { + indx = indx_strt; + bndx = bstrt; + for (i = 0; i < colsb; i++) { + bufferb[indx] = calpha * conjf(b[bndx++]); + // printf( "( %f, %f )\n", crealf( bufferb[indx] ), + // cimagf( bufferb[indx] ) ); + indx += rowsb; + } + indx_strt++; + bstrt += ldb; + } + } + + /* Now muliply the transposed b matrix by a */ + + if (cbeta == 0.0) { /* beta == 0.0 */ + astrt = 0; + indx = 0; + cstrt = 0; + for (i = 0; i < rowsa; i++) { + /* Transpose the a row of the a matrix */ + andx = astrt; + indx = 0; /* indx will be used for accessing both buffera and + bufferb */ + for (ja = 0; ja < colsa; ja++) { + buffera[indx++] = calpha * a[andx]; + andx += lda; + } + astrt++; + cndx = cstrt; + indx = 0; + for (j = 0; j < colsb; j++) { + temp = 0.0; + for (k = 0; k < rowsb; k++) + temp += buffera[k] * bufferb[indx++]; + c[cndx] = temp; + cndx += ldc; + // printf( "( %f, %f )\n", crealf( c[cndx] ), cimagf( + // c[cndx] ) ); + } + cstrt++; /* set index for next row of c */ + indx_strt = 0; + } + } else { /* beta != 0.0 */ + astrt = 0; + indx = 0; + cstrt = 0; + for (i = 0; i < rowsa; i++) { + /* Transpose the a row of the a matrix */ + andx = astrt; + indx = 0; /* indx will be used for accessing both buffera and + bufferb */ + for (ja = 0; ja < colsa; ja++) { + buffera[indx++] = calpha * a[andx]; + andx += lda; + } + astrt++; + cndx = cstrt; + indx = 0; + for (j = 0; j < colsb; j++) { + temp = 0.0; + for (k = 0; k < rowsb; k++) + temp += buffera[k] * bufferb[indx++]; + c[cndx] = cbeta * c[cndx] + temp; + // printf( "( %f, %f )\n", crealf( c[cndx] ), cimagf( + // c[cndx] ) ); + cndx += ldc; + } + cstrt++; /* set index for next row of c */ + indx_strt = 0; + } + } + } + } + } + + else { + tindex = 3; + if (ta == 0) + tindex--; + if (tb == 0) + tindex -= 2; + switch (tindex) { + case 0: + ftn_mnaxnb_cmplx32_(&mra, &ncb, &kab, alpha, a, &lda, b, &ldb, + beta, c, &ldc); + break; + case 1: + ftn_mtaxnb_cmplx32_(&mra, &ncb, &kab, alpha, a, &lda, b, &ldb, + beta, c, &ldc); + break; + case 2: + ftn_mnaxtb_cmplx32_(&mra, &ncb, &kab, alpha, a, &lda, b, &ldb, + beta, c, &ldc); + break; + case 3: + ftn_mtaxtb_cmplx32_(&mra, &ncb, &kab, alpha, a, &lda, b, &ldb, + beta, c, &ldc); + } + } + +} diff --git a/runtime/flang/mmul.c b/runtime/flang/mmul.c index b89dba03c8..4114f4e5a4 100644 --- a/runtime/flang/mmul.c +++ b/runtime/flang/mmul.c @@ -45,6 +45,17 @@ dotp_real8(__REAL8_T *c, int nj, __REAL8_T *a, int ai, int ais, __REAL8_T *b, *c = cc; } +static void +dotp_real16(__REAL16_T *c, int nj, __REAL16_T *a, int ai, int ais, __REAL16_T *b, + int bk, int bks) +{ + register __float128 cc; + cc = *c; + for (; --nj >= 0; ai += ais, bk += bks) + cc += a[ai] * b[bk]; + *c = cc; +} + static void dotp_cplx8(__CPLX8_T *c, int nj, __CPLX8_T *a, int ai, int ais, __CPLX8_T *b, int bk, int bks) @@ -90,6 +101,21 @@ dotp_cplx16(__CPLX16_T *c, int nj, __CPLX16_T *a, int ai, int ais, c->i = ci; } +static void +dotp_cplx32(__CPLX32_T *c, int nj, __CPLX32_T *a, int ai, int ais, + __CPLX32_T *b, int bk, int bks) +{ + register __float128 cr, ci; + cr = c->r; + ci = c->i; + for (; --nj >= 0; ai += ais, bk += bks) { + cr += (__float128) a[ai].r * (__float128) b[bk].r + (__float128) a[ai].i * (__float128) b[bk].i; + ci += (__float128) a[ai].r * (__float128) b[bk].i - (__float128) a[ai].i * (__float128) b[bk].r; + } + c->r = cr; + c->i = ci; +} + static void mmul_cplx16(__CPLX16_T *c, int nj, __CPLX16_T *a, int ai, int ais, __CPLX16_T *b, int bk, int bks) @@ -105,6 +131,23 @@ mmul_cplx16(__CPLX16_T *c, int nj, __CPLX16_T *a, int ai, int ais, c->i = ci; } +// AOCC begin +static void +mmul_cplx32(__CPLX32_T *c, int nj, __CPLX32_T *a, int ai, int ais, + __CPLX32_T *b, int bk, int bks) +{ + register __float128 cr, ci; + cr = c->r; + ci = c->i; + for (; --nj >= 0; ai += ais, bk += bks) { + cr += a[ai].r * b[bk].r - a[ai].i * b[bk].i; + ci += a[ai].r * b[bk].i + a[ai].i * b[bk].r; + } + c->r = cr; + c->i = ci; +} +// AOCC end + static void dotp_int1(__INT1_T *c, int nj, __INT1_T *a, int ai, int ais, __INT1_T *b, int bk, int bks) @@ -276,12 +319,18 @@ void ENTFTN(DOTPR, dotpr)(char *cb, char *ab0, char *bb0, F90_Desc *cs, case __REAL8: dotp = dotp_real8; break; + case __REAL16: + dotp = dotp_real16; + break; case __CPLX8: dotp = dotp_cplx8; break; case __CPLX16: dotp = dotp_cplx16; break; + case __CPLX32: + dotp = dotp_cplx32; + break; case __INT1: dotp = dotp_int1; break; @@ -458,12 +507,18 @@ static void I8(mmul_mxm)(char *cb0, char *ab0, char *bb0, F90_Desc *cs0, case __REAL8: mmul = dotp_real8; break; + case __REAL16: + mmul = dotp_real16; + break; case __CPLX8: mmul = mmul_cplx8; break; case __CPLX16: mmul = mmul_cplx16; break; + case __CPLX32: + mmul = mmul_cplx32; + break; case __INT1: mmul = dotp_int1; break; @@ -682,12 +737,18 @@ static void I8(mmul_vxm)(char *cb0, char *ab0, char *bb0, F90_Desc *cs0, case __REAL8: mmul = dotp_real8; break; + case __REAL16: + mmul = dotp_real16; + break; case __CPLX8: mmul = mmul_cplx8; break; case __CPLX16: mmul = mmul_cplx16; break; + case __CPLX32: + mmul = mmul_cplx32; + break; case __INT1: mmul = dotp_int1; break; @@ -930,12 +991,18 @@ static void I8(mmul_mxv)(char *cb0, char *ab0, char *bb0, F90_Desc *cs0, case __REAL8: mmul = dotp_real8; break; + case __REAL16: + mmul = dotp_real16; + break; case __CPLX8: mmul = mmul_cplx8; break; case __CPLX16: mmul = mmul_cplx16; break; + case __CPLX32: + mmul = mmul_cplx32; + break; case __INT1: mmul = dotp_int1; break; diff --git a/runtime/flang/mmul_cplx32contmxm.F95 b/runtime/flang/mmul_cplx32contmxm.F95 new file mode 100644 index 0000000000..f8df8080f1 --- /dev/null +++ b/runtime/flang/mmul_cplx32contmxm.F95 @@ -0,0 +1,39 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +! Notified per clause 4(b) of the license. +! Last Modified: Oct 2020 + + +#include "mmul_dir.h" + +subroutine F90_matmul_cplx32_contmxm(dest, src1, src2, k_extent,m_extent,n_extent) + + COMPLEX*32, dimension(k_extent,m_extent) :: src1 + COMPLEX*32, dimension(m_extent,n_extent) :: src2 + COMPLEX*32, dimension(k_extent,n_extent) :: dest + DESC_INT k_extent + DESC_INT n_extent + DESC_INT m_extent + + DESC_INT k + DESC_INT n + DESC_INT m + + do n=1,n_extent + do k=1,k_extent + dest(k,n) = 0 + end do + end do + do n=1,n_extent + do m=1,m_extent + do k=1,k_extent + dest(k,n) = dest(k,n) + src1(k,m) * src2(m,n) + end do + end do + end do + +end subroutine diff --git a/runtime/flang/mmul_cplx32contmxv.F95 b/runtime/flang/mmul_cplx32contmxv.F95 new file mode 100644 index 0000000000..52e22515f1 --- /dev/null +++ b/runtime/flang/mmul_cplx32contmxv.F95 @@ -0,0 +1,33 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +! Notified per clause 4(b) of the license. +! Last Modified: Oct 2020 + + +#include "mmul_dir.h" + +subroutine F90_matmul_cplx32_contmxv(dest, src1, src2, k_extent, m_extent) + + DESC_INT k_extent + DESC_INT m_extent + COMPLEX*32, dimension(k_extent,m_extent) :: src1 + COMPLEX*32, dimension(m_extent) :: src2 + COMPLEX*32, dimension(k_extent) :: dest + + DESC_INT k + DESC_INT m + + do k=1,k_extent + dest(k) = 0 + end do + do m=1,m_extent + do k=1,k_extent + dest(k) = dest(k) + src1(k,m) * src2(m) + end do + end do + +end subroutine diff --git a/runtime/flang/mmul_cplx32contvxm.F95 b/runtime/flang/mmul_cplx32contvxm.F95 new file mode 100644 index 0000000000..9fab4434ef --- /dev/null +++ b/runtime/flang/mmul_cplx32contvxm.F95 @@ -0,0 +1,32 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! +! Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +! Notified per clause 4(b) of the license. +! Last Modified: Oct 2020 +! + +#include "mmul_dir.h" + +subroutine F90_matmul_cplx32_contvxm(dest, src1, src2, m_extent, n_extent) + + DESC_INT n_extent + DESC_INT m_extent + COMPLEX*32, dimension(m_extent) :: src1 + COMPLEX*32, dimension(m_extent,n_extent) :: src2 + COMPLEX*32, dimension(n_extent) :: dest + + DESC_INT n + DESC_INT m + + do n=1,n_extent + dest(n) = 0 + do m=1,m_extent + dest(n) = dest(n) + src1(m) * src2(m,n) + end do + end do + +end subroutine diff --git a/runtime/flang/mmul_cplx32str1.F95 b/runtime/flang/mmul_cplx32str1.F95 new file mode 100644 index 0000000000..741aedec41 --- /dev/null +++ b/runtime/flang/mmul_cplx32str1.F95 @@ -0,0 +1,854 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +! Notified per clause 4(b) of the license. +! Last Modified: Oct 2020 + + + +#include "mmul_dir.h" + +subroutine F90_matmul_cplx32_str1(dest,s1,s2, & + k_extnt,m_extnt,n_extnt, & + s1_d1_extnt,s2_d1_extnt,d_d1_extnt, & + d_d1_lstride) + + DESC_INT n_extnt,m_extnt,k_extnt + DESC_INT s1_d1_extnt,s2_d1_extnt,d_d1_extnt,d_d1_lstride + INTEGER bs + parameter (bs=192) + COMPLEX*32 s1(s1_d1_extnt,m_extnt) + COMPLEX*32 s2(s2_d1_extnt,k_extnt) + COMPLEX*32 dest(d_d1_extnt,n_extnt*d_d1_lstride) + DESC_INT i, j, l, nmod4, mmod4 + DESC_INT ii,jj,ll,temppos, nn, kk, itest + COMPLEX*32 t00,t01,t02,t03 + COMPLEX*32 t10,t11,t12,t13 + COMPLEX*32 t20,t21,t22,t23 + COMPLEX*32 t30,t31,t32,t33 + COMPLEX*32 temp0, temp1, temp2, temp3, temp (bs*bs) + COMPLEX*32 s20, s21, s22, s23 + INTEGER flag + COMPLEX*32 zero + parameter (zero = 0.0q0) + + DESC_INT k,n,m + + if (d_d1_lstride .eq. 1) then + nmod4 = mod (k_extnt, 4) + mmod4 = mod (n_extnt, 4) + kk = k_extnt - nmod4 + nn = n_extnt - mmod4 + itest = nmod4 + mmod4 + do jj=1,k_extnt,bs + do ii=1,n_extnt,bs + flag = 0 + do ll=1,m_extnt,bs + temppos = 1 + if ((k_extnt .ge. 4) .and. (n_extnt .ge. 4)) then + if (jj .le. kk) then + j = jj + do i=ii,min(nn,ii+bs-1),4 + if (flag .eq. 0) then + t00=zero + t01=zero + t02=zero + t03=zero + t10=zero + t11=zero + t12=zero + t13=zero + t20=zero + t21=zero + t22=zero + t23=zero + t30=zero + t31=zero + t32=zero + t33=zero + else + t00=dest(i+0,j+0) + t01=dest(i+0,j+1) + t02=dest(i+0,j+2) + t03=dest(i+0,j+3) + t10=dest(i+1,j+0) + t11=dest(i+1,j+1) + t12=dest(i+1,j+2) + t13=dest(i+1,j+3) + t20=dest(i+2,j+0) + t21=dest(i+2,j+1) + t22=dest(i+2,j+2) + t23=dest(i+2,j+3) + t30=dest(i+3,j+0) + t31=dest(i+3,j+1) + t32=dest(i+3,j+2) + t33=dest(i+3,j+3) + end if + do l=ll,min(m_extnt,ll+bs-1) + temp0 = s1(i+0,l) + temp1 = s1(i+1,l) + temp2 = s1(i+2,l) + temp3 = s1(i+3,l) + s20 = s2(l,j+0) + s21 = s2(l,j+1) + s22 = s2(l,j+2) + s23 = s2(l,j+3) + t00=t00+s20*temp0 + t01=t01+s21*temp0 + t02=t02+s22*temp0 + t03=t03+s23*temp0 + t10=t10+s20*temp1 + t11=t11+s21*temp1 + t12=t12+s22*temp1 + t13=t13+s23*temp1 + t20=t20+s20*temp2 + t21=t21+s21*temp2 + t22=t22+s22*temp2 + t23=t23+s23*temp2 + t30=t30+s20*temp3 + t31=t31+s21*temp3 + t32=t32+s22*temp3 + t33=t33+s23*temp3 + temp (temppos+0) = temp0 + temp (temppos+1) = temp1 + temp (temppos+2) = temp2 + temp (temppos+3) = temp3 + temppos = temppos + 4 + end do + dest(i+0,j+0)=t00 + dest(i+0,j+1)=t01 + dest(i+0,j+2)=t02 + dest(i+0,j+3)=t03 + dest(i+1,j+0)=t10 + dest(i+1,j+1)=t11 + dest(i+1,j+2)=t12 + dest(i+1,j+3)=t13 + dest(i+2,j+0)=t20 + dest(i+2,j+1)=t21 + dest(i+2,j+2)=t22 + dest(i+2,j+3)=t23 + dest(i+3,j+0)=t30 + dest(i+3,j+1)=t31 + dest(i+3,j+2)=t32 + dest(i+3,j+3)=t33 + end do + do j=jj+4,min(kk,jj+bs-1),4 + temppos = 1 + do i=ii,min(nn,ii+bs-1),4 + if (flag .eq. 0) then + t00=zero + t01=zero + t02=zero + t03=zero + t10=zero + t11=zero + t12=zero + t13=zero + t20=zero + t21=zero + t22=zero + t23=zero + t30=zero + t31=zero + t32=zero + t33=zero + else + t00=dest(i+0,j+0) + t01=dest(i+0,j+1) + t02=dest(i+0,j+2) + t03=dest(i+0,j+3) + t10=dest(i+1,j+0) + t11=dest(i+1,j+1) + t12=dest(i+1,j+2) + t13=dest(i+1,j+3) + t20=dest(i+2,j+0) + t21=dest(i+2,j+1) + t22=dest(i+2,j+2) + t23=dest(i+2,j+3) + t30=dest(i+3,j+0) + t31=dest(i+3,j+1) + t32=dest(i+3,j+2) + t33=dest(i+3,j+3) + endif + do l=ll,min(m_extnt,ll+bs-1) + temp0 = temp (temppos+0) + temp1 = temp (temppos+1) + temp2 = temp (temppos+2) + temp3 = temp (temppos+3) + s20 = s2(l,j+0) + s21 = s2(l,j+1) + s22 = s2(l,j+2) + s23 = s2(l,j+3) + t00=t00+s20*temp0 + t01=t01+s21*temp0 + t02=t02+s22*temp0 + t03=t03+s23*temp0 + t10=t10+s20*temp1 + t11=t11+s21*temp1 + t12=t12+s22*temp1 + t13=t13+s23*temp1 + t20=t20+s20*temp2 + t21=t21+s21*temp2 + t22=t22+s22*temp2 + t23=t23+s23*temp2 + t30=t30+s20*temp3 + t31=t31+s21*temp3 + t32=t32+s22*temp3 + t33=t33+s23*temp3 + temppos = temppos + 4 + end do + dest(i+0,j+0)=t00 + dest(i+0,j+1)=t01 + dest(i+0,j+2)=t02 + dest(i+0,j+3)=t03 + dest(i+1,j+0)=t10 + dest(i+1,j+1)=t11 + dest(i+1,j+2)=t12 + dest(i+1,j+3)=t13 + dest(i+2,j+0)=t20 + dest(i+2,j+1)=t21 + dest(i+2,j+2)=t22 + dest(i+2,j+3)=t23 + dest(i+3,j+0)=t30 + dest(i+3,j+1)=t31 + dest(i+3,j+2)=t32 + dest(i+3,j+3)=t33 + end do + end do + end if + end if + if (itest .ne. 0) then + if (nmod4 .ne. 0) then + temppos = 1 + do j=kk+1,min(kk+1,jj+bs-1) + do i=ii,min(nn,ii+bs-1),4 + if (flag .eq. 0) then + t00=zero + t10=zero + t20=zero + t30=zero + else + t00=dest(i+0,j+0) + t10=dest(i+1,j+0) + t20=dest(i+2,j+0) + t30=dest(i+3,j+0) + end if + do l=ll,min(m_extnt,ll+bs-1) + temp0 = s1(i+0,l) + temp1 = s1(i+1,l) + temp2 = s1(i+2,l) + temp3 = s1(i+3,l) + t00=t00+s2(l,j+0)*temp0 + t10=t10+s2(l,j+0)*temp1 + t20=t20+s2(l,j+0)*temp2 + t30=t30+s2(l,j+0)*temp3 + temp (temppos+0) = temp0 + temp (temppos+1) = temp1 + temp (temppos+2) = temp2 + temp (temppos+3) = temp3 + temppos = temppos + 4 + end do + dest(i+0,j+0)=t00 + dest(i+1,j+0)=t10 + dest(i+2,j+0)=t20 + dest(i+3,j+0)=t30 + end do + end do + do j=kk+2,min(k_extnt,jj+bs-1) + temppos = 1 + do i=ii,min(nn,ii+bs-1),4 + if (flag .eq. 0) then + t00=zero + t10=zero + t20=zero + t30=zero + else + t00=dest(i+0,j+0) + t10=dest(i+1,j+0) + t20=dest(i+2,j+0) + t30=dest(i+3,j+0) + end if + do l=ll,min(m_extnt,ll+bs-1) + temp0 = temp (temppos+0) + temp1 = temp (temppos+1) + temp2 = temp (temppos+2) + temp3 = temp (temppos+3) + t00=t00+s2(l,j+0)*temp0 + t10=t10+s2(l,j+0)*temp1 + t20=t20+s2(l,j+0)*temp2 + t30=t30+s2(l,j+0)*temp3 + temppos = temppos + 4 + end do + dest(i+0,j+0)=t00 + dest(i+1,j+0)=t10 + dest(i+2,j+0)=t20 + dest(i+3,j+0)=t30 + end do + end do + end if + if (mmod4 .ne. 0) then + temppos = 1 + if (jj .le. kk) then + j = jj + do i=nn+1,min(n_extnt,ii+bs-1) + if (flag .eq. 0) then + t00=zero + t01=zero + t02=zero + t03=zero + else + t00=dest(i+0,j+0) + t01=dest(i+0,j+1) + t02=dest(i+0,j+2) + t03=dest(i+0,j+3) + end if + do l=ll,min(m_extnt,ll+bs-1) + temp0 = s1(i+0,l) + t00=t00+s2(l,j+0)*temp0 + t01=t01+s2(l,j+1)*temp0 + t02=t02+s2(l,j+2)*temp0 + t03=t03+s2(l,j+3)*temp0 + temp (temppos) = temp0 + temppos = temppos + 1 + end do + dest(i+0,j+0)=t00 + dest(i+0,j+1)=t01 + dest(i+0,j+2)=t02 + dest(i+0,j+3)=t03 + end do + do j=jj+4,min(kk,jj+bs-1),4 + temppos = 1 + do i=nn+1,min(n_extnt,ii+bs-1) + if (flag .eq. 0) then + t00=zero + t01=zero + t02=zero + t03=zero + else + t00=dest(i+0,j+0) + t01=dest(i+0,j+1) + t02=dest(i+0,j+2) + t03=dest(i+0,j+3) + end if + do l=ll,min(m_extnt,ll+bs-1) + temp0 = temp (temppos) + t00=t00+s2(l,j+0)*temp0 + t01=t01+s2(l,j+1)*temp0 + t02=t02+s2(l,j+2)*temp0 + t03=t03+s2(l,j+3)*temp0 + temppos = temppos + 1 + end do + dest(i+0,j+0)=t00 + dest(i+0,j+1)=t01 + dest(i+0,j+2)=t02 + dest(i+0,j+3)=t03 + end do + end do + end if + end if + if ((nmod4 .ne. 0) .and. (mmod4 .ne. 0)) then + temppos = 1 + do j=kk+1,min(kk+1,jj+bs-1) + do i=nn+1,min(n_extnt,ii+bs-1) + if (flag .eq. 0) then + t00=zero + else + t00=dest(i,j) + end if + do l=ll,min(m_extnt,ll+bs-1) + temp0 = s1(i,l) + t00=t00+s2(l,j)*temp0 + temp (temppos) = temp0 + temppos = temppos + 1 + end do + dest(i,j)=t00 + end do + end do + do j=kk+2,min(k_extnt,jj+bs-1) + temppos = 1 + do i=nn+1,min(n_extnt,ii+bs-1) + if (flag .eq. 0) then + t00=zero + else + t00=dest(i,j) + end if + do l=ll,min(m_extnt,ll+bs-1) + temp0 = temp (temppos) + t00=t00+s2(l,j)*temp0 + temppos = temppos + 1 + end do + dest(i,j)=t00 + end do + end do + end if + end if + flag = 1 + end do + end do + end do + else + do k = 1, k_extnt + do n = 1, n_extnt + dest(1+(n-1)*d_d1_lstride,k) = 0.0q0 + enddo + enddo + do k = 1, k_extnt + do m = 1, m_extnt + do n = 1, n_extnt + dest(1+(n-1)*d_d1_lstride,k) = & + dest(1+(n-1)*d_d1_lstride,k) + & + s1(n,m) * s2(m,k) + enddo + enddo + enddo + endif + return + end + +subroutine F90_matmul_cplx32_str1_mxv(dest, s1,s2, & + n_extent,m_extent, ld1,dlstride) + + implicit none + DESC_INT n_extent,m_extent,ld1,ld2,dlstride + DESC_INT mmod4, mmod2, m2 + DESC_INT jx,kx,jj,kk,kmod4,k4,incx + DESC_INT j0,j1,j2,j3,iy,ky,m4 + COMPLEX*32 t0,t1,t2,t3 + COMPLEX*32 s1(ld1,m_extent) + COMPLEX*32 s2(m_extent) + COMPLEX*32 dest(ld1) + + DESC_INT i,j,k + INTEGER bs + parameter (bs = 384) + COMPLEX*32 temp (bs) + DESC_INT ind(bs) + COMPLEX*32 zero + parameter (zero = 0.0Q0) + + if (dlstride .eq. 1) then + do k = 1, n_extent + dest(k) = 0.0q0 + end do + mmod4 = mod(n_extent, 4) + mmod2 = mod(n_extent, 2) + m4 = n_extent - mmod4 + m2 = n_extent- mmod2 + kx = 1 + ky = 1 + incx = 1 + jx = kx + do jj = 1, m_extent, bs + jx = kx + (jj-1) + kk = 0 + do j = jj, min (m_extent, jj+bs-1) + if (s2(jx) .ne. zero) then + kk = kk + 1 + temp(kk) = s2(jx) + ind(kk) = j + end if + jx = jx + 1 + end do + kmod4 = mod(kk, 4) + k4 = kk - kmod4 + do j = 1, k4, 4 + t0 = temp(j) + t1 = temp(j+1) + t2 = temp(j+2) + t3 = temp(j+3) + j0 = ind(j) + j1 = ind(j+1) + j2 = ind(j+2) + j3 = ind(j+3) + iy = ky + do i = 1, m4, 4 + dest( iy ) = dest( iy )+t0*s1(i, j0) & + + t1*s1(i, j1) & + + t2*s1(i, j2) & + + t3*s1(i, j3) + + dest(iy+1) = dest(iy+1)+t0*s1(i+1, j0) & + + t1*s1(i+1, j1) & + + t2*s1(i+1, j2) & + + t3*s1(i+1, j3) + + dest(iy+2) = dest(iy+2)+t0*s1(i+2, j0) & + + t1*s1(i+2, j1) & + + t2*s1(i+2, j2) & + + t3*s1(i+2, j3) + + dest(iy+3) = dest(iy+3 )+t0*s1(i+3, j0) & + + t1*s1(i+3, j1) & + + t2*s1(i+3, j2) & + + t3*s1(i+3, j3) + iy = iy + 4 + end do + iy = ky + m4 + do i = m4 + 1, n_extent + dest(iy) = dest(iy) + t0*s1(i, j0) & + + t1*s1(i, j1) & + + t2*s1(i, j2) & + + t3*s1(i, j3) + iy = iy + 1 + end do + end do + do j = k4+1, kk + t0 = temp(j) + j0 = ind(j) + iy = ky + do i = 1, m4, 4 + dest( iy ) = dest(iy) +t0*s1(i,j0) + dest( iy+1) = dest(iy+1) +t0*s1(i+1,j0) + dest( iy+2) = dest(iy+2)+t0*s1(i+2,j0) + dest( iy+3) = dest(iy+3)+t0*s1(i+3,j0) + iy = iy + 4 + end do + end do + do j = k4+1, kk + t0 = temp(j) + j0 = ind(j) + iy = ky + m4 + do i = m4 + 1, n_extent + dest(iy) = dest(iy) + t0 * s1(i, j0) + iy = iy + 1 + end do + end do + + end do + else + do k = 1, n_extent + dest(1+(k-1)*dlstride) = 0.0q0 + enddo + mmod4 = mod(n_extent, 4) + mmod2 = mod(n_extent, 2) + m4 = n_extent - mmod4 + m2 = n_extent- mmod2 + kx = 1 + ky = 1 + incx = 1 + jx = kx + do jj = 1, m_extent, bs + jx = kx + (jj-1) + kk = 0 + do j = jj, min (m_extent, jj+bs-1) + if (s2(jx) .ne. zero) then + kk = kk + 1 + temp(kk) = s2(jx) + ind(kk) = j + end if + jx = jx + 1 + end do + kmod4 = mod(kk, 4) + k4 = kk - kmod4 + do j = 1, k4, 4 + t0 = temp(j) + t1 = temp(j+1) + t2 = temp(j+2) + t3 = temp(j+3) + j0 = ind(j) + j1 = ind(j+1) + j2 = ind(j+2) + j3 = ind(j+3) + iy = ky + do i = 1, m4, 4 + dest(1+(iy-1)*dlstride) = dest(1+(iy-1)*dlstride) + t0*s1(i, j0) & + + t1*s1(i, j1) & + + t2*s1(i, j2) & + + t3*s1(i, j3) + + dest(1+(iy + 1 -1)*dlstride) = dest(1+(iy + 1 -1)*dlstride) + t0*s1(i+1, j0) & + + t1*s1(i+1, j1) & + + t2*s1(i+1, j2) & + + t3*s1(i+1, j3) + + dest(1+(iy + 2 -1)*dlstride) = dest(1+(iy + 2 -1)*dlstride) + t0*s1(i+2, j0) & + + t1*s1(i+2, j1) & + + t2*s1(i+2, j2) & + + t3*s1(i+2, j3) + + dest(1+(iy + 3 -1)*dlstride) = dest(1+(iy + 3 -1)*dlstride) + t0*s1(i+3, j0) & + + t1*s1(i+3, j1) & + + t2*s1(i+3, j2) & + + t3*s1(i+3, j3) + iy = iy + 4 + end do + iy = ky + m4 + do i = m4 + 1, n_extent + dest(1+(iy-1)*dlstride) = dest(1+(iy-1)*dlstride) + t0*s1(i, j0) & + + t1*s1(i, j1) & + + t2*s1(i, j2) & + + t3*s1(i, j3) + iy = iy + 1 + end do + end do + do j = k4+1, kk + t0 = temp(j) + j0 = ind(j) + iy = ky + do i = 1, m4, 4 + dest(1+(iy-1)*dlstride) = dest(1+(iy-1)*dlstride) + t0*s1(i,j0) + dest(1+(iy + 1 -1)*dlstride) = dest(1+(iy + 1 -1)*dlstride) + t0*s1(i+1,j0) + dest(1+(iy + 2 -1)*dlstride) = dest(1+(iy + 2 -1)*dlstride) + t0*s1(i+2,j0) + dest(1+(iy + 3 -1)*dlstride) = dest(1+(iy + 3 -1)*dlstride) + t0*s1(i+3,j0) + iy = iy + 4 + end do + end do + do j = k4+1, kk + t0 = temp(j) + j0 = ind(j) + iy = ky + m4 + do i = m4 + 1, n_extent + dest(1+(iy-1)*dlstride) = dest(1+(iy-1)*dlstride) + t0 * s1(i, j0) + iy = iy + 1 + end do + end do + end do + endif +end + +subroutine F90_matmul_cplx32_str1_vxm(dest, s1,s2, & + k_extent,m_extent, ld1,dlstride) + + implicit none + DESC_INT k_extent,m_extent,ld1,ld2,dlstride + COMPLEX*32 s1(m_extent) + COMPLEX*32 s2(ld1,k_extent) + COMPLEX*32 dest(k_extent) + + INTEGER bs + parameter (bs = 384) + COMPLEX*32 temp (bs) + COMPLEX*32 t0,t1,t2,t3 + COMPLEX*32 t4,t5,t6,t7 + COMPLEX*32 dtemp0, dtemp1, dtemp2, dtemp3 + COMPLEX*32 dtemp4, dtemp5, dtemp6, dtemp7 + DESC_INT ind(bs),ind0,ind1,ind2,ind3 + DESC_INT ind4,ind5,ind6,ind7 + COMPLEX*32 zero + parameter (zero = 0.0Q0) + + DESC_INT mi,ki,ti + DESC_INT ii,jj,j,jx,kk,jnext + DESC_INT mmod8,m8,kmod8,k8,tmod8,tt8 + DESC_INT mmod4,m4,kmod4,k4,tmod4,tt4 + + if (dlstride .eq. 1) then + do ki = 1, k_extent + dest(ki) = 0.0q0 + end do + + mmod8 = mod(m_extent,8) + m8 = m_extent - mmod8 + kmod8 = mod(k_extent,8) + k8 = k_extent - kmod8 + + do kk = 1,k8,8 + dtemp0 = dest(kk) + dtemp1 = dest(kk+1) + dtemp2 = dest(kk+2) + dtemp3 = dest(kk+3) + dtemp4 = dest(kk+4) + dtemp5 = dest(kk+5) + dtemp6 = dest(kk+6) + dtemp7 = dest(kk+7) + jnext = 1 + do jj = 1,m8,bs + ! load s1 temp vector + ti = 0 + jx = jj + do j = jj, min (m_extent, jj+bs-1) + if (s1(jx) .ne. zero) then + ti = ti + 1 + temp(ti) = s1(jx) + ind(ti) = j + end if + jx = jx + 1 + end do + + tmod8 = mod(ti,8) + tt8 = ti - tmod8 + + if (tt8 .ne. 0) then + jnext = ind(tt8)+1 + endif + + ti = 1 + do ii = 1,tt8,8 + t0 = temp(ti) + t1 = temp(ti+1) + t2 = temp(ti+2) + t3 = temp(ti+3) + t4 = temp(ti+4) + t5 = temp(ti+5) + t6 = temp(ti+6) + t7 = temp(ti+7) + ind0 = ind(ti) + ind1 = ind(ti+1) + ind2 = ind(ti+2) + ind3 = ind(ti+3) + ind4 = ind(ti+4) + ind5 = ind(ti+5) + ind6 = ind(ti+6) + ind7 = ind(ti+7) + + dtemp0 = dtemp0 + & + t0 * s2(ind0, kk) + t1 * s2(ind1, kk) + & + t2 * s2(ind2, kk) + t3 * s2(ind3, kk) + & + t4 * s2(ind4, kk) + t5 * s2(ind5, kk) + & + t6 * s2(ind6, kk) + t7 * s2(ind7, kk) + dtemp1 = dtemp1 + & + t0 * s2(ind0, kk+1) + t1 * s2(ind1, kk+1) + & + t2 * s2(ind2, kk+1) + t3 * s2(ind3, kk+1) + & + t4 * s2(ind4, kk+1) + t5 * s2(ind5, kk+1) + & + t6 * s2(ind6, kk+1) + t7 * s2(ind7, kk+1) + dtemp2 = dtemp2 + & + t0 * s2(ind0, kk+2) + t1 * s2(ind1, kk+2) + & + t2 * s2(ind2, kk+2) + t3 * s2(ind3, kk+2) + & + t4 * s2(ind4, kk+2) + t5 * s2(ind5, kk+2) + & + t6 * s2(ind6, kk+2) + t7 * s2(ind7, kk+2) + dtemp3 = dtemp3 + & + t0 * s2(ind0, kk+3) + t1 * s2(ind1, kk+3) + & + t2 * s2(ind2, kk+3) + t3 * s2(ind3, kk+3) + & + t4 * s2(ind4, kk+3) + t5 * s2(ind5, kk+3) + & + t6 * s2(ind6, kk+3) + t7 * s2(ind7, kk+3) + + dtemp4 = dtemp4 + & + t0 * s2(ind0, kk+4) + t1 * s2(ind1, kk+4) + & + t2 * s2(ind2, kk+4) + t3 * s2(ind3, kk+4) + & + t4 * s2(ind4, kk+4) + t5 * s2(ind5, kk+4) + & + t6 * s2(ind6, kk+4) + t7 * s2(ind7, kk+4) + dtemp5 = dtemp5 + & + t0 * s2(ind0, kk+5) + t1 * s2(ind1, kk+5) + & + t2 * s2(ind2, kk+5) + t3 * s2(ind3, kk+5) + & + t4 * s2(ind4, kk+5) + t5 * s2(ind5, kk+5) + & + t6 * s2(ind6, kk+5) + t7 * s2(ind7, kk+5) + dtemp6 = dtemp6 + & + t0 * s2(ind0, kk+6) + t1 * s2(ind1, kk+6) + & + t2 * s2(ind2, kk+6) + t3 * s2(ind3, kk+6) + & + t4 * s2(ind4, kk+6) + t5 * s2(ind5, kk+6) + & + t6 * s2(ind6, kk+6) + t7 * s2(ind7, kk+6) + dtemp7 = dtemp7 + & + t0 * s2(ind0, kk+7) + t1 * s2(ind1, kk+7) + & + t2 * s2(ind2, kk+7) + t3 * s2(ind3, kk+7) + & + t4 * s2(ind4, kk+7) + t5 * s2(ind5, kk+7) + & + t6 * s2(ind6, kk+7) + t7 * s2(ind7, kk+7) + ti = ti + 8 + enddo + enddo + do ii = jnext,m_extent + t0 = s1(ii) + dtemp0 = dtemp0 + t0 * s2(ii,kk) + dtemp1 = dtemp1 + t0 * s2(ii,kk+1) + dtemp2 = dtemp2 + t0 * s2(ii,kk+2) + dtemp3 = dtemp3 + t0 * s2(ii,kk+3) + dtemp4 = dtemp4 + t0 * s2(ii,kk+4) + dtemp5 = dtemp5 + t0 * s2(ii,kk+5) + dtemp6 = dtemp6 + t0 * s2(ii,kk+6) + dtemp7 = dtemp7 + t0 * s2(ii,kk+7) + enddo + dest(kk) = dtemp0 + dest(kk+1) = dtemp1 + dest(kk+2) = dtemp2 + dest(kk+3) = dtemp3 + dest(kk+4) = dtemp4 + dest(kk+5) = dtemp5 + dest(kk+6) = dtemp6 + dest(kk+7) = dtemp7 + enddo + do kk = k8+1,k_extent + dtemp0 = dest(kk) + do ii = 1,m_extent + dtemp0 = dtemp0 + s1(ii) * s2(ii,kk) + enddo + dest(kk) = dtemp0 + enddo + + + else + do kk = 1, k_extent + dest(1+(kk-1)*dlstride) = 0 + end do + + mmod4 = mod(m_extent,4) + m4 = m_extent - mmod4 + kmod4 = mod(k_extent,4) + k4 = k_extent - kmod4 + + do kk = 1,k4,4 + dtemp0 = dest(1+(kk-1)*dlstride) + dtemp1 = dest(1+(kk)*dlstride) + dtemp2 = dest(1+(kk+1)*dlstride) + dtemp3 = dest(1+(kk+2)*dlstride) + jnext = 1 + do jj = 1,m4,bs + ! load s1 temp vector + ti = 0 + jx = jj + do j = jj, min (m_extent, jj+bs-1) + if (s1(jx) .ne. zero) then + ti = ti + 1 + temp(ti) = s1(jx) + ind(ti) = j + end if + jx = jx + 1 + end do + + tmod4 = mod(ti,4) + tt4 = ti - tmod4 + + if (tt4 .ne. 0) then + jnext = ind(tt4)+1 + endif + + ti = 1 + do ii = 1,tt4,4 + t0 = temp(ti) + t1 = temp(ti+1) + t2 = temp(ti+2) + t3 = temp(ti+3) + ind0 = ind(ti) + ind1 = ind(ti+1) + ind2 = ind(ti+2) + ind3 = ind(ti+3) + + dtemp0 = dtemp0 + & + t0 * s2(ind0, kk) + t1 * s2(ind1, kk) + & + t2 * s2(ind2, kk) + t3 * s2(ind3, kk) + dtemp1 = dtemp1 + & + t0 * s2(ind0, kk+1) + t1 * s2(ind1, kk+1) + & + t2 * s2(ind2, kk+1) + t3 * s2(ind3, kk+1) + dtemp2 = dtemp2 + & + t0 * s2(ind0, kk+2) + t1 * s2(ind1, kk+2) + & + t2 * s2(ind2, kk+2) + t3 * s2(ind3, kk+2) + dtemp3 = dtemp3 + & + t0 * s2(ind0, kk+3) + t1 * s2(ind1, kk+3) + & + t2 * s2(ind2, kk+3) + t3 * s2(ind3, kk+3) + + ti = ti + 4 + enddo + enddo + do ii = jnext,m_extent + t0 = s1(ii) + dtemp0 = dtemp0 + t0 * s2(ii,kk) + dtemp1 = dtemp1 + t0 * s2(ii,kk+1) + dtemp2 = dtemp2 + t0 * s2(ii,kk+2) + dtemp3 = dtemp3 + t0 * s2(ii,kk+3) + enddo + dest(1+(kk-1)*dlstride) = dtemp0 + dest(1+(kk)*dlstride) = dtemp1 + dest(1+(kk+1)*dlstride) = dtemp2 + dest(1+(kk+2)*dlstride) = dtemp3 + enddo + do kk = k4+1,k_extent + dtemp0 = dest(1+(kk-1)*dlstride) + do ii = 1,m_extent + dtemp0 = dtemp0 + s1(ii) * s2(ii,kk) + enddo + dest(1+(kk-1)*dlstride) = dtemp0 + enddo + endif +end + diff --git a/runtime/flang/mmul_cplx32str1_t.F95 b/runtime/flang/mmul_cplx32str1_t.F95 new file mode 100644 index 0000000000..c993efa36d --- /dev/null +++ b/runtime/flang/mmul_cplx32str1_t.F95 @@ -0,0 +1,239 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +! Notified per clause 4(b) of the license. +! Last Modified: Oct 2020 + + +#include "mmul_dir.h" + +subroutine F90_matmul_cplx32_str1_mxv_t(dest, s1,s2, & + n_extent,m_extent, ld1,dlstride) + implicit none + DESC_INT n_extent,m_extent,ld1,ld2,dlstride + COMPLEX*32 s1(ld1,m_extent) + COMPLEX*32 s2(m_extent) + COMPLEX*32 dest(ld1) + DESC_INT i,j,k + DESC_INT nmod8, mmod4, mmod2, n8, m2, kmod2, k2 + DESC_INT jx,kx,ii,jj,kk,kmod4,k4,incx + DESC_INT j0,j1,j2,j3,ix,iy,jy,ky,m4 + COMPLEX*32 t0,t1,t2,t3,t4,t5,t6,t7,t8,x0,x1 + INTEGER bs + parameter (bs = 384) + COMPLEX*32 temp (bs) + DESC_INT ind(bs) + COMPLEX*32 zero + parameter (zero = 0.0q0) + + if (dlstride .eq. 1) then + do k = 1, m_extent + dest(1+(k-1)*dlstride) = 0.0q0 + end do + nmod8 = mod(m_extent, 8) + mmod4 = mod(n_extent, 4) + mmod2 = mod(n_extent, 2) + n8 = m_extent - nmod8 + m4 = n_extent - mmod4 + m2 = n_extent- mmod2 + kx = 1 + ky = 1 + incx = 1 + jx = kx + nmod8 = mod(m_extent, 8) + n8= m_extent - nmod8 + do ii = 1, n_extent, bs + jy = ky + kk = 0 + ix = kx + (ii - 1) * incx + do i = ii, min (n_extent, ii+bs-1) + kk = kk + 1 + temp(kk) = s2(ix) + ix = ix + incx + end do + kmod2 = mod(kk, 2) + k2= kk - kmod2 + do j = 1, n8, 8 + t0 = zero + t1 = zero + t2 = zero + t3 = zero + t4 = zero + t5 = zero + t6 = zero + t7 = zero + do i = 1, k2, 2 + x0 = temp(i) + x1 = temp(i + 1) + t0 = t0 + s1(i+ii-1, j)*x0 & + + s1(i+ii, j)*x1 + t1 = t1 + s1(i+ii-1, j+1)*x0 & + + s1(i+ii, j+1)*x1 + t2 = t2 + s1(i+ii-1, j+2)*x0 & + + s1(i+ii, j+2)*x1 + t3 = t3 + s1(i+ii-1, j+3)*x0 & + + s1(i+ii, j+3)*x1 + t4 = t4 + s1(i+ii-1, j+4)*x0 & + + s1(i+ii, j+4)*x1 + t5 = t5 + s1(i+ii-1, j+5)*x0 & + + s1(i+ii, j+5)*x1 + t6 = t6 + s1(i+ii-1, j+6)*x0 & + + s1(i+ii, j+6)*x1 + t7 = t7 + s1(i+ii-1, j+7)*x0 & + + s1(i+ii, j+7)*x1 + end do + do i = k2 + 1, kk + x0 = temp(i) + t0 = t0 + s1(i+ii-1, j) * x0 + t1 = t1 + s1(i+ii-1, j+1)* x0 + t2 = t2 + s1(i+ii-1, j+2)* x0 + t3 = t3 + s1(i+ii-1, j+3)* x0 + t4 = t4 + s1(i+ii-1, j+4)* x0 + t5 = t5 + s1(i+ii-1, j+5)* x0 + t6 = t6 + s1(i+ii-1, j+6)* x0 + t7 = t7 + s1(i+ii-1, j+7)* x0 + end do + dest(jy) = dest(jy) + t0 + dest(jy + 1) = dest(jy + 1) + t1 + dest(jy + 2) = dest(jy + 2) + t2 + dest(jy + 3) = dest(jy + 3) + t3 + dest(jy + 4) = dest(jy + 4) + t4 + dest(jy + 5) = dest(jy + 5) + t5 + dest(jy + 6) = dest(jy + 6) + t6 + dest(jy + 7) = dest(jy + 7) + t7 + jy = jy + 8 + end do + jy = ky + n8 + do j = n8+1, m_extent + t0 = zero + do i = 1, k2, 2 + x0 = temp(i) + x1 = temp(i + 1) + t0 = t0 + s1(i+ii-1, j)*x0 & + + s1(i+ii, j)*x1 + end do + dest(jy) = dest(jy) + t0 + jy= jy + 1 + end do + + jy = ky + n8 + do j = n8+1, m_extent + t0 = zero + do i = k2 + 1, kk + x0 = temp(i) + t0 = t0 + s1(i+ii-1, j)*x0 + end do + dest(jy) = dest(jy) + t0 + jy= jy + 1 + end do + end do + + else + do k = 1, m_extent + dest(1+(k-1)*dlstride) = 0.0q0 + end do + nmod8 = mod(m_extent, 8) + mmod4 = mod(n_extent, 4) + mmod2 = mod(n_extent, 2) + n8 = m_extent - nmod8 + m4 = n_extent - mmod4 + m2 = n_extent- mmod2 + kx = 1 + ky = 1 + incx = 1 + jx = kx + nmod8 = mod(m_extent, 8) + n8= m_extent - nmod8 + do ii = 1, n_extent, bs + jy = ky + kk = 0 + ix = kx + (ii - 1) * incx + do i = ii, min (n_extent, ii+bs-1) + kk = kk + 1 + temp(kk) = s2(ix) + ix = ix + incx + end do + kmod2 = mod(kk, 2) + k2= kk - kmod2 + do j = 1, n8, 8 + t0 = zero + t1 = zero + t2 = zero + t3 = zero + t4 = zero + t5 = zero + t6 = zero + t7 = zero + do i = 1, k2, 2 + x0 = temp(i) + x1 = temp(i + 1) + t0 = t0 + s1(i+ii-1, j)*x0 & + + s1(i+ii, j)*x1 + t1 = t1 + s1(i+ii-1, j+1)*x0 & + + s1(i+ii, j+1)*x1 + t2 = t2 + s1(i+ii-1, j+2)*x0 & + + s1(i+ii, j+2)*x1 + t3 = t3 + s1(i+ii-1, j+3)*x0 & + + s1(i+ii, j+3)*x1 + t4 = t4 + s1(i+ii-1, j+4)*x0 & + + s1(i+ii, j+4)*x1 + t5 = t5 + s1(i+ii-1, j+5)*x0 & + + s1(i+ii, j+5)*x1 + t6 = t6 + s1(i+ii-1, j+6)*x0 & + + s1(i+ii, j+6)*x1 + t7 = t7 + s1(i+ii-1, j+7)*x0 & + + s1(i+ii, j+7)*x1 + end do + do i = k2 + 1, kk + x0 = temp(i) + t0 = t0 + s1(i+ii-1, j) * x0 + t1 = t1 + s1(i+ii-1, j+1)* x0 + t2 = t2 + s1(i+ii-1, j+2)* x0 + t3 = t3 + s1(i+ii-1, j+3)* x0 + t4 = t4 + s1(i+ii-1, j+4)* x0 + t5 = t5 + s1(i+ii-1, j+5)* x0 + t6 = t6 + s1(i+ii-1, j+6)* x0 + t7 = t7 + s1(i+ii-1, j+7)* x0 + end do + dest(1+(jy-1)*dlstride) = dest(1+(jy-1)*dlstride) + t0 + dest(1+(jy + 1 -1)*dlstride) = dest(1+(jy + 1 -1)*dlstride) + t1 + dest(1+(jy + 2 -1)*dlstride) = dest(1+(jy + 2 -1)*dlstride) + t2 + dest(1+(jy + 3 -1)*dlstride) = dest(1+(jy + 3 -1)*dlstride) + t3 + dest(1+(jy + 4 -1)*dlstride) = dest(1+(jy + 4 -1)*dlstride) + t4 + dest(1+(jy + 5 -1)*dlstride) = dest(1+(jy + 5 -1)*dlstride) + t5 + dest(1+(jy + 6 -1)*dlstride) = dest(1+(jy + 6 -1)*dlstride) + t6 + dest(1+(jy + 7 -1)*dlstride) = dest(1+(jy + 7 -1)*dlstride) + t7 + jy = jy + 8 + end do + jy = ky + n8 + do j = n8+1, m_extent + t0 = zero + do i = 1, k2, 2 + x0 = temp(i) + x1 = temp(i + 1) + t0 = t0 + s1(i+ii-1, j)*x0 & + + s1(i+ii, j)*x1 + end do + dest(1+(jy-1)*dlstride) = dest(1+(jy-1)*dlstride) + t0 + jy= jy + 1 + end do + + jy = ky + n8 + do j = n8+1, m_extent + t0 = zero + do i = k2 + 1, kk + x0 = temp(i) + t0 = t0 + s1(i+ii-1, j)*x0 + end do + dest(1+(jy-1)*dlstride) = dest(1+(jy-1)*dlstride) + t0 + jy= jy + 1 + end do + end do + endif +end + + + diff --git a/runtime/flang/mmul_dir.h b/runtime/flang/mmul_dir.h index d29bc6972a..4c031156a6 100644 --- a/runtime/flang/mmul_dir.h +++ b/runtime/flang/mmul_dir.h @@ -1,8 +1,11 @@ -! +! ! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. ! See https://llvm.org/LICENSE.txt for license information. ! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -! +! +! Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +! Notified per clause 4(b) of the license. +! Last Modified: Oct 2020 ! directives.h -- contains preprocessor directives for F90 rte files @@ -24,6 +27,8 @@ #define F90_matmul_cplx32_contvxm PREFIX(_mm_cplx32_contvxm_i8) #define F90_matmul_cplx32_str1 PREFIX(_mm_cplx32_str1_i8) #define F90_matmul_cplx32_str1_mxv PREFIX(_mm_cplx32_str1_mxv_i8) +#define F90_matmul_cplx32_str1_mxv_t PREFIX(_mm_cplx32_str1_mxv_t_i8) +#define F90_matmul_cplx32_str1_vxm PREFIX(_mm_cplx32_str1_vxm_i8) #define F90_matmul_cplx8_contmxm PREFIX(_mm_cplx8_contmxm_i8) #define F90_matmul_cplx8_contmxv PREFIX(_mm_cplx8_contmxv_i8) #define F90_matmul_cplx8_contvxm PREFIX(_mm_cplx8_contvxm_i8) @@ -89,6 +94,16 @@ #define F90_matmul_real8_str1_mxv PREFIX(_mm_real8_str1_mxv_i8) #define F90_matmul_real8_str1_mxv_t PREFIX(_mm_real8_str1_mxv_t_i8) #define F90_matmul_real8_str1_vxm PREFIX(_mm_real8_str1_vxm_i8) +#define F90_matmul_real16_contmxm PREFIX(_mm_real16_contmxm_i8) +#define F90_matmul_real16_contmxv PREFIX(_mm_real16_contmxv_i8) +#define F90_matmul_real16_contvxm PREFIX(_mm_real16_contvxm_i8) +#define F90_matmul_real16_str1 PREFIX(_mm_real16_str1_i8) +#define _F90_matmul_real16_str1a _PREFIX(_mm_real16_str1a_i8) +#define _F90_matmul_real16_str1b _PREFIX(_mm_real16_str1b_i8) +#define _F90_matmul_real16_str1c _PREFIX(_mm_real16_str1c_i8) +#define F90_matmul_real16_str1_mxv PREFIX(_mm_real16_str1_mxv_i8) +#define F90_matmul_real16_str1_mxv_t PREFIX(_mm_real16_str1_mxv_t_i8) +#define F90_matmul_real16_str1_vxm PREFIX(_mm_real16_str1_vxm_i8) #else #define DESC_INT INTEGER(4) #define F90_matmul_cplx16_contmxm PREFIX(_mm_cplx16_contmxm) @@ -103,6 +118,8 @@ #define F90_matmul_cplx32_contvxm PREFIX(_mm_cplx32_contvxm) #define F90_matmul_cplx32_str1 PREFIX(_mm_cplx32_str1) #define F90_matmul_cplx32_str1_mxv PREFIX(_mm_cplx32_str1_mxv) +#define F90_matmul_cplx32_str1_mxv_t PREFIX(_mm_cplx32_str1_mxv_t) +#define F90_matmul_cplx32_str1_vxm PREFIX(_mm_cplx32_str1_vxm) #define F90_matmul_cplx8_contmxm PREFIX(_mm_cplx8_contmxm) #define F90_matmul_cplx8_contmxv PREFIX(_mm_cplx8_contmxv) #define F90_matmul_cplx8_contvxm PREFIX(_mm_cplx8_contvxm) @@ -168,4 +185,14 @@ #define F90_matmul_real8_str1_mxv PREFIX(_mm_real8_str1_mxv) #define F90_matmul_real8_str1_mxv_t PREFIX(_mm_real8_str1_mxv_t) #define F90_matmul_real8_str1_vxm PREFIX(_mm_real8_str1_vxm) +#define F90_matmul_real16_contmxm PREFIX(_mm_real16_contmxm) +#define F90_matmul_real16_contmxv PREFIX(_mm_real16_contmxv) +#define F90_matmul_real16_contvxm PREFIX(_mm_real16_contvxm) +#define F90_matmul_real16_str1 PREFIX(_mm_real16_str1) +#define _F90_matmul_real16_str1a _PREFIX(_mm_real16_str1a) +#define _F90_matmul_real16_str1b _PREFIX(_mm_real16_str1b) +#define _F90_matmul_real16_str1c _PREFIX(_mm_real16_str1c) +#define F90_matmul_real16_str1_mxv PREFIX(_mm_real16_str1_mxv) +#define F90_matmul_real16_str1_mxv_t PREFIX(_mm_real16_str1_mxv_t) +#define F90_matmul_real16_str1_vxm PREFIX(_mm_real16_str1_vxm) #endif /* DESC_I8 */ diff --git a/runtime/flang/mmul_real16contmxm.F95 b/runtime/flang/mmul_real16contmxm.F95 new file mode 100644 index 0000000000..7bb7611730 --- /dev/null +++ b/runtime/flang/mmul_real16contmxm.F95 @@ -0,0 +1,36 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + + +#include "mmul_dir.h" + +subroutine F90_matmul_real16_contmxm(dest, src1, src2, k_extent, m_extent, n_extent) + + REAL*16, dimension(k_extent,m_extent) :: src1 + REAL*16, dimension(m_extent,n_extent) :: src2 + REAL*16, dimension(k_extent,n_extent) :: dest + DESC_INT k_extent + DESC_INT n_extent + DESC_INT m_extent + + DESC_INT k + DESC_INT n + DESC_INT m + + do n=1,n_extent + do k=1,k_extent + dest(k,n) = 0 + end do + end do + do n=1,n_extent + do m=1,m_extent + do k=1,k_extent + dest(k,n) = dest(k,n) + src1(k,m) * src2(m,n) + end do + end do + end do + +end subroutine diff --git a/runtime/flang/mmul_real16contmxv.F95 b/runtime/flang/mmul_real16contmxv.F95 new file mode 100644 index 0000000000..d3d8e6dc41 --- /dev/null +++ b/runtime/flang/mmul_real16contmxv.F95 @@ -0,0 +1,30 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + + +#include "mmul_dir.h" + +subroutine F90_matmul_real16_contmxv(dest, src1, src2, k_extent, m_extent) + + DESC_INT k_extent + DESC_INT m_extent + REAL*16, dimension(k_extent,m_extent) :: src1 + REAL*16, dimension(m_extent) :: src2 + REAL*16, dimension(k_extent) :: dest + + DESC_INT k + DESC_INT m + + do k=1,k_extent + dest(k) = 0 + end do + do m=1,m_extent + do k=1,k_extent + dest(k) = dest(k) + src1(k,m) * src2(m) + end do + end do + +end subroutine diff --git a/runtime/flang/mmul_real16contvxm.F95 b/runtime/flang/mmul_real16contvxm.F95 new file mode 100644 index 0000000000..b81f190ec2 --- /dev/null +++ b/runtime/flang/mmul_real16contvxm.F95 @@ -0,0 +1,29 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + + +#include "mmul_dir.h" + +subroutine F90_matmul_real16_contvxm(dest, src1, src2, m_extent, n_extent) + + DESC_INT n_extent + DESC_INT m_extent + REAL*16, dimension(m_extent) :: src1 + REAL*16, dimension(m_extent,n_extent) :: src2 + REAL*16, dimension(n_extent) :: dest + + REAL*16 rslt + DESC_INT n + DESC_INT m + + do n=1,n_extent + dest(n) = 0; + do m=1,m_extent + dest(n) = dest(n) + src1(m) * src2(m,n) + end do + end do + +end subroutine diff --git a/runtime/flang/mmul_real16str1.F95 b/runtime/flang/mmul_real16str1.F95 new file mode 100644 index 0000000000..75af7c24f2 --- /dev/null +++ b/runtime/flang/mmul_real16str1.F95 @@ -0,0 +1,813 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + + + +#include "mmul_dir.h" + +subroutine F90_matmul_real16_str1(dest,s1,s2, & + k_extnt,m_extnt,n_extnt, & + s1_d1_extnt,s2_d1_extnt,d_d1_extnt, & + d_d1_lstride) + + DESC_INT n_extnt,m_extnt,k_extnt + DESC_INT s1_d1_extnt,s2_d1_extnt,d_d1_extnt,d_d1_lstride + INTEGER bs +#if defined(LINUX8664) + parameter (bs=128) +#else + parameter (bs=192) +#endif + REAL*16 s1(s1_d1_extnt,m_extnt) + REAL*16 s2(s2_d1_extnt,k_extnt) + REAL*16 dest(d_d1_extnt,n_extnt*d_d1_lstride) + DESC_INT i, j, l, nmod4, mmod4 + DESC_INT ii,jj,ll,temppos, nn, kk, itest + real *16 t00,t01,t02,t03 + real *16 t10,t11,t12,t13 + real *16 t20,t21,t22,t23 + real *16 t30,t31,t32,t33 + real *16 temp0, temp1, temp2, temp3 +#if defined(LINUX8664) + real *16 temp(4*bs*bs) +#else + real *16 temp(bs*bs) +#endif + real *16 s20, s21, s22, s23 + INTEGER flag + real *16 zero + parameter (zero = 0.0d0) + + DESC_INT k,n,m + + if (d_d1_lstride .eq. 1) then +#if defined(LINUX8664) + call _F90_matmul_real16_str1a(s1,s2,dest, & + s1_d1_extnt,s2_d1_extnt,d_d1_extnt,k_extnt,n_extnt,m_extnt, & + 1.0D0,0.0D0,temp, temp((bs*bs)+1),bs) +#else + nmod4 = mod (k_extnt, 4) + mmod4 = mod (n_extnt, 4) + kk = k_extnt - nmod4 + nn = n_extnt - mmod4 + itest = nmod4 + mmod4 + do jj=1,k_extnt,bs + do ii=1,n_extnt,bs + flag = 0 + do ll=1,m_extnt,bs + temppos = 1 + if ((k_extnt .ge. 4) .and. (n_extnt .ge. 4)) then + if (jj .le. kk) then + j = jj + do i=ii,min(nn,ii+bs-1),4 + if (flag .eq. 0) then + t00=zero + t01=zero + t02=zero + t03=zero + t10=zero + t11=zero + t12=zero + t13=zero + t20=zero + t21=zero + t22=zero + t23=zero + t30=zero + t31=zero + t32=zero + t33=zero + else + t00=dest(i+0,j+0) + t01=dest(i+0,j+1) + t02=dest(i+0,j+2) + t03=dest(i+0,j+3) + t10=dest(i+1,j+0) + t11=dest(i+1,j+1) + t12=dest(i+1,j+2) + t13=dest(i+1,j+3) + t20=dest(i+2,j+0) + t21=dest(i+2,j+1) + t22=dest(i+2,j+2) + t23=dest(i+2,j+3) + t30=dest(i+3,j+0) + t31=dest(i+3,j+1) + t32=dest(i+3,j+2) + t33=dest(i+3,j+3) + end if + do l=ll,min(m_extnt,ll+bs-1) + temp0 = s1(i+0,l) + temp1 = s1(i+1,l) + temp2 = s1(i+2,l) + temp3 = s1(i+3,l) + s20 = s2(l,j+0) + s21 = s2(l,j+1) + s22 = s2(l,j+2) + s23 = s2(l,j+3) + t00=t00+s20*temp0 + t01=t01+s21*temp0 + t02=t02+s22*temp0 + t03=t03+s23*temp0 + t10=t10+s20*temp1 + t11=t11+s21*temp1 + t12=t12+s22*temp1 + t13=t13+s23*temp1 + t20=t20+s20*temp2 + t21=t21+s21*temp2 + t22=t22+s22*temp2 + t23=t23+s23*temp2 + t30=t30+s20*temp3 + t31=t31+s21*temp3 + t32=t32+s22*temp3 + t33=t33+s23*temp3 + temp (temppos+0) = temp0 + temp (temppos+1) = temp1 + temp (temppos+2) = temp2 + temp (temppos+3) = temp3 + temppos = temppos + 4 + end do + dest(i+0,j+0)=t00 + dest(i+0,j+1)=t01 + dest(i+0,j+2)=t02 + dest(i+0,j+3)=t03 + dest(i+1,j+0)=t10 + dest(i+1,j+1)=t11 + dest(i+1,j+2)=t12 + dest(i+1,j+3)=t13 + dest(i+2,j+0)=t20 + dest(i+2,j+1)=t21 + dest(i+2,j+2)=t22 + dest(i+2,j+3)=t23 + dest(i+3,j+0)=t30 + dest(i+3,j+1)=t31 + dest(i+3,j+2)=t32 + dest(i+3,j+3)=t33 + end do + do j=jj+4,min(kk,jj+bs-1),4 + temppos = 1 + do i=ii,min(nn,ii+bs-1),4 + if (flag .eq. 0) then + t00=zero + t01=zero + t02=zero + t03=zero + t10=zero + t11=zero + t12=zero + t13=zero + t20=zero + t21=zero + t22=zero + t23=zero + t30=zero + t31=zero + t32=zero + t33=zero + else + t00=dest(i+0,j+0) + t01=dest(i+0,j+1) + t02=dest(i+0,j+2) + t03=dest(i+0,j+3) + t10=dest(i+1,j+0) + t11=dest(i+1,j+1) + t12=dest(i+1,j+2) + t13=dest(i+1,j+3) + t20=dest(i+2,j+0) + t21=dest(i+2,j+1) + t22=dest(i+2,j+2) + t23=dest(i+2,j+3) + t30=dest(i+3,j+0) + t31=dest(i+3,j+1) + t32=dest(i+3,j+2) + t33=dest(i+3,j+3) + endif + do l=ll,min(m_extnt,ll+bs-1) + temp0 = temp (temppos+0) + temp1 = temp (temppos+1) + temp2 = temp (temppos+2) + temp3 = temp (temppos+3) + s20 = s2(l,j+0) + s21 = s2(l,j+1) + s22 = s2(l,j+2) + s23 = s2(l,j+3) + t00=t00+s20*temp0 + t01=t01+s21*temp0 + t02=t02+s22*temp0 + t03=t03+s23*temp0 + t10=t10+s20*temp1 + t11=t11+s21*temp1 + t12=t12+s22*temp1 + t13=t13+s23*temp1 + t20=t20+s20*temp2 + t21=t21+s21*temp2 + t22=t22+s22*temp2 + t23=t23+s23*temp2 + t30=t30+s20*temp3 + t31=t31+s21*temp3 + t32=t32+s22*temp3 + t33=t33+s23*temp3 + temppos = temppos + 4 + end do + dest(i+0,j+0)=t00 + dest(i+0,j+1)=t01 + dest(i+0,j+2)=t02 + dest(i+0,j+3)=t03 + dest(i+1,j+0)=t10 + dest(i+1,j+1)=t11 + dest(i+1,j+2)=t12 + dest(i+1,j+3)=t13 + dest(i+2,j+0)=t20 + dest(i+2,j+1)=t21 + dest(i+2,j+2)=t22 + dest(i+2,j+3)=t23 + dest(i+3,j+0)=t30 + dest(i+3,j+1)=t31 + dest(i+3,j+2)=t32 + dest(i+3,j+3)=t33 + end do + end do + end if + end if + if (itest .ne. 0) then + if (nmod4 .ne. 0) then + temppos = 1 + do j=kk+1,min(kk+1,jj+bs-1) + do i=ii,min(nn,ii+bs-1),4 + if (flag .eq. 0) then + t00=zero + t10=zero + t20=zero + t30=zero + else + t00=dest(i+0,j+0) + t10=dest(i+1,j+0) + t20=dest(i+2,j+0) + t30=dest(i+3,j+0) + end if + do l=ll,min(m_extnt,ll+bs-1) + temp0 = s1(i+0,l) + temp1 = s1(i+1,l) + temp2 = s1(i+2,l) + temp3 = s1(i+3,l) + t00=t00+s2(l,j+0)*temp0 + t10=t10+s2(l,j+0)*temp1 + t20=t20+s2(l,j+0)*temp2 + t30=t30+s2(l,j+0)*temp3 + temp (temppos+0) = temp0 + temp (temppos+1) = temp1 + temp (temppos+2) = temp2 + temp (temppos+3) = temp3 + temppos = temppos + 4 + end do + dest(i+0,j+0)=t00 + dest(i+1,j+0)=t10 + dest(i+2,j+0)=t20 + dest(i+3,j+0)=t30 + end do + end do + do j=kk+2,min(k_extnt,jj+bs-1) + temppos = 1 + do i=ii,min(nn,ii+bs-1),4 + if (flag .eq. 0) then + t00=zero + t10=zero + t20=zero + t30=zero + else + t00=dest(i+0,j+0) + t10=dest(i+1,j+0) + t20=dest(i+2,j+0) + t30=dest(i+3,j+0) + end if + do l=ll,min(m_extnt,ll+bs-1) + temp0 = temp (temppos+0) + temp1 = temp (temppos+1) + temp2 = temp (temppos+2) + temp3 = temp (temppos+3) + t00=t00+s2(l,j+0)*temp0 + t10=t10+s2(l,j+0)*temp1 + t20=t20+s2(l,j+0)*temp2 + t30=t30+s2(l,j+0)*temp3 + temppos = temppos + 4 + end do + dest(i+0,j+0)=t00 + dest(i+1,j+0)=t10 + dest(i+2,j+0)=t20 + dest(i+3,j+0)=t30 + end do + end do + end if + if (mmod4 .ne. 0) then + temppos = 1 + if (jj .le. kk) then + j = jj + do i=nn+1,min(n_extnt,ii+bs-1) + if (flag .eq. 0) then + t00=zero + t01=zero + t02=zero + t03=zero + else + t00=dest(i+0,j+0) + t01=dest(i+0,j+1) + t02=dest(i+0,j+2) + t03=dest(i+0,j+3) + end if + do l=ll,min(m_extnt,ll+bs-1) + temp0 = s1(i+0,l) + t00=t00+s2(l,j+0)*temp0 + t01=t01+s2(l,j+1)*temp0 + t02=t02+s2(l,j+2)*temp0 + t03=t03+s2(l,j+3)*temp0 + temp (temppos) = temp0 + temppos = temppos + 1 + end do + dest(i+0,j+0)=t00 + dest(i+0,j+1)=t01 + dest(i+0,j+2)=t02 + dest(i+0,j+3)=t03 + end do + do j=jj+4,min(kk,jj+bs-1),4 + temppos = 1 + do i=nn+1,min(n_extnt,ii+bs-1) + if (flag .eq. 0) then + t00=zero + t01=zero + t02=zero + t03=zero + else + t00=dest(i+0,j+0) + t01=dest(i+0,j+1) + t02=dest(i+0,j+2) + t03=dest(i+0,j+3) + end if + do l=ll,min(m_extnt,ll+bs-1) + temp0 = temp (temppos) + t00=t00+s2(l,j+0)*temp0 + t01=t01+s2(l,j+1)*temp0 + t02=t02+s2(l,j+2)*temp0 + t03=t03+s2(l,j+3)*temp0 + temppos = temppos + 1 + end do + dest(i+0,j+0)=t00 + dest(i+0,j+1)=t01 + dest(i+0,j+2)=t02 + dest(i+0,j+3)=t03 + end do + end do + end if + end if + if ((nmod4 .ne. 0) .and. (mmod4 .ne. 0)) then + temppos = 1 + do j=kk+1,min(kk+1,jj+bs-1) + do i=nn+1,min(n_extnt,ii+bs-1) + if (flag .eq. 0) then + t00=zero + else + t00=dest(i,j) + end if + do l=ll,min(m_extnt,ll+bs-1) + temp0 = s1(i,l) + t00=t00+s2(l,j)*temp0 + temp (temppos) = temp0 + temppos = temppos + 1 + end do + dest(i,j)=t00 + end do + end do + do j=kk+2,min(k_extnt,jj+bs-1) + temppos = 1 + do i=nn+1,min(n_extnt,ii+bs-1) + if (flag .eq. 0) then + t00=zero + else + t00=dest(i,j) + end if + do l=ll,min(m_extnt,ll+bs-1) + temp0 = temp (temppos) + t00=t00+s2(l,j)*temp0 + temppos = temppos + 1 + end do + dest(i,j)=t00 + end do + end do + end if + end if + flag = 1 + end do + end do + end do +#endif + else + do k = 1, k_extnt + do n = 1, n_extnt + dest(1+(n-1)*d_d1_lstride,k) = 0.0d0 + enddo + enddo + do k = 1, k_extnt + do m = 1, m_extnt + do n = 1, n_extnt + dest(1+(n-1)*d_d1_lstride,k) = & + dest(1+(n-1)*d_d1_lstride,k) + & + s1(n,m) * s2(m,k) + enddo + enddo + enddo + endif + return + end + +subroutine F90_matmul_real16_str1_mxv(dest, s1,s2, & + n_extent,m_extent, ld1,dlstride) + + implicit none + DESC_INT n_extent,m_extent,ld1,ld2,dlstride + DESC_INT mmod4, mmod2, m2 + DESC_INT jx,kx,jj,kk,kmod4,k4,incx,kk2 + DESC_INT j0,j1,j2,j3,iy,ky,m4 + REAL*16 t0,t1,t2,t3 + REAL*16 s1(ld1,m_extent) + REAL*16 s2(m_extent) + REAL*16 dest(ld1*dlstride) + + DESC_INT i,j,k + INTEGER bs + parameter (bs = 384) + REAL*16 temp (bs) + REAL*16 temp2 (bs) + DESC_INT ind(bs) + REAL*16 zero + parameter (zero = 0.0D0) + + if (dlstride .eq. 1) then + do k = 1, n_extent + dest(k) = 0.0d0 + end do + kx = 1 + incx = 1 + jx = kx + do jj = 1, m_extent, bs + jx = kx + (jj-1) + kk = 0 + do j = jj, min (m_extent, jj+bs-1) + if (s2(jx) .ne. zero) then + kk = kk + 1 + temp(kk) = s2(jx) + ind(kk) = j + end if + jx = jx + 1 + end do + kmod4 = mod(kk, 4) + k4 = kk - kmod4 + do j = 1, k4, 4 + t0 = temp(j) + t1 = temp(j+1) + t2 = temp(j+2) + t3 = temp(j+3) + j0 = ind(j) + j1 = ind(j+1) + j2 = ind(j+2) + j3 = ind(j+3) + do i = 1, n_extent + dest( i ) = dest( i )+t0*s1(i, j0) & + + t1*s1(i, j1) & + + t2*s1(i, j2) & + + t3*s1(i, j3) + end do + end do + do j = k4+1, kk + t0 = temp(j) + j0 = ind(j) + do i = 1, n_extent + dest( i ) = dest(i) +t0*s1(i,j0) + end do + end do + end do + else + do k = 1, n_extent + dest(1+(k-1)*dlstride) = 0.0d0 + enddo + mmod4 = mod(n_extent, 4) + mmod2 = mod(n_extent, 2) + m4 = n_extent - mmod4 + m2 = n_extent- mmod2 + kx = 1 + ky = 1 + incx = 1 + jx = kx + do jj = 1, m_extent, bs + jx = kx + (jj-1) + kk = 0 + do j = jj, min (m_extent, jj+bs-1) + if (s2(jx) .ne. zero) then + kk = kk + 1 + temp(kk) = s2(jx) + ind(kk) = j + end if + jx = jx + 1 + end do + kmod4 = mod(kk, 4) + k4 = kk - kmod4 + do j = 1, k4, 4 + t0 = temp(j) + t1 = temp(j+1) + t2 = temp(j+2) + t3 = temp(j+3) + j0 = ind(j) + j1 = ind(j+1) + j2 = ind(j+2) + j3 = ind(j+3) + iy = ky + do m2 = 1, n_extent, bs + m4 = min(m2+bs-1,n_extent) + kk2 = 0 + do i = m2,m4 + kk2 = kk2 + 1 + temp2(kk2) = zero + enddo + kk2 = 0 + do i = m2,m4 + kk2 = kk2 + 1 + temp2(kk2) = temp2(kk2) + t0*s1(i, j0) + t1*s1(i, j1) & + + t2*s1(i, j2) + t3*s1(i, j3) + enddo + kk2 = 0 + do i = m2,m4 + kk2 = kk2 + 1 + dest(1+(i-1)*dlstride) = dest(1+(i-1)*dlstride) + temp2(kk2) + enddo + enddo + end do + do j = k4+1, kk + t0 = temp(j) + j0 = ind(j) + do m2 = 1, n_extent, bs + m4 = min(m2+bs-1,n_extent) + kk2 = 0 + do i = m2,m4 + kk2 = kk2 + 1 + temp2(kk2) = zero + enddo + kk2 = 0 + do i = m2,m4 + kk2 = kk2 + 1 + temp2(kk2) = temp2(kk2) + t0*s1(i, j0) + enddo + kk2 = 0 + do i = m2,m4 + kk2 = kk2 + 1 + dest(1+(i-1)*dlstride) = dest(1+(i-1)*dlstride) + temp2(kk2) + enddo + enddo + end do + end do + endif +end + +subroutine F90_matmul_real16_str1_vxm(dest, s1,s2, & + k_extent,m_extent, ld1,dlstride) + + implicit none + DESC_INT k_extent,m_extent,ld1,ld2,dlstride + REAL*16 s1(m_extent) + REAL*16 s2(ld1,k_extent) + REAL*16 dest(k_extent) + + INTEGER bs + parameter (bs = 384) + REAL*16 temp (bs) + REAL*16 t0,t1,t2,t3 + REAL*16 t4,t5,t6,t7 + REAL*16 dtemp0, dtemp1, dtemp2, dtemp3 + REAL*16 dtemp4, dtemp5, dtemp6, dtemp7 + DESC_INT ind(bs),ind0,ind1,ind2,ind3 + DESC_INT ind4,ind5,ind6,ind7 + REAL*16 zero + parameter (zero = 0.0D0) + + DESC_INT mi,ki,ti + DESC_INT ii,jj,j,jx,kk,jnext + DESC_INT mmod8,m8,kmod8,k8,tmod8,tt8 + DESC_INT mmod4,m4,kmod4,k4,tmod4,tt4 + + if (dlstride .eq. 1) then + do ki = 1, k_extent + dest(ki) = 0.0d0 + end do + + mmod8 = mod(m_extent,8) + m8 = m_extent - mmod8 + kmod8 = mod(k_extent,8) + k8 = k_extent - kmod8 + + do kk = 1,k8,8 + dtemp0 = dest(kk) + dtemp1 = dest(kk+1) + dtemp2 = dest(kk+2) + dtemp3 = dest(kk+3) + dtemp4 = dest(kk+4) + dtemp5 = dest(kk+5) + dtemp6 = dest(kk+6) + dtemp7 = dest(kk+7) + jnext = 1 + do jj = 1,m8,bs + ! load s1 temp vector + ti = 0 + jx = jj + do j = jj, min (m_extent, jj+bs-1) + if (s1(jx) .ne. zero) then + ti = ti + 1 + temp(ti) = s1(jx) + ind(ti) = j + end if + jx = jx + 1 + end do + + tmod8 = mod(ti,8) + tt8 = ti - tmod8 + + if (tt8 .ne. 0) then + jnext = ind(tt8)+1 + endif + + ti = 1 + do ii = 1,tt8,8 + t0 = temp(ti) + t1 = temp(ti+1) + t2 = temp(ti+2) + t3 = temp(ti+3) + t4 = temp(ti+4) + t5 = temp(ti+5) + t6 = temp(ti+6) + t7 = temp(ti+7) + ind0 = ind(ti) + ind1 = ind(ti+1) + ind2 = ind(ti+2) + ind3 = ind(ti+3) + ind4 = ind(ti+4) + ind5 = ind(ti+5) + ind6 = ind(ti+6) + ind7 = ind(ti+7) + + dtemp0 = dtemp0 + & + t0 * s2(ind0, kk) + t1 * s2(ind1, kk) + & + t2 * s2(ind2, kk) + t3 * s2(ind3, kk) + & + t4 * s2(ind4, kk) + t5 * s2(ind5, kk) + & + t6 * s2(ind6, kk) + t7 * s2(ind7, kk) + dtemp1 = dtemp1 + & + t0 * s2(ind0, kk+1) + t1 * s2(ind1, kk+1) + & + t2 * s2(ind2, kk+1) + t3 * s2(ind3, kk+1) + & + t4 * s2(ind4, kk+1) + t5 * s2(ind5, kk+1) + & + t6 * s2(ind6, kk+1) + t7 * s2(ind7, kk+1) + dtemp2 = dtemp2 + & + t0 * s2(ind0, kk+2) + t1 * s2(ind1, kk+2) + & + t2 * s2(ind2, kk+2) + t3 * s2(ind3, kk+2) + & + t4 * s2(ind4, kk+2) + t5 * s2(ind5, kk+2) + & + t6 * s2(ind6, kk+2) + t7 * s2(ind7, kk+2) + dtemp3 = dtemp3 + & + t0 * s2(ind0, kk+3) + t1 * s2(ind1, kk+3) + & + t2 * s2(ind2, kk+3) + t3 * s2(ind3, kk+3) + & + t4 * s2(ind4, kk+3) + t5 * s2(ind5, kk+3) + & + t6 * s2(ind6, kk+3) + t7 * s2(ind7, kk+3) + + dtemp4 = dtemp4 + & + t0 * s2(ind0, kk+4) + t1 * s2(ind1, kk+4) + & + t2 * s2(ind2, kk+4) + t3 * s2(ind3, kk+4) + & + t4 * s2(ind4, kk+4) + t5 * s2(ind5, kk+4) + & + t6 * s2(ind6, kk+4) + t7 * s2(ind7, kk+4) + dtemp5 = dtemp5 + & + t0 * s2(ind0, kk+5) + t1 * s2(ind1, kk+5) + & + t2 * s2(ind2, kk+5) + t3 * s2(ind3, kk+5) + & + t4 * s2(ind4, kk+5) + t5 * s2(ind5, kk+5) + & + t6 * s2(ind6, kk+5) + t7 * s2(ind7, kk+5) + dtemp6 = dtemp6 + & + t0 * s2(ind0, kk+6) + t1 * s2(ind1, kk+6) + & + t2 * s2(ind2, kk+6) + t3 * s2(ind3, kk+6) + & + t4 * s2(ind4, kk+6) + t5 * s2(ind5, kk+6) + & + t6 * s2(ind6, kk+6) + t7 * s2(ind7, kk+6) + dtemp7 = dtemp7 + & + t0 * s2(ind0, kk+7) + t1 * s2(ind1, kk+7) + & + t2 * s2(ind2, kk+7) + t3 * s2(ind3, kk+7) + & + t4 * s2(ind4, kk+7) + t5 * s2(ind5, kk+7) + & + t6 * s2(ind6, kk+7) + t7 * s2(ind7, kk+7) + ti = ti + 8 + enddo + enddo + do ii = jnext,m_extent + t0 = s1(ii) + dtemp0 = dtemp0 + t0 * s2(ii,kk) + dtemp1 = dtemp1 + t0 * s2(ii,kk+1) + dtemp2 = dtemp2 + t0 * s2(ii,kk+2) + dtemp3 = dtemp3 + t0 * s2(ii,kk+3) + dtemp4 = dtemp4 + t0 * s2(ii,kk+4) + dtemp5 = dtemp5 + t0 * s2(ii,kk+5) + dtemp6 = dtemp6 + t0 * s2(ii,kk+6) + dtemp7 = dtemp7 + t0 * s2(ii,kk+7) + enddo + dest(kk) = dtemp0 + dest(kk+1) = dtemp1 + dest(kk+2) = dtemp2 + dest(kk+3) = dtemp3 + dest(kk+4) = dtemp4 + dest(kk+5) = dtemp5 + dest(kk+6) = dtemp6 + dest(kk+7) = dtemp7 + enddo + do kk = k8+1,k_extent + dtemp0 = dest(kk) + do ii = 1,m_extent + dtemp0 = dtemp0 + s1(ii) * s2(ii,kk) + enddo + dest(kk) = dtemp0 + enddo + + + else + do kk = 1, k_extent + dest(1+(kk-1)*dlstride) = 0 + end do + + mmod4 = mod(m_extent,4) + m4 = m_extent - mmod4 + kmod4 = mod(k_extent,4) + k4 = k_extent - kmod4 + + do kk = 1,k4,4 + dtemp0 = dest(1+(kk-1)*dlstride) + dtemp1 = dest(1+(kk)*dlstride) + dtemp2 = dest(1+(kk+1)*dlstride) + dtemp3 = dest(1+(kk+2)*dlstride) + jnext = 1 + do jj = 1,m4,bs + ! load s1 temp vector + ti = 0 + jx = jj + do j = jj, min (m_extent, jj+bs-1) + if (s1(jx) .ne. zero) then + ti = ti + 1 + temp(ti) = s1(jx) + ind(ti) = j + end if + jx = jx + 1 + end do + + tmod4 = mod(ti,4) + tt4 = ti - tmod4 + + if (tt4 .ne. 0) then + jnext = ind(tt4)+1 + endif + + ti = 1 + do ii = 1,tt4,4 + t0 = temp(ti) + t1 = temp(ti+1) + t2 = temp(ti+2) + t3 = temp(ti+3) + ind0 = ind(ti) + ind1 = ind(ti+1) + ind2 = ind(ti+2) + ind3 = ind(ti+3) + + dtemp0 = dtemp0 + & + t0 * s2(ind0, kk) + t1 * s2(ind1, kk) + & + t2 * s2(ind2, kk) + t3 * s2(ind3, kk) + dtemp1 = dtemp1 + & + t0 * s2(ind0, kk+1) + t1 * s2(ind1, kk+1) + & + t2 * s2(ind2, kk+1) + t3 * s2(ind3, kk+1) + dtemp2 = dtemp2 + & + t0 * s2(ind0, kk+2) + t1 * s2(ind1, kk+2) + & + t2 * s2(ind2, kk+2) + t3 * s2(ind3, kk+2) + dtemp3 = dtemp3 + & + t0 * s2(ind0, kk+3) + t1 * s2(ind1, kk+3) + & + t2 * s2(ind2, kk+3) + t3 * s2(ind3, kk+3) + + ti = ti + 4 + enddo + enddo + do ii = jnext,m_extent + t0 = s1(ii) + dtemp0 = dtemp0 + t0 * s2(ii,kk) + dtemp1 = dtemp1 + t0 * s2(ii,kk+1) + dtemp2 = dtemp2 + t0 * s2(ii,kk+2) + dtemp3 = dtemp3 + t0 * s2(ii,kk+3) + enddo + dest(1+(kk-1)*dlstride) = dtemp0 + dest(1+(kk)*dlstride) = dtemp1 + dest(1+(kk+1)*dlstride) = dtemp2 + dest(1+(kk+2)*dlstride) = dtemp3 + enddo + do kk = k4+1,k_extent + dtemp0 = dest(1+(kk-1)*dlstride) + do ii = 1,m_extent + dtemp0 = dtemp0 + s1(ii) * s2(ii,kk) + enddo + dest(1+(kk-1)*dlstride) = dtemp0 + enddo + endif +end + + diff --git a/runtime/flang/mmul_real16str1_t.F95 b/runtime/flang/mmul_real16str1_t.F95 new file mode 100644 index 0000000000..5feefad311 --- /dev/null +++ b/runtime/flang/mmul_real16str1_t.F95 @@ -0,0 +1,150 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + + +#include "mmul_dir.h" + +subroutine F90_matmul_real16_str1_mxv_t(dest, s1,s2, & + n_extent,m_extent, ld1,dlstride) + implicit none + DESC_INT n_extent,m_extent,ld1,ld2,dlstride + REAL*16 s1(ld1,m_extent) + REAL*16 s2(m_extent) + REAL*16 dest(ld1*dlstride) + DESC_INT i,j,k + DESC_INT nmod8, mmod4, mmod2, n8, m2, kmod2, k2 + DESC_INT jx,kx,ii,jj,kk,kmod4,k4,incx + DESC_INT j0,j1,j2,j3,ix,iy,jy,ky,m4 + REAL*16 t0,t1,t2,t3,t4,t5,t6,t7,t8,x0,x1 + INTEGER bs + parameter (bs = 384) + REAL*16 temp (bs) + DESC_INT ind(bs) + REAL*16 zero + parameter (zero = 0.0D0) + + if (dlstride .eq. 1) then + do k = 1, m_extent + dest(1+(k-1)*dlstride) = 0.0d0 + end do + nmod8 = mod(m_extent, 8) + n8 = m_extent - nmod8 + kx = 1 + incx = 1 + jx = kx + nmod8 = mod(m_extent, 8) + n8= m_extent - nmod8 + do ii = 1, n_extent, bs + kk = 0 + ix = kx + (ii - 1) * incx + do i = ii, min (n_extent, ii+bs-1) + kk = kk + 1 + temp(kk) = s2(ix) + ix = ix + incx + end do + kmod2 = mod(kk, 2) + k2= kk - kmod2 + do j = 1, n8, 8 + t0 = zero + t1 = zero + t2 = zero + t3 = zero + t4 = zero + t5 = zero + t6 = zero + t7 = zero + do i = 1, kk + t0 = t0 + s1(i+ii-1, j)*temp(i) + t1 = t1 + s1(i+ii-1, j+1)*temp(i) + t2 = t2 + s1(i+ii-1, j+2)*temp(i) + t3 = t3 + s1(i+ii-1, j+3)*temp(i) + t4 = t4 + s1(i+ii-1, j+4)*temp(i) + t5 = t5 + s1(i+ii-1, j+5)*temp(i) + t6 = t6 + s1(i+ii-1, j+6)*temp(i) + t7 = t7 + s1(i+ii-1, j+7)*temp(i) + end do + dest(j) = dest(j) + t0 + dest(j + 1) = dest(j + 1) + t1 + dest(j + 2) = dest(j + 2) + t2 + dest(j + 3) = dest(j + 3) + t3 + dest(j + 4) = dest(j + 4) + t4 + dest(j + 5) = dest(j + 5) + t5 + dest(j + 6) = dest(j + 6) + t6 + dest(j + 7) = dest(j + 7) + t7 + end do + do j = n8+1, m_extent + do i = 1, kk + dest(j) = dest(j) + s1(i+ii-1, j)*temp(i) + end do + end do + end do + + else + do k = 1, m_extent + dest(1+(k-1)*dlstride) = 0.0d0 + end do + nmod8 = mod(m_extent, 8) + n8 = m_extent - nmod8 + kx = 1 + ky = 1 + incx = 1 + jx = kx + nmod8 = mod(m_extent, 8) + n8= m_extent - nmod8 + do ii = 1, n_extent, bs + jy = ky + kk = 0 + ix = kx + (ii - 1) * incx + do i = ii, min (n_extent, ii+bs-1) + kk = kk + 1 + temp(kk) = s2(ix) + ix = ix + incx + end do + do j = 1, n8, 8 + t0 = zero + t1 = zero + t2 = zero + t3 = zero + t4 = zero + t5 = zero + t6 = zero + t7 = zero + do i = 1, kk + t0 = t0 + s1(i+ii-1, j)*temp(i) + t1 = t1 + s1(i+ii-1, j+1)*temp(i) + t2 = t2 + s1(i+ii-1, j+2)*temp(i) + t3 = t3 + s1(i+ii-1, j+3)*temp(i) + t4 = t4 + s1(i+ii-1, j+4)*temp(i) + t5 = t5 + s1(i+ii-1, j+5)*temp(i) + t6 = t6 + s1(i+ii-1, j+6)*temp(i) + t7 = t7 + s1(i+ii-1, j+7)*temp(i) + end do + dest(1+(jy-1)*dlstride) = dest(1+(jy-1)*dlstride) + t0 + dest(1+(jy + 1 -1)*dlstride) = dest(1+(jy + 1 -1)*dlstride) + t1 + dest(1+(jy + 2 -1)*dlstride) = dest(1+(jy + 2 -1)*dlstride) + t2 + dest(1+(jy + 3 -1)*dlstride) = dest(1+(jy + 3 -1)*dlstride) + t3 + dest(1+(jy + 4 -1)*dlstride) = dest(1+(jy + 4 -1)*dlstride) + t4 + dest(1+(jy + 5 -1)*dlstride) = dest(1+(jy + 5 -1)*dlstride) + t5 + dest(1+(jy + 6 -1)*dlstride) = dest(1+(jy + 6 -1)*dlstride) + t6 + dest(1+(jy + 7 -1)*dlstride) = dest(1+(jy + 7 -1)*dlstride) + t7 + jy = jy + 8 + end do + jy = ky + n8 + do j = n8+1, m_extent + t0 = zero + do i = 1, kk + t0 = t0 + s1(i+ii-1, j)*temp(i) + end do + dest(1+(jy-1)*dlstride) = dest(1+(jy-1)*dlstride) + t0 + jy= jy + 1 + end do + end do + endif +end + + + + diff --git a/runtime/flang/mmulcplx32.c b/runtime/flang/mmulcplx32.c new file mode 100644 index 0000000000..96fab3dff0 --- /dev/null +++ b/runtime/flang/mmulcplx32.c @@ -0,0 +1,273 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + +/* clang-format off */ + +/** \file + * \brief F90 MATMUL intrinsics for COMPLEX*32 type + */ + +#include "stdioInterf.h" +#include "fioMacros.h" +#include "matmul.h" + +void ENTF90(MATMUL_CPLX32, matmul_cplx32)(char *dest_addr, char *s1_addr, + char *s2_addr, F90_Desc *dest_desc, + F90_Desc *s1_desc, F90_Desc *s2_desc) +{ + + __CPLX32_T *s1_base; + __CPLX32_T *s2_base; + __CPLX32_T *dest_base; + __CPLX32_T *d_elem_p; + __CPLX32_T *s1_elem_p; + __CPLX32_T *s2_elem_p; + + __CPLX32_T rslt_tmp; + + __INT_T s1_d1_lstride; + __INT_T s1_d1_sstride; + __INT_T s1_d1_lb; + __INT_T s1_d1_soffset = 0; + + __INT_T s1_d2_lstride = 1; + __INT_T s1_d2_sstride = 1; + __INT_T s1_d2_lb = 0; + __INT_T s1_d2_soffset = 0; + + __INT_T s2_d1_lstride; + __INT_T s2_d1_sstride; + __INT_T s2_d1_lb; + __INT_T s2_d1_soffset = 0; + + __INT_T s2_d2_lstride = 1; + __INT_T s2_d2_sstride = 1; + __INT_T s2_d2_lb = 0; + __INT_T s2_d2_soffset = 0; + + __INT_T d_d1_lstride; + __INT_T d_d1_sstride; + __INT_T d_d1_lb; + __INT_T d_d1_soffset = 0; + + __INT_T d_d2_lstride = 1; + __INT_T d_d2_sstride = 1; + __INT_T d_d2_lb = 0; + __INT_T d_d2_soffset = 0; + + __INT_T d_rank = F90_RANK_G(dest_desc); + __INT_T s1_rank = F90_RANK_G(s1_desc); + __INT_T s2_rank = F90_RANK_G(s2_desc); + + __INT_T k_extent = s2_rank == 2 ? F90_DIM_EXTENT_G(s2_desc, 1) : 1; + __INT_T m_extent = s1_rank == 2 ? F90_DIM_EXTENT_G(s1_desc, 1) + : F90_DIM_EXTENT_G(s1_desc, 0); + __INT_T n_extent = s1_rank == 2 ? F90_DIM_EXTENT_G(s1_desc, 0) : 1; + + __INT_T dest_offset; + + __INT_T s1_d1_base, s1_d1_delta, s1_d1_offset, s1_d2_base, s1_d2_delta, + s1_d2_offset, s2_d1_base, s2_d1_delta, s2_d1_offset, s2_d2_base, + s2_d2_delta, s2_d2_offset, d_d1_base, d_d1_delta, d_d1_offset, d_d2_base, + d_d2_delta, d_d2_offset; + + __INT_T k; + __INT_T m; + __INT_T n; + + /* mxm + * s1(n,m) x s2(m,k) -> dest(n,k) + * Check + * dest_d1 extent== n_extnet + * dest_d2 extent == k_extent + * s2_d1 extent = m_extent + * + * mxv + * s1(n,m) x s2(m) -> dest(n) + * Check + * dest_d1 extent== n_extent + * s2_d1 extent == m_extent + * + * vxm + * s1(m) x s2(m,k) -> dest(k) + * check + * s2_d1 extent == m_extent + * dest_d1 extent == k_extent + */ + + if (d_rank == 2 && s1_rank == 2 && s2_rank == 2) { + if (F90_DIM_EXTENT_G(dest_desc, 0) != n_extent || + F90_DIM_EXTENT_G(dest_desc, 1) != k_extent || + F90_DIM_EXTENT_G(s2_desc, 0) != m_extent) { + __fort_abort("MATMUL: nonconforming array shapes"); + } + } else if (d_rank == 1 && s1_rank == 2 && s2_rank == 1) { + if (F90_DIM_EXTENT_G(dest_desc, 0) != n_extent || + F90_DIM_EXTENT_G(s2_desc, 0) != m_extent) { + __fort_abort("MATMUL: nonconforming array shapes"); + } + } else if (d_rank == 1 && s1_rank == 1 && s2_rank == 2) { + if (F90_DIM_EXTENT_G(dest_desc, 0) != k_extent || + F90_DIM_EXTENT_G(s2_desc, 0) != m_extent) { + __fort_abort("MATMUL: nonconforming array shapes"); + } + } else { + __fort_abort("MATMUL: non-conforming array shapes"); + } + + s1_d1_lstride = F90_DIM_LSTRIDE_G(s1_desc, 0); + s1_d1_sstride = F90_DIM_SSTRIDE_G(s1_desc, 0); + s1_d1_lb = F90_DIM_LBOUND_G(s1_desc, 0); + if (s1_d1_sstride != 1 || F90_DIM_SOFFSET_G(s1_desc, 0)) + s1_d1_soffset = F90_DIM_SOFFSET_G(s1_desc, 0) + s1_d1_sstride - s1_d1_lb; + + if (s1_rank == 2) { + s1_d2_lstride = F90_DIM_LSTRIDE_G(s1_desc, 1); + s1_d2_lb = F90_DIM_LBOUND_G(s1_desc, 1); + s1_d2_sstride = F90_DIM_SSTRIDE_G(s1_desc, 1); + if (s1_d2_sstride != 1 || F90_DIM_SOFFSET_G(s1_desc, 1)) + s1_d2_soffset = F90_DIM_SOFFSET_G(s1_desc, 1) + s1_d2_sstride - s1_d2_lb; + } + + s2_d1_lstride = F90_DIM_LSTRIDE_G(s2_desc, 0); + s2_d1_lb = F90_DIM_LBOUND_G(s2_desc, 0); + s2_d1_sstride = F90_DIM_SSTRIDE_G(s2_desc, 0); + if (s2_d1_sstride != 1 || F90_DIM_SOFFSET_G(s2_desc, 0)) + s2_d1_soffset = F90_DIM_SOFFSET_G(s2_desc, 0) + s2_d1_sstride - s2_d1_lb; + + if (s2_rank == 2) { + s2_d2_lstride = F90_DIM_LSTRIDE_G(s2_desc, 1); + s2_d2_lb = F90_DIM_LBOUND_G(s2_desc, 1); + s2_d2_sstride = F90_DIM_SSTRIDE_G(s2_desc, 1); + if (s2_d2_sstride != 1 || F90_DIM_SOFFSET_G(s2_desc, 1)) + s2_d2_soffset = F90_DIM_SOFFSET_G(s2_desc, 1) + s2_d2_sstride - s2_d2_lb; + } + + d_d1_lstride = F90_DIM_LSTRIDE_G(dest_desc, 0); + d_d1_lb = F90_DIM_LBOUND_G(dest_desc, 0); + d_d1_sstride = F90_DIM_SSTRIDE_G(dest_desc, 0); + if (d_d1_sstride != 1 || F90_DIM_SOFFSET_G(dest_desc, 0)) + d_d1_soffset = F90_DIM_SOFFSET_G(dest_desc, 0) + d_d1_sstride - d_d1_lb; + + if (d_rank == 2) { + d_d2_lstride = F90_DIM_LSTRIDE_G(dest_desc, 1); + d_d2_lb = F90_DIM_LBOUND_G(dest_desc, 1); + d_d2_sstride = F90_DIM_SSTRIDE_G(dest_desc, 1); + if (d_d2_sstride != 1 || F90_DIM_SOFFSET_G(dest_desc, 1)) + d_d2_soffset = F90_DIM_SOFFSET_G(dest_desc, 1) + d_d2_sstride - d_d2_lb; + } + + s1_base = (__CPLX32_T *)s1_addr + F90_LBASE_G(s1_desc) + + s1_d1_lb * s1_d1_lstride + s1_d2_lb * s1_d2_lstride - 1; + s2_base = (__CPLX32_T *)s2_addr + F90_LBASE_G(s2_desc) + + s2_d1_lb * s2_d1_lstride + s2_d2_lb * s2_d2_lstride - 1; + dest_base = (__CPLX32_T *)dest_addr + F90_LBASE_G(dest_desc) + + d_d1_lb * d_d1_lstride + d_d2_lb * d_d2_lstride - 1; + + d_d1_offset = d_d1_base = d_d1_soffset * d_d1_lstride; + d_d1_delta = d_d1_sstride * d_d1_lstride; + + d_d2_offset = d_d2_base = d_d2_soffset * d_d2_lstride; + d_d2_delta = s1_rank == 2 ? d_d2_sstride * d_d2_lstride : d_d1_delta; + + s1_d1_offset = s1_d1_base = s1_d1_soffset * s1_d1_lstride; + s1_d1_delta = s1_d1_sstride * s1_d1_lstride; + + s1_d2_offset = s1_d2_base = s1_d2_soffset * s1_d2_lstride; + s1_d2_delta = s1_rank == 2 ? s1_d2_sstride * s1_d2_lstride : s1_d1_delta; + + s2_d1_offset = s2_d1_base = s2_d1_soffset * s2_d1_lstride; + s2_d1_delta = s2_d1_sstride * s2_d1_lstride; + + s2_d2_offset = s2_d2_base = s2_d2_soffset * s2_d2_lstride; + s2_d2_delta = s2_d2_sstride * s2_d2_lstride; + + if ((s1_d1_sstride == 1) && (s2_d1_sstride == 1) && (d_d1_sstride == 1) && + (s1_d2_sstride == 1) && (s2_d2_sstride == 1) && (d_d2_sstride == 1) && + (s1_d1_lstride == 1) && (s2_d1_lstride == 1)) { + + s1_base += s1_d2_soffset * s1_d2_lstride; + s2_base += s2_d1_soffset * s2_d1_lstride; + if (s2_rank == 1) { + F90_MATMUL(cplx32_str1_mxv)( dest_base + d_d1_soffset*d_d1_lstride + + d_d2_soffset*d_d2_lstride, + s1_base + s1_d1_soffset * s1_d1_lstride, + s2_base + s2_d2_soffset * s2_d2_lstride, + &n_extent,&m_extent, + &s1_d2_lstride, &d_d1_lstride); + } else if (s1_rank == 1) { + F90_MATMUL(cplx32_str1_vxm)( dest_base + d_d1_soffset*d_d1_lstride + + d_d2_soffset*d_d2_lstride, + s1_base + s1_d1_soffset * s1_d1_lstride, + s2_base + s2_d2_soffset * s2_d2_lstride, + &k_extent,&m_extent, + &s2_d2_lstride, &d_d1_lstride); + + } else { + F90_MATMUL(cplx32_str1)(dest_base + d_d1_soffset*d_d1_lstride + + d_d2_soffset*d_d2_lstride, + s1_base + s1_d1_soffset * s1_d1_lstride, + s2_base + s2_d2_soffset * s2_d2_lstride, + &k_extent,&m_extent,&n_extent, + &s1_d2_lstride,&s2_d2_lstride,&d_d2_lstride, + &d_d1_lstride); + } + } else if (s1_rank == 2) { + for (k = 0; k < k_extent; k++) { + d_elem_p = dest_base + d_d1_base + d_d2_offset; + d_d2_offset += d_d2_delta; + for (n = 0; n < n_extent; n++) { + d_elem_p->r = 0; + d_elem_p->i = 0; + d_elem_p += d_d1_delta; + } + } + + d_d2_offset = d_d2_base; + for (k = 0; k < k_extent; k++) { + s2_elem_p = s2_base + s2_d1_base + s2_d2_offset; + s2_d2_offset += s2_d2_delta; + s1_d2_offset = s1_d2_base; + for (m = 0; m < m_extent; m++) { + s1_elem_p = s1_base + s1_d1_base + s1_d2_offset; + s1_d2_offset += s1_d2_delta; + d_elem_p = dest_base + d_d1_base + d_d2_offset; + for (n = 0; n < n_extent; n++) { + d_elem_p->r += + s1_elem_p->r * s2_elem_p->r - s1_elem_p->i * s2_elem_p->i; + d_elem_p->i += + s1_elem_p->r * s2_elem_p->i + s1_elem_p->i * s2_elem_p->r; + + s1_elem_p += s1_d1_delta; + d_elem_p += d_d1_delta; + } + s2_elem_p += s2_d1_delta; + } + d_d2_offset += d_d2_delta; + } + } else { + s1_base += s1_d1_base; + s2_base += s2_d1_soffset * s2_d1_lstride; + dest_offset = d_d1_base; + for (k = 0; k < k_extent; k++) { + s1_elem_p = s1_base; + s2_elem_p = s2_base + s2_d2_base; + rslt_tmp.r = 0; + rslt_tmp.i = 0; + for (m = 0; m < m_extent; m++) { + rslt_tmp.r += s1_elem_p->r * s2_elem_p->r - s1_elem_p->i * s2_elem_p->i; + rslt_tmp.i += s1_elem_p->r * s2_elem_p->i + s1_elem_p->i * s2_elem_p->r; + + s1_elem_p += s1_d1_delta; + s2_elem_p += s2_d1_delta; + } + *(dest_base + dest_offset) = rslt_tmp; + dest_offset += d_d1_delta; + s2_d2_base += s2_d2_delta; + } + } +} diff --git a/runtime/flang/mmulcplx32_t.c b/runtime/flang/mmulcplx32_t.c new file mode 100644 index 0000000000..627d516d1e --- /dev/null +++ b/runtime/flang/mmulcplx32_t.c @@ -0,0 +1,231 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + +/* clang-format off */ + +/** \file + * \brief F90 MATMUL intrinsics for COMPLEX*32 type + */ + +#include "stdioInterf.h" +#include "fioMacros.h" +#include "matmul.h" + +void ENTF90(MATMUL_CPLX32, + matmul_cplx32mxv_t)(char *dest_addr, char *s1_addr, char *s2_addr, + int *t_flag, F90_Desc *dest_desc, + F90_Desc *s1_desc, F90_Desc *s2_desc) +{ + + __CPLX32_T *s1_base; + __CPLX32_T *s2_base; + __CPLX32_T *dest_base; + + __CPLX32_T rslt_tmp; + __CPLX32_T *s1_p; + __CPLX32_T *s2_p; + + __INT_T s1_d1_lstride; + __INT_T s1_d1_sstride; + __INT_T s1_d1_lb; + __INT_T s1_d1_soffset = 0; + + __INT_T s1_d2_lstride = 1; + __INT_T s1_d2_sstride = 1; + __INT_T s1_d2_lb = 0; + __INT_T s1_d2_soffset = 0; + + __INT_T s2_d1_lstride; + __INT_T s2_d1_sstride; + __INT_T s2_d1_lb; + __INT_T s2_d1_soffset = 0; + + __INT_T s2_d2_lstride = 1; + __INT_T s2_d2_sstride = 1; + __INT_T s2_d2_lb = 0; + __INT_T s2_d2_soffset = 0; + + __INT_T d_d1_lstride; + __INT_T d_d1_sstride; + __INT_T d_d1_lb; + __INT_T d_d1_soffset = 0; + + __INT_T d_d2_lstride = 1; + __INT_T d_d2_sstride = 1; + __INT_T d_d2_lb = 0; + __INT_T d_d2_soffset = 0; + + __INT_T d_rank = F90_RANK_G(dest_desc); + __INT_T s1_rank = F90_RANK_G(s1_desc); + __INT_T s2_rank = F90_RANK_G(s2_desc); + + __INT_T k_extent = s2_rank == 2 ? F90_DIM_EXTENT_G(s2_desc, 1) : 1; + __INT_T m_extent = s1_rank == 2 ? F90_DIM_EXTENT_G(s1_desc, 1) + : F90_DIM_EXTENT_G(s1_desc, 0); + __INT_T n_extent = s1_rank == 2 ? F90_DIM_EXTENT_G(s1_desc, 0) : 1; + + /* mxm + * transpose(s1(n,m)) x s2(n,k) -> dest(m,k) + * Check + * dest_d1 extent== m_extnet + * dest_d2 extent == k_extent + * s2_d1 extent = n_extent + * + * mxv + * transpose(s1(n,m)) x s2(n) -> dest(m) + * Check + * dest_d1 extent== m_extent + * s2_d1 extent == n_extent + */ + + if (d_rank == 2 && s1_rank == 2 && s2_rank == 2) { + if (F90_DIM_EXTENT_G(dest_desc, 0) != m_extent || + F90_DIM_EXTENT_G(dest_desc, 1) != n_extent || + F90_DIM_EXTENT_G(s2_desc, 0) != n_extent) { + __fort_abort("MATMUL: nonconforming array shapes"); + } + } else if (d_rank == 1 && s1_rank == 2 && s2_rank == 1) { + if (F90_DIM_EXTENT_G(dest_desc, 0) != m_extent || + F90_DIM_EXTENT_G(s2_desc, 0) != n_extent) { + __fort_abort("MATMUL: nonconforming array shapes"); + } + } else { + __fort_abort("MATMUL: non-conforming array shapes"); + } + + s1_d1_lstride = F90_DIM_LSTRIDE_G(s1_desc, 0); + s1_d1_sstride = F90_DIM_SSTRIDE_G(s1_desc, 0); + s1_d1_lb = F90_DIM_LBOUND_G(s1_desc, 0); + if (s1_d1_sstride != 1 || F90_DIM_SOFFSET_G(s1_desc, 0)) + s1_d1_soffset = F90_DIM_SOFFSET_G(s1_desc, 0) + s1_d1_sstride - s1_d1_lb; + + if (s1_rank == 2) { + s1_d2_lstride = F90_DIM_LSTRIDE_G(s1_desc, 1); + s1_d2_lb = F90_DIM_LBOUND_G(s1_desc, 1); + s1_d2_sstride = F90_DIM_SSTRIDE_G(s1_desc, 1); + if (s1_d2_sstride != 1 || F90_DIM_SOFFSET_G(s1_desc, 1)) + s1_d2_soffset = F90_DIM_SOFFSET_G(s1_desc, 1) + s1_d2_sstride - s1_d2_lb; + } + + s2_d1_lstride = F90_DIM_LSTRIDE_G(s2_desc, 0); + s2_d1_lb = F90_DIM_LBOUND_G(s2_desc, 0); + s2_d1_sstride = F90_DIM_SSTRIDE_G(s2_desc, 0); + if (s2_d1_sstride != 1 || F90_DIM_SOFFSET_G(s2_desc, 0)) + s2_d1_soffset = F90_DIM_SOFFSET_G(s2_desc, 0) + s2_d1_sstride - s2_d1_lb; + + if (s2_rank == 2) { + s2_d2_lstride = F90_DIM_LSTRIDE_G(s2_desc, 1); + s2_d2_lb = F90_DIM_LBOUND_G(s2_desc, 1); + s2_d2_sstride = F90_DIM_SSTRIDE_G(s2_desc, 1); + if (s2_d2_sstride != 1 || F90_DIM_SOFFSET_G(s2_desc, 1)) + s2_d2_soffset = F90_DIM_SOFFSET_G(s2_desc, 1) + s2_d2_sstride - s2_d2_lb; + } + + d_d1_lstride = F90_DIM_LSTRIDE_G(dest_desc, 0); + d_d1_lb = F90_DIM_LBOUND_G(dest_desc, 0); + d_d1_sstride = F90_DIM_SSTRIDE_G(dest_desc, 0); + if (d_d1_sstride != 1 || F90_DIM_SOFFSET_G(dest_desc, 0)) + d_d1_soffset = F90_DIM_SOFFSET_G(dest_desc, 0) + d_d1_sstride - d_d1_lb; + + if (d_rank == 2) { + d_d2_lstride = F90_DIM_LSTRIDE_G(dest_desc, 1); + d_d2_lb = F90_DIM_LBOUND_G(dest_desc, 1); + d_d2_sstride = F90_DIM_SSTRIDE_G(dest_desc, 1); + if (d_d2_sstride != 1 || F90_DIM_SOFFSET_G(dest_desc, 1)) + d_d2_soffset = F90_DIM_SOFFSET_G(dest_desc, 1) + d_d2_sstride - d_d2_lb; + } + + if ((s1_d1_sstride == 1) && (s2_d1_sstride == 1) && (d_d1_sstride == 1) && + (s1_d2_sstride == 1) && (s2_d2_sstride == 1) && (d_d2_sstride == 1) && + (s1_d1_lstride == 1) && (s2_d1_lstride == 1)) { + + s1_base = (__CPLX32_T *)s1_addr + F90_LBASE_G(s1_desc) + + s1_d2_soffset * s1_d2_lstride + s1_d1_lb * s1_d1_lstride + + s1_d2_lb * s1_d2_lstride - 1; + s2_base = (__CPLX32_T *)s2_addr + F90_LBASE_G(s2_desc) + + s2_d1_soffset * s2_d1_lstride + s2_d1_lb * s2_d1_lstride + + s2_d2_lb * s2_d2_lstride - 1; + dest_base = (__CPLX32_T *)dest_addr + F90_LBASE_G(dest_desc) + + d_d1_lb * d_d1_lstride + d_d2_lb * d_d2_lstride - 1; + + if (s2_rank == 1) { + F90_MATMUL(cplx32_str1_mxv_t)( dest_base + d_d1_soffset*d_d1_lstride + + d_d2_soffset*d_d2_lstride, + s1_base + s1_d1_soffset * s1_d1_lstride, + s2_base + s2_d2_soffset * s2_d2_lstride, + &n_extent,&m_extent, + &s1_d2_lstride, &d_d1_lstride); + + } else { + __fort_abort( + "Internal Error: matrix by matrix matmul/transpose not implemented"); + } + return; + } + + /* transpose s1 */ + { + __INT_T dest_offset; + __INT_T s1_d1_base, s1_d1_offset, s1_m_delta, s1_d2_base, s1_n_delta, + s2_d1_base, s2_n_delta, s2_d2_base, s2_k_delta, d_d1_base, d_m_delta, + d_d2_base, d_k_delta; + __INT_T k; + __INT_T l; + __INT_T m; + __INT_T n; + + l = s1_d1_lstride; + s1_d1_lstride = s1_d2_lstride; + s1_d2_lstride = l; + + s1_base = (__CPLX32_T *)s1_addr + F90_LBASE_G(s1_desc) + + s1_d1_lb * s1_d1_lstride + s1_d2_lb * s1_d2_lstride - 1; + s2_base = (__CPLX32_T *)s2_addr + F90_LBASE_G(s2_desc) + + s2_d1_lb * s2_d1_lstride + s2_d2_lb * s2_d2_lstride - 1; + dest_base = (__CPLX32_T *)dest_addr + F90_LBASE_G(dest_desc) + + d_d1_lb * d_d1_lstride + d_d2_lb * d_d2_lstride - 1; + + d_d1_base = d_d1_soffset * d_d1_lstride; + d_m_delta = d_d1_sstride * d_d1_lstride; + d_d2_base = d_d2_soffset * d_d2_lstride; + d_k_delta = s1_rank == 2 ? d_d2_sstride * d_d2_lstride : d_m_delta; + + s1_d1_base = s1_d1_soffset * s1_d1_lstride; + s1_d1_offset = s1_d1_base; + s1_m_delta = s1_d1_sstride * s1_d1_lstride; + s1_base += s1_d2_soffset * s1_d2_lstride; + s1_n_delta = s1_rank == 2 ? s1_d2_sstride * s1_d2_lstride : s1_m_delta; + + s2_base += s2_d1_soffset * s2_d1_lstride; + s2_n_delta = s2_d1_sstride * s2_d1_lstride; + s2_d2_base = s2_d2_soffset * s2_d2_lstride; + s2_k_delta = s2_d2_sstride * s2_d2_lstride; + + for (k = 0; k < k_extent; k++) { + dest_offset = d_d1_base + d_d2_base; + d_d2_base += d_k_delta; + s1_d1_offset = s1_d1_base; + for (m = 0; m < m_extent; m++) { + s1_p = s1_base + s1_d1_offset; + s1_d1_offset += s1_m_delta; + s2_p = s2_base + s2_d2_base; + rslt_tmp.r = 0; + rslt_tmp.i = 0; + for (n = 0; n < n_extent; n++) { + rslt_tmp.r += s1_p->r * s2_p->r - s1_p->i * s2_p->i; + rslt_tmp.i += s1_p->r * s2_p->i + s1_p->i * s2_p->r; + + s1_p += s1_n_delta; + s2_p += s2_n_delta; + } + *(dest_base + dest_offset) = rslt_tmp; + dest_offset += d_m_delta; + } + s2_d2_base += s2_k_delta; + } + } +} diff --git a/runtime/flang/mmulreal16.c b/runtime/flang/mmulreal16.c new file mode 100644 index 0000000000..465205430d --- /dev/null +++ b/runtime/flang/mmulreal16.c @@ -0,0 +1,265 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + +/* clang-format off */ + +/** \file + * \brief F90 MATMUL intrinsics for real*16 type + */ + +#include "stdioInterf.h" +#include "fioMacros.h" +#include "matmul.h" + +void ENTF90(MATMUL_REAL16, matmul_real16)(char *dest_addr, char *s1_addr, + char *s2_addr, F90_Desc *dest_desc, + F90_Desc *s1_desc, F90_Desc *s2_desc) +{ + + __REAL16_T *s1_base; + __REAL16_T *s2_base; + __REAL16_T *dest_base; + __REAL16_T *d_elem_p; + __REAL16_T *s1_elem_p; + __REAL16_T *s2_elem_p; + + __REAL16_T rslt_tmp; + + __INT_T s1_d1_lstride; + __INT_T s1_d1_sstride; + __INT_T s1_d1_lb; + __INT_T s1_d1_soffset = 0; + + __INT_T s1_d2_lstride = 1; + __INT_T s1_d2_sstride = 1; + __INT_T s1_d2_lb = 0; + __INT_T s1_d2_soffset = 0; + + __INT_T s2_d1_lstride; + __INT_T s2_d1_sstride; + __INT_T s2_d1_lb; + __INT_T s2_d1_soffset = 0; + + __INT_T s2_d2_lstride = 1; + __INT_T s2_d2_sstride = 1; + __INT_T s2_d2_lb = 0; + __INT_T s2_d2_soffset = 0; + + __INT_T d_d1_lstride; + __INT_T d_d1_sstride; + __INT_T d_d1_lb; + __INT_T d_d1_soffset = 0; + + __INT_T d_d2_lstride = 1; + __INT_T d_d2_sstride = 1; + __INT_T d_d2_lb = 0; + __INT_T d_d2_soffset = 0; + + __INT_T d_rank = F90_RANK_G(dest_desc); + __INT_T s1_rank = F90_RANK_G(s1_desc); + __INT_T s2_rank = F90_RANK_G(s2_desc); + + __INT_T k_extent = s2_rank == 2 ? F90_DIM_EXTENT_G(s2_desc, 1) : 1; + __INT_T m_extent = s1_rank == 2 ? F90_DIM_EXTENT_G(s1_desc, 1) + : F90_DIM_EXTENT_G(s1_desc, 0); + __INT_T n_extent = s1_rank == 2 ? F90_DIM_EXTENT_G(s1_desc, 0) : 1; + + __INT_T dest_offset; + + __INT_T s1_d1_base, s1_d1_delta, s1_d1_offset, s1_d2_base, s1_d2_delta, + s1_d2_offset, s2_d1_base, s2_d1_delta, s2_d1_offset, s2_d2_base, + s2_d2_delta, s2_d2_offset, d_d1_base, d_d1_delta, d_d1_offset, d_d2_base, + d_d2_delta, d_d2_offset; + + __INT_T k; + __INT_T m; + __INT_T n; + + /* mxm + * s1(n,m) x s2(m,k) -> dest(n,k) + * Check + * dest_d1 extent== n_extnet + * dest_d2 extent == k_extent + * s2_d1 extent = m_extent + * + * mxv + * s1(n,m) x s2(m) -> dest(n) + * Check + * dest_d1 extent== n_extent + * s2_d1 extent == m_extent + * + * vxm + * s1(m) x s2(m,k) -> dest(k) + * check + * s2_d1 extent == m_extent + * dest_d1 extent == k_extent + */ + + if (d_rank == 2 && s1_rank == 2 && s2_rank == 2) { + if (F90_DIM_EXTENT_G(dest_desc, 0) != n_extent || + F90_DIM_EXTENT_G(dest_desc, 1) != k_extent || + F90_DIM_EXTENT_G(s2_desc, 0) != m_extent) { + __fort_abort("MATMUL: nonconforming array shapes"); + } + } else if (d_rank == 1 && s1_rank == 2 && s2_rank == 1) { + if (F90_DIM_EXTENT_G(dest_desc, 0) != n_extent || + F90_DIM_EXTENT_G(s2_desc, 0) != m_extent) { + __fort_abort("MATMUL: nonconforming array shapes"); + } + } else if (d_rank == 1 && s1_rank == 1 && s2_rank == 2) { + if (F90_DIM_EXTENT_G(dest_desc, 0) != k_extent || + F90_DIM_EXTENT_G(s2_desc, 0) != m_extent) { + __fort_abort("MATMUL: nonconforming array shapes"); + } + } else { + __fort_abort("MATMUL: non-conforming array shapes"); + } + + s1_d1_lstride = F90_DIM_LSTRIDE_G(s1_desc, 0); + s1_d1_sstride = F90_DIM_SSTRIDE_G(s1_desc, 0); + s1_d1_lb = F90_DIM_LBOUND_G(s1_desc, 0); + if (s1_d1_sstride != 1 || F90_DIM_SOFFSET_G(s1_desc, 0)) + s1_d1_soffset = F90_DIM_SOFFSET_G(s1_desc, 0) + s1_d1_sstride - s1_d1_lb; + + if (s1_rank == 2) { + s1_d2_lstride = F90_DIM_LSTRIDE_G(s1_desc, 1); + s1_d2_lb = F90_DIM_LBOUND_G(s1_desc, 1); + s1_d2_sstride = F90_DIM_SSTRIDE_G(s1_desc, 1); + if (s1_d2_sstride != 1 || F90_DIM_SOFFSET_G(s1_desc, 1)) + s1_d2_soffset = F90_DIM_SOFFSET_G(s1_desc, 1) + s1_d2_sstride - s1_d2_lb; + } + + s2_d1_lstride = F90_DIM_LSTRIDE_G(s2_desc, 0); + s2_d1_lb = F90_DIM_LBOUND_G(s2_desc, 0); + s2_d1_sstride = F90_DIM_SSTRIDE_G(s2_desc, 0); + if (s2_d1_sstride != 1 || F90_DIM_SOFFSET_G(s2_desc, 0)) + s2_d1_soffset = F90_DIM_SOFFSET_G(s2_desc, 0) + s2_d1_sstride - s2_d1_lb; + + if (s2_rank == 2) { + s2_d2_lstride = F90_DIM_LSTRIDE_G(s2_desc, 1); + s2_d2_lb = F90_DIM_LBOUND_G(s2_desc, 1); + s2_d2_sstride = F90_DIM_SSTRIDE_G(s2_desc, 1); + if (s2_d2_sstride != 1 || F90_DIM_SOFFSET_G(s2_desc, 1)) + s2_d2_soffset = F90_DIM_SOFFSET_G(s2_desc, 1) + s2_d2_sstride - s2_d2_lb; + } + + d_d1_lstride = F90_DIM_LSTRIDE_G(dest_desc, 0); + d_d1_lb = F90_DIM_LBOUND_G(dest_desc, 0); + d_d1_sstride = F90_DIM_SSTRIDE_G(dest_desc, 0); + if (d_d1_sstride != 1 || F90_DIM_SOFFSET_G(dest_desc, 0)) + d_d1_soffset = F90_DIM_SOFFSET_G(dest_desc, 0) + d_d1_sstride - d_d1_lb; + + if (d_rank == 2) { + d_d2_lstride = F90_DIM_LSTRIDE_G(dest_desc, 1); + d_d2_lb = F90_DIM_LBOUND_G(dest_desc, 1); + d_d2_sstride = F90_DIM_SSTRIDE_G(dest_desc, 1); + if (d_d2_sstride != 1 || F90_DIM_SOFFSET_G(dest_desc, 1)) + d_d2_soffset = F90_DIM_SOFFSET_G(dest_desc, 1) + d_d2_sstride - d_d2_lb; + } + s1_base = (__REAL16_T *)s1_addr + F90_LBASE_G(s1_desc) + + s1_d1_lb * s1_d1_lstride + s1_d2_lb * s1_d2_lstride - 1; + s2_base = (__REAL16_T *)s2_addr + F90_LBASE_G(s2_desc) + + s2_d1_lb * s2_d1_lstride + s2_d2_lb * s2_d2_lstride - 1; + dest_base = (__REAL16_T *)dest_addr + F90_LBASE_G(dest_desc) + + d_d1_lb * d_d1_lstride + d_d2_lb * d_d2_lstride - 1; + + d_d1_offset = d_d1_base = d_d1_soffset * d_d1_lstride; + d_d1_delta = d_d1_sstride * d_d1_lstride; + + d_d2_offset = d_d2_base = d_d2_soffset * d_d2_lstride; + d_d2_delta = s1_rank == 2 ? d_d2_sstride * d_d2_lstride : d_d1_delta; + + s1_d1_offset = s1_d1_base = s1_d1_soffset * s1_d1_lstride; + s1_d1_delta = s1_d1_sstride * s1_d1_lstride; + + s1_d2_offset = s1_d2_base = s1_d2_soffset * s1_d2_lstride; + s1_d2_delta = s1_rank == 2 ? s1_d2_sstride * s1_d2_lstride : s1_d1_delta; + + s2_d1_offset = s2_d1_base = s2_d1_soffset * s2_d1_lstride; + s2_d1_delta = s2_d1_sstride * s2_d1_lstride; + + s2_d2_offset = s2_d2_base = s2_d2_soffset * s2_d2_lstride; + s2_d2_delta = s2_d2_sstride * s2_d2_lstride; + + if ((s1_d1_sstride == 1) && (s2_d1_sstride == 1) && (d_d1_sstride == 1) && + (s1_d2_sstride == 1) && (s2_d2_sstride == 1) && (d_d2_sstride == 1) && + (s1_d1_lstride == 1) && (s2_d1_lstride == 1)) { + + s1_base += s1_d2_soffset * s1_d2_lstride; + s2_base += s2_d1_soffset * s2_d1_lstride; + if (s2_rank == 1) { + F90_MATMUL(real16_str1_mxv)(dest_base + d_d1_soffset*d_d1_lstride + + d_d2_soffset*d_d2_lstride, + s1_base + s1_d1_soffset * s1_d1_lstride, + s2_base + s2_d2_soffset * s2_d2_lstride, + &n_extent,&m_extent, + &s1_d2_lstride, &d_d1_lstride); + + } else if (s1_rank == 1) { + F90_MATMUL(real16_str1_vxm)( dest_base + d_d1_soffset*d_d1_lstride + + d_d2_soffset*d_d2_lstride, + s1_base + s1_d1_soffset * s1_d1_lstride, + s2_base + s2_d2_soffset * s2_d2_lstride, + &k_extent,&m_extent, + &s2_d2_lstride, &d_d1_lstride); + } else { + F90_MATMUL(real16_str1)(dest_base + d_d1_soffset*d_d1_lstride + + d_d2_soffset*d_d2_lstride, + s1_base + s1_d1_soffset * s1_d1_lstride, + s2_base + s2_d2_soffset * s2_d2_lstride, + &k_extent,&m_extent,&n_extent, + &s1_d2_lstride,&s2_d2_lstride,&d_d2_lstride, + &d_d1_lstride); + } + } else if (s1_rank == 2) { + for (k = 0; k < k_extent; k++) { + d_elem_p = dest_base + d_d1_base + d_d2_offset; + d_d2_offset += d_d2_delta; + for (n = 0; n < n_extent; n++) { + *d_elem_p = 0; + d_elem_p += d_d1_delta; + } + } + + d_d2_offset = d_d2_base; + for (k = 0; k < k_extent; k++) { + s2_elem_p = s2_base + s2_d1_base + s2_d2_offset; + s2_d2_offset += s2_d2_delta; + s1_d2_offset = s1_d2_base; + for (m = 0; m < m_extent; m++) { + s1_elem_p = s1_base + s1_d1_base + s1_d2_offset; + s1_d2_offset += s1_d2_delta; + d_elem_p = dest_base + d_d1_base + d_d2_offset; + for (n = 0; n < n_extent; n++) { + *d_elem_p += *s1_elem_p * *s2_elem_p; + + d_elem_p += d_d1_delta; + s1_elem_p += s1_d1_delta; + } + s2_elem_p += s2_d1_delta; + } + d_d2_offset += d_d2_delta; + } + } else { + s1_base += s1_d1_base; + s2_base += s2_d1_soffset * s2_d1_lstride; + dest_offset = d_d1_base; + for (k = 0; k < k_extent; k++) { + s1_elem_p = s1_base; + s2_elem_p = s2_base + s2_d2_base; + rslt_tmp = 0; + for (m = 0; m < m_extent; m++) { + rslt_tmp += *s1_elem_p * *s2_elem_p; + s1_elem_p += s1_d1_delta; + s2_elem_p += s2_d1_delta; + } + *(dest_base + dest_offset) = rslt_tmp; + dest_offset += d_d1_delta; + s2_d2_base += s2_d2_delta; + } + } +} diff --git a/runtime/flang/mmulreal16_t.c b/runtime/flang/mmulreal16_t.c new file mode 100644 index 0000000000..2587fb9ab4 --- /dev/null +++ b/runtime/flang/mmulreal16_t.c @@ -0,0 +1,228 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + +/* clang-format off */ + +/** \file + * \brief F90 MATMUL intrinsics for REAL*8 type + */ + +#include "stdioInterf.h" +#include "fioMacros.h" +#include "matmul.h" + +void ENTF90(matmul_real16, + matmul_real16mxv_t)(char *dest_addr, char *s1_addr, char *s2_addr, + int *t_flag, F90_Desc *dest_desc, + F90_Desc *s1_desc, F90_Desc *s2_desc) +{ + + __REAL16_T *s1_base; + __REAL16_T *s1_elem_p; + __REAL16_T *s2_base; + __REAL16_T *s2_elem_p; + __REAL16_T *dest_base; + + __REAL16_T rslt_tmp; + + __INT_T s1_d1_lstride; + __INT_T s1_d1_sstride; + __INT_T s1_d1_lb; + __INT_T s1_d1_soffset = 0; + + __INT_T s1_d2_lstride = 1; + __INT_T s1_d2_sstride = 1; + __INT_T s1_d2_lb = 0; + __INT_T s1_d2_soffset = 0; + + __INT_T s2_d1_lstride; + __INT_T s2_d1_sstride; + __INT_T s2_d1_lb; + __INT_T s2_d1_soffset = 0; + + __INT_T s2_d2_lstride = 1; + __INT_T s2_d2_sstride = 1; + __INT_T s2_d2_lb = 0; + __INT_T s2_d2_soffset = 0; + + __INT_T d_d1_lstride; + __INT_T d_d1_sstride; + __INT_T d_d1_lb; + __INT_T d_d1_soffset = 0; + + __INT_T d_d2_lstride = 1; + __INT_T d_d2_sstride = 1; + __INT_T d_d2_lb = 0; + __INT_T d_d2_soffset = 0; + + __INT_T d_rank = F90_RANK_G(dest_desc); + __INT_T s1_rank = F90_RANK_G(s1_desc); + __INT_T s2_rank = F90_RANK_G(s2_desc); + + __INT_T k_extent = s2_rank == 2 ? F90_DIM_EXTENT_G(s2_desc, 1) : 1; + __INT_T m_extent = s1_rank == 2 ? F90_DIM_EXTENT_G(s1_desc, 1) + : F90_DIM_EXTENT_G(s1_desc, 0); + __INT_T n_extent = s1_rank == 2 ? F90_DIM_EXTENT_G(s1_desc, 0) : 1; + + /* mxm + * transpose(s1(n,m)) x s2(n,k) -> dest(m,k) + * Check + * dest_d1 extent== m_extnet + * dest_d2 extent == k_extent + * s2_d1 extent = n_extent + * + * mxv + * transpose(s1(n,m)) x s2(n) -> dest(m) + * Check + * dest_d1 extent== m_extent + * s2_d1 extent == n_extent + */ + + if (d_rank == 2 && s1_rank == 2 && s2_rank == 2) { + if (F90_DIM_EXTENT_G(dest_desc, 0) != m_extent || + F90_DIM_EXTENT_G(dest_desc, 1) != n_extent || + F90_DIM_EXTENT_G(s2_desc, 0) != n_extent) { + __fort_abort("MATMUL: nonconforming array shapes"); + } + } else if (d_rank == 1 && s1_rank == 2 && s2_rank == 1) { + if (F90_DIM_EXTENT_G(dest_desc, 0) != m_extent || + F90_DIM_EXTENT_G(s2_desc, 0) != n_extent) { + __fort_abort("MATMUL: nonconforming array shapes"); + } + } else { + __fort_abort("MATMUL: non-conforming array shapes"); + } + + s1_d1_lstride = F90_DIM_LSTRIDE_G(s1_desc, 0); + s1_d1_sstride = F90_DIM_SSTRIDE_G(s1_desc, 0); + s1_d1_lb = F90_DIM_LBOUND_G(s1_desc, 0); + if (s1_d1_sstride != 1 || F90_DIM_SOFFSET_G(s1_desc, 0)) + s1_d1_soffset = F90_DIM_SOFFSET_G(s1_desc, 0) + s1_d1_sstride - s1_d1_lb; + + if (s1_rank == 2) { + s1_d2_lstride = F90_DIM_LSTRIDE_G(s1_desc, 1); + s1_d2_lb = F90_DIM_LBOUND_G(s1_desc, 1); + s1_d2_sstride = F90_DIM_SSTRIDE_G(s1_desc, 1); + if (s1_d2_sstride != 1 || F90_DIM_SOFFSET_G(s1_desc, 1)) + s1_d2_soffset = F90_DIM_SOFFSET_G(s1_desc, 1) + s1_d2_sstride - s1_d2_lb; + } + + s2_d1_lstride = F90_DIM_LSTRIDE_G(s2_desc, 0); + s2_d1_lb = F90_DIM_LBOUND_G(s2_desc, 0); + s2_d1_sstride = F90_DIM_SSTRIDE_G(s2_desc, 0); + if (s2_d1_sstride != 1 || F90_DIM_SOFFSET_G(s2_desc, 0)) + s2_d1_soffset = F90_DIM_SOFFSET_G(s2_desc, 0) + s2_d1_sstride - s2_d1_lb; + + if (s2_rank == 2) { + s2_d2_lstride = F90_DIM_LSTRIDE_G(s2_desc, 1); + s2_d2_lb = F90_DIM_LBOUND_G(s2_desc, 1); + s2_d2_sstride = F90_DIM_SSTRIDE_G(s2_desc, 1); + if (s2_d2_sstride != 1 || F90_DIM_SOFFSET_G(s2_desc, 1)) + s2_d2_soffset = F90_DIM_SOFFSET_G(s2_desc, 1) + s2_d2_sstride - s2_d2_lb; + } + + d_d1_lstride = F90_DIM_LSTRIDE_G(dest_desc, 0); + d_d1_lb = F90_DIM_LBOUND_G(dest_desc, 0); + d_d1_sstride = F90_DIM_SSTRIDE_G(dest_desc, 0); + if (d_d1_sstride != 1 || F90_DIM_SOFFSET_G(dest_desc, 0)) + d_d1_soffset = F90_DIM_SOFFSET_G(dest_desc, 0) + d_d1_sstride - d_d1_lb; + + if (d_rank == 2) { + d_d2_lstride = F90_DIM_LSTRIDE_G(dest_desc, 1); + d_d2_lb = F90_DIM_LBOUND_G(dest_desc, 1); + d_d2_sstride = F90_DIM_SSTRIDE_G(dest_desc, 1); + if (d_d2_sstride != 1 || F90_DIM_SOFFSET_G(dest_desc, 1)) + d_d2_soffset = F90_DIM_SOFFSET_G(dest_desc, 1) + d_d2_sstride - d_d2_lb; + } + + if ((s1_d1_sstride == 1) && (s2_d1_sstride == 1) && (d_d1_sstride == 1) && + (s1_d2_sstride == 1) && (s2_d2_sstride == 1) && (d_d2_sstride == 1) && + (s1_d1_lstride == 1) && (s2_d1_lstride == 1)) { + + s1_base = (__REAL16_T *)s1_addr + F90_LBASE_G(s1_desc) + + s1_d2_soffset * s1_d2_lstride + s1_d1_lb * s1_d1_lstride + + s1_d2_lb * s1_d2_lstride - 1; + s2_base = (__REAL16_T *)s2_addr + F90_LBASE_G(s2_desc) + + s2_d1_soffset * s2_d1_lstride + s2_d1_lb * s2_d1_lstride + + s2_d2_lb * s2_d2_lstride - 1; + dest_base = (__REAL16_T *)dest_addr + F90_LBASE_G(dest_desc) + + d_d1_lb * d_d1_lstride + d_d2_lb * d_d2_lstride - 1; + + if (s2_rank == 1) { + F90_MATMUL(real16_str1_mxv_t)( dest_base + d_d1_soffset*d_d1_lstride + + d_d2_soffset*d_d2_lstride, + s1_base + s1_d1_soffset * s1_d1_lstride, + s2_base + s2_d2_soffset * s2_d2_lstride, + &n_extent,&m_extent, + &s1_d2_lstride, &d_d1_lstride); + + } else { + __fort_abort( + "Internal Error: matrix by matrix matmul/transpose not implemented"); + } + return; + } + + /* transpose s1 */ + { + __INT_T dest_offset; + __INT_T s1_d1_base, s1_d1_offset, s1_m_delta, s1_d2_base, s1_n_delta, + s2_d1_base, s2_n_delta, s2_d2_base, s2_k_delta, d_d1_base, d_m_delta, + d_d2_base, d_k_delta; + __INT_T k; + __INT_T l; + __INT_T m; + __INT_T n; + + l = s1_d1_lstride; + s1_d1_lstride = s1_d2_lstride; + s1_d2_lstride = l; + + s1_base = (__REAL16_T *)s1_addr + F90_LBASE_G(s1_desc) + + s1_d1_lb * s1_d1_lstride + s1_d2_lb * s1_d2_lstride - 1; + s2_base = (__REAL16_T *)s2_addr + F90_LBASE_G(s2_desc) + + s2_d1_lb * s2_d1_lstride + s2_d2_lb * s2_d2_lstride - 1; + dest_base = (__REAL16_T *)dest_addr + F90_LBASE_G(dest_desc) + + d_d1_lb * d_d1_lstride + d_d2_lb * d_d2_lstride - 1; + + d_d1_base = d_d1_soffset * d_d1_lstride; + d_m_delta = d_d1_sstride * d_d1_lstride; + d_d2_base = d_d2_soffset * d_d2_lstride; + d_k_delta = s1_rank == 2 ? d_d2_sstride * d_d2_lstride : d_m_delta; + + s1_d1_base = s1_d1_soffset * s1_d1_lstride; + s1_d1_offset = s1_d1_base; + s1_m_delta = s1_d1_sstride * s1_d1_lstride; + s1_base += s1_d2_soffset * s1_d2_lstride; + s1_n_delta = s1_rank == 2 ? s1_d2_sstride * s1_d2_lstride : s1_m_delta; + + s2_base += s2_d1_soffset * s2_d1_lstride; + s2_n_delta = s2_d1_sstride * s2_d1_lstride; + s2_d2_base = s2_d2_soffset * s2_d2_lstride; + s2_k_delta = s2_d2_sstride * s2_d2_lstride; + + for (k = 0; k < k_extent; k++) { + dest_offset = d_d1_base + d_d2_base; + d_d2_base += d_k_delta; + s1_d1_offset = s1_d1_base; + for (m = 0; m < m_extent; m++) { + s1_elem_p = s1_base + s1_d1_offset; + s1_d1_offset += s1_m_delta; + s2_elem_p = s2_base + s2_d2_base; + rslt_tmp = 0; + for (n = 0; n < n_extent; n++) { + rslt_tmp += *s1_elem_p * *s2_elem_p; + s1_elem_p += s1_n_delta; + s2_elem_p += s2_n_delta; + } + *(dest_base + dest_offset) = rslt_tmp; + dest_offset += d_m_delta; + } + s2_d2_base += s2_k_delta; + } + } +} diff --git a/runtime/flang/mnaxnb_cmplx32.F95 b/runtime/flang/mnaxnb_cmplx32.F95 new file mode 100644 index 0000000000..7dafe3f7a1 --- /dev/null +++ b/runtime/flang/mnaxnb_cmplx32.F95 @@ -0,0 +1,335 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + + +! directives.h -- contains preprocessor directives for F90 rte files + +#include "mmul_dir.h" + +subroutine ftn_mnaxnb_cmplx32( mra, ncb, kab, alpha, a, lda, b, ldb, & + & beta, c, ldc ) + implicit none +#include "pgf90_mmul_cmplx16.h" + + ! Everything herein is focused on how the transposition buffer maps + ! to the matrix a. The size of the buffer is bufrows * bufcols + ! Since once transposed data will be read from the buffer down the rows, + ! bufrows corresponds to the columns of a while bufcols corresponds to + ! the rows of a. A bit confusing, but correct, I think + ! There are 4 cases to consider: + ! 1. rowsa <= bufcols AND colsa <= bufrows + ! 2. rowsa <= bufcols ( corresponds to a wide matrix ) + ! 3. colsa <= bufrows ( corresponds to a high matrix ) + ! 4. Both dimensions of a exceed both dimensions of the buffer + ! + ! The main idea here is that the bufrows will define the usage of the + ! L1 cache. We reference the same column or columns multiply while + ! accessing multiple partial rows of a transposed in the buffer. + + + ! + ! rowsa colsb + ! <-bufca(1)>< (2) > <-bufcb(1)><(2)> + ! i = 1, m -ar-> j = 1, n --br-> + ! ^ +----------+------+ ^ +----------+----+ ^ + ! | | x | | | x | | + ! | | x | | | x | | + ! bufr(1) | A**T x | rowchunks=2 | B x | | + ! | | x | | | x | | + ! | | | buffera x | | | | bufferb x | ka = 1, k + ! | | | x | | | | x | | + ! ac | | I x III | | bc | a x c | | + ! | v +xxxxxxxxxxxxxxxxx+ | | +xxxxxxxxxxxxxxx+ | + ! v ^ | x | | v | x | | + ! | | x | | | x | | + ! bufr(2) | x | | | x | | + ! | | II x IV | | | b x d | | + ! V +----------+------+ V +----------+----+ V + ! <--colachunks=2--> <-colbchunks=2> + ! x's mark buffer boudaries on the transposed matrices + ! For this case, bufca(1) = bufcols, bufr(1) = bufrows + + ! The structure of this code came from mnaxnb_real. + colsa = kab + rowsb = kab + rowsa = mra + colsb = ncb + if (colsa * rowsa * colsb < min_blocked_mult) then + if( beta .eq. 0.0 ) then + do j = 1, colsb + do i = 1, rowsa + temprr0 = 0.0 + tempri0 = 0.0 + tempir0 = 0.0 + tempii0 = 0.0 + do k = 1, colsa + temprr0 = temprr0 + real(alpha) * real(a(i, k)) * real(b(k, j)) - aimag(alpha) * aimag(a(i, k)) * real(b(k, j)) + enddo + do k = 1, colsa + tempii0 = tempii0 + real(alpha) * aimag(a(i, k)) * aimag(b(k, j)) + aimag(alpha) * real(a(i, k)) * aimag(b(k, j)) + enddo + do k = 1, colsa + tempir0 = tempir0 + real(alpha) * real(a(i, k)) * aimag(b(k, j)) - aimag(alpha) * aimag(a(i, k)) * aimag(b(k, j)) + enddo + do k = 1, colsa + tempri0 = tempri0 + real(alpha) * aimag(a(i, k)) * real(b(k, j)) + aimag(alpha) * real(a(i, k)) * real(b(k, j)) + enddo + c(i, j) = dcmplx((temprr0 - tempii0), (tempri0 + tempir0)) + enddo + enddo + else + do j = 1, colsb + do i = 1, rowsa + temprr0 = 0.0 + tempri0 = 0.0 + tempir0 = 0.0 + tempii0 = 0.0 + do k = 1, colsa + temprr0 = temprr0 + real(alpha) * real(a(i, k)) * real(b(k, j)) - aimag(alpha) * aimag(a(i, k)) * real(b(k, j)) + enddo + do k = 1, colsa + tempii0 = tempii0 + real(alpha) * aimag(a(i, k)) * aimag(b(k, j)) + aimag(alpha) * real(a(i, k)) * aimag(b(k, j)) + enddo + do k = 1, colsa + tempir0 = tempir0 + real(alpha) * real(a(i, k)) * aimag(b(k, j)) - aimag(alpha) * aimag(a(i, k)) * aimag(b(k, j)) + enddo + do k = 1, colsa + tempri0 = tempri0 + real(alpha) * aimag(a(i, k)) * real(b(k, j)) + aimag(alpha) * real(a(i, k)) * real(b(k, j)) + enddo + + c(i, j) = beta * c(i, j) + dcmplx((temprr0 - tempii0), (tempri0 + tempir0)) + enddo + enddo + endif + else + allocate( buffera( bufrows * bufcols ) ) + + bufca = min( bufcols, rowsa ) + + colachunks = ( rowsa + bufcols - 1)/bufcols + ! set the number of buffer row chunks we will work on + bufr = min( bufrows, colsa ) + bufr_sav = bufr + rowchunks = ( colsa + bufr - 1 )/bufr + bufca_sav = bufca + ac = 1 ! column index in matrix a for transpose + ! lor = colsa - bufr ! left-over rows adjusts for the the fact that + ! colsa/bufr * bufr may not be equal to colsa + ! Note that the starting column index into matrix a (ac) is the same as + ! starting index into matrix b. But we need 1 less than that so we can + ! add an index to it + colsb_chunks = 4 + colsb_end = colsb/colsb_chunks * colsb_chunks + colsb_strt = colsb_end + 1 + do rowchunk = 1, rowchunks + ar = 1 + do colachunk = 1, colachunks + bufca = min( bufca_sav, rowsa - ar + 1 ) + bufr = min( bufr_sav, colsa - ac + 1 ) + call ftn_transpose_cmplx32( ta, a( ar, ac ), lda, alpha, buffera, & + & bufr, bufca ) + if ( ac .eq. 1 )then + + if( beta .eq. 0.0 ) then + do j = 1, colsb_end, colsb_chunks + ndxa = 0 + do i = ar, ar + bufca - 1 + bk = ac - 1 + temprr0 = 0.0 + temprr1 = 0.0 + temprr2 = 0.0 + temprr3 = 0.0 + tempii0 = 0.0 + tempii1 = 0.0 + tempii2 = 0.0 + tempii3 = 0.0 + tempri0 = 0.0 + tempri1 = 0.0 + tempri2 = 0.0 + tempri3 = 0.0 + tempir0 = 0.0 + tempir1 = 0.0 + tempir2 = 0.0 + tempir3 = 0.0 + do k = 1, bufr ! dot product of real(a) * real(b) + bufatempr = real( buffera( ndxa + k ) ) + temprr0 = temprr0 + bufatempr * & + & real( b( bk + k, j ) ) + temprr1 = temprr1 + bufatempr * & + & real( b( bk + k, j + 1 ) ) + temprr2 = temprr2 + bufatempr * & + & real( b( bk + k, j + 2 ) ) + temprr3 = temprr3 + bufatempr * & + & real( b( bk + k, j + 3 ) ) + ! temp4 = temp4 + bufatemp * b( bk + k, j + 4 ) + ! temp5 = temp5 + bufatemp * b( bk + k, j + 5 ) + ! temp6 = temp6 + bufatemp * b( bk + k, j + 6 ) + ! temp7 = temp7 + bufatemp * b( bk + k, j + 7 ) + enddo + do k = 1, bufr ! dot product of aimag(a) * aimag(b) + bufatempi = aimag( buffera( ndxa + k ) ) + tempii0 = tempii0 + bufatempi * & + & aimag( b( bk + k, j ) ) + tempii1 = tempii1 + bufatempi * & + & aimag( b( bk + k, j + 1 ) ) + tempii2 = tempii2 + bufatempi * & + & aimag( b( bk + k, j + 2 ) ) + tempii3 = tempii3 + bufatempi * & + & aimag( b( bk + k, j + 3 ) ) + ! temp4 = temp4 + bufatemp * b( bk + k, j + 4 ) + ! temp5 = temp5 + bufatemp * b( bk + k, j + 5 ) + ! temp6 = temp6 + bufatemp * b( bk + k, j + 6 ) + ! temp7 = temp7 + bufatemp * b( bk + k, j + 7 ) + enddo + do k = 1, bufr ! cross dot product of real(a) * aimag(b) + bufatempr = real( buffera( ndxa + k ) ) + tempri0 = tempri0 + bufatempr * & + & aimag( b( bk + k, j ) ) + tempri1 = tempri1 + bufatempr * & + & aimag( b( bk + k, j + 1 ) ) + tempri2 = tempri2 + bufatempr * & + & aimag( b( bk + k, j + 2 ) ) + tempri3 = tempri3 + bufatempr * & + & aimag( b( bk + k, j + 3 ) ) + ! temp4 = temp4 + bufatemp * b( bk + k, j + 4 ) + ! temp5 = temp5 + bufatemp * b( bk + k, j + 5 ) + ! temp6 = temp6 + bufatemp * b( bk + k, j + 6 ) + ! temp7 = temp7 + bufatemp * b( bk + k, j + 7 ) + enddo + do k = 1, bufr ! cross dot product of aimag(a) * real(b) + bufatempi = aimag( buffera( ndxa + k ) ) + tempir0 = tempir0 + bufatempi * & + & real( b( bk + k, j ) ) + tempir1 = tempir1 + bufatempi * & + & real( b( bk + k, j + 1 ) ) + tempir2 = tempir2 + bufatempi * & + & real( b( bk + k, j + 2 ) ) + tempir3 = tempir3 + bufatempi * & + & real( b( bk + k, j + 3 ) ) + ! temp4 = temp4 + bufatemp * b( bk + k, j + 4 ) + ! temp5 = temp5 + bufatemp * b( bk + k, j + 5 ) + ! temp6 = temp6 + bufatemp * b( bk + k, j + 6 ) + ! temp7 = temp7 + bufatemp * b( bk + k, j + 7 ) + enddo + c(i, j ) = DCMPLX(temprr0 - tempii0, tempri0 + tempir0) + c(i, j + 1) = DCMPLX(temprr1 - tempii1, tempri1 + tempir1) + c(i, j + 2) = DCMPLX(temprr2 - tempii2, tempri2 + tempir2) + c(i, j + 3) = DCMPLX(temprr3 - tempii3, tempri3 + tempir3) + ndxa = ndxa + bufr + enddo + enddo + + ! This takes care of the last + ! colsb - colsb/colsb_chunks*colsb_chunks cases + do j = colsb_strt, colsb + ndxa = 0 + bk = ac - 1 + do i = ar, ar + bufca - 1 + temp = 0.0 + do k = 1, bufr + temp = temp + buffera( ndxa + k ) * b( bk + k, j ) + enddo + c( i, j ) = temp + ndxa = ndxa + bufr + enddo + enddo + else + do j = 1, colsb_end, colsb_chunks + ndxa = 0 + do i = ar, ar + bufca - 1 + bk = ac - 1 + temp0 = 0.0 + temp1 = 0.0 + temp2 = 0.0 + temp3 = 0.0 + do k = 1, bufr + bufatemp = buffera( ndxa + k ) + temp0 = temp0 + bufatemp * b( bk + k, j ) + temp1 = temp1 + bufatemp * b( bk + k, j + 1 ) + temp2 = temp2 + bufatemp * b( bk + k, j + 2 ) + temp3 = temp3 + bufatemp * b( bk + k, j + 3 ) + ! temp4 = temp4 + bufatemp * b( bk + k, j + 4 ) + ! temp5 = temp5 + bufatemp * b( bk + k, j + 5 ) + ! temp6 = temp6 + bufatemp * b( bk + k, j + 6 ) + ! temp7 = temp7 + bufatemp * b( bk + k, j + 7 ) + enddo + c( i, j ) = beta * c( i, j ) + temp0 + c( i, j + 1 ) = beta * c( i, j + 1 ) + temp1 + c( i, j + 2 ) = beta * c( i, j + 2 ) + temp2 + c( i, j + 3 ) = beta * c( i, j + 3 ) + temp3 + ndxa = ndxa + bufr + enddo + enddo + + ! This takes care of the last + ! colsb - colsb/colsb_chunks*colsb_chunks cases + do j = colsb_strt, colsb + ndxa = 0 + bk = ac - 1 + do i = ar, ar + bufca - 1 + temp = 0.0 + do k = 1, bufr + temp = temp + buffera( ndxa + k ) * b( bk + k, j ) + enddo + c( i, j ) = beta * c( i, j ) + temp + ndxa = ndxa + bufr + enddo + enddo + endif + else + do j = 1, colsb_end, colsb_chunks + ndxa = 0 + do i = ar, ar + bufca - 1 + bk = ac - 1 + temp0 = 0.0 + temp1 = 0.0 + temp2 = 0.0 + temp3 = 0.0 + do k = 1, bufr + bufatemp = buffera( ndxa + k ) + temp0 = temp0 + bufatemp * b( bk + k, j ) + temp1 = temp1 + bufatemp * b( bk + k, j + 1 ) + temp2 = temp2 + bufatemp * b( bk + k, j + 2 ) + temp3 = temp3 + bufatemp * b( bk + k, j + 3 ) + ! temp4 = temp4 + bufatemp * b( bk + k, j + 4 ) + ! temp5 = temp5 + bufatemp * b( bk + k, j + 5 ) + ! temp6 = temp6 + bufatemp * b( bk + k, j + 6 ) + ! temp7 = temp7 + bufatemp * b( bk + k, j + 7 ) + enddo + c( i, j ) = c( i, j ) + temp0 + c( i, j + 1 ) = c( i, j + 1 ) + temp1 + c( i, j + 2 ) = c( i, j + 2 ) + temp2 + c( i, j + 3 ) = c( i, j + 3 ) + temp3 + ndxa = ndxa + bufr + enddo + enddo + + ! This takes care of the last colsb - colsb/colsb_chunks*colsb_chunks + ! cases + do j = colsb_strt, colsb + ndxa = 0 + bk = ac - 1 + do i = ar, ar + bufca - 1 + temp = 0.0 + do k = 1, bufr + temp = temp + buffera( ndxa + k ) * b( bk + k, j ) + enddo + c( i, j ) = c( i, j ) + temp + ndxa = ndxa + bufr + enddo + enddo + endif + ! adjust the boundaries in the direction of the columns of a + + ar = ar + bufca + enddo + ! adjust the row values + ac = ac + bufr + enddo + deallocate( buffera ) + endif + return +end subroutine ftn_mnaxnb_cmplx32 diff --git a/runtime/flang/mnaxtb_cmplx32.F95 b/runtime/flang/mnaxtb_cmplx32.F95 new file mode 100644 index 0000000000..20a241521d --- /dev/null +++ b/runtime/flang/mnaxtb_cmplx32.F95 @@ -0,0 +1,317 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + + +! directives.h -- contains preprocessor directives for F90 rte files + +#include "mmul_dir.h" + +subroutine ftn_mnaxtb_cmplx32( mra, ncb, kab, alpha, a, lda, b, ldb, beta, & + & c, ldc ) + implicit none +#include "pgf90_mmul_cmplx32.h" + + ! + ! The main idea here is that the bufrows will define the usage of the + ! L1 cache. We reference the same column or columns multiply while + ! accessing multiple partial rows of matrix a transposed in the buffer. + + ! Remember that everything is buffer centric + ! + ! + ! <- bufca(1)>< (2)> <-bufcb-> + ! i = 1, m j = 1, n + ! rowsa colsb + ! ar ---> bc ---> + ! ^ +----------+------+ ^ +----------+----+ ^ + ! | | x | | | b x | | + ! | | x | | | u x | | + ! bufr(1) | A**T x | rowchunks=2 | f a x c | | + ! | | x | | | f x | | + ! | | buffera x | | | e x | kab = 1, k + ! | | x | | br | r x | | + ! | | I x III | | | | b x | | + ! v +xxxxxxxxxxxxxxxxx+ | | +xxxxxxxxxx+xxxx| | + ! ^ | x | | v | x | | + ! | | II x IV | | | B b x d | | + ! bufr(2) | x | | | x | | + ! | | x | | | x | | + ! V +----------+------+ V +----------+----+ V + ! <--colchunks=2--> + ! x's mark buffer boudaries on the transposed matrices + ! For this case, bufca(1) = bufcols, bufr(1) = bufrows + ! + ! Algorimically, we perform dot products of (I,a), (III,a), (II,b) + ! and (IV,b). The partial dot products of (I,a) are added to those + ! of (II,b) and those of (III,a) are added to those of (IV,b) + ! + ! Iterations over the "chunks" are buffer based + ! while iterations over i and j are matrix based and keep track of where + ! we are in the larger scheme of things + ! Iterations over i and j are bounded by buffer dimensions + ! + colsa = kab + rowsb = kab + rowsa = mra + colsb = ncb + if (colsa * rowsa * colsb < min_blocked_mult) then + if( beta .eq. 0.0 ) then + do j = 1, colsb + do i = 1, rowsa + temprr0 = 0.0 + tempri0 = 0.0 + tempir0 = 0.0 + tempii0 = 0.0 + do k = 1, colsa + temprr0 = temprr0 + real(alpha) * real(a(i, k)) * real(b(j, k)) - aimag(alpha) * aimag(a(i, k)) * real(b(j, k)) + enddo + do k = 1, colsa + tempii0 = tempii0 + real(alpha) * aimag(a(i, k)) * aimag(b(j, k)) + aimag(alpha) * real(a(i, k)) * aimag(b(j, k)) + enddo + do k = 1, colsa + tempir0 = tempir0 + real(alpha) * real(a(i, k)) * aimag(b(j, k)) - aimag(alpha) * aimag(a(i, k)) * aimag(b(j, k)) + enddo + do k = 1, colsa + tempri0 = tempri0 + real(alpha) * aimag(a(i, k)) * real(b(j, k)) + aimag(alpha) * real(a(i, k)) * real(b(j, k)) + enddo + c(i, j) = dcmplx((temprr0 - tempii0), (tempri0 + tempir0)) + enddo + enddo + else + do j = 1, colsb + do i = 1, rowsa + temprr0 = 0.0 + tempri0 = 0.0 + tempir0 = 0.0 + tempii0 = 0.0 + do k = 1, colsa + temprr0 = temprr0 + real(alpha) * real(a(i, k)) * real(b(j, k)) - aimag(alpha) * aimag(a(i, k)) * real(b(j, k)) + enddo + do k = 1, colsa + tempii0 = tempii0 + real(alpha) * aimag(a(i, k)) * aimag(b(j, k)) + aimag(alpha) * real(a(i, k)) * aimag(b(j, k)) + enddo + do k = 1, colsa + tempir0 = tempir0 + real(alpha) * real(a(i, k)) * aimag(b(j, k)) - aimag(alpha) * aimag(a(i, k)) * aimag(b(j, k)) + enddo + do k = 1, colsa + tempri0 = tempri0 + real(alpha) * aimag(a(i, k)) * real(b(j, k)) + aimag(alpha) * real(a(i, k)) * real(b(j, k)) + enddo + + c(i, j) = beta * c(i, j) + dcmplx((temprr0 - tempii0), (tempri0 + tempir0)) + enddo + enddo + endif + else + allocate( buffera( bufrows * bufcols ) ) + allocate( bufferb( bufrows * bufcols ) ) + + ! for algoritmic purposes, kab is the number of columns in matrix b, which + ! is also the number of columns in matrix a. + + + bufr = min( bufrows, colsa ) + bufr_sav = bufr + bufca = min( bufcols, rowsa ) + bufca_sav = bufca + bufcb = min( bufcols, colsb ) + bufcb_sav = bufcb + ar_sav = 1 + ac_sav = 1 + bc = 1 + br = 1 + ! both rowchunks and colchunks are buffer centric + rowchunks = ( colsa + bufr - 1 )/bufr + colachunks = ( rowsa + bufca - 1 )/bufca + colbchunks = ( colsb + bufcb - 1 )/bufcb + ! these are for loop unrolling + colsb_chunk = 4 + + do rowchunk = 1, rowchunks + bufcb = bufcb_sav + do colbchunk = 1, colbchunks + bufcb = min( bufcb_sav, colsb - bc + 1 ) + bufr = min( bufr_sav, rowsb - br + 1 ) + call ftn_transpose_cmplx32( tb, b( bc, br ), ldb, alpha, bufferb, & + & bufr, bufcb ) + ! ar = ar_sav + ! ac = 1 + ar = 1 + ac = ac_sav + do colachunk = 1, colachunks + if( br .eq. 1 )then + ! Note: alpha is 1.0 for matrix a to avoid multiplying by + ! alpha * alpha + bufca = min( bufca_sav, rowsa - ar + 1 ) + call ftn_transpose_cmplx32( ta, a( ar, ac ), lda, one, buffera, & + & bufr, bufca ) + ndxb0 = 0 + ndxb1 = bufr + ndxb2 = ndxb1 + bufr + ndxb3 = ndxb2 + bufr + colsb_chunks = bufcb/colsb_chunk + colsb_end = bc + colsb_chunks * colsb_chunk - 1 + colsb_strt = colsb_end + 1 + jend = bc + bufcb - 1 + j = bc + if( beta .eq. 0.0 ) then + do jb = 1, colsb_chunks + ndxa = 0 + do i = ar, ar + bufca - 1 + temp0 = 0.0 + temp1 = 0.0 + temp2 = 0.0 + temp3 = 0.0 + do k = 1, bufr + bufatemp = buffera( ndxa + k ) + temp0 = temp0 + bufferb( ndxb0 + k ) * bufatemp + temp1 = temp1 + bufferb( ndxb1 + k ) * bufatemp + temp2 = temp2 + bufferb( ndxb2 + k ) * bufatemp + temp3 = temp3 + bufferb( ndxb3 + k ) * bufatemp + enddo + c( i, j ) = temp0 + c( i, j + 1 ) = temp1 + c( i, j + 2 ) = temp2 + c( i, j + 3 ) = temp3 + ndxa = ndxa + bufr + enddo + ndxa = 0 + ndxb0 = ndxb0 + bufr * colsb_chunk + ndxb1 = ndxb1 + bufr * colsb_chunk + ndxb2 = ndxb2 + bufr * colsb_chunk + ndxb3 = ndxb3 + bufr * colsb_chunk + j = j + 4 + enddo + ndxb = bufr * colsb_chunks * colsb_chunk + do j = colsb_strt, jend + ndxa = 0 + do i = ar, ar + bufca - 1 + temp = 0.0 + do k = 1, bufr + temp = temp + bufferb( ndxb + k ) * & + & buffera( ndxa + k ) + enddo + c( i, j ) = temp + ndxa = ndxa + bufr + enddo + ndxb = ndxb + bufr + enddo + ! ac = ac + bufca + ar = ar + bufca + ! print *, "ac: ", ac + else + do jb = 1, colsb_chunks + ndxa = 0 + do i = ar, ar + bufca - 1 + temp0 = 0.0 + temp1 = 0.0 + temp2 = 0.0 + temp3 = 0.0 + do k = 1, bufr + bufatemp = buffera( ndxa + k ) + temp0 = temp0 + bufferb( ndxb0 + k ) * bufatemp + temp1 = temp1 + bufferb( ndxb1 + k ) * bufatemp + temp2 = temp2 + bufferb( ndxb2 + k ) * bufatemp + temp3 = temp3 + bufferb( ndxb3 + k ) * bufatemp + enddo + c( i, j ) = beta * c( i, j ) + temp0 + c( i, j + 1 ) = beta * c( i, j + 1 ) + temp1 + c( i, j + 2 ) = beta * c( i, j + 2 ) + temp2 + c( i, j + 3 ) = beta * c( i, j + 3 ) + temp3 + ndxa = ndxa + bufr + enddo + ndxa = 0 + ndxb0 = ndxb0 + bufr * colsb_chunk + ndxb1 = ndxb1 + bufr * colsb_chunk + ndxb2 = ndxb2 + bufr * colsb_chunk + ndxb3 = ndxb3 + bufr * colsb_chunk + j = j + 4 + enddo + ndxb = bufr * colsb_chunks * colsb_chunk + do j = colsb_strt, jend + ndxa = 0 + do i = ar, ar + bufca - 1 + temp = 0.0 + do k = 1, bufr + temp = temp + bufferb( ndxb + k ) * & + & buffera( ndxa + k ) + enddo + c( i, j ) = beta * c( i, j ) + temp + ndxa = ndxa + bufr + enddo + ndxb = ndxb + bufr + enddo + ! ac = ac + bufca + ar = ar + bufca + ! print *, "ac: ", ac + endif + else + bufca = min( bufca_sav, rowsa - ar + 1 ) + call ftn_transpose_cmplx32( ta, a( ar, ac ), lda, one , buffera, & + & bufr, bufca ) + ndxb0 = 0 + ndxb1 = bufr + ndxb2 = ndxb1 + bufr + ndxb3 = ndxb2 + bufr + colsb_chunks = bufcb/colsb_chunk + colsb_end = bc + colsb_chunks * colsb_chunk - 1 + colsb_strt = colsb_end + 1 + jend = bc + bufcb - 1 + j = bc + do jb = 1, colsb_chunks + ndxa = 0 + do i = ar, ar + bufca - 1 + temp0 = 0.0 + temp1 = 0.0 + temp2 = 0.0 + temp3 = 0.0 + do k = 1, bufr + bufatemp = buffera( ndxa + k ) + temp0 = temp0 + bufferb( ndxb0 + k ) * bufatemp + temp1 = temp1 + bufferb( ndxb1 + k ) * bufatemp + temp2 = temp2 + bufferb( ndxb2 + k ) * bufatemp + temp3 = temp3 + bufferb( ndxb3 + k ) * bufatemp + enddo + c( i, j ) = c( i, j ) + temp0 + c( i, j + 1 ) = c( i, j + 1 ) + temp1 + c( i, j + 2 ) = c( i, j + 2 ) + temp2 + c( i, j + 3 ) = c( i, j + 3 ) + temp3 + ndxa = ndxa + bufr + enddo + ndxa = 0 + ndxb0 = ndxb0 + bufr * colsb_chunk + ndxb1 = ndxb1 + bufr * colsb_chunk + ndxb2 = ndxb2 + bufr * colsb_chunk + ndxb3 = ndxb3 + bufr * colsb_chunk + j = j + 4 + enddo + ndxb = bufr * colsb_chunks * colsb_chunk + do j = colsb_strt, jend + ndxa = 0 + do i = ar, ar + bufca - 1 + temp = 0.0 + do k = 1, bufr + temp = temp + bufferb( ndxb + k ) * buffera( ndxa + k ) + enddo + c( i, j ) = c( i, j ) + temp + ndxa = ndxa + bufr + enddo + ndxb = ndxb + bufr + enddo + ar = ar + bufca + endif + enddo + + bc = bc + bufcb + enddo + br = br + bufr + ac_sav = ac_sav + bufr + bc = 1 + enddo + deallocate( buffera ) + deallocate( bufferb ) + endif + return +end subroutine ftn_mnaxtb_cmplx32 diff --git a/runtime/flang/mtaxnb_cmplx32.F95 b/runtime/flang/mtaxnb_cmplx32.F95 new file mode 100644 index 0000000000..79fb1e1f57 --- /dev/null +++ b/runtime/flang/mtaxnb_cmplx32.F95 @@ -0,0 +1,249 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + + +! directives.h -- contains preprocessor directives for F90 rte files + +#include "mmul_dir.h" + +subroutine ftn_mtaxnb_cmplx32( mra, ncb, kab, alpha, a, lda, b, ldb, beta, & + & c, ldc ) + implicit none +#include "pgf90_mmul_cmplx32.h" + + ! + ! rowsa + ! <-bufca(1)>< (2) > colsb + ! i = 1, m -ar-> j = 1, n + ! ^ +----------+------+ ^ bk = 0->+--------------------+ ^ + ! | | x | | | | | + ! | | x | | | | | + ! bufr(1) | A**T x | rowchunks=2 | | | + ! | | x | | | B | | + ! | | | buffera x | | | | ka = 1, k + ! | | | x | | | | | + ! ac | | I x III | | | | | + ! | v +xxxxxxxxxxxxxxxxx+ | bk = bk>+xxxxxxxxxxxxxxxxxxxx+ | + ! v ^ | x | | + bufr | | | + ! | | x | | | | | + ! bufr(2) | x | | | | | + ! | | II x IV | | | | | + ! V +----------+------+ V +--------------------+ V + ! <--colachunks=2--> + ! x's mark buffer boudaries on the transposed matrix for A, the + ! part of B that is multiplied by buffera in B + ! + + + !( I think this comment should be removed. The exchange of meanings for + ! colsa and rowsa is valid IF you are simply writing DO loops, but + ! we are not doing that herein. + ! since matrix a is transposed, the rows and columns get switched + colsa = kab + rowsb = kab + rowsa = mra + colsb = ncb + if (colsa * rowsa * colsb < min_blocked_mult) then + if( beta .eq. 0.0 ) then + do j = 1, colsb + do i = 1, rowsa + temprr0 = 0.0 + tempri0 = 0.0 + tempir0 = 0.0 + tempii0 = 0.0 + do k = 1, colsa + temprr0 = temprr0 + real(alpha) * real(a(k, i)) * real(b(k, j)) - aimag(alpha) * aimag(a(k, i)) * real(b(k, j)) + enddo + do k = 1, colsa + tempii0 = tempii0 + real(alpha) * aimag(a(k, i)) * aimag(b(k, j)) + aimag(alpha) * real(a(k, i)) * aimag(b(k, j)) + enddo + do k = 1, colsa + tempir0 = tempir0 + real(alpha) * real(a(k, i)) * aimag(b(k, j)) - aimag(alpha) * aimag(a(k, i)) * aimag(b(k, j)) + enddo + do k = 1, colsa + tempri0 = tempri0 + real(alpha) * aimag(a(k, i)) * real(b(k, j)) + aimag(alpha) * real(a(k, i)) * real(b(k, j)) + enddo + c(i, j) = dcmplx((temprr0 - tempii0), (tempri0 + tempir0)) + enddo + enddo + else + do j = 1, colsb + do i = 1, rowsa + temprr0 = 0.0 + tempri0 = 0.0 + tempir0 = 0.0 + tempii0 = 0.0 + do k = 1, colsa + temprr0 = temprr0 + real(alpha) * real(a(k, i)) * real(b(k, j)) - aimag(alpha) * aimag(a(k, i)) * real(b(k, j)) + enddo + do k = 1, colsa + tempii0 = tempii0 + real(alpha) * aimag(a(k, i)) * aimag(b(k, j)) + aimag(alpha) * real(a(k, i)) * aimag(b(k, j)) + enddo + do k = 1, colsa + tempir0 = tempir0 + real(alpha) * real(a(k, i)) * aimag(b(k, j)) - aimag(alpha) * aimag(a(k, i)) * aimag(b(k, j)) + enddo + do k = 1, colsa + tempri0 = tempri0 + real(alpha) * aimag(a(k, i)) * real(b(k, j)) + aimag(alpha) * real(a(k, i)) * real(b(k, j)) + enddo + + c(i, j) = beta * c(i, j) + dcmplx((temprr0 - tempii0), (tempri0 + tempir0)) + enddo + enddo + endif + else + allocate( buffera( bufrows * bufcols ) ) + + bufca = min( rowsa, bufcols ) + bufca_sav = bufca + colachunks = ( rowsa + bufca - 1)/bufca + ! set the number of buffer row chunks we will work on + bufr = min( colsa, bufrows ) + bufr_sav = bufr + rowchunks = ( colsa + bufr - 1 )/bufr + + ac = 1 ! column index in matrix a for gather. + ! Note that the starting column index into matrix a (ac) is the same as + ! starting index into matrix b. But we need 1 less than that so we can + ! add an index to it + ar = 1 + colsb_chunk = 4 + colsb_chunks = colsb/colsb_chunk + colsb_end = colsb_chunks * colsb_chunk + colsb_strt = colsb_end + 1 + + do rowchunk = 1, rowchunks ! This will set the values over k + ar = 1 ! row index in matrix a for gather and reference to C() + ! loc = rowsa - bufca + do colachunk = 1, colachunks ! this over m + if( ac .eq. 1 ) then + bufca = min( bufca_sav, rowsa - ar + 1 ) + bufr = min( bufr_sav, colsa - ac + 1 ) + call ftn_gather_cmplx32( ta, a( ac, ar ), lda, alpha, buffera, & + & bufr, bufca ) + bk = ac - 1 + if( beta .eq. 0.0 ) then + do j = 1, colsb_end, colsb_chunk + ndxa = 0 + do i = ar, ar + bufca - 1 + temp0 = 0 + temp1 = 0 + temp2 = 0 + temp3 = 0 + do k = 1, bufr + bufatemp = buffera( ndxa + k ) + temp0 = temp0 + bufatemp * b( bk + k, j ) + temp1 = temp1 + bufatemp * b( bk + k, j + 1 ) + temp2 = temp2 + bufatemp * b( bk + k, j + 2 ) + temp3 = temp3 + bufatemp * b( bk + k, j + 3 ) + enddo + c( i, j ) = temp0 + c( i, j + 1 ) = temp1 + c( i, j + 2 ) = temp2 + c( i, j + 3 ) = temp3 + ndxa = ndxa + bufr + enddo + enddo + do j = colsb_strt, colsb + ndxa = 0 + do i = ar, ar + bufca - 1 + temp = 0.0 + do k = 1, bufr + temp = temp + buffera( ndxa + k ) * b( bk + k, j ) + enddo + c( i, j ) = temp + ndxa = ndxa + bufr + enddo + enddo + else + do j = 1, colsb_end, colsb_chunk + ndxa = 0 + do i = ar, ar + bufca - 1 + temp0 = 0 + temp1 = 0 + temp2 = 0 + temp3 = 0 + do k = 1, bufr + bufatemp = buffera( ndxa + k ) + temp0 = temp0 + bufatemp * b( bk + k, j ) + temp1 = temp1 + bufatemp * b( bk + k, j + 1 ) + temp2 = temp2 + bufatemp * b( bk + k, j + 2 ) + temp3 = temp3 + bufatemp * b( bk + k, j + 3 ) + enddo + c( i, j ) = beta * c( i, j ) + temp0 + c( i, j + 1 ) = beta * c( i, j + 1 ) + temp1 + c( i, j + 2 ) = beta * c( i, j + 2 ) + temp2 + c( i, j + 3 ) = beta * c( i, j + 3 ) + temp3 + ndxa = ndxa + bufr + enddo + enddo + do j = colsb_strt, colsb + ndxa = 0 + do i = ar, ar + bufca - 1 + temp = 0.0 + do k = 1, bufr + temp = temp + buffera( ndxa + k ) * b( bk + k, j ) + enddo + c( i, j ) = beta * c( i, j ) + temp + ndxa = ndxa + bufr + enddo + enddo + endif + else + bufca = min( bufca_sav, rowsa - ar + 1 ) + bufr = min( bufr_sav, colsa - ac + 1 ) + call ftn_gather_cmplx32( ta, a( ac, ar ), lda, alpha, buffera, & + & bufr, bufca ) + bk = ac - 1 + do j = 1, colsb_end, colsb_chunk + ndxa = 0 + do i = ar, ar + bufca - 1 + temp0 = 0 + temp1 = 0 + temp2 = 0 + temp3 = 0 + do k = 1, bufr + bufatemp = buffera( ndxa + k ) + temp0 = temp0 + bufatemp * b( bk + k, j ) + temp1 = temp1 + bufatemp * b( bk + k, j + 1 ) + temp2 = temp2 + bufatemp * b( bk + k, j + 2 ) + temp3 = temp3 + bufatemp * b( bk + k, j + 3 ) + enddo + c( i, j ) = c( i, j ) + temp0 + c( i, j + 1 ) = c( i, j + 1 ) + temp1 + c( i, j + 2 ) = c( i, j + 2 ) + temp2 + c( i, j + 3 ) = c( i, j + 3 ) + temp3 + ndxa = ndxa + bufr + enddo + enddo + do j = colsb_strt, colsb + ndxa = 0 + do i = ar, ar + bufca - 1 + temp = 0.0 + do k = 1, bufr + temp = temp + buffera( ndxa + k ) * b( bk + k, j ) + enddo + c( i, j ) = c( i, j ) + temp + ndxa = ndxa + bufr + enddo + enddo + endif + ar = ar + bufca + ! bufr = min( bufr, lor ) + ! lor = lor - bufr + enddo + ac = ac + bufr + ! bufca = min( bufca, loc ) + ! loc = loc - bufca ! Note: this is not circular since the loops are + ! controlled but the number of buffera chunks we use. + ! bufr = bufr + colsa + + ! lor = colsa - bufr + enddo + + deallocate( buffera ) + endif + return +end subroutine ftn_mtaxnb_cmplx32 diff --git a/runtime/flang/mtaxtb_cmplx32.F95 b/runtime/flang/mtaxtb_cmplx32.F95 new file mode 100644 index 0000000000..d262b91787 --- /dev/null +++ b/runtime/flang/mtaxtb_cmplx32.F95 @@ -0,0 +1,376 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + + +! directives.h -- contains preprocessor directives for F90 rte files + +#include "mmul_dir.h" + +subroutine ftn_mtaxtb_cmplx32( mra, ncb, kab, alpha, a, lda, b, ldb, beta, & + & c, ldc ) + implicit none +#include "pgf90_mmul_cmplx32.h" + + ! Everything herein is focused on how the transposition buffer maps + ! to the matrix a. The size of the buffer is bufrows * bufcols + ! Since once transposed data will be read from the buffer down the rows, + ! bufrows corresponds to the columns of a while bufcols corresponds to + ! the rows of a. A bit confusing, but correct, I think + ! There are 4 cases to consider: + ! 1. rowsa <= bufcols AND colsa <= bufrows + ! 2. rowsa <= bufcols ( corresponds to a wide matrix ) + ! 3. colsa <= bufrows ( corresponds to a high matrix ) + ! 4. Both dimensions of a exceed both dimensions of the buffer + ! + ! The main idea here is that the bufrows will define the usage of the + ! L1 cache. We reference the same column or columns multiply while + ! accessing multiple partial rows of a transposed in the buffer. + + ! + ! rowsa <-bufcb-> + ! colsb + ! i = 1, m -ac-> j = 1, n --bc-> + ! | +-----------------+ ^ +----------+----+ ^ + ! | | | | | x | | + ! | | | | | x | | + ! ak | A | rowchunks=2 | B x | | + ! | | | | | x | | + ! | | | | | | x | ka = 1, k + ! | | | | | | x | | + ! | | | | br | a x | | + ! v +xxxxxxxxxxxxxxxxx+ | | +xxxxxxxxxxxxxxx+ | + ! | | | | v | x | | + ! | | | | | x | | + ! | | | | x | | + ! | | | | | b x | | + ! V +-----------------+ V +----------+----+ V + ! <--colachunks=2--> + ! x's mark buffer boudaries on the transposed matrices + ! For this case, bufca(1) = bufcols, bufr(1) = bufrows + + colsa = kab + rowsb = kab + rowsa = mra + colsb = ncb + if (colsa * rowsa * colsb < min_blocked_mult) then + if( beta .eq. 0.0 ) then + do j = 1, colsb + do i = 1, rowsa + temprr0 = 0.0 + tempri0 = 0.0 + tempir0 = 0.0 + tempii0 = 0.0 + do k = 1, colsa + temprr0 = temprr0 + real(alpha) * real(a(k, i)) * real(b(j, k)) - aimag(alpha) * aimag(a(k, i)) * real(b(j, k)) + enddo + do k = 1, colsa + tempii0 = tempii0 + real(alpha) * aimag(a(k, i)) * aimag(b(j, k)) + aimag(alpha) * real(a(k, i)) * aimag(b(j, k)) + enddo + do k = 1, colsa + tempir0 = tempir0 + real(alpha) * real(a(k, i)) * aimag(b(j, k)) - aimag(alpha) * aimag(a(k, i)) * aimag(b(j, k)) + enddo + do k = 1, colsa + tempri0 = tempri0 + real(alpha) * aimag(a(k, i)) * real(b(j, k)) + aimag(alpha) * real(a(k, i)) * real(b(j, k)) + enddo + c(i, j) = dcmplx((temprr0 - tempii0), (tempri0 + tempir0)) + enddo + enddo + else + do j = 1, colsb + do i = 1, rowsa + temprr0 = 0.0 + tempri0 = 0.0 + tempir0 = 0.0 + tempii0 = 0.0 + do k = 1, colsa + temprr0 = temprr0 + real(alpha) * real(a(k, i)) * real(b(j, k)) - aimag(alpha) * aimag(a(k, i)) * real(b(j, k)) + enddo + do k = 1, colsa + tempii0 = tempii0 + real(alpha) * aimag(a(k, i)) * aimag(b(j, k)) + aimag(alpha) * real(a(k, i)) * aimag(b(j, k)) + enddo + do k = 1, colsa + tempir0 = tempir0 + real(alpha) * real(a(k, i)) * aimag(b(j, k)) - aimag(alpha) * aimag(a(k, i)) * aimag(b(j, k)) + enddo + do k = 1, colsa + tempri0 = tempri0 + real(alpha) * aimag(a(k, i)) * real(b(j, k)) + aimag(alpha) * real(a(k, i)) * real(b(j, k)) + enddo + + c(i, j) = beta * c(i, j) + dcmplx((temprr0 - tempii0), (tempri0 + tempir0)) + enddo + enddo + endif + else + allocate( bufferb( bufrows * bufcols ) ) + + ! set the number of buffer row chunks we will work on + bufr = min( bufrows, rowsb ) + bufr_sav = bufr + rowchunks = ( rowsb + bufr - 1 )/bufr + + bufcb = min( bufcols, colsb ) + bufcb_sav = bufcb + colbchunks = ( colsb + bufcb - 1)/bufcb + ! Note that the starting column index into matrix a (ac) is the same as + ! starting index into matrix b. But we need 1 less than that so we can + ! add an index to it + br = 1 + ac = 1 + bc = 1 + ak = 0 + colsa_chunk = 4 + colsa_chunks = mra/colsa_chunk + colsa_end = colsa_chunks * colsa_chunk + colsa_strt = colsa_end + 1 + + + do rowchunk = 1, rowchunks + bc = 1 + do colbchunk = 1, colbchunks + ak = br - 1 + if( ta .eq. 2 )then !conjugate matrix a; b conjugated in transpose + if( br .eq. 1 ) then + bufcb = min( bufcb_sav, colsb - bc + 1 ) + bufr = min( bufr_sav, rowsb - br + 1 ) + call ftn_transpose_cmplx32( tb, b( bc, br ), ldb, alpha, bufferb, & + & bufr, bufcb ) + if( beta .eq. 0.0 ) then + do i = 1, colsa_end, colsa_chunk + ndxb = 0 + do j = bc, bc + bufcb - 1 + temp0 = 0.0 + temp1 = 0.0 + temp2 = 0.0 + temp3 = 0.0 + do k = 1, bufr + bufbtemp = bufferb( ndxb + k ) + temp0 = temp0 + bufbtemp * conjg( a( ak + k, i ) ) + temp1 = temp1 + bufbtemp * conjg( a( ak + k, i + 1 ) ) + temp2 = temp2 + bufbtemp * conjg( a( ak + k, i + 2 ) ) + temp3 = temp3 + bufbtemp * conjg( a( ak + k, i + 3 ) ) + enddo + c( i, j ) = temp0 + c( i + 1, j ) = temp1 + c( i + 2, j ) = temp2 + c( i + 3, j ) = temp3 + ndxb = ndxb + bufr + enddo + enddo + ! Now clean up whatever is left from the loop unrolling + do i = colsa_strt, mra + ndxb = 0 + do j = bc, bc + bufcb - 1 + temp = 0.0 + do k = 1, bufr + temp = temp + bufferb( ndxb + k ) * & + & conjg( a( ak + k, i ) ) + enddo + c( i, j ) = temp + ndxb = ndxb + bufr + enddo + enddo + else + do i = 1, colsa_end, colsa_chunk + ndxb = 0 + do j = bc, bc + bufcb - 1 + temp0 = 0.0 + temp1 = 0.0 + temp2 = 0.0 + temp3 = 0.0 + do k = 1, bufr + bufbtemp = bufferb( ndxb + k ) + temp0 = temp0 + bufbtemp * conjg( a( ak + k, i ) ) + temp1 = temp1 + bufbtemp * conjg( a( ak + k, i + 1 ) ) + temp2 = temp2 + bufbtemp * conjg( a( ak + k, i + 2 ) ) + temp3 = temp3 + bufbtemp * conjg( a( ak + k, i + 3 ) ) + enddo + c( i, j ) = beta * c( i, j ) + temp0 + c( i + 1, j ) = beta * c( i + 1, j ) + temp1 + c( i + 2, j ) = beta * c( i + 2, j ) + temp2 + c( i + 3, j ) = beta * c( i + 3, j ) + temp3 + ndxb = ndxb + bufr + enddo + enddo + ! Now clean up whatever is left from the loop unrolling + do i = colsa_strt, mra + ndxb = 0 + do j = bc, bc + bufcb - 1 + temp = 0.0 + do k = 1, bufr + temp = temp + bufferb( ndxb + k ) * & + & conjg( a( ak + k, i ) ) + enddo + c( i, j ) = beta * c( i, j ) + temp + ndxb = ndxb + bufr + enddo + enddo + endif + else + bufcb = min( bufcb_sav, colsb - bc + 1 ) + bufr = min( bufr_sav, rowsb - br + 1 ) + call ftn_transpose_cmplx32( tb, b( bc, br ), ldb, alpha, bufferb, & + & bufr, bufcb ) + do i = 1, colsa_end, colsa_chunk + ndxb = 0 + do j = bc, bc + bufcb - 1 + temp0 = 0.0 + temp1 = 0.0 + temp2 = 0.0 + temp3 = 0.0 + do k = 1, bufr + bufbtemp = bufferb( ndxb + k ) + temp0 = temp0 + bufbtemp * conjg( a( ak + k, i ) ) + temp1 = temp1 + bufbtemp * conjg( a( ak + k, i + 1 ) ) + temp2 = temp2 + bufbtemp * conjg( a( ak + k, i + 2 ) ) + temp3 = temp3 + bufbtemp * conjg( a( ak + k, i + 3 ) ) + enddo + c( i, j ) = c( i, j ) + temp0 + c( i + 1, j ) = c( i + 1, j ) + temp1 + c( i + 2, j ) = c( i + 2, j ) + temp2 + c( i + 3, j ) = c( i + 3, j ) + temp3 + ndxb = ndxb + bufr + enddo + enddo + ! Now clean up whatever is left from the loop unrolling + do i = colsa_strt, mra + ndxb = 0 + do j = bc, bc + bufcb - 1 + temp = 0.0 + do k = 1, bufr + temp = temp + bufferb( ndxb + k ) * conjg( a( ak + k, i ) ) + enddo + c( i, j ) = c( i, j ) + temp + ndxb = ndxb + bufr + enddo + enddo + endif + else + if( br .eq. 1 ) then + bufcb = min( bufcb_sav, colsb - bc + 1 ) + bufr = min( bufr_sav, rowsb - br + 1 ) + call ftn_transpose_cmplx32( tb, b( bc, br ), ldb, alpha, bufferb, & + & bufr, bufcb ) + if( beta .eq. 0.0 ) then + do i = 1, colsa_end, colsa_chunk + ndxb = 0 + do j = bc, bc + bufcb - 1 + temp0 = 0.0 + temp1 = 0.0 + temp2 = 0.0 + temp3 = 0.0 + do k = 1, bufr + bufbtemp = bufferb( ndxb + k ) + temp0 = temp0 + bufbtemp * a( ak + k, i ) + temp1 = temp1 + bufbtemp * a( ak + k, i + 1 ) + temp2 = temp2 + bufbtemp * a( ak + k, i + 2 ) + temp3 = temp3 + bufbtemp * a( ak + k, i + 3 ) + enddo + c( i, j ) = temp0 + c( i + 1, j ) = temp1 + c( i + 2, j ) = temp2 + c( i + 3, j ) = temp3 + ndxb = ndxb + bufr + enddo + enddo + ! Now clean up whatever is left from the loop unrolling + do i = colsa_strt, mra + ndxb = 0 + do j = bc, bc + bufcb - 1 + temp = 0.0 + do k = 1, bufr + temp = temp + bufferb( ndxb + k ) * a( ak + k, i ) + enddo + c( i, j ) = temp + ndxb = ndxb + bufr + enddo + enddo + else + do i = 1, colsa_end, colsa_chunk + ndxb = 0 + do j = bc, bc + bufcb - 1 + temp0 = 0.0 + temp1 = 0.0 + temp2 = 0.0 + temp3 = 0.0 + do k = 1, bufr + bufbtemp = bufferb( ndxb + k ) + temp0 = temp0 + bufbtemp * a( ak + k, i ) + temp1 = temp1 + bufbtemp * a( ak + k, i + 1 ) + temp2 = temp2 + bufbtemp * a( ak + k, i + 2 ) + temp3 = temp3 + bufbtemp * a( ak + k, i + 3 ) + enddo + c( i, j ) = beta * c( i, j ) + temp0 + c( i + 1, j ) = beta * c( i + 1, j ) + temp1 + c( i + 2, j ) = beta * c( i + 2, j ) + temp2 + c( i + 3, j ) = beta * c( i + 3, j ) + temp3 + ndxb = ndxb + bufr + enddo + enddo + ! Now clean up whatever is left from the loop unrolling + do i = colsa_strt, mra + ndxb = 0 + do j = bc, bc + bufcb - 1 + temp = 0.0 + do k = 1, bufr + temp = temp + bufferb( ndxb + k ) * a( ak + k, i ) + enddo + c( i, j ) = beta * c( i, j ) + temp + ndxb = ndxb + bufr + enddo + enddo + endif + else + bufcb = min( bufcb_sav, colsb - bc + 1 ) + bufr = min( bufr_sav, rowsb - br + 1 ) + call ftn_transpose_cmplx32( tb, b( bc, br ), ldb, alpha, bufferb, & + & bufr, bufcb ) + do i = 1, colsa_end, colsa_chunk + ndxb = 0 + do j = bc, bc + bufcb - 1 + temp0 = 0.0 + temp1 = 0.0 + temp2 = 0.0 + temp3 = 0.0 + do k = 1, bufr + bufbtemp = bufferb( ndxb + k ) + temp0 = temp0 + bufbtemp * a( ak + k, i ) + temp1 = temp1 + bufbtemp * a( ak + k, i + 1 ) + temp2 = temp2 + bufbtemp * a( ak + k, i + 2 ) + temp3 = temp3 + bufbtemp * a( ak + k, i + 3 ) + enddo + c( i, j ) = c( i, j ) + temp0 + c( i + 1, j ) = c( i + 1, j ) + temp1 + c( i + 2, j ) = c( i + 2, j ) + temp2 + c( i + 3, j ) = c( i + 3, j ) + temp3 + ndxb = ndxb + bufr + enddo + enddo + ! Now clean up whatever is left from the loop unrolling + do i = colsa_strt, mra + ndxb = 0 + do j = bc, bc + bufcb - 1 + temp = 0.0 + do k = 1, bufr + temp = temp + bufferb( ndxb + k ) * a( ak + k, i ) + enddo + c( i, j ) = c( i, j ) + temp + ndxb = ndxb + bufr + enddo + enddo + endif + endif + ! adjust the boundaries in the direction of the columns of b + ! adjust the row values + bc = bc + bufcb + enddo + br = br + bufr + ! controlled but tcbe numbebrcbof bufferb chunks we use. + + enddo + deallocate( bufferb ) + endif + return + end subroutine ftn_mtaxtb_cmplx32 + diff --git a/runtime/flang/mvmul_cmplx32.F95 b/runtime/flang/mvmul_cmplx32.F95 new file mode 100644 index 0000000000..2c94306ea9 --- /dev/null +++ b/runtime/flang/mvmul_cmplx32.F95 @@ -0,0 +1,89 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + + +#include "mmul_dir.h" + +subroutine ftn_mvmul_cmplx32( ta, tb, m, k, alpha, a, lda, b, beta, c ) + implicit none + + integer*8 :: m, k, lda + complex*32 :: alpha, beta + complex*32, dimension( lda, * ) :: a + complex*32, dimension( * ) :: b, c + integer :: ta, tb + ! Local variables + + integer*8 :: i, j, kk + complex*32 :: temp + +! print *, "#### In mvmul ####" + if( beta .ne. 0 )then + do i = 1, m + c( i ) = beta * c( i ) + enddo + else + do i = 1, m + c( i ) = 0.0 + enddo + endif + + if( ta .eq. 0 )then ! normally oriented a matrix + if( tb .ne. 2 )then + do i = 1, m + do kk = 1, k + c( i ) = c( i ) + alpha * a( i, kk ) * b( kk ) + enddo + enddo + else + do i = 1, m + do kk = 1, k + c( i ) = c( i ) + alpha * a( i, kk ) * conjg( b( kk ) ) + enddo + enddo + endif + else ! matrix a is transposed - may be improved with buffering of b * alpha + if( ta .ne. 2 )then ! a not conjugated + if( tb .ne. 2 )then ! b not conjugated + do i = 1, m + temp = 0.0 + do kk = 1, k + temp = temp + a( kk, i ) * b( kk ) + enddo + c( i ) = c( i ) + alpha * temp + enddo + else ! b is conjugated + do i = 1, m + temp = 0.0 + do kk = 1, k + temp = temp + a( kk, i ) * conjg( b( kk ) ) + enddo + c( i ) = c( i ) + alpha * temp + enddo + endif + else ! a is conjugated + if( tb .ne. 2 )then ! b not conjugated + do i = 1, m + temp = 0.0 + do kk = 1, k + temp = temp + conjg( a( kk, i ) ) * b( kk ) + enddo + c( i ) = c( i ) + alpha * temp + enddo + else ! b is conjugated + do i = 1, m + temp = 0.0 + do kk = 1, k + temp = temp + conjg( a( kk, i ) ) * conjg( b( kk ) ) + enddo + c( i ) = c( i ) + alpha * temp + enddo + endif + endif + endif + return +end subroutine ftn_mvmul_cmplx32 + diff --git a/runtime/flang/nmlread.c b/runtime/flang/nmlread.c index 43139e7bcc..467289adfb 100644 --- a/runtime/flang/nmlread.c +++ b/runtime/flang/nmlread.c @@ -4,6 +4,12 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified: May 2020 + */ /* clang-format off */ @@ -1705,6 +1711,10 @@ eval(int v, char *loc_addr) __POINT_T new_ndims; __POINT_T actual_ndims; + // AOCC BEGIN + F90_Desc* sd; + // AOCC END + if (v > vrf_cur) { descp = VRF_DESCP(v - 1); @@ -1753,6 +1763,13 @@ eval(int v, char *loc_addr) offset *= I8(siz_of)(descp); new_addr += offset; } + // AOCC BEGIN + else if (descp->ndims == -1 && sb.ndims == 1) { + sd = get_descriptor(descp); + new_addr = I8(__fort_local_address)((*(char **)sb.loc_addr), sd, + (__INT_T *)&sb.sect[0].lwb); + } + // AOCC END break; case VRF_SECTION: @@ -2150,8 +2167,17 @@ static int read_record(void) { if (internal_file) { - if (n_irecs == 0) + if (n_irecs == 0) { + // AOCC Begin + // In case of allocatable arrays, single record will + // hold the full details. If the buffer is not empty, + // continue processing the buffer. + if (currc && *currc && byte_cnt) { + return 0; + } + // AOCC End return FIO_EEOF; + } if (accessed) in_recp += rec_len; n_irecs--; diff --git a/runtime/flang/norm2.F95 b/runtime/flang/norm2.F95 index 466aa4eeed..b1fc3719e8 100644 --- a/runtime/flang/norm2.F95 +++ b/runtime/flang/norm2.F95 @@ -118,6 +118,25 @@ function sum_of_squares_real8(array) result(res) end do end function sum_of_squares_real8 +! AOCC begin +! calculate sum of squares of elements of a single dimensional real(16) array +! at REAL(16) precision, it is called by routines that calculate norm2 of +! arrays with rank 1 to 7 + function sum_of_squares_real16(array) result(res) + implicit none + + real(16) :: array(:), res + integer(8) :: i, array_lbnd(1), array_ubnd(1) + + array_lbnd = lbound(array) + array_ubnd = ubound(array) + res = zero + do i = array_lbnd(1), array_ubnd(1) + res = res + (array(i) * array(i)) + end do + end function sum_of_squares_real16 +! AOCC end + ! calculate norm2() of a single real(4) dimensional array. It is called by ! routines of the form norm2(array, dim) where arrays rank >= 1 and <= 7 ! and dim <= rank. @@ -192,6 +211,27 @@ function norm_real8(array, pfr) result(res) end select end function norm_real8 + ! AOCC begin + ! calculate norm2() of a single real(16) dimensional array. It is called by + ! routines of the form norm2(array, dim) where arrays rank >= 1 and <= 7 + ! and dim <= rank. + function norm_real16(array) result(res) + implicit none + + real(16) :: array(:), sum, res + integer(8) :: start, array_size + + if (is_contiguous(array)) then + start = loc(array(:)) + array_size = size(array) + call I8(stride_1_norm2_real16) (start, array_size, res) + else + sum = sum_of_squares_real16 (array) + res = sqrt(sum) + endif + end function norm_real16 + ! AOCC end + subroutine save_unf_state (unf_save, unf) use ieee_arithmetic use ieee_exceptions @@ -411,6 +451,19 @@ subroutine F90(nodim_1_real8) (res, array, pfr) res = norm_real8(array, pfr) end subroutine F90(nodim_1_real8) +! AOCC begin +subroutine F90(nodim_1_real16) (res, array) + use I8(__norm2) + implicit none + + real(16) :: array(:), res, sum + integer(8) :: start, array_size + integer(4) :: pfr + + res = norm_real16(array) +end subroutine F90(nodim_1_real16) +! AOCC end + subroutine F90(nodim_2_real4) (res, array) use I8(__norm2) implicit none @@ -502,6 +555,31 @@ subroutine F90(nodim_2_real8) (res, array, pfr) endif end subroutine F90(nodim_2_real8) +! AOCC begin +subroutine F90(nodim_2_real16) (res, array) + use I8(__norm2) + implicit none + + real(16) :: array(:,:), res, sum + integer(8) :: start, i, array_size, array_lbnd(2), array_ubnd(2) + + if (is_contiguous(array)) then + start = loc(array(:,:)) + array_size = size(array) + call I8(stride_1_norm2_real16) (start, array_size, res) + else + sum = zero + array_lbnd = lbound(array) + array_ubnd = ubound(array) + + do i = array_lbnd(1), array_ubnd(1) + sum = sum + sum_of_squares_real16 (array(i,:)) + end do + res = sqrt(sum) + endif +end subroutine F90(nodim_2_real16) +! AOCC end + subroutine F90(nodim_3_real4) (res, array) use I8(__norm2) implicit none @@ -596,6 +674,33 @@ subroutine F90(nodim_3_real8) (res, array, pfr) end select end subroutine F90(nodim_3_real8) +! AOCC begin +subroutine F90(nodim_3_real16) (res, array) + use I8(__norm2) + implicit none + + real(16) :: array(:,:,:), res, sum + integer(8) :: start, i, j, array_size, array_lbnd(3), array_ubnd(3) + + if (is_contiguous(array)) then + start = loc(array(:,:,:)) + array_size = size(array) + call I8(stride_1_norm2_real16) (start, array_size, res) + else + sum = zero + array_lbnd = lbound(array) + array_ubnd = ubound(array) + + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(2), array_ubnd(2) + sum = sum + sum_of_squares_real16 (array(i,j,:)) + end do + end do + res = sqrt(sum) + endif +end subroutine F90(nodim_3_real16) +! AOCC end + subroutine F90(nodim_4_real4) (res, array) use I8(__norm2) implicit none @@ -698,6 +803,35 @@ subroutine F90(nodim_4_real8) (res, array, pfr) end select end subroutine F90(nodim_4_real8) +! AOCC begin +subroutine F90(nodim_4_real16) (res, array) + use I8(__norm2) + implicit none + + real(16) :: array(:,:,:,:), res, sum + integer(8) :: start, i, j, k, array_size, array_lbnd(4), array_ubnd(4) + + if (is_contiguous(array)) then + start = loc(array(:,:,:,:)) + array_size = size(array) + call I8(stride_1_norm2_real16) (start, array_size, res) + else + sum = zero + array_lbnd = lbound(array) + array_ubnd = ubound(array) + + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(2), array_ubnd(2) + do k = array_lbnd(3), array_ubnd(3) + sum = sum + sum_of_squares_real16 (array(i,j,k,:)) + end do + end do + end do + res = sqrt(sum) + endif +end subroutine F90(nodim_4_real16) +! AOCC end + subroutine F90(nodim_5_real4) (res, array) use I8(__norm2) implicit none @@ -808,6 +942,37 @@ subroutine F90(nodim_5_real8) (res, array, pfr) end select end subroutine F90(nodim_5_real8) +! AOCC begin +subroutine F90(nodim_5_real16) (res, array) + use I8(__norm2) + implicit none + + real(16) :: array(:,:,:,:,:), res, sum + integer(8) :: start, i, j, k, l, array_size, array_lbnd(5), array_ubnd(5) + + if (is_contiguous(array)) then + start = loc(array(:,:,:,:,:)) + array_size = size(array) + call I8(stride_1_norm2_real16) (start, array_size, res) + else + sum = zero + array_lbnd = lbound(array) + array_ubnd = ubound(array) + + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(2), array_ubnd(2) + do k = array_lbnd(3), array_ubnd(3) + do l = array_lbnd(4), array_ubnd(4) + sum = sum + sum_of_squares_real16 (array(i,j,k,l,:)) + end do + end do + end do + end do + res = sqrt(sum) + endif +end subroutine F90(nodim_5_real16) +! AOCC end + subroutine F90(nodim_6_real4) (res, array) use I8(__norm2) implicit none @@ -926,6 +1091,39 @@ subroutine F90(nodim_6_real8) (res, array, pfr) end select end subroutine F90(nodim_6_real8) +! AOCC begin +subroutine F90(nodim_6_real16) (res, array) + use I8(__norm2) + implicit none + + real(16) :: array(:,:,:,:,:,:), res, sum + integer(8) :: start, i, j, k, l, m, array_size, array_lbnd(6), array_ubnd(6) + + if (is_contiguous(array)) then + start = loc(array(:,:,:,:,:,:)) + array_size = size(array) + call I8(stride_1_norm2_real16) (start, array_size, res) + else + sum = zero + array_lbnd = lbound(array) + array_ubnd = ubound(array) + + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(2), array_ubnd(2) + do k = array_lbnd(3), array_ubnd(3) + do l = array_lbnd(4), array_ubnd(4) + do m = array_lbnd(5), array_ubnd(5) + sum = sum + sum_of_squares_real16 (array(i,j,k,l,m,:)) + end do + end do + end do + end do + end do + res = sqrt(sum) + endif +end subroutine F90(nodim_6_real16) +! AOCC end + subroutine F90(nodim_7_real4) (res, array) use I8(__norm2) implicit none @@ -1052,8 +1250,43 @@ subroutine F90(nodim_7_real8) (res, array, pfr) end select end subroutine F90(nodim_7_real8) +! AOCC begin +subroutine F90(nodim_7_real16) (res, array) + use I8(__norm2) + implicit none + + real(16) :: array(:,:,:,:,:,:,:), res, sum + integer(8) :: start, i, j, k, l, m, n, array_size, array_lbnd(7), array_ubnd(7) + + if (is_contiguous(array)) then + start = loc(array(:,:,:,:,:,:,:)) + array_size = size(array) + call I8(stride_1_norm2_real16) (start, array_size, res) + else + sum = zero + array_lbnd = lbound(array) + array_ubnd = ubound(array) + + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(2), array_ubnd(2) + do k = array_lbnd(3), array_ubnd(3) + do l = array_lbnd(4), array_ubnd(4) + do m = array_lbnd(5), array_ubnd(5) + do n = array_lbnd(6), array_ubnd(6) + sum = sum + sum_of_squares_real16 (array(i,j,k,l,m,n,:)) + end do + end do + end do + end do + end do + end do + res = sqrt(sum) + endif +end subroutine F90(nodim_7_real16) +! AOCC end + ! The next few routines actually handle dim version of norm2() calls -! for each rank of real(4) and real(8) arrays +! for each rank of real(4), real(8) and real(16) arrays ! AOCC subroutine F90(dim_2_real4) (res, array, dim) use I8(__norm2) @@ -1101,6 +1334,31 @@ subroutine F90(dim_2_real8) (res, array, pfr, dim) endif end subroutine F90(dim_2_real8) +! AOCC begin +subroutine F90(dim_2_real16) (res, array, dim) + use I8(__norm2) + implicit none + + real(16) :: array(:,:), res(:) + integer(4) :: dim + integer(8) :: i + integer(8) :: array_lbnd(2), array_ubnd(2) + + array_lbnd = lbound(array) + array_ubnd = ubound(array) + + if (dim .eq. 1) then + do i = array_lbnd(2), array_ubnd(2) + res(i) = norm_real16(array(:,i)) + end do + else if (dim .eq. 2) then + do i = array_lbnd(1), array_ubnd(1) + res(i) = norm_real16(array(i,:)) + end do + endif +end subroutine F90(dim_2_real16) +! AOCC end + subroutine F90(dim_3_real4) (res, array, dim) use I8(__norm2) implicit none @@ -1167,6 +1425,41 @@ subroutine F90(dim_3_real8) (res, array, pfr, dim) endif end subroutine F90(dim_3_real8) +! AOCC begin +subroutine F90(dim_3_real16) (res, array, dim) + use I8(__norm2) + implicit none + + real(16) :: array(:,:,:), res(:,:) + integer(4) :: dim + integer(8) :: i, j + integer(8) :: array_lbnd(3), array_ubnd(3) + + array_lbnd = lbound(array) + array_ubnd = ubound(array) + + if (dim .eq. 1) then + do i = array_lbnd(2), array_ubnd(2) + do j = array_lbnd(3), array_ubnd(3) + res(i,j) = norm_real16(array(:,i,j)) + end do + end do + else if (dim .eq. 2) then + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(3), array_ubnd(3) + res(i,j) = norm_real16(array(i,:,j)) + end do + end do + else if (dim .eq. 3) then + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(2), array_ubnd(2) + res(i,j) = norm_real16(array(i,j,:)) + end do + end do + endif +end subroutine F90(dim_3_real16) +! AOCC end + subroutine F90(dim_4_real4) (res, array, dim) use I8(__norm2) implicit none @@ -1261,6 +1554,55 @@ subroutine F90(dim_4_real8) (res, array, pfr, dim) endif end subroutine F90(dim_4_real8) +! AOCC begin +subroutine F90(dim_4_real16) (res, array, dim) + use I8(__norm2) + implicit none + + real(16) :: array(:,:,:,:), res(:,:,:) + integer(4) :: dim + integer(8) :: i, j, k + integer(8) :: array_lbnd(4), array_ubnd(4) + + array_lbnd = lbound(array) + array_ubnd = ubound(array) + + if (dim .eq. 1) then + do i = array_lbnd(2), array_ubnd(2) + do j = array_lbnd(3), array_ubnd(3) + do k = array_lbnd(4), array_ubnd(4) + res(i,j,k) = norm_real16(array(:,i,j,k)) + end do + end do + end do + else if (dim .eq. 2) then + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(3), array_ubnd(3) + do k = array_lbnd(4), array_ubnd(4) + res(i,j,k) = norm_real16(array(i,:,j,k)) + end do + end do + end do + else if (dim .eq. 3) then + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(2), array_ubnd(2) + do k = array_lbnd(4), array_ubnd(4) + res(i,j,k) = norm_real16(array(i,j,:,k)) + end do + end do + end do + else if (dim .eq. 4) then + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(2), array_ubnd(2) + do k = array_lbnd(3), array_ubnd(3) + res(i,j,k) = norm_real16(array(i,j,k,:)) + end do + end do + end do + endif +end subroutine F90(dim_4_real16) +! AOCC end + subroutine F90(dim_5_real4) (res, array, dim) use I8(__norm2) implicit none @@ -1391,6 +1733,73 @@ subroutine F90(dim_5_real8) (res, array, pfr, dim) endif end subroutine F90(dim_5_real8) +! AOCC begin +subroutine F90(dim_5_real16) (res, array, dim) + use I8(__norm2) + implicit none + + real(16) :: array(:,:,:,:,:), res(:,:,:,:) + integer(4) :: dim + integer(8) :: i, j, k, l + integer(8) :: array_lbnd(5), array_ubnd(5) + + array_lbnd = lbound(array) + array_ubnd = ubound(array) + + if (dim .eq. 1) then + do i = array_lbnd(2), array_ubnd(2) + do j = array_lbnd(3), array_ubnd(3) + do k = array_lbnd(4), array_ubnd(4) + do l = array_lbnd(5), array_ubnd(5) + res(i,j,k,l) = norm_real16(array(:,i,j,k,l)) + end do + end do + end do + end do + else if (dim .eq. 2) then + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(3), array_ubnd(3) + do k = array_lbnd(4), array_ubnd(4) + do l = array_lbnd(5), array_ubnd(5) + res(i,j,k,l) = norm_real16(array(i,:,j,k,l)) + end do + end do + end do + end do + else if (dim .eq. 3) then + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(2), array_ubnd(2) + do k = array_lbnd(4), array_ubnd(4) + do l = array_lbnd(5), array_ubnd(5) + res(i,j,k,l) = norm_real16(array(i,j,:,k,l)) + end do + end do + end do + end do + else if (dim .eq. 4) then + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(2), array_ubnd(2) + do k = array_lbnd(3), array_ubnd(3) + do l = array_lbnd(5), array_ubnd(5) + res(i,j,k,l) = norm_real16(array(i,j,k,:,l)) + end do + end do + end do + end do + else if (dim .eq. 5) then + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(2), array_ubnd(2) + do k = array_lbnd(3), array_ubnd(3) + do l = array_lbnd(4), array_ubnd(4) + res(i,j,k,l) = norm_real16(array(i,j,k,l,:)) + end do + end do + end do + end do + endif +end subroutine F90(dim_5_real16) +! AOCC end + subroutine F90(dim_6_real4) (res, array, dim) use I8(__norm2) implicit none @@ -1565,6 +1974,95 @@ subroutine F90(dim_6_real8) (res, array, pfr, dim) endif end subroutine F90(dim_6_real8) +! AOCC begin +subroutine F90(dim_6_real16) (res, array, dim) + use I8(__norm2) + implicit none + + real(16) :: array(:,:,:,:,:,:), res(:,:,:,:,:) + integer(4) :: dim + integer(8) :: i, j, k, l, m + integer(8) :: array_lbnd(6), array_ubnd(6) + + array_lbnd = lbound(array) + array_ubnd = ubound(array) + + if (dim .eq. 1) then + do i = array_lbnd(2), array_ubnd(2) + do j = array_lbnd(3), array_ubnd(3) + do k = array_lbnd(4), array_ubnd(4) + do l = array_lbnd(5), array_ubnd(5) + do m = array_lbnd(6), array_ubnd(6) + res(i,j,k,l,m) = norm_real16(array(:,i,j,k,l,m)) + end do + end do + end do + end do + end do + else if (dim .eq. 2) then + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(3), array_ubnd(3) + do k = array_lbnd(4), array_ubnd(4) + do l = array_lbnd(5), array_ubnd(5) + do m = array_lbnd(6), array_ubnd(6) + res(i,j,k,l,m) = norm_real16(array(i,:,j,k,l,m)) + end do + end do + end do + end do + end do + else if (dim .eq. 3) then + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(2), array_ubnd(2) + do k = array_lbnd(4), array_ubnd(4) + do l = array_lbnd(5), array_ubnd(5) + do m = array_lbnd(6), array_ubnd(6) + res(i,j,k,l,m) = norm_real16(array(i,j,:,k,l,m)) + end do + end do + end do + end do + end do + else if (dim .eq. 4) then + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(2), array_ubnd(2) + do k = array_lbnd(3), array_ubnd(3) + do l = array_lbnd(5), array_ubnd(5) + do m = array_lbnd(6), array_ubnd(6) + res(i,j,k,l,m) = norm_real16(array(i,j,k,:,l,m)) + end do + end do + end do + end do + end do + else if (dim .eq. 5) then + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(2), array_ubnd(2) + do k = array_lbnd(3), array_ubnd(3) + do l = array_lbnd(4), array_ubnd(4) + do m = array_lbnd(6), array_ubnd(6) + res(i,j,k,l,m) = norm_real16(array(i,j,k,l,:,m)) + end do + end do + end do + end do + end do + else if (dim .eq. 6) then + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(2), array_ubnd(2) + do k = array_lbnd(3), array_ubnd(3) + do l = array_lbnd(4), array_ubnd(4) + do m = array_lbnd(5), array_ubnd(5) + res(i,j,k,l,m) = norm_real16(array(i,j,k,l,m,:)) + end do + end do + end do + end do + end do + endif +end subroutine F90(dim_6_real16) +! AOCC end + subroutine F90(dim_7_real4) (res, array, dim) use I8(__norm2) implicit none @@ -1790,3 +2288,118 @@ subroutine F90(dim_7_real8) (res, array, pfr, dim) end do endif end subroutine F90(dim_7_real8) + +! AOCC begin +subroutine F90(dim_7_real16) (res, array, dim) + use I8(__norm2) + implicit none + + real(16) :: array(:,:,:,:,:,:,:), res(:,:,:,:,:,:) + integer(4) :: dim + integer(8) :: i, j, k, l, m, n + integer(8) :: array_lbnd(7), array_ubnd(7) + + array_lbnd = lbound(array) + array_ubnd = ubound(array) + + if (dim .eq. 1) then + do i = array_lbnd(2), array_ubnd(2) + do j = array_lbnd(3), array_ubnd(3) + do k = array_lbnd(4), array_ubnd(4) + do l = array_lbnd(5), array_ubnd(5) + do m = array_lbnd(6), array_ubnd(6) + do n = array_lbnd(7), array_ubnd(7) + res(i,j,k,l,m,n) = norm_real16(array(:,i,j,k,l,m,n)) + end do + end do + end do + end do + end do + end do + else if (dim .eq. 2) then + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(3), array_ubnd(3) + do k = array_lbnd(4), array_ubnd(4) + do l = array_lbnd(5), array_ubnd(5) + do m = array_lbnd(6), array_ubnd(6) + do n = array_lbnd(7), array_ubnd(7) + res(i,j,k,l,m,n) = norm_real16(array(i,:,j,k,l,m,n)) + end do + end do + end do + end do + end do + end do + else if (dim .eq. 3) then + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(2), array_ubnd(2) + do k = array_lbnd(4), array_ubnd(4) + do l = array_lbnd(5), array_ubnd(5) + do m = array_lbnd(6), array_ubnd(6) + do n = array_lbnd(7), array_ubnd(7) + res(i,j,k,l,m,n) = norm_real16(array(i,j,:,k,l,m,n)) + end do + end do + end do + end do + end do + end do + else if (dim .eq. 4) then + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(2), array_ubnd(2) + do k = array_lbnd(3), array_ubnd(3) + do l = array_lbnd(5), array_ubnd(5) + do m = array_lbnd(6), array_ubnd(6) + do n = array_lbnd(7), array_ubnd(7) + res(i,j,k,l,m,n) = norm_real16(array(i,j,k,:,l,m,n)) + end do + end do + end do + end do + end do + end do + else if (dim .eq. 5) then + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(2), array_ubnd(2) + do k = array_lbnd(3), array_ubnd(3) + do l = array_lbnd(4), array_ubnd(4) + do m = array_lbnd(6), array_ubnd(6) + do n = array_lbnd(7), array_ubnd(7) + res(i,j,k,l,m,n) = norm_real16(array(i,j,k,l,:,m,n)) + end do + end do + end do + end do + end do + end do + else if (dim .eq. 6) then + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(2), array_ubnd(2) + do k = array_lbnd(3), array_ubnd(3) + do l = array_lbnd(4), array_ubnd(4) + do m = array_lbnd(5), array_ubnd(5) + do n = array_lbnd(7), array_ubnd(7) + res(i,j,k,l,m,n) = norm_real16(array(i,j,k,l,m,:,n)) + end do + end do + end do + end do + end do + end do + else if (dim .eq. 7) then + do i = array_lbnd(1), array_ubnd(1) + do j = array_lbnd(2), array_ubnd(2) + do k = array_lbnd(3), array_ubnd(3) + do l = array_lbnd(4), array_ubnd(4) + do m = array_lbnd(5), array_ubnd(5) + do n = array_lbnd(6), array_ubnd(6) + res(i,j,k,l,m,n) = norm_real16(array(i,j,k,l,m,n,:)) + end do + end do + end do + end do + end do + end do + endif +end subroutine F90(dim_7_real16) +! AOCC end diff --git a/runtime/flang/norm2.h b/runtime/flang/norm2.h index 49e683af14..f068c35d02 100644 --- a/runtime/flang/norm2.h +++ b/runtime/flang/norm2.h @@ -20,9 +20,11 @@ #elif defined(DESC_I8) // implies !defined(__AVX2__) #define NORM2_REAL4 norm2_real4_i8_ #define NORM2_REAL8 norm2_real8_i8_ +#define NORM2_REAL16 norm2_real16_i8_ // AOCC #else // implies !defined(__AVX2__) && !defined(DESC_I8) #define NORM2_REAL4 norm2_real4_ #define NORM2_REAL8 norm2_real8_ +#define NORM2_REAL16 norm2_real16_ // AOCC #endif #endif diff --git a/runtime/flang/omp_lib.F95 b/runtime/flang/omp_lib.F95 index 1aa57ca7f6..6ccbdfb64b 100644 --- a/runtime/flang/omp_lib.F95 +++ b/runtime/flang/omp_lib.F95 @@ -27,6 +27,16 @@ ! are access private ! + for windows, the contained routines are forced to be 'cref' ! +! +! Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +! Notified per clause 4(b) of the license. +! * +! * Bug fixes. +! * +! * Date of Modification: November 2019 +! * Date of Modification: 24th Jan'20 +! + #if defined(TARGET_WIN_X8632) || defined(TARGET_WIN_X8664) #define DECDIR !DEC$ @@ -170,7 +180,7 @@ subroutine ompgetschedule(kind, modifier) bind(C, name='omp_get_schedule') private ogs1, ogs2, ogs4, ogs8, ompgetschedule interface - function omp_get_thread_limit () + function omp_get_thread_limit () bind(c, name='omp_get_thread_limit') use omp_lib_kinds integer ( kind=omp_integer_kind ) :: omp_get_thread_limit DECDIR ATTRIBUTES C :: omp_get_thread_limit @@ -180,7 +190,7 @@ end function omp_get_thread_limit end interface interface - function omp_get_num_procs () + function omp_get_num_procs () bind(C, name='omp_get_num_procs') use omp_lib_kinds integer ( kind=omp_integer_kind ) :: omp_get_num_procs DECDIR ATTRIBUTES C :: omp_get_num_procs @@ -190,7 +200,7 @@ end function omp_get_num_procs end interface interface - function omp_get_num_threads () + function omp_get_num_threads () bind(C, name='omp_get_num_threads') use omp_lib_kinds integer ( kind=omp_integer_kind ) :: omp_get_num_threads DECDIR ATTRIBUTES C :: omp_get_num_threads @@ -200,7 +210,7 @@ end function omp_get_num_threads end interface interface - function omp_get_thread_num () + function omp_get_thread_num () bind(C, name='omp_get_thread_num') use omp_lib_kinds integer ( kind=omp_integer_kind ) :: omp_get_thread_num DECDIR ATTRIBUTES C :: omp_get_thread_num @@ -509,6 +519,22 @@ function omp_get_max_task_priority() bind(C, name='omp_get_max_task_priority') integer (kind=omp_integer_kind) omp_get_max_task_priority end function omp_get_max_task_priority +#if 1 + function omp_target_is_present(ptr, idev) bind(C, name='omp_target_is_present') + use omp_lib_kinds + use, intrinsic :: iso_c_binding, only : c_ptr, c_int + type(c_ptr), value :: ptr + integer (kind=omp_integer_kind), value :: idev + logical (kind=omp_logical_kind) omp_target_is_present + end function omp_target_is_present +#else + function omp_target_is_present(ptr) bind(C, name='omp_target_is_present') + use omp_lib_kinds + use, intrinsic :: iso_c_binding, only : c_ptr, c_int + type(c_ptr), value :: ptr + logical (kind=omp_logical_kind) omp_target_is_present + end function omp_target_is_present +#endif subroutine omp_init_lock_with_hint(svar, hint) bind(C, name='omp_init_lock_with_hint') use omp_lib_kinds integer (kind=omp_lock_kind) svar @@ -520,7 +546,6 @@ subroutine omp_init_nest_lock_with_hint(nvar, hint) bind(C, name='omp_init_nest_ integer (kind=omp_nest_lock_kind) nvar integer (kind=omp_lock_hint_kind), value :: hint end subroutine omp_init_nest_lock_with_hint - end interface diff --git a/runtime/flang/open.c b/runtime/flang/open.c index a69dba5fa3..78b726f2fa 100644 --- a/runtime/flang/open.c +++ b/runtime/flang/open.c @@ -4,6 +4,15 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified: May 2020 + * + * Support to revert to the old value when newunit has errors. + * Date of Modification: 15th June 2020 + */ /* clang-format off */ @@ -27,12 +36,20 @@ static FIO_FCB *Fcb; /* pointer to the file control block */ int next_newunit = -13; +__INT_T old_unit; //AOCC +__INT_T *old_unit_ptr; //AOCC /* --------------------------------------------------------------------- */ int -ENTF90IO(GET_NEWUNIT, get_newunit)() +ENTF90IO(GET_NEWUNIT, get_newunit)(__INT_T *newunit) { set_gbl_newunit(TRUE); + //AOCC Begin + if(newunit){ + old_unit = *newunit; + old_unit_ptr = newunit; + } + //AOCC End return next_newunit--; } @@ -106,8 +123,11 @@ __fortio_open(int unit, int action_flag, int status_flag, int dispose_flag, /* check that file is not already connected to different unit: */ for (f = fioFcbTbls.fcbs; f; f = f->next) if (f->named && strcmp(filename, f->name) == 0) - if (unit != f->unit) + if (unit != f->unit){ + if(old_unit_ptr) //AOCC + *old_unit_ptr = old_unit; EXIT_OPEN(__fortio_error(FIO_EOPENED)) + } } /* ------- handle situation in which unit is already connected: */ @@ -120,12 +140,21 @@ __fortio_open(int unit, int action_flag, int status_flag, int dispose_flag, /* make sure no specifier other than BLANK is different than the one currently in effect */ - if (status_flag == FIO_SCRATCH && f->status != FIO_SCRATCH) + if (status_flag == FIO_SCRATCH && f->status != FIO_SCRATCH){ + if(old_unit_ptr) //AOCC + *old_unit_ptr = old_unit; EXIT_OPEN(__fortio_error(FIO_ECOMPAT)) - if (acc_flag != f->acc || form_flag != f->form) + } + if (acc_flag != f->acc || form_flag != f->form){ + if(old_unit_ptr) //AOCC + *old_unit_ptr = old_unit; EXIT_OPEN(__fortio_error(FIO_ECOMPAT)) - if (acc_flag == FIO_DIRECT && reclen != (f->reclen / f->wordlen)) + } + if (acc_flag == FIO_DIRECT && reclen != (f->reclen / f->wordlen)){ + if(old_unit_ptr) //AOCC + *old_unit_ptr = old_unit; EXIT_OPEN(__fortio_error(FIO_ECOMPAT)) + } f->blank = blank_flag; if (pos_flag == FIO_REWIND) { @@ -139,8 +168,11 @@ __fortio_open(int unit, int action_flag, int status_flag, int dispose_flag, EXIT_OPEN(0) /* no error occurred */ } else { /* case 2: file to be connected is NOT the same: */ - if (__fortio_close(f, 0 /*dispose flag*/) != 0) + if (__fortio_close(f, 0 /*dispose flag*/) != 0){ + if(old_unit_ptr) //AOCC + *old_unit_ptr = old_unit; EXIT_OPEN(ERR_FLAG) + } } } @@ -173,33 +205,44 @@ __fortio_open(int unit, int action_flag, int status_flag, int dispose_flag, if (status_flag == FIO_OLD) { /* if OLD and doesn't exist, then error */ - if (__fort_access(filename, 0) != 0) + if (__fort_access(filename, 0) != 0){ + if(old_unit_ptr) //AOCC + *old_unit_ptr = old_unit; EXIT_OPEN(__fortio_error(FIO_ENOEXIST)) - + } /* open file for readonly or read/write: */ perms = "r+"; if ((action_flag == FIO_READ) || (lcl_fp = __io_fopen(filename, perms)) == NULL) { perms = "r"; - if ((lcl_fp = (__io_fopen(filename, perms))) == NULL) + if ((lcl_fp = (__io_fopen(filename, perms))) == NULL){ EXIT_OPEN(__fortio_error(__io_errno())) + } } } else if (status_flag == FIO_NEW) { /* if NEW and exists then error */ - if (__fort_access(filename, 0) == 0) + if (__fort_access(filename, 0) == 0){ + if(old_unit_ptr) //AOCC + *old_unit_ptr = old_unit; EXIT_OPEN(__fortio_error(FIO_EEXIST)) - + } perms = "w+"; - if ((lcl_fp = __io_fopen(filename, perms)) == NULL) + if ((lcl_fp = __io_fopen(filename, perms)) == NULL){ + if(old_unit_ptr) //AOCC + *old_unit_ptr = old_unit; EXIT_OPEN(__fortio_error(__io_errno())) + } } else if (status_flag == FIO_REPLACE) { /* if file does not exist, create a file; * if file exists, delete the file and create a new file. */ perms = "w+"; - if ((lcl_fp = __io_fopen(filename, perms)) == NULL) + if ((lcl_fp = __io_fopen(filename, perms)) == NULL){ + if(old_unit_ptr) //AOCC + *old_unit_ptr = old_unit; EXIT_OPEN(__fortio_error(__io_errno())) + } } else if (status_flag == FIO_UNKNOWN) { i = 0; if (__fort_access(filename, 0) == 0) { /* file exists */ @@ -209,17 +252,25 @@ __fortio_open(int unit, int action_flag, int status_flag, int dispose_flag, perms = "w+"; if ((lcl_fp = __io_fopen(filename, perms)) == NULL) { - if (i == 0) /* file does not exist */ + if (i == 0){ /* file does not exist */ + if(old_unit_ptr) //AOCC + *old_unit_ptr = old_unit; EXIT_OPEN(__fortio_error(__io_errno())) + } /* try again with different mode: */ perms = "r"; - if ((lcl_fp = __io_fopen(filename, perms)) == NULL) + if ((lcl_fp = __io_fopen(filename, perms)) == NULL){ + if(old_unit_ptr) //AOCC + *old_unit_ptr = old_unit; EXIT_OPEN(__fortio_error(__io_errno())) + } } } else { assert(status_flag == FIO_SCRATCH); perms = "w+"; - if ((lcl_fp = __io_fopen(filename, perms)) == NULL) { + if ((lcl_fp = __io_fopen(filename, perms)) == NULL){ + if(old_unit_ptr) //AOCC + *old_unit_ptr = old_unit; EXIT_OPEN(__fortio_error(__io_errno())) } __fort_unlink(filename); @@ -1154,7 +1205,7 @@ ENTF90IO(OPEN03A, open03a)( Fcb->sign = FIO_PLUS; else if (__fortio_eq_str(CADR(sign), CLEN(sign), "SUPPRESS")) Fcb->sign = FIO_SUPPRESS; - else if (__fortio_eq_str(CADR(sign), CLEN(sign), "PROCESOR_DEFINED")) + else if (__fortio_eq_str(CADR(sign), CLEN(sign), "PROCESSOR_DEFINED")) Fcb->sign = FIO_PROCESSOR_DEFINED; else return __fortio_error(FIO_ESPEC); diff --git a/runtime/flang/pgf90_mmul_cmplx16.h b/runtime/flang/pgf90_mmul_cmplx16.h index 8c30c4c973..35aac4367e 100644 --- a/runtime/flang/pgf90_mmul_cmplx16.h +++ b/runtime/flang/pgf90_mmul_cmplx16.h @@ -53,3 +53,7 @@ #undef DCMPLX #define DCMPLX(r,i) cmplx(r,i,kind=8) + +#undef QCMPLX +#define QCMPLX(r,i) cmplx(r,i,kind=16) + diff --git a/runtime/flang/pgf90_mmul_cmplx32.h b/runtime/flang/pgf90_mmul_cmplx32.h new file mode 100644 index 0000000000..86f382a6a1 --- /dev/null +++ b/runtime/flang/pgf90_mmul_cmplx32.h @@ -0,0 +1,59 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + + ! + ! Global variables + ! + integer*8 :: mra, ncb, kab, lda, ldb, ldc + complex*32, dimension( lda, * )::a + complex*32, dimension( ldb, * )::b + complex*32, dimension( ldc, * )::c + complex*32 :: alpha, beta, one = 1.0 + character*1 :: ca, cb + ! + ! local variables + ! + integer*8 :: colsa, rowsa, rowsb, colsb + integer*8 :: i, j, jb, k, ak, bk, jend + integer*8 :: ar, ar_sav, ac, ac_sav, br, bc + integer*8 :: ndxa, ndxasav + integer*8 :: ndxb, ndxbsav, ndxb0, ndxb1, ndxb2, ndxb3 + integer*8 :: colachunk, colachunks, colbchunk, colbchunks + integer*8 :: rowchunk, rowchunks + integer*8 :: colsb_chunk, colsb_chunks, colsb_strt, colsb_end + integer*8 :: colsa_chunk, colsa_chunks, colsa_strt, colsa_end + integer*8 :: bufr, bufr_sav, bufca, bufca_sav, bufcb, bufcb_sav + integer :: ta, tb + complex*32 :: temp, temp0, temp1, temp2, temp3 + real*8 :: temprr0, temprr1, temprr2, temprr3 + real*8 :: tempii0, tempii1, tempii2, tempii3 + real*8 :: tempri0, tempri1, tempri2, tempri3 + real*8 :: tempir0, tempir1, tempir2, tempir3 + complex*32 :: bufatemp, bufbtemp + real*8 :: bufatempr, bufatempi, bufbtempr, bufbtempi + real*8 :: time_start, time_end, ttime, all_time + + integer, parameter :: bufrows = 512, bufcols = 8192 +! integer, parameter :: bufrows = 2, bufcols = 3 +! complex*32, dimension( bufrows * bufcols ) :: buffera, bufferb + complex*32, allocatable, dimension(:) :: buffera, bufferb + +!Minimun number of multiplications needed to activate the blocked optimization. +#ifdef TARGET_X8664 + integer, parameter :: min_blocked_mult = 15000 +#elif TARGET_LINUX_POWER + integer, parameter :: min_blocked_mult = 15000 !Complex calculations not vectorized on OpenPower. +#else + #warning untuned matrix multiplication parameter + integer, parameter :: min_blocked_mult = 15000 +#endif + +#undef DCMPLX +#define DCMPLX(r,i) cmplx(r,i,kind=8) + +#undef QCMPLX +#define QCMPLX(r,i) cmplx(r,i,kind=32) + diff --git a/runtime/flang/red.h b/runtime/flang/red.h index 990dbc8a92..7df9dbecc3 100644 --- a/runtime/flang/red.h +++ b/runtime/flang/red.h @@ -9,7 +9,6 @@ /* FIXME: still used */ #include "fort_vars.h" - /* intrinsic reduction function enumeration */ typedef enum { diff --git a/runtime/flang/red_norm2.c b/runtime/flang/red_norm2.c index 2c6268385d..eb482d57bf 100644 --- a/runtime/flang/red_norm2.c +++ b/runtime/flang/red_norm2.c @@ -17,6 +17,12 @@ void F90_I8(stride_1_norm2_real8) (__POINT_T *src_pointer, __INT_T *size, __REAL F90_I8(norm2_real8) (src_pointer, size, result); } +// AOCC begin +void F90_I8(stride_1_norm2_real16) (__POINT_T *src_pointer, __INT_T *size, __REAL16_T *result) { + F90_I8(norm2_real16) (src_pointer, size, result); +} +// AOCC end + void ENTFTN(NORM2_NODIM, norm2_nodim) (__POINT_T *result, __POINT_T *src, __INT4_T * pfr, _DIST_TYPE *result_kind, F90_Desc *src_desc) { char error_msg[50]; @@ -74,6 +80,35 @@ void ENTFTN(NORM2_NODIM, norm2_nodim) (__POINT_T *result, __POINT_T *src, __INT4 sprintf(error_msg, "Rank : %d, can not be less than 1 or greater 7\n", src_desc->rank); __fort_abort(error_msg); } + // AOCC begin + } else if (src_desc->kind == __REAL16) { + switch(src_desc->rank) { + case 1: + F90_NORM2(nodim_1_real16) (result, src, src_desc); + break; + case 2: + F90_NORM2(nodim_2_real16) (result, src, src_desc); + break; + case 3: + F90_NORM2(nodim_3_real16) (result, src, src_desc); + break; + case 4: + F90_NORM2(nodim_4_real16) (result, src, src_desc); + break; + case 5: + F90_NORM2(nodim_5_real16) (result, src, src_desc); + break; + case 6: + F90_NORM2(nodim_6_real16) (result, src, src_desc); + break; + case 7: + F90_NORM2(nodim_7_real16) (result, src, src_desc); + break; + default: + sprintf(error_msg, "Rank : %d, can not be less than 1 or greater 7\n", src_desc->rank); + __fort_abort(error_msg); + } + // AOCC end } else if (src_desc->len == 0) { // empty array case *result = 0.0; @@ -144,6 +179,35 @@ void ENTFTN(NORM2, norm2) (__POINT_T *result, __POINT_T *src, __INT4_T * pfr, __ sprintf(error_msg, "Rank : %d, can not be less than 1 or greater 7\n", src_desc->rank); __fort_abort(error_msg); } + // AOCC begin + } else if (src_desc->kind == __REAL16) { + switch (src_desc->rank) { + case 1: + F90_NORM2(nodim_1_real16) (result, src, src_desc); + break; + case 2: + F90_NORM2(dim_2_real16) (result, src, dim, result_desc, src_desc); + break; + case 3: + F90_NORM2(dim_3_real16) (result, src, dim, result_desc, src_desc); + break; + case 4: + F90_NORM2(dim_4_real16) (result, src, dim, result_desc, src_desc); + break; + case 5: + F90_NORM2(dim_5_real16) (result, src, dim, result_desc, src_desc); + break; + case 6: + F90_NORM2(dim_6_real16) (result, src, dim, result_desc, src_desc); + break; + case 7: + F90_NORM2(dim_7_real16) (result, src, dim, result_desc, src_desc); + break; + default: + sprintf(error_msg, "Rank : %d, can not be less than 1 or greater 7\n", src_desc->rank); + __fort_abort(error_msg); + } + // AOCC end } else if (src_desc->len == 0) { // empty array case *result = 0.0; diff --git a/runtime/flang/red_norm2_stride1.c b/runtime/flang/red_norm2_stride1.c index 5104614031..5fd13437ef 100644 --- a/runtime/flang/red_norm2_stride1.c +++ b/runtime/flang/red_norm2_stride1.c @@ -35,3 +35,17 @@ void NORM2_REAL8 (__POINT_T *src_pointer, __INT_T *size, __REAL8_T *result) { } *result = sqrt(sum); } + +// AOCC begin +void NORM2_REAL16 (__POINT_T *src_pointer, __INT_T *size, __REAL16_T *result) { + // Passing in integer*8 address of starting point in the array + __REAL16_T *src = (__REAL16_T *)(*src_pointer); + __REAL16_T sum = 0; + __INT_T i; + + for (i = 0; i < *size; ++i) { + sum += src[i]*src[i]; + } + *result = sqrt(sum); +} +// AOCC end diff --git a/runtime/flang/rnum.c b/runtime/flang/rnum.c index 6772c24d1e..f3466aa7b8 100644 --- a/runtime/flang/rnum.c +++ b/runtime/flang/rnum.c @@ -330,6 +330,115 @@ static void I8(prng_loop_r_npb)(__REAL4_T *hb, F90_Desc *harvest, __INT_T li, } } +// AOCC begin +static void I8(prng_loop_q_npb)(__REAL8_T *hb, F90_Desc *harvest, __INT_T li, + int dim, __INT_T section_offset, __INT_T limit) +{ + DECL_DIM_PTRS(hdd); + DECL_DIM_PTRS(tdd); + __INT_T cl, clof, cn, current, i, il, iu, lo, n; + __INT_T hi, tcl, tcn, tclof; + int itmp; + double tmp1, tmp2; + + SET_DIM_PTRS(hdd, harvest, dim - 1); + cl = DIST_DPTR_CL_G(hdd); + cn = DIST_DPTR_CN_G(hdd); + clof = DIST_DPTR_CLOF_G(hdd); + + if (dim > (limit + 1)) + for (; cn > 0; + --cn, cl += DIST_DPTR_CS_G(hdd), clof += DIST_DPTR_CLOS_G(hdd)) { + n = I8(__fort_block_bounds)(harvest, dim, cl, &il, &iu); + lo = li + + (F90_DPTR_SSTRIDE_G(hdd) * il + F90_DPTR_SOFFSET_G(hdd) - clof) * + F90_DPTR_LSTRIDE_G(hdd); + current = F90_DPTR_EXTENT_G(hdd) * section_offset + + (il - F90_DPTR_LBOUND_G(hdd)); + for (i = 0; i < n; ++i) { + I8(prng_loop_q_npb)(hb, harvest, lo, dim - 1, current + i, limit); + lo += F90_DPTR_SSTRIDE_G(hdd) * F90_DPTR_LSTRIDE_G(hdd); + } + } + /* + * Optimization collapsing non-distributed leading dimensions. + */ + else if (limit > 0) { + for (; cn > 0; + --cn, cl += DIST_DPTR_CS_G(hdd), clof += DIST_DPTR_CLOS_G(hdd)) { + /* + * Find first current and low value of fill range. + */ + n = I8(__fort_block_bounds)(harvest, dim, cl, &il, &iu); + lo = li + + (F90_DPTR_SSTRIDE_G(hdd) * il + F90_DPTR_SOFFSET_G(hdd) - clof) * + F90_DPTR_LSTRIDE_G(hdd); + current = F90_DPTR_EXTENT_G(hdd) * section_offset + + (il - F90_DPTR_LBOUND_G(hdd)); + hi = lo + (n - 1) * F90_DPTR_SSTRIDE_G(hdd) * F90_DPTR_LSTRIDE_G(hdd); + for (i = dim - 1; i > 0; --i) { + SET_DIM_PTRS(tdd, harvest, i - 1); + tcl = DIST_DPTR_CL_G(tdd); + tcn = DIST_DPTR_CN_G(tdd); + tclof = DIST_DPTR_CLOF_G(tdd); + (void)I8(__fort_block_bounds)(harvest, i, tcl, &il, &iu); + lo = lo + + (F90_DPTR_SSTRIDE_G(tdd) * il + F90_DPTR_SOFFSET_G(tdd) - tclof) * + F90_DPTR_LSTRIDE_G(tdd); + current = + F90_DPTR_EXTENT_G(tdd) * current + (il - F90_DPTR_LBOUND_G(tdd)); + n = I8(__fort_block_bounds)( + harvest, i, tcl + (tcn - 1) * DIST_DPTR_CS_G(tdd), &il, &iu); + hi = hi + + (F90_DPTR_SSTRIDE_G(tdd) * (il + n - 1) + F90_DPTR_SOFFSET_G(tdd) - + tclof) * + F90_DPTR_LSTRIDE_G(tdd); + } + /* + * Fill the array with random numbers. + */ + hb[lo] = advance_seed_npb(current - last_i); + last_i = current + hi - lo; + for (i = lo + 1; i <= hi; ++i) { + tmp1 = seed_lo * table[0][0]; + itmp = T23 * tmp1; + tmp2 = R23 * itmp; + seed_hi = tmp2 + seed_lo * table[0][1] + seed_hi * table[0][0]; + seed_lo = tmp1 - tmp2; + itmp = seed_hi; + seed_hi -= itmp; + hb[i] = seed_lo + seed_hi; + } + } + } else { + for (; cn > 0; + --cn, cl += DIST_DPTR_CS_G(hdd), clof += DIST_DPTR_CLOS_G(hdd)) { + n = I8(__fort_block_bounds)(harvest, dim, cl, &il, &iu); + if (n > 0) { + lo = li + + (F90_DPTR_SSTRIDE_G(hdd) * il + F90_DPTR_SOFFSET_G(hdd) - clof) * + F90_DPTR_LSTRIDE_G(hdd); + current = F90_DPTR_EXTENT_G(hdd) * section_offset + + (il - F90_DPTR_LBOUND_G(hdd)); + hb[lo] = advance_seed_npb(current - last_i); + for (i = 1; i < n; ++i) { + lo += F90_DPTR_SSTRIDE_G(hdd) * F90_DPTR_LSTRIDE_G(hdd); + tmp1 = seed_lo * table[0][0]; + itmp = T23 * tmp1; + tmp2 = R23 * itmp; + seed_hi = tmp2 + seed_lo * table[0][1] + seed_hi * table[0][0]; + seed_lo = tmp1 - tmp2; + itmp = seed_hi; + seed_hi -= itmp; + hb[lo] = seed_lo + seed_hi; + } + last_i = current + n - 1; + } + } + } +} +// AOCC end + /* * ======================================================================== * Lagged fibonacci pseudo-random number generator code. @@ -6108,6 +6217,114 @@ static void I8(prng_loop_r_lf)(__REAL4_T *hb, F90_Desc *harvest, __INT_T li, } } +// AOCC begin +/* + * Routine that loops through a dimension of the quad precision output. + * Recursive down to last dimension, where work is done. + */ + +static void I8(prng_loop_q_lq)(__REAL16_T *hb, F90_Desc *harvest, __INT_T li, + int dim, __INT_T section_offset, __INT_T limit) +{ + DECL_DIM_PTRS(hdd); + DECL_DIM_PTRS(tdd); + __INT_T cl, cn, current, i, il, iu, lo, clof, n; + __INT_T hi, tcl, tcn, tclof; + + SET_DIM_PTRS(hdd, harvest, dim - 1); + cl = DIST_DPTR_CL_G(hdd); + cn = DIST_DPTR_CN_G(hdd); + clof = DIST_DPTR_CLOF_G(hdd); + + if (dim > 1) + for (; cn > 0; + --cn, cl += DIST_DPTR_CS_G(hdd), clof += DIST_DPTR_CLOS_G(hdd)) { + n = I8(__fort_block_bounds)(harvest, dim, cl, &il, &iu); + lo = li + + (F90_DPTR_SSTRIDE_G(hdd) * il + F90_DPTR_SOFFSET_G(hdd) - clof) * + F90_DPTR_LSTRIDE_G(hdd); + current = F90_DPTR_EXTENT_G(hdd) * section_offset + + (il - F90_DPTR_LBOUND_G(hdd)); + for (i = 0; i < n; ++i) { + I8(prng_loop_q_lq)(hb, harvest, lo, dim - 1, current + i, limit); + lo += F90_DPTR_SSTRIDE_G(hdd) * F90_DPTR_LSTRIDE_G(hdd); + } + } + /* + * Optimization collapsing non-distributed leading dimensions. + */ + else if (limit > 0) { + for (; cn > 0; + --cn, cl += DIST_DPTR_CS_G(hdd), clof += DIST_DPTR_CLOS_G(hdd)) { + /* + * Find first current and low value of fill range. + */ + n = I8(__fort_block_bounds)(harvest, dim, cl, &il, &iu); + lo = li + + (F90_DPTR_SSTRIDE_G(hdd) * il + F90_DPTR_SOFFSET_G(hdd) - clof) * + F90_DPTR_LSTRIDE_G(hdd); + current = F90_DPTR_EXTENT_G(hdd) * section_offset + + (il - F90_DPTR_LBOUND_G(hdd)); + hi = lo + (n - 1) * F90_DPTR_SSTRIDE_G(hdd) * F90_DPTR_LSTRIDE_G(hdd); + for (i = dim - 1; i > 0; --i) { + SET_DIM_PTRS(tdd, harvest, i - 1); + tcl = DIST_DPTR_CL_G(tdd); + tcn = DIST_DPTR_CN_G(tdd); + tclof = DIST_DPTR_CLOF_G(tdd); + (void)I8(__fort_block_bounds)(harvest, i, tcl, &il, &iu); + lo = lo + + (F90_DPTR_SSTRIDE_G(tdd) * il + F90_DPTR_SOFFSET_G(tdd) - tclof) * + F90_DPTR_LSTRIDE_G(hdd); + current = + F90_DPTR_EXTENT_G(tdd) * current + (il - F90_DPTR_LBOUND_G(tdd)); + n = I8(__fort_block_bounds)( + harvest, i, tcl + (tcn - 1) * DIST_DPTR_CS_G(tdd), &il, &iu); + hi = hi + + (F90_DPTR_SSTRIDE_G(tdd) * (il + n - 1) + F90_DPTR_SOFFSET_G(tdd) - + tclof) * + F90_DPTR_LSTRIDE_G(tdd); + } + /* + * Fill the array with random numbers. + */ + hb[lo] = advance_seed_lf(current - last_i); + last_i = current + hi - lo; + for (i = lo + 1; i <= hi; ++i) { + offset = (offset + 1) & MASK; + seed_lf[offset] = seed_lf[(offset - SHORT_LAG) & MASK] + + seed_lf[(offset - LONG_LAG) & MASK]; + if (seed_lf[offset] > 1.0) + seed_lf[offset] -= 1.0; + hb[i] = seed_lf[offset]; + } + } + } else { + for (; cn > 0; + --cn, cl += DIST_DPTR_CS_G(hdd), clof += DIST_DPTR_CLOS_G(hdd)) { + n = I8(__fort_block_bounds)(harvest, dim, cl, &il, &iu); + if (n > 0) { + lo = li + + (F90_DPTR_SSTRIDE_G(hdd) * il + F90_DPTR_SOFFSET_G(hdd) - clof) * + F90_DPTR_LSTRIDE_G(hdd); + current = F90_DPTR_EXTENT_G(hdd) * section_offset + + (il - F90_DPTR_LBOUND_G(hdd)); + hb[lo] = advance_seed_lf(current - last_i); + for (i = 1; i < n; ++i) { + lo += F90_DPTR_SSTRIDE_G(hdd) * F90_DPTR_LSTRIDE_G(hdd); + offset = (offset + 1) & MASK; + seed_lf[offset] = seed_lf[(offset - SHORT_LAG) & MASK] + + seed_lf[(offset - LONG_LAG) & MASK]; + if (seed_lf[offset] > 1.0) + seed_lf[offset] -= 1.0; + hb[lo] = seed_lf[offset]; + } + last_i = current + n - 1; + } + } + } +} +// AOCC end + /* * ======================================================================== * Common code. @@ -6117,6 +6334,10 @@ static void I8(prng_loop_r_lf)(__REAL4_T *hb, F90_Desc *harvest, __INT_T li, static int fibonacci = 1; static double (*advance_seed)(__INT_T) = advance_seed_lf; +// AOCC begin +static void (*prng_loop_q)(__REAL16_T *, F90_Desc *, __INT_T, int, __INT_T, + __INT_T) = I8(prng_loop_q_lq); +// AOCC end static void (*prng_loop_d)(__REAL8_T *, F90_Desc *, __INT_T, int, __INT_T, __INT_T) = I8(prng_loop_d_lf); static void (*prng_loop_r)(__REAL4_T *, F90_Desc *, __INT_T, int, __INT_T, @@ -6127,6 +6348,7 @@ set_fibonacci(void) { fibonacci = 1; advance_seed = advance_seed_lf; + prng_loop_q = I8(prng_loop_q_lq); // AOCC prng_loop_d = I8(prng_loop_d_lf); prng_loop_r = I8(prng_loop_r_lf); } @@ -6136,6 +6358,7 @@ set_npb(void) { fibonacci = 0; advance_seed = advance_seed_npb; + prng_loop_q = I8(prng_loop_q_npb); prng_loop_d = I8(prng_loop_d_npb); prng_loop_r = I8(prng_loop_r_npb); } @@ -6276,6 +6499,60 @@ void ENTFTN(RNUMD, rnumd)(__REAL8_T *hb, F90_Desc *harvest) MP_V(sem); } +/* + * AOCC + * Quad precision, pseudo-random number generator, RANDOM_NUMBER. + */ + +void ENTFTN(RNUMQ, rnumq)(__REAL16_T *hb, F90_Desc *harvest) +{ + __INT_T final, i; + int itmp; + double tmp1, tmp2; + + MP_P(sem); + if (F90_TAG_G(harvest) == __DESC) { + if (F90_GSIZE_G(harvest) <= 0) { + MP_V(sem); + return; + } + last_i = -1; + if (~F90_FLAGS_G(harvest) & __OFF_TEMPLATE) { + I8(__fort_cycle_bounds)(harvest); + i = I8(level)(harvest); + prng_loop_q(hb, harvest, F90_LBASE_G(harvest) - 1, F90_RANK_G(harvest), 0, + i); + } + final = F90_GSIZE_G(harvest) - 1; + if (last_i < final) + (void)advance_seed(final - last_i); +#ifdef DEBUG + else if (last_i != final) + rnum_abort(__FILE__, __LINE__, + "random_number: internal error: last_i != final"); +#endif + } else { + if (fibonacci) { + offset = (offset + 1) & MASK; + seed_lf[offset] = seed_lf[(offset - SHORT_LAG) & MASK] + + seed_lf[(offset - LONG_LAG) & MASK]; + if (seed_lf[offset] > 1.0) + seed_lf[offset] -= 1.0; + *hb = seed_lf[offset]; + } else { + tmp1 = seed_lo * table[0][0]; + itmp = T23 * tmp1; + tmp2 = R23 * itmp; + seed_hi = tmp2 + seed_lo * table[0][1] + seed_hi * table[0][0]; + seed_lo = tmp1 - tmp2; + itmp = seed_hi; + seed_hi -= itmp; + *hb = seed_lo + seed_hi; + } + } + MP_V(sem); +} + /* * put_int writes a single integer. */ diff --git a/runtime/flang/stat_linux.c b/runtime/flang/stat_linux.c index 1ed1850202..6bab037264 100644 --- a/runtime/flang/stat_linux.c +++ b/runtime/flang/stat_linux.c @@ -4,12 +4,23 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * + * Using clock_gettime to gather CPU times of all threads. + * Date of modification 9th Dec 2019 + * + */ /** \file * \brief Fill in statistics structure (Linux version) */ #include +// AOCC Modification : include for clock_gettime +#include #include #include #include @@ -94,6 +105,35 @@ static double first = 0.0; double __fort_second() +{ + // AOCC Modification : struct variable holding the cpu time + // struct timeval v; + // struct timezone t; + struct timespec v; + double d; + int s; + + // AOCC Modification : system call from gettimeofday to gather CPU times of + // all threads in the current process + // s = gettimeofday(&v, &t); + s = clock_gettime(CLOCK_PROCESS_CPUTIME_ID, &v); + if (s == -1) { + // AOCC Modification : throw error for clock_gettime instead of gettimeofday + // __fort_abortp("gettimeofday"); + __fort_abortp("clock_gettime"); + } + // AOCC Modification : change denominator to 1000000000 for nano-seconds + // d = (double)v.tv_sec + (double)v.tv_usec / 1000000; + d = (double)v.tv_sec + (double)v.tv_nsec / 1000000000; + if (first == 0.0) { + first = d; + } + return (d - first); +} + +/* AOCC begin */ +double +__fort_sysclk_second() { struct timeval v; struct timezone t; @@ -110,6 +150,7 @@ __fort_second() } return (d - first); } +/* AOCC end */ void __fort_set_second(double d) diff --git a/runtime/flang/stime3f.c b/runtime/flang/stime3f.c index 97aba9ad5d..54b6e7f1b1 100644 --- a/runtime/flang/stime3f.c +++ b/runtime/flang/stime3f.c @@ -4,6 +4,12 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified: May 2020 + */ /* clang-format off */ @@ -18,9 +24,9 @@ int ENT3F(STIME, stime)(int *tp) { int i; - time_t t = *tp; - - if ((i = stime(&t))) + struct timespec ts = {}; + ts.tv_sec = *tp; + if ((i = clock_settime(CLOCK_REALTIME, &ts))) i = __io_errno(); return i; diff --git a/runtime/flang/transpose_cmplx32.F95 b/runtime/flang/transpose_cmplx32.F95 new file mode 100644 index 0000000000..3b3b2acf3c --- /dev/null +++ b/runtime/flang/transpose_cmplx32.F95 @@ -0,0 +1,91 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + + +! directives.h -- contains preprocessor directives for F90 rte files + +#include "mmul_dir.h" + +subroutine ftn_transpose_cmplx32( ta, a, lda, alpha, buffer, bufrows, bufcols ) + implicit none + integer*8 lda + integer :: bufrows, bufcols + integer i, j, ndx, ndxsave + complex*32 :: a( lda, * ), alpha + complex*32 :: buffer(bufrows * bufcols) + integer :: ta + + ! + ! The plan here is to copy the matrix a to the buffer, or at least a + ! portion of it, such that the matrix (really a buffer) is in proper + ! order for successive access. Some number of columns of a will be + ! dispersed to buffer to minimize page faults. + ! The calling function can manage the buffer for both L1 and L2 cache + ! utilization. bufcols defines the number of values taken from L1 cache + ! for each dot product. bufrows * bufcols defines how much L2 cache is + ! used. + ! + ! We may want to change this to be able to handle multiple sections of L1 + ! cache usage such as giving an additional parameter, say, nbufrows + ! which would essentially copy more of the matrix a to the buffer using + ! an additional loop + + ! + ! What do the parameters mean? + ! buffer: buffer array + ! a: matrix to be transposed + ! bufcols: number of rows in matrix a to transpose + ! bufrowss: number of cols in matrix a to transpose + ! lda: number of rows in matrix a + ! Note that we don't care what the dimensions of a are. We assume that the + ! calling function has done this correctly + ! + ndxsave = 1 + if( alpha .eq. 1.0 )then + if( ta .eq. 2 )then ! conjugate the data on transfer to buffer + do j = 1, bufrows + ndx = ndxsave + do i = 1, bufcols + buffer( ndx ) = conjg( a( i, j ) ) + ndx = ndx + bufrows + enddo + ndxsave = ndxsave + 1 + enddo + else + do j = 1, bufrows + ndx = ndxsave + do i = 1, bufcols + buffer( ndx ) = a( i, j ) + ndx = ndx + bufrows + enddo + ndxsave = ndxsave + 1 + enddo + endif + else + if( ta .eq. 2 )then ! conjugate the data on transfer to buffer + do j = 1, bufrows + ndx = ndxsave + do i = 1, bufcols + buffer( ndx ) = alpha * conjg( a( i, j ) ) + ndx = ndx + bufrows + enddo + ndxsave = ndxsave + 1 + enddo + else + do j = 1, bufrows + ndx = ndxsave + do i = 1, bufcols + buffer( ndx ) = alpha * a( i, j ) + ndx = ndx + bufrows + enddo + ndxsave = ndxsave + 1 + enddo + endif + endif + ! write( *, * ) ( a(1, j ), j = 1, bufcols ) + ! write( *, * )( buffer( i ), i = 1, bufrows * bufcols ) + return +end subroutine ftn_transpose_cmplx32 diff --git a/runtime/flang/type.c b/runtime/flang/type.c index 749cb8d730..b6160d7d46 100644 --- a/runtime/flang/type.c +++ b/runtime/flang/type.c @@ -4,6 +4,12 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified: May 2020 + */ /* clang-format off */ @@ -778,8 +784,10 @@ void ENTF90(DEALLOC_POLY_MBR03A, OBJECT_DESC *src = (OBJECT_DESC *)sd; TYPE_DESC *src_td; - if (!I8(__fort_allocated)(area)) + if (!I8(__fort_allocated)(area)) { + if (ISPRESENT(stat)) *stat = 2; // AOCC return; + } if (src) { src_td = (src->type) ? src->type : 0; @@ -847,8 +855,10 @@ void ENTF90(DEALLOC_POLY03A, dealloc_poly03a)(F90_Desc *sd, __STAT_T *stat, OBJECT_DESC *src = (OBJECT_DESC *)sd; TYPE_DESC *src_td; - if (!I8(__fort_allocated)(area)) + if (!I8(__fort_allocated)(area)) { + if (ISPRESENT(stat)) *stat = 2; // AOCC return; + } if (src) { src_td = (src->type) ? src->type : 0; diff --git a/runtime/flang/vmmul_cmplx32.F95 b/runtime/flang/vmmul_cmplx32.F95 new file mode 100644 index 0000000000..6b94d06877 --- /dev/null +++ b/runtime/flang/vmmul_cmplx32.F95 @@ -0,0 +1,177 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + + +! directives.h -- contains preprocessor directives for F90 rte files +#include "mmul_dir.h" + +subroutine ftn_vmmul_cmplx32( ta, tb, n, k, alpha, a, b, ldb, beta, c ) + implicit none + integer*8 :: n, k, ldb + integer :: ta, tb + complex*32, dimension (ldb, * ) :: b + complex*32, dimension ( * ) :: a, c + complex*32 :: alpha, beta + +! local variables + integer*8 :: i, j, kk + complex*32 :: temp + + +! print *, "#### In vmmul ####" + + if( beta .ne. 0.0 )then + do i = 1, n + c( i ) = beta * c( i ) + enddo + else + do i = 1, n + c( i ) = 0.0 + enddo + end if + + + + + + if( tb .eq. 2 )then !conjugate b + if( ta .eq. 2 )then ! conjugate a - since tb = 2, b is normally oriented + if( alpha .eq. ( 1.0, 0.0 ) )then + do j = 1, n + do kk = 1, k + c( j ) = c( j ) + conjg( a( kk ) ) * conjg( b( j, kk ) ) + enddo + enddo + elseif( alpha .eq. (-1.0, 0.0 ) )then + do j = 1, n + do kk = 1, k + c( j ) = c( j ) - conjg( a( kk ) ) * conjg( b( j, kk ) ) + enddo + enddo + else + do j = 1, n + do kk = 1, k + c( j ) = c( j ) + alpha * conjg( a( kk ) ) * conjg( b( kk, j ) ) + enddo + enddo + endif + else ! don't conjugate a - if ta != 2, it is just a complex vector + if( alpha .eq. ( 1.0, 0.0 ) )then + do j = 1, n + do kk = 1, k + c( j ) = c( j ) + a( kk ) * conjg( b( j, kk ) ) + enddo + enddo + elseif( alpha .eq. ( -1.0, 0.0 ) )then + do j = 1, n + do kk = 1, k + c( j ) = c( j ) - a( kk ) * conjg( b( j, kk ) ) + enddo + enddo + else + do j = 1, n + do kk = 1, k + c( j ) = c( j ) + alpha * a( kk ) * conjg( b( j, kk ) ) + enddo + enddo + endif + endif + elseif( tb .eq. 1 )then ! b is tranpsosed + if( ta .ne. 2 )then ! no conjugation of a is required + if( alpha .eq. ( 1.0, 0.0 ) )then + do j = 1, n + do kk = 1, k + c( j ) = c( j ) + a( kk ) * b( j, kk ) + enddo + enddo + elseif( alpha .eq. ( -1.0, 0.0 ) )then + do j = 1, n + do kk = 1, k + c( j ) = c( j ) - a( kk ) * b( j, kk ) + enddo + enddo + else + do j = 1, n + do kk = 1, k + c( j ) = c( j ) + alpha * a( kk ) * b( j, kk ) + enddo + enddo + endif + else + if( alpha .eq. ( 1.0, 0.0 ) )then + do j = 1, n + do kk = 1, k + c( j ) = c( j ) + conjg( a( kk ) ) * b( j, kk ) + enddo + enddo + elseif( alpha .eq. ( -1.0, 0.0 ) )then + do j = 1, n + do kk = 1, k + c( j ) = c( j ) - conjg( a( kk ) ) * b( j, kk ) + enddo + enddo + else + do j = 1, n + do kk = 1, k + c( j ) = c( j ) + alpha * conjg( a( kk ) ) * b( j, kk ) + enddo + enddo + endif + endif + else ! b is normally oriented - + if( ta .ne. 2 )then ! a is not conjugated + if( alpha .eq. ( 1.0, 0.0 ) )then + do j = 1, n + temp = 0.0 + do kk = 1, k + temp = temp + a(kk) * b( kk, j ) + enddo + c( j ) = c( j ) + temp + enddo + elseif( alpha .eq. ( -1.0, 0.0 ) )then + do j = 1, n + temp = 0.0 + do kk = 1, k + temp = temp + a(kk) * b( kk, j ) + enddo + c( j ) = c( j ) - temp + enddo + else + do j = 1, n + temp = 0.0 + do kk = 1, k + temp = temp + a(kk) * b( kk, j ) + enddo + c( j ) = c( j ) + alpha * temp + enddo + endif + else ! a is conjugated + if( alpha .eq. ( 1.0, 0.0 ) )then + do kk = 1, k + temp = conjg( a( kk ) ) + do j = 1, n + c( j ) = c( j ) + temp * b( j, kk ) + enddo + enddo + elseif( alpha .eq. ( -1.0, 0.0 ) )then + do kk = 1, k + temp = conjg( a( kk ) ) + do j = 1, n + c( j ) = c( j ) - temp * b( j, kk ) + enddo + enddo + else + do kk = 1, k + temp = alpha * conjg( a( kk ) ) + do j = 1, n + c( j ) = c( j ) - temp * b( j, kk ) + enddo + enddo + endif + endif + endif +return +end subroutine ftn_vmmul_cmplx32 diff --git a/runtime/flangrti/CMakeLists.txt b/runtime/flangrti/CMakeLists.txt index 97fe566302..395fd63d4f 100644 --- a/runtime/flangrti/CMakeLists.txt +++ b/runtime/flangrti/CMakeLists.txt @@ -9,6 +9,8 @@ enable_language(C ASM) # Enable assembly SET(ASM_OPTIONS "-DLINUX_ELF") SET(CMAKE_ASM_FLAGS "${CFLAGS} ${ASM_OPTIONS}" ) +SET(CFLAGS, "${CFLAGS} -w") + if( ${TARGET_ARCHITECTURE} STREQUAL "x86_64" ) set(ARCH_DEP_FILES x86_64-Linux/x86_daz.c @@ -31,6 +33,8 @@ SET(PGC_SRC_FILES bessel_tyn.c dbessel_tjn.c dbessel_tyn.c + qbessel_tjn.c + qbessel_tyn.c f2cmain.c kidnnt.c ktrap.c @@ -38,6 +42,7 @@ SET(PGC_SRC_FILES mcopy2.c mcopy4.c mcopy8.c + mcopy16.c mthi64.c mset1.c mset2.c @@ -46,7 +51,9 @@ SET(PGC_SRC_FILES mzero1.c mzero2.c mzero4.c + mzero4.c mzero8.c + mzero16.c ioargs.c memalign.c iostdinit.c @@ -78,12 +85,22 @@ add_flang_library(flangrti_shared # Resolve symbols against libm target_link_libraries(flangrti_shared m) +# Resolve symbols against libpthread +find_package(Threads REQUIRED) +if (CMAKE_THREAD_LIBS_INIT) + target_link_libraries(flangrti_shared "${CMAKE_THREAD_LIBS_INIT}") +endif() + # Import OpenMP if (NOT DEFINED LIBOMP_EXPORT_DIR) find_library( FLANG_LIBOMP libomp.so - HINTS ${CMAKE_BINARY_DIR}/lib) + HINTS + ${CMAKE_BINARY_DIR}/lib + ${OPENMP_BUILD_DIR} + NO_DEFAULT_PATH) + message (STATUS "FLANGRTI ${FLANG_LIBOMP}") target_link_libraries(flangrti_shared ${FLANG_LIBOMP}) endif() @@ -91,7 +108,8 @@ find_library( LIBPGMATH libpgmath.so HINTS ${CMAKE_BINARY_DIR}/lib) -target_link_libraries(flangrti_shared ${LIBPGMATH}) +target_link_libraries(flangrti_shared ${LIBPGMATH} -Wl,-rpath,\$ORIGIN) +target_link_libraries(flangrti_shared ${LIBQUADMATH_LOC}) if( ${TARGET_ARCHITECTURE} STREQUAL "aarch64" ) target_compile_definitions(flangrti_static PRIVATE TARGET_LINUX_ARM) diff --git a/runtime/flangrti/llcrit.c b/runtime/flangrti/llcrit.c index bda79937e2..761748f2c0 100644 --- a/runtime/flangrti/llcrit.c +++ b/runtime/flangrti/llcrit.c @@ -5,9 +5,12 @@ * */ +#include #include #include #include +#include +#include #include "komp.h" /* This routine makes a simple omp library call to force lazy initialization of @@ -63,6 +66,19 @@ static kmp_critical_name nest_sem; static omp_nest_lock_t nest_lock; static int is_init_nest = 0; +static int is_init_nest_red = 0; +static int is_atfork_registered = 0; + +static void __llcrit_atfork(void) +{ + is_init_nest = 0; + is_init_nest_red = 0; + /* The atfork handlers are inherited by the sub-processes, + * see https://elias.rhi.hi.is/libc/Threads-and-Fork.html + */ + if (!is_atfork_registered) + fprintf(__io_stderr(), "The atfork not registered when it should be!\n"); +} void _mp_bcs_nest(void) @@ -70,6 +86,12 @@ _mp_bcs_nest(void) if (!is_init_nest) { _mp_p(&nest_sem); if (!is_init_nest) { + if (!is_atfork_registered) { + if (pthread_atfork(NULL, NULL, __llcrit_atfork)) + fprintf(__io_stderr(), "Could not register atfork handler!\n"); + else + is_atfork_registered = 1; + } omp_init_nest_lock(&nest_lock); is_init_nest = 1; } @@ -93,14 +115,18 @@ _mp_ecs_nest(void) static kmp_critical_name nest_sem_red; static omp_nest_lock_t nest_lock_red; -static int is_init_nest_red = 0; - void _mp_bcs_nest_red(void) { if (!is_init_nest_red) { _mp_p(&nest_sem_red); if (!is_init_nest_red) { + if (!is_atfork_registered) { + if (pthread_atfork(NULL, NULL, __llcrit_atfork)) + fprintf(__io_stderr(), "Could not register atfork handler!\n"); + else + is_atfork_registered = 1; + } omp_init_nest_lock(&nest_lock_red); is_init_nest_red = 1; } diff --git a/runtime/flangrti/mcopy16.c b/runtime/flangrti/mcopy16.c new file mode 100644 index 0000000000..c06607161a --- /dev/null +++ b/runtime/flangrti/mcopy16.c @@ -0,0 +1,25 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ + +#include "memops.h" + +#if !defined(INLINE_MEMOPS) +void +__c_mcopy16(__float128 *dest, __float128 *src, long cnt) +{ + long i; + + for (i = 0; i < cnt; i++) { + dest[i] = src[i]; + } + return; +} +#endif diff --git a/runtime/flangrti/mzero16.c b/runtime/flangrti/mzero16.c new file mode 100644 index 0000000000..1ab9e180cf --- /dev/null +++ b/runtime/flangrti/mzero16.c @@ -0,0 +1,25 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ + +#include "memops.h" + +#if !defined(INLINE_MEMOPS) +void +__c_mzero16(__float128 *dest, long cnt) +{ + long i; + + for (i = 0; i < cnt; i++) { + dest[i] = 0; + } + return; +} +#endif diff --git a/runtime/flangrti/qbessel_tjn.c b/runtime/flangrti/qbessel_tjn.c new file mode 100644 index 0000000000..a9e2c51818 --- /dev/null +++ b/runtime/flangrti/qbessel_tjn.c @@ -0,0 +1,39 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ + +/* bessel_tjn.c implements __float128 F2008 bessel_jn transformational intrinsic */ + +__float128 __mth_i_qbessel_j0(__float128 arg); +__float128 __mth_i_qbessel_j1(__float128 arg); +__float128 __mth_i_qbessel_jn(int n, __float128 arg); + +void +f90_qbessel_jn(__float128 *rslts, int *n1, int *n2, __float128 *x) +{ + int i; + __float128 *rslt_p; + + for (i = *n1, rslt_p = rslts; i <= *n2; i++, rslt_p++) { + switch (i) { + case 0: + *rslt_p = __mth_i_qbessel_j0(*x); + break; + case 1: + *rslt_p = __mth_i_qbessel_j1(*x); + break; + default: + *rslt_p = __mth_i_qbessel_jn(i, *x); + break; + } + } +} + + diff --git a/runtime/flangrti/qbessel_tyn.c b/runtime/flangrti/qbessel_tyn.c new file mode 100644 index 0000000000..95a31d6c1f --- /dev/null +++ b/runtime/flangrti/qbessel_tyn.c @@ -0,0 +1,38 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ + +/* bessel_tyn.c implements float F2008 bessel_yn transformational intrinsic */ + +__float128 __mth_i_qbessel_y0(__float128 arg); +__float128 __mth_i_qbessel_y1(__float128 arg); +__float128 __mth_i_qbessel_yn(int n, __float128 arg); + +void +f90_qbessel_yn(__float128 *rslts, int *n1, int *n2, __float128 *x) +{ + int i; + __float128 *rslt_p; + + for (i = *n1, rslt_p = rslts; i <= *n2; i++, rslt_p++) { + switch (i) { + case 0: + *rslt_p = __mth_i_qbessel_y0(*x); + break; + case 1: + *rslt_p = __mth_i_qbessel_y1(*x); + break; + default: + *rslt_p = __mth_i_qbessel_yn(i, *x); + break; + } + } +} + diff --git a/runtime/include/FuncArgMacros.h b/runtime/include/FuncArgMacros.h index 86b6b8f5bb..77267e1c87 100644 --- a/runtime/include/FuncArgMacros.h +++ b/runtime/include/FuncArgMacros.h @@ -76,6 +76,7 @@ #if defined(DESC_I8) #define ENTF90IO(UC, LC) f90io_##LC##_i8 #define ENTF90(UC, LC) f90_##LC##_i8 +#define __ENTF90(UC, LC) __f90_##LC##_i8 #define ENTFTN(UC, LC) fort_##LC##_i8 #define ENTRY(UC, LC) LC##_i8 #define ENTCRF90IO(UC, LC) crf90io_##LC##_i8 /* FIXME: HPF, delete all with this prefix*/ @@ -86,6 +87,7 @@ #else /* !defined(DESC_I8) */ #define ENTF90IO(UC, LC) f90io_##LC #define ENTF90(UC, LC) f90_##LC +#define __ENTF90(UC, LC) __f90_##LC #define ENTFTN(UC, LC) fort_##LC #define ENTRY(UC, LC) LC #define ENTCRF90IO(UC, LC) crf90io_##LC /* FIXME: HPF, delete all with this prefix*/ diff --git a/runtime/include/memops.h b/runtime/include/memops.h index 1b9a55f9f3..e3a41e5fde 100644 --- a/runtime/include/memops.h +++ b/runtime/include/memops.h @@ -4,7 +4,10 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ - +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ /** \file * \brief Various memory operations */ @@ -44,6 +47,13 @@ __c_mzero8(long long *dest, long cnt) (void) __builtin_memset(dest, 0, (size_t) cnt * sizeof(long long)); } +static inline void +__attribute__((always_inline)) +__c_mzero16(__float128 *dest, long cnt) +{ + (void) __builtin_memset(dest, 0, (size_t) cnt * sizeof(__float128)); +} + static inline void __attribute__((always_inline)) __c_mcopy1(char *dest, char *src, long cnt) @@ -72,6 +82,13 @@ __c_mcopy8(long long *dest, long long *src, long cnt) (void) __builtin_memcpy(dest, src, (size_t) cnt * sizeof(long long)); } +static inline void +__attribute__((always_inline)) +__c_mcopy16(__float128 *dest, __float128 *src, long cnt) +{ + (void) __builtin_memcpy(dest, src, (size_t) cnt * sizeof(__float128)); +} + static inline void __attribute__((always_inline)) __c_mset1(char *dest, int value, long cnt) diff --git a/runtime/include/stdioInterf.h b/runtime/include/stdioInterf.h index 6c11eeebd5..f0e666eb95 100644 --- a/runtime/include/stdioInterf.h +++ b/runtime/include/stdioInterf.h @@ -2,6 +2,15 @@ * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. * See https://llvm.org/LICENSE.txt for license information. * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * */ #if !defined(__PGSTDINIT_H__) @@ -60,6 +69,7 @@ typedef long seekoffx_t; #define __io_strtod(p, ep) __fortio_strtod(p, ep) #define __io_ecvt(v, n, d, s, r) __fortio_ecvt(v, n, d, s, r) #define __io_fcvt(v, n, sf, d, s, r) __fortio_fcvt(v, n, sf, d, s, r) +#define __io_qcvt(v, n, q, s, r) __fortio_qcvt(v, n, q, s, r) // AOCC /* and defines for other routines */ #define __fort_getfd(fp) __io_getfd(fp) diff --git a/runtime/libpgmath/CMakeLists.txt b/runtime/libpgmath/CMakeLists.txt index fe2d4ee175..a6eb3947e6 100644 --- a/runtime/libpgmath/CMakeLists.txt +++ b/runtime/libpgmath/CMakeLists.txt @@ -3,8 +3,15 @@ # See https://llvm.org/LICENSE.txt for license information. # SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception # +# +# Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +# Notified per clause 4(b) of the license. +# +# Last Modified: May 2020 +# cmake_minimum_required(VERSION 3.1.0) +enable_language(C ASM) if(POLICY CMP0042) cmake_policy(SET CMP0042 NEW) # Set MACOSX_RPATH=YES by default @@ -13,6 +20,10 @@ if(POLICY CMP0022) cmake_policy(SET CMP0022 NEW) # Required when interacting with LLVM and Clang endif() +# Set default libdir to be "lib" for ROCm, distros will override this anyway: +set(CMAKE_INSTALL_LIBDIR "lib" CACHE STRING "Library install directory") +include(GNUInstallDirs) + # Add path for custom modules set(CMAKE_MODULE_PATH "${CMAKE_CURRENT_SOURCE_DIR}/cmake" @@ -91,6 +102,8 @@ if(CMAKE_C_COMPILER_ID STREQUAL "GNU" AND ${LIBPGMATH_SYSTEM_PROCESSOR} MATCHES string(REPLACE "-std=c++11" "-std=gnu++11" CMAKE_CXX_FLAGS_RELWITHDEBINFO "${CMAKE_CXX_FLAGS_RELWITHDEBINFO}") endif() +SET(CMAKE_CFLAGS, "${CMAKE_C_CFLAGS} -w") + # Needs to be changed to support cross-compilation include(GetHostTriple) get_host_triple(LIBPGMATH_HOST_TRIPLE) diff --git a/runtime/libpgmath/cmake/config.guess b/runtime/libpgmath/cmake/config.guess deleted file mode 100644 index ccb30f4e75..0000000000 --- a/runtime/libpgmath/cmake/config.guess +++ /dev/null @@ -1,1528 +0,0 @@ -#! /bin/sh -# Attempt to guess a canonical system name. -# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, -# 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, -# 2011 Free Software Foundation, Inc. - -timestamp='2011-08-20' - -# This file is free software; you can redistribute it and/or modify it -# under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA -# 02110-1301, USA. -# -# As a special exception to the GNU General Public License, if you -# distribute this file as part of a program that contains a -# configuration script generated by Autoconf, you may include it under -# the same distribution terms that you use for the rest of that program. - - -# Originally written by Per Bothner. Please send patches (context -# diff format) to and include a ChangeLog -# entry. -# -# This script attempts to guess a canonical system name similar to -# config.sub. If it succeeds, it prints the system name on stdout, and -# exits with 0. Otherwise, it exits with 1. -# -# You can get the latest version of this script from: -# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD - -me=`echo "$0" | sed -e 's,.*/,,'` - -usage="\ -Usage: $0 [OPTION] - -Output the configuration name of the system \`$me' is run on. - -Operation modes: - -h, --help print this help, then exit - -t, --time-stamp print date of last modification, then exit - -v, --version print version number, then exit - -Report bugs and patches to ." - -version="\ -GNU config.guess ($timestamp) - -Originally written by Per Bothner. -Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, -2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free -Software Foundation, Inc. - -This is free software; see the source for copying conditions. There is NO -warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." - -help=" -Try \`$me --help' for more information." - -# Parse command line -while test $# -gt 0 ; do - case $1 in - --time-stamp | --time* | -t ) - echo "$timestamp" ; exit ;; - --version | -v ) - echo "$version" ; exit ;; - --help | --h* | -h ) - echo "$usage"; exit ;; - -- ) # Stop option processing - shift; break ;; - - ) # Use stdin as input. - break ;; - -* ) - echo "$me: invalid option $1$help" >&2 - exit 1 ;; - * ) - break ;; - esac -done - -if test $# != 0; then - echo "$me: too many arguments$help" >&2 - exit 1 -fi - -trap 'exit 1' 1 2 15 - -# CC_FOR_BUILD -- compiler used by this script. Note that the use of a -# compiler to aid in system detection is discouraged as it requires -# temporary files to be created and, as you can see below, it is a -# headache to deal with in a portable fashion. - -# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still -# use `HOST_CC' if defined, but it is deprecated. - -# Portable tmp directory creation inspired by the Autoconf team. - -set_cc_for_build=' -trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ; -trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ; -: ${TMPDIR=/tmp} ; - { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || - { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } || - { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } || - { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ; -dummy=$tmp/dummy ; -tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ; -case $CC_FOR_BUILD,$HOST_CC,$CC in - ,,) echo "int x;" > $dummy.c ; - for c in cc gcc c89 c99 ; do - if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then - CC_FOR_BUILD="$c"; break ; - fi ; - done ; - if test x"$CC_FOR_BUILD" = x ; then - CC_FOR_BUILD=no_compiler_found ; - fi - ;; - ,,*) CC_FOR_BUILD=$CC ;; - ,*,*) CC_FOR_BUILD=$HOST_CC ;; -esac ; set_cc_for_build= ;' - -# This is needed to find uname on a Pyramid OSx when run in the BSD universe. -# (ghazi@noc.rutgers.edu 1994-08-24) -if (test -f /.attbin/uname) >/dev/null 2>&1 ; then - PATH=$PATH:/.attbin ; export PATH -fi - -UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown -UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown -UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown -UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown - -# Note: order is significant - the case branches are not exclusive. - -case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in - *:NetBSD:*:*) - # NetBSD (nbsd) targets should (where applicable) match one or - # more of the tupples: *-*-netbsdelf*, *-*-netbsdaout*, - # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently - # switched to ELF, *-*-netbsd* would select the old - # object file format. This provides both forward - # compatibility and a consistent mechanism for selecting the - # object file format. - # - # Note: NetBSD doesn't particularly care about the vendor - # portion of the name. We always set it to "unknown". - sysctl="sysctl -n hw.machine_arch" - UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ - /usr/sbin/$sysctl 2>/dev/null || echo unknown)` - case "${UNAME_MACHINE_ARCH}" in - armeb) machine=armeb-unknown ;; - arm*) machine=arm-unknown ;; - sh3el) machine=shl-unknown ;; - sh3eb) machine=sh-unknown ;; - sh5el) machine=sh5le-unknown ;; - *) machine=${UNAME_MACHINE_ARCH}-unknown ;; - esac - # The Operating System including object format, if it has switched - # to ELF recently, or will in the future. - case "${UNAME_MACHINE_ARCH}" in - arm*|i386|m68k|ns32k|sh3*|sparc|vax) - eval $set_cc_for_build - if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ - | grep -q __ELF__ - then - # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). - # Return netbsd for either. FIX? - os=netbsd - else - os=netbsdelf - fi - ;; - *) - os=netbsd - ;; - esac - # The OS release - # Debian GNU/NetBSD machines have a different userland, and - # thus, need a distinct triplet. However, they do not need - # kernel version information, so it can be replaced with a - # suitable tag, in the style of linux-gnu. - case "${UNAME_VERSION}" in - Debian*) - release='-gnu' - ;; - *) - release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` - ;; - esac - # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: - # contains redundant information, the shorter form: - # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. - echo "${machine}-${os}${release}" - exit ;; - *:OpenBSD:*:*) - UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` - echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE} - exit ;; - *:ekkoBSD:*:*) - echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE} - exit ;; - *:SolidBSD:*:*) - echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE} - exit ;; - macppc:MirBSD:*:*) - echo powerpc-unknown-mirbsd${UNAME_RELEASE} - exit ;; - *:MirBSD:*:*) - echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE} - exit ;; - alpha:OSF1:*:*) - case $UNAME_RELEASE in - *4.0) - UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` - ;; - *5.*) - UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'` - ;; - esac - # According to Compaq, /usr/sbin/psrinfo has been available on - # OSF/1 and Tru64 systems produced since 1995. I hope that - # covers most systems running today. This code pipes the CPU - # types through head -n 1, so we only detect the type of CPU 0. - ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` - case "$ALPHA_CPU_TYPE" in - "EV4 (21064)") - UNAME_MACHINE="alpha" ;; - "EV4.5 (21064)") - UNAME_MACHINE="alpha" ;; - "LCA4 (21066/21068)") - UNAME_MACHINE="alpha" ;; - "EV5 (21164)") - UNAME_MACHINE="alphaev5" ;; - "EV5.6 (21164A)") - UNAME_MACHINE="alphaev56" ;; - "EV5.6 (21164PC)") - UNAME_MACHINE="alphapca56" ;; - "EV5.7 (21164PC)") - UNAME_MACHINE="alphapca57" ;; - "EV6 (21264)") - UNAME_MACHINE="alphaev6" ;; - "EV6.7 (21264A)") - UNAME_MACHINE="alphaev67" ;; - "EV6.8CB (21264C)") - UNAME_MACHINE="alphaev68" ;; - "EV6.8AL (21264B)") - UNAME_MACHINE="alphaev68" ;; - "EV6.8CX (21264D)") - UNAME_MACHINE="alphaev68" ;; - "EV6.9A (21264/EV69A)") - UNAME_MACHINE="alphaev69" ;; - "EV7 (21364)") - UNAME_MACHINE="alphaev7" ;; - "EV7.9 (21364A)") - UNAME_MACHINE="alphaev79" ;; - esac - # A Pn.n version is a patched version. - # A Vn.n version is a released version. - # A Tn.n version is a released field test version. - # A Xn.n version is an unreleased experimental baselevel. - # 1.2 uses "1.2" for uname -r. - echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` - # Reset EXIT trap before exiting to avoid spurious non-zero exit code. - exitcode=$? - trap '' 0 - exit $exitcode ;; - Alpha\ *:Windows_NT*:*) - # How do we know it's Interix rather than the generic POSIX subsystem? - # Should we change UNAME_MACHINE based on the output of uname instead - # of the specific Alpha model? - echo alpha-pc-interix - exit ;; - 21064:Windows_NT:50:3) - echo alpha-dec-winnt3.5 - exit ;; - Amiga*:UNIX_System_V:4.0:*) - echo m68k-unknown-sysv4 - exit ;; - *:[Aa]miga[Oo][Ss]:*:*) - echo ${UNAME_MACHINE}-unknown-amigaos - exit ;; - *:[Mm]orph[Oo][Ss]:*:*) - echo ${UNAME_MACHINE}-unknown-morphos - exit ;; - *:OS/390:*:*) - echo i370-ibm-openedition - exit ;; - *:z/VM:*:*) - echo s390-ibm-zvmoe - exit ;; - *:OS400:*:*) - echo powerpc-ibm-os400 - exit ;; - arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) - echo arm-acorn-riscix${UNAME_RELEASE} - exit ;; - arm:riscos:*:*|arm:RISCOS:*:*) - echo arm-unknown-riscos - exit ;; - SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) - echo hppa1.1-hitachi-hiuxmpp - exit ;; - Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) - # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. - if test "`(/bin/universe) 2>/dev/null`" = att ; then - echo pyramid-pyramid-sysv3 - else - echo pyramid-pyramid-bsd - fi - exit ;; - NILE*:*:*:dcosx) - echo pyramid-pyramid-svr4 - exit ;; - DRS?6000:unix:4.0:6*) - echo sparc-icl-nx6 - exit ;; - DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*) - case `/usr/bin/uname -p` in - sparc) echo sparc-icl-nx7; exit ;; - esac ;; - s390x:SunOS:*:*) - echo ${UNAME_MACHINE}-ibm-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - sun4H:SunOS:5.*:*) - echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) - echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - i86pc:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*) - echo i386-pc-auroraux${UNAME_RELEASE} - exit ;; - i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*) - eval $set_cc_for_build - SUN_ARCH="i386" - # If there is a compiler, see if it is configured for 64-bit objects. - # Note that the Sun cc does not turn __LP64__ into 1 like gcc does. - # This test works for both compilers. - if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then - if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \ - (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ - grep IS_64BIT_ARCH >/dev/null - then - SUN_ARCH="x86_64" - fi - fi - echo ${SUN_ARCH}-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - sun4*:SunOS:6*:*) - # According to config.sub, this is the proper way to canonicalize - # SunOS6. Hard to guess exactly what SunOS6 will be like, but - # it's likely to be more like Solaris than SunOS4. - echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - sun4*:SunOS:*:*) - case "`/usr/bin/arch -k`" in - Series*|S4*) - UNAME_RELEASE=`uname -v` - ;; - esac - # Japanese Language versions have a version number like `4.1.3-JL'. - echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` - exit ;; - sun3*:SunOS:*:*) - echo m68k-sun-sunos${UNAME_RELEASE} - exit ;; - sun*:*:4.2BSD:*) - UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` - test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 - case "`/bin/arch`" in - sun3) - echo m68k-sun-sunos${UNAME_RELEASE} - ;; - sun4) - echo sparc-sun-sunos${UNAME_RELEASE} - ;; - esac - exit ;; - aushp:SunOS:*:*) - echo sparc-auspex-sunos${UNAME_RELEASE} - exit ;; - # The situation for MiNT is a little confusing. The machine name - # can be virtually everything (everything which is not - # "atarist" or "atariste" at least should have a processor - # > m68000). The system name ranges from "MiNT" over "FreeMiNT" - # to the lowercase version "mint" (or "freemint"). Finally - # the system name "TOS" denotes a system which is actually not - # MiNT. But MiNT is downward compatible to TOS, so this should - # be no problem. - atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} - exit ;; - atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} - exit ;; - *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} - exit ;; - milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) - echo m68k-milan-mint${UNAME_RELEASE} - exit ;; - hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) - echo m68k-hades-mint${UNAME_RELEASE} - exit ;; - *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) - echo m68k-unknown-mint${UNAME_RELEASE} - exit ;; - m68k:machten:*:*) - echo m68k-apple-machten${UNAME_RELEASE} - exit ;; - powerpc:machten:*:*) - echo powerpc-apple-machten${UNAME_RELEASE} - exit ;; - RISC*:Mach:*:*) - echo mips-dec-mach_bsd4.3 - exit ;; - RISC*:ULTRIX:*:*) - echo mips-dec-ultrix${UNAME_RELEASE} - exit ;; - VAX*:ULTRIX*:*:*) - echo vax-dec-ultrix${UNAME_RELEASE} - exit ;; - 2020:CLIX:*:* | 2430:CLIX:*:*) - echo clipper-intergraph-clix${UNAME_RELEASE} - exit ;; - mips:*:*:UMIPS | mips:*:*:RISCos) - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c -#ifdef __cplusplus -#include /* for printf() prototype */ - int main (int argc, char *argv[]) { -#else - int main (argc, argv) int argc; char *argv[]; { -#endif - #if defined (host_mips) && defined (MIPSEB) - #if defined (SYSTYPE_SYSV) - printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); - #endif - #if defined (SYSTYPE_SVR4) - printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); - #endif - #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) - printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); - #endif - #endif - exit (-1); - } -EOF - $CC_FOR_BUILD -o $dummy $dummy.c && - dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` && - SYSTEM_NAME=`$dummy $dummyarg` && - { echo "$SYSTEM_NAME"; exit; } - echo mips-mips-riscos${UNAME_RELEASE} - exit ;; - Motorola:PowerMAX_OS:*:*) - echo powerpc-motorola-powermax - exit ;; - Motorola:*:4.3:PL8-*) - echo powerpc-harris-powermax - exit ;; - Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) - echo powerpc-harris-powermax - exit ;; - Night_Hawk:Power_UNIX:*:*) - echo powerpc-harris-powerunix - exit ;; - m88k:CX/UX:7*:*) - echo m88k-harris-cxux7 - exit ;; - m88k:*:4*:R4*) - echo m88k-motorola-sysv4 - exit ;; - m88k:*:3*:R3*) - echo m88k-motorola-sysv3 - exit ;; - AViiON:dgux:*:*) - # DG/UX returns AViiON for all architectures - UNAME_PROCESSOR=`/usr/bin/uname -p` - if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] - then - if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ - [ ${TARGET_BINARY_INTERFACE}x = x ] - then - echo m88k-dg-dgux${UNAME_RELEASE} - else - echo m88k-dg-dguxbcs${UNAME_RELEASE} - fi - else - echo i586-dg-dgux${UNAME_RELEASE} - fi - exit ;; - M88*:DolphinOS:*:*) # DolphinOS (SVR3) - echo m88k-dolphin-sysv3 - exit ;; - M88*:*:R3*:*) - # Delta 88k system running SVR3 - echo m88k-motorola-sysv3 - exit ;; - XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) - echo m88k-tektronix-sysv3 - exit ;; - Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) - echo m68k-tektronix-bsd - exit ;; - *:IRIX*:*:*) - echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` - exit ;; - ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. - echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id - exit ;; # Note that: echo "'`uname -s`'" gives 'AIX ' - i*86:AIX:*:*) - echo i386-ibm-aix - exit ;; - ia64:AIX:*:*) - if [ -x /usr/bin/oslevel ] ; then - IBM_REV=`/usr/bin/oslevel` - else - IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} - fi - echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} - exit ;; - *:AIX:2:3) - if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #include - - main() - { - if (!__power_pc()) - exit(1); - puts("powerpc-ibm-aix3.2.5"); - exit(0); - } -EOF - if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` - then - echo "$SYSTEM_NAME" - else - echo rs6000-ibm-aix3.2.5 - fi - elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then - echo rs6000-ibm-aix3.2.4 - else - echo rs6000-ibm-aix3.2 - fi - exit ;; - *:AIX:*:[4567]) - IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` - if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then - IBM_ARCH=rs6000 - else - IBM_ARCH=powerpc - fi - if [ -x /usr/bin/oslevel ] ; then - IBM_REV=`/usr/bin/oslevel` - else - IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} - fi - echo ${IBM_ARCH}-ibm-aix${IBM_REV} - exit ;; - *:AIX:*:*) - echo rs6000-ibm-aix - exit ;; - ibmrt:4.4BSD:*|romp-ibm:BSD:*) - echo romp-ibm-bsd4.4 - exit ;; - ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and - echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to - exit ;; # report: romp-ibm BSD 4.3 - *:BOSX:*:*) - echo rs6000-bull-bosx - exit ;; - DPX/2?00:B.O.S.:*:*) - echo m68k-bull-sysv3 - exit ;; - 9000/[34]??:4.3bsd:1.*:*) - echo m68k-hp-bsd - exit ;; - hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) - echo m68k-hp-bsd4.4 - exit ;; - 9000/[34678]??:HP-UX:*:*) - HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` - case "${UNAME_MACHINE}" in - 9000/31? ) HP_ARCH=m68000 ;; - 9000/[34]?? ) HP_ARCH=m68k ;; - 9000/[678][0-9][0-9]) - if [ -x /usr/bin/getconf ]; then - sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` - sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` - case "${sc_cpu_version}" in - 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 - 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 - 532) # CPU_PA_RISC2_0 - case "${sc_kernel_bits}" in - 32) HP_ARCH="hppa2.0n" ;; - 64) HP_ARCH="hppa2.0w" ;; - '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 - esac ;; - esac - fi - if [ "${HP_ARCH}" = "" ]; then - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - - #define _HPUX_SOURCE - #include - #include - - int main () - { - #if defined(_SC_KERNEL_BITS) - long bits = sysconf(_SC_KERNEL_BITS); - #endif - long cpu = sysconf (_SC_CPU_VERSION); - - switch (cpu) - { - case CPU_PA_RISC1_0: puts ("hppa1.0"); break; - case CPU_PA_RISC1_1: puts ("hppa1.1"); break; - case CPU_PA_RISC2_0: - #if defined(_SC_KERNEL_BITS) - switch (bits) - { - case 64: puts ("hppa2.0w"); break; - case 32: puts ("hppa2.0n"); break; - default: puts ("hppa2.0"); break; - } break; - #else /* !defined(_SC_KERNEL_BITS) */ - puts ("hppa2.0"); break; - #endif - default: puts ("hppa1.0"); break; - } - exit (0); - } -EOF - (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` - test -z "$HP_ARCH" && HP_ARCH=hppa - fi ;; - esac - if [ ${HP_ARCH} = "hppa2.0w" ] - then - eval $set_cc_for_build - - # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating - # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler - # generating 64-bit code. GNU and HP use different nomenclature: - # - # $ CC_FOR_BUILD=cc ./config.guess - # => hppa2.0w-hp-hpux11.23 - # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess - # => hppa64-hp-hpux11.23 - - if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | - grep -q __LP64__ - then - HP_ARCH="hppa2.0w" - else - HP_ARCH="hppa64" - fi - fi - echo ${HP_ARCH}-hp-hpux${HPUX_REV} - exit ;; - ia64:HP-UX:*:*) - HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` - echo ia64-hp-hpux${HPUX_REV} - exit ;; - 3050*:HI-UX:*:*) - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #include - int - main () - { - long cpu = sysconf (_SC_CPU_VERSION); - /* The order matters, because CPU_IS_HP_MC68K erroneously returns - true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct - results, however. */ - if (CPU_IS_PA_RISC (cpu)) - { - switch (cpu) - { - case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; - case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; - case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; - default: puts ("hppa-hitachi-hiuxwe2"); break; - } - } - else if (CPU_IS_HP_MC68K (cpu)) - puts ("m68k-hitachi-hiuxwe2"); - else puts ("unknown-hitachi-hiuxwe2"); - exit (0); - } -EOF - $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` && - { echo "$SYSTEM_NAME"; exit; } - echo unknown-hitachi-hiuxwe2 - exit ;; - 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) - echo hppa1.1-hp-bsd - exit ;; - 9000/8??:4.3bsd:*:*) - echo hppa1.0-hp-bsd - exit ;; - *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) - echo hppa1.0-hp-mpeix - exit ;; - hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) - echo hppa1.1-hp-osf - exit ;; - hp8??:OSF1:*:*) - echo hppa1.0-hp-osf - exit ;; - i*86:OSF1:*:*) - if [ -x /usr/sbin/sysversion ] ; then - echo ${UNAME_MACHINE}-unknown-osf1mk - else - echo ${UNAME_MACHINE}-unknown-osf1 - fi - exit ;; - parisc*:Lites*:*:*) - echo hppa1.1-hp-lites - exit ;; - C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) - echo c1-convex-bsd - exit ;; - C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) - if getsysinfo -f scalar_acc - then echo c32-convex-bsd - else echo c2-convex-bsd - fi - exit ;; - C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) - echo c34-convex-bsd - exit ;; - C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) - echo c38-convex-bsd - exit ;; - C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) - echo c4-convex-bsd - exit ;; - CRAY*Y-MP:*:*:*) - echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - CRAY*[A-Z]90:*:*:*) - echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ - | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ - -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ - -e 's/\.[^.]*$/.X/' - exit ;; - CRAY*TS:*:*:*) - echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - CRAY*T3E:*:*:*) - echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - CRAY*SV1:*:*:*) - echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - *:UNICOS/mp:*:*) - echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) - FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` - FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` - FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` - echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" - exit ;; - 5000:UNIX_System_V:4.*:*) - FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` - FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'` - echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" - exit ;; - i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) - echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} - exit ;; - sparc*:BSD/OS:*:*) - echo sparc-unknown-bsdi${UNAME_RELEASE} - exit ;; - *:BSD/OS:*:*) - echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} - exit ;; - *:FreeBSD:*:*) - UNAME_PROCESSOR=`/usr/bin/uname -p` - case ${UNAME_PROCESSOR} in - amd64) - echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; - *) - echo ${UNAME_PROCESSOR}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; - esac - exit ;; - i*:CYGWIN*:*) - echo ${UNAME_MACHINE}-pc-cygwin - exit ;; - *:MINGW*:*) - echo ${UNAME_MACHINE}-pc-mingw32 - exit ;; - *:MSYS*:*) - echo ${UNAME_MACHINE}-pc-msys - exit ;; - i*:windows32*:*) - # uname -m includes "-pc" on this system. - echo ${UNAME_MACHINE}-mingw32 - exit ;; - i*:PW*:*) - echo ${UNAME_MACHINE}-pc-pw32 - exit ;; - *:Interix*:*) - case ${UNAME_MACHINE} in - x86) - echo i586-pc-interix${UNAME_RELEASE} - exit ;; - authenticamd | genuineintel | EM64T) - echo x86_64-unknown-interix${UNAME_RELEASE} - exit ;; - IA64) - echo ia64-unknown-interix${UNAME_RELEASE} - exit ;; - esac ;; - [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) - echo i${UNAME_MACHINE}-pc-mks - exit ;; - 8664:Windows_NT:*) - echo x86_64-pc-mks - exit ;; - i*:Windows_NT*:* | Pentium*:Windows_NT*:*) - # How do we know it's Interix rather than the generic POSIX subsystem? - # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we - # UNAME_MACHINE based on the output of uname instead of i386? - echo i586-pc-interix - exit ;; - i*:UWIN*:*) - echo ${UNAME_MACHINE}-pc-uwin - exit ;; - amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) - echo x86_64-unknown-cygwin - exit ;; - p*:CYGWIN*:*) - echo powerpcle-unknown-cygwin - exit ;; - prep*:SunOS:5.*:*) - echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - *:GNU:*:*) - # the GNU system - echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` - exit ;; - *:GNU/*:*:*) - # other systems with GNU libc and userland - echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-gnu - exit ;; - i*86:Minix:*:*) - echo ${UNAME_MACHINE}-pc-minix - exit ;; - aarch64*:Linux:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; - alpha:Linux:*:*) - case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in - EV5) UNAME_MACHINE=alphaev5 ;; - EV56) UNAME_MACHINE=alphaev56 ;; - PCA56) UNAME_MACHINE=alphapca56 ;; - PCA57) UNAME_MACHINE=alphapca56 ;; - EV6) UNAME_MACHINE=alphaev6 ;; - EV67) UNAME_MACHINE=alphaev67 ;; - EV68*) UNAME_MACHINE=alphaev68 ;; - esac - objdump --private-headers /bin/sh | grep -q ld.so.1 - if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi - echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC} - exit ;; - arm*:Linux:*:*) - eval $set_cc_for_build - if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \ - | grep -q __ARM_EABI__ - then - echo ${UNAME_MACHINE}-unknown-linux-gnu - else - if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ - | grep -q __ARM_PCS_VFP - then - echo ${UNAME_MACHINE}-unknown-linux-gnueabi - else - echo ${UNAME_MACHINE}-unknown-linux-gnueabihf - fi - fi - exit ;; - avr32*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; - cris:Linux:*:*) - echo cris-axis-linux-gnu - exit ;; - crisv32:Linux:*:*) - echo crisv32-axis-linux-gnu - exit ;; - frv:Linux:*:*) - echo frv-unknown-linux-gnu - exit ;; - i*86:Linux:*:*) - LIBC=gnu - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #ifdef __dietlibc__ - LIBC=dietlibc - #endif -EOF - eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC'` - echo "${UNAME_MACHINE}-pc-linux-${LIBC}" - exit ;; - ia64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; - m32r*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; - m68*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; - mips:Linux:*:* | mips64:Linux:*:*) - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #undef CPU - #undef ${UNAME_MACHINE} - #undef ${UNAME_MACHINE}el - #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) - CPU=${UNAME_MACHINE}el - #else - #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) - CPU=${UNAME_MACHINE} - #else - CPU= - #endif - #endif -EOF - eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'` - test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; } - ;; - or32:Linux:*:*) - echo or32-unknown-linux-gnu - exit ;; - padre:Linux:*:*) - echo sparc-unknown-linux-gnu - exit ;; - parisc64:Linux:*:* | hppa64:Linux:*:*) - echo hppa64-unknown-linux-gnu - exit ;; - parisc:Linux:*:* | hppa:Linux:*:*) - # Look for CPU level - case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in - PA7*) echo hppa1.1-unknown-linux-gnu ;; - PA8*) echo hppa2.0-unknown-linux-gnu ;; - *) echo hppa-unknown-linux-gnu ;; - esac - exit ;; - ppc64:Linux:*:*) - echo powerpc64-unknown-linux-gnu - exit ;; - ppc64le:Linux:*:*) - echo powerpc64le-unknown-linux-gnu - exit ;; - ppc:Linux:*:*) - echo powerpc-unknown-linux-gnu - exit ;; - s390:Linux:*:* | s390x:Linux:*:*) - echo ${UNAME_MACHINE}-ibm-linux - exit ;; - sh64*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; - sh*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; - sparc:Linux:*:* | sparc64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; - tile*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; - vax:Linux:*:*) - echo ${UNAME_MACHINE}-dec-linux-gnu - exit ;; - x86_64:Linux:*:*) - echo x86_64-unknown-linux-gnu - exit ;; - xtensa*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; - i*86:DYNIX/ptx:4*:*) - # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. - # earlier versions are messed up and put the nodename in both - # sysname and nodename. - echo i386-sequent-sysv4 - exit ;; - i*86:UNIX_SV:4.2MP:2.*) - # Unixware is an offshoot of SVR4, but it has its own version - # number series starting with 2... - # I am not positive that other SVR4 systems won't match this, - # I just have to hope. -- rms. - # Use sysv4.2uw... so that sysv4* matches it. - echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} - exit ;; - i*86:OS/2:*:*) - # If we were able to find `uname', then EMX Unix compatibility - # is probably installed. - echo ${UNAME_MACHINE}-pc-os2-emx - exit ;; - i*86:XTS-300:*:STOP) - echo ${UNAME_MACHINE}-unknown-stop - exit ;; - i*86:atheos:*:*) - echo ${UNAME_MACHINE}-unknown-atheos - exit ;; - i*86:syllable:*:*) - echo ${UNAME_MACHINE}-pc-syllable - exit ;; - i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*) - echo i386-unknown-lynxos${UNAME_RELEASE} - exit ;; - i*86:*DOS:*:*) - echo ${UNAME_MACHINE}-pc-msdosdjgpp - exit ;; - i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) - UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` - if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then - echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} - else - echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} - fi - exit ;; - i*86:*:5:[678]*) - # UnixWare 7.x, OpenUNIX and OpenServer 6. - case `/bin/uname -X | grep "^Machine"` in - *486*) UNAME_MACHINE=i486 ;; - *Pentium) UNAME_MACHINE=i586 ;; - *Pent*|*Celeron) UNAME_MACHINE=i686 ;; - esac - echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} - exit ;; - i*86:*:3.2:*) - if test -f /usr/options/cb.name; then - UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then - UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` - (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 - (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ - && UNAME_MACHINE=i586 - (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ - && UNAME_MACHINE=i686 - (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ - && UNAME_MACHINE=i686 - echo ${UNAME_MACHINE}-pc-sco$UNAME_REL - else - echo ${UNAME_MACHINE}-pc-sysv32 - fi - exit ;; - pc:*:*:*) - # Left here for compatibility: - # uname -m prints for DJGPP always 'pc', but it prints nothing about - # the processor, so we play safe by assuming i586. - # Note: whatever this is, it MUST be the same as what config.sub - # prints for the "djgpp" host, or else GDB configury will decide that - # this is a cross-build. - echo i586-pc-msdosdjgpp - exit ;; - Intel:Mach:3*:*) - echo i386-pc-mach3 - exit ;; - paragon:*:*:*) - echo i860-intel-osf1 - exit ;; - i860:*:4.*:*) # i860-SVR4 - if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then - echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 - else # Add other i860-SVR4 vendors below as they are discovered. - echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 - fi - exit ;; - mini*:CTIX:SYS*5:*) - # "miniframe" - echo m68010-convergent-sysv - exit ;; - mc68k:UNIX:SYSTEM5:3.51m) - echo m68k-convergent-sysv - exit ;; - M680?0:D-NIX:5.3:*) - echo m68k-diab-dnix - exit ;; - M68*:*:R3V[5678]*:*) - test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;; - 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0) - OS_REL='' - test -r /etc/.relid \ - && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` - /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ - && { echo i486-ncr-sysv4.3${OS_REL}; exit; } - /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ - && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; - 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) - /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ - && { echo i486-ncr-sysv4; exit; } ;; - NCR*:*:4.2:* | MPRAS*:*:4.2:*) - OS_REL='.3' - test -r /etc/.relid \ - && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` - /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ - && { echo i486-ncr-sysv4.3${OS_REL}; exit; } - /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ - && { echo i586-ncr-sysv4.3${OS_REL}; exit; } - /bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \ - && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; - m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) - echo m68k-unknown-lynxos${UNAME_RELEASE} - exit ;; - mc68030:UNIX_System_V:4.*:*) - echo m68k-atari-sysv4 - exit ;; - TSUNAMI:LynxOS:2.*:*) - echo sparc-unknown-lynxos${UNAME_RELEASE} - exit ;; - rs6000:LynxOS:2.*:*) - echo rs6000-unknown-lynxos${UNAME_RELEASE} - exit ;; - PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*) - echo powerpc-unknown-lynxos${UNAME_RELEASE} - exit ;; - SM[BE]S:UNIX_SV:*:*) - echo mips-dde-sysv${UNAME_RELEASE} - exit ;; - RM*:ReliantUNIX-*:*:*) - echo mips-sni-sysv4 - exit ;; - RM*:SINIX-*:*:*) - echo mips-sni-sysv4 - exit ;; - *:SINIX-*:*:*) - if uname -p 2>/dev/null >/dev/null ; then - UNAME_MACHINE=`(uname -p) 2>/dev/null` - echo ${UNAME_MACHINE}-sni-sysv4 - else - echo ns32k-sni-sysv - fi - exit ;; - PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort - # says - echo i586-unisys-sysv4 - exit ;; - *:UNIX_System_V:4*:FTX*) - # From Gerald Hewes . - # How about differentiating between stratus architectures? -djm - echo hppa1.1-stratus-sysv4 - exit ;; - *:*:*:FTX*) - # From seanf@swdc.stratus.com. - echo i860-stratus-sysv4 - exit ;; - i*86:VOS:*:*) - # From Paul.Green@stratus.com. - echo ${UNAME_MACHINE}-stratus-vos - exit ;; - *:VOS:*:*) - # From Paul.Green@stratus.com. - echo hppa1.1-stratus-vos - exit ;; - mc68*:A/UX:*:*) - echo m68k-apple-aux${UNAME_RELEASE} - exit ;; - news*:NEWS-OS:6*:*) - echo mips-sony-newsos6 - exit ;; - R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) - if [ -d /usr/nec ]; then - echo mips-nec-sysv${UNAME_RELEASE} - else - echo mips-unknown-sysv${UNAME_RELEASE} - fi - exit ;; - BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. - echo powerpc-be-beos - exit ;; - BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. - echo powerpc-apple-beos - exit ;; - BePC:BeOS:*:*) # BeOS running on Intel PC compatible. - echo i586-pc-beos - exit ;; - BePC:Haiku:*:*) # Haiku running on Intel PC compatible. - echo i586-pc-haiku - exit ;; - x86_64:Haiku:*:*) # Haiku running on x86_64. - echo x86_64-unknown-haiku - exit ;; - SX-4:SUPER-UX:*:*) - echo sx4-nec-superux${UNAME_RELEASE} - exit ;; - SX-5:SUPER-UX:*:*) - echo sx5-nec-superux${UNAME_RELEASE} - exit ;; - SX-6:SUPER-UX:*:*) - echo sx6-nec-superux${UNAME_RELEASE} - exit ;; - SX-7:SUPER-UX:*:*) - echo sx7-nec-superux${UNAME_RELEASE} - exit ;; - SX-8:SUPER-UX:*:*) - echo sx8-nec-superux${UNAME_RELEASE} - exit ;; - SX-8R:SUPER-UX:*:*) - echo sx8r-nec-superux${UNAME_RELEASE} - exit ;; - Power*:Rhapsody:*:*) - echo powerpc-apple-rhapsody${UNAME_RELEASE} - exit ;; - *:Rhapsody:*:*) - echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} - exit ;; - *:Darwin:*:*) - UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown - case $UNAME_PROCESSOR in - i386) - eval $set_cc_for_build - if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then - if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ - (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ - grep IS_64BIT_ARCH >/dev/null - then - UNAME_PROCESSOR="x86_64" - fi - fi ;; - unknown) UNAME_PROCESSOR=powerpc ;; - esac - echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} - exit ;; - *:procnto*:*:* | *:QNX:[0123456789]*:*) - UNAME_PROCESSOR=`uname -p` - if test "$UNAME_PROCESSOR" = "x86"; then - UNAME_PROCESSOR=i386 - UNAME_MACHINE=pc - fi - echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} - exit ;; - *:QNX:*:4*) - echo i386-pc-qnx - exit ;; - NEO-?:NONSTOP_KERNEL:*:*) - echo neo-tandem-nsk${UNAME_RELEASE} - exit ;; - NSE-?:NONSTOP_KERNEL:*:*) - echo nse-tandem-nsk${UNAME_RELEASE} - exit ;; - NSR-?:NONSTOP_KERNEL:*:*) - echo nsr-tandem-nsk${UNAME_RELEASE} - exit ;; - *:NonStop-UX:*:*) - echo mips-compaq-nonstopux - exit ;; - BS2000:POSIX*:*:*) - echo bs2000-siemens-sysv - exit ;; - DS/*:UNIX_System_V:*:*) - echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} - exit ;; - *:Plan9:*:*) - # "uname -m" is not consistent, so use $cputype instead. 386 - # is converted to i386 for consistency with other x86 - # operating systems. - if test "$cputype" = "386"; then - UNAME_MACHINE=i386 - else - UNAME_MACHINE="$cputype" - fi - echo ${UNAME_MACHINE}-unknown-plan9 - exit ;; - *:TOPS-10:*:*) - echo pdp10-unknown-tops10 - exit ;; - *:TENEX:*:*) - echo pdp10-unknown-tenex - exit ;; - KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) - echo pdp10-dec-tops20 - exit ;; - XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) - echo pdp10-xkl-tops20 - exit ;; - *:TOPS-20:*:*) - echo pdp10-unknown-tops20 - exit ;; - *:ITS:*:*) - echo pdp10-unknown-its - exit ;; - SEI:*:*:SEIUX) - echo mips-sei-seiux${UNAME_RELEASE} - exit ;; - *:DragonFly:*:*) - echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` - exit ;; - *:*VMS:*:*) - UNAME_MACHINE=`(uname -p) 2>/dev/null` - case "${UNAME_MACHINE}" in - A*) echo alpha-dec-vms ; exit ;; - I*) echo ia64-dec-vms ; exit ;; - V*) echo vax-dec-vms ; exit ;; - esac ;; - *:XENIX:*:SysV) - echo i386-pc-xenix - exit ;; - i*86:skyos:*:*) - echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//' - exit ;; - i*86:rdos:*:*) - echo ${UNAME_MACHINE}-pc-rdos - exit ;; - i*86:AROS:*:*) - echo ${UNAME_MACHINE}-pc-aros - exit ;; -esac - -#echo '(No uname command or uname output not recognized.)' 1>&2 -#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2 - -eval $set_cc_for_build -cat >$dummy.c < -# include -#endif -main () -{ -#if defined (sony) -#if defined (MIPSEB) - /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, - I don't know.... */ - printf ("mips-sony-bsd\n"); exit (0); -#else -#include - printf ("m68k-sony-newsos%s\n", -#ifdef NEWSOS4 - "4" -#else - "" -#endif - ); exit (0); -#endif -#endif - -#if defined (__arm) && defined (__acorn) && defined (__unix) - printf ("arm-acorn-riscix\n"); exit (0); -#endif - -#if defined (hp300) && !defined (hpux) - printf ("m68k-hp-bsd\n"); exit (0); -#endif - -#if defined (NeXT) -#if !defined (__ARCHITECTURE__) -#define __ARCHITECTURE__ "m68k" -#endif - int version; - version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; - if (version < 4) - printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); - else - printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); - exit (0); -#endif - -#if defined (MULTIMAX) || defined (n16) -#if defined (UMAXV) - printf ("ns32k-encore-sysv\n"); exit (0); -#else -#if defined (CMU) - printf ("ns32k-encore-mach\n"); exit (0); -#else - printf ("ns32k-encore-bsd\n"); exit (0); -#endif -#endif -#endif - -#if defined (__386BSD__) - printf ("i386-pc-bsd\n"); exit (0); -#endif - -#if defined (sequent) -#if defined (i386) - printf ("i386-sequent-dynix\n"); exit (0); -#endif -#if defined (ns32000) - printf ("ns32k-sequent-dynix\n"); exit (0); -#endif -#endif - -#if defined (_SEQUENT_) - struct utsname un; - - uname(&un); - - if (strncmp(un.version, "V2", 2) == 0) { - printf ("i386-sequent-ptx2\n"); exit (0); - } - if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ - printf ("i386-sequent-ptx1\n"); exit (0); - } - printf ("i386-sequent-ptx\n"); exit (0); - -#endif - -#if defined (vax) -# if !defined (ultrix) -# include -# if defined (BSD) -# if BSD == 43 - printf ("vax-dec-bsd4.3\n"); exit (0); -# else -# if BSD == 199006 - printf ("vax-dec-bsd4.3reno\n"); exit (0); -# else - printf ("vax-dec-bsd\n"); exit (0); -# endif -# endif -# else - printf ("vax-dec-bsd\n"); exit (0); -# endif -# else - printf ("vax-dec-ultrix\n"); exit (0); -# endif -#endif - -#if defined (alliant) && defined (i860) - printf ("i860-alliant-bsd\n"); exit (0); -#endif - - exit (1); -} -EOF - -$CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && SYSTEM_NAME=`$dummy` && - { echo "$SYSTEM_NAME"; exit; } - -# Apollos put the system type in the environment. - -test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; } - -# Convex versions that predate uname can use getsysinfo(1) - -if [ -x /usr/convex/getsysinfo ] -then - case `getsysinfo -f cpu_type` in - c1*) - echo c1-convex-bsd - exit ;; - c2*) - if getsysinfo -f scalar_acc - then echo c32-convex-bsd - else echo c2-convex-bsd - fi - exit ;; - c34*) - echo c34-convex-bsd - exit ;; - c38*) - echo c38-convex-bsd - exit ;; - c4*) - echo c4-convex-bsd - exit ;; - esac -fi - -cat >&2 < in order to provide the needed -information to handle your system. - -config.guess timestamp = $timestamp - -uname -m = `(uname -m) 2>/dev/null || echo unknown` -uname -r = `(uname -r) 2>/dev/null || echo unknown` -uname -s = `(uname -s) 2>/dev/null || echo unknown` -uname -v = `(uname -v) 2>/dev/null || echo unknown` - -/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` -/bin/uname -X = `(/bin/uname -X) 2>/dev/null` - -hostinfo = `(hostinfo) 2>/dev/null` -/bin/universe = `(/bin/universe) 2>/dev/null` -/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` -/bin/arch = `(/bin/arch) 2>/dev/null` -/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` -/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` - -UNAME_MACHINE = ${UNAME_MACHINE} -UNAME_RELEASE = ${UNAME_RELEASE} -UNAME_SYSTEM = ${UNAME_SYSTEM} -UNAME_VERSION = ${UNAME_VERSION} -EOF - -exit 1 - -# Local variables: -# eval: (add-hook 'write-file-hooks 'time-stamp) -# time-stamp-start: "timestamp='" -# time-stamp-format: "%:y-%02m-%02d" -# time-stamp-end: "'" -# End: diff --git a/runtime/libpgmath/cmake/modules/GetHostTriple.cmake b/runtime/libpgmath/cmake/modules/GetHostTriple.cmake index 59eb85a0f3..ae7d28d6fb 100644 --- a/runtime/libpgmath/cmake/modules/GetHostTriple.cmake +++ b/runtime/libpgmath/cmake/modules/GetHostTriple.cmake @@ -1,5 +1,11 @@ # Returns the host triple. # Invokes config.guess +# +# Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +# Notified per clause 4(b) of the license. +# +# Last Modified: May 2020 +# function( get_host_triple var ) if( MSVC ) @@ -15,15 +21,18 @@ function( get_host_triple var ) set( value "i686-pc-mingw32" ) endif() else( MSVC ) - set(config_guess ${CMAKE_CURRENT_SOURCE_DIR}/cmake/config.guess) - execute_process(COMMAND sh ${config_guess} - RESULT_VARIABLE TT_RV - OUTPUT_VARIABLE TT_OUT - OUTPUT_STRIP_TRAILING_WHITESPACE) - if( NOT TT_RV EQUAL 0 ) - message(FATAL_ERROR "Failed to execute ${config_guess}") - endif( NOT TT_RV EQUAL 0 ) - set( value ${TT_OUT} ) +# +# AOCC: removing usage of config.guess and hardcoding target-triple +# +# set(config_guess ${CMAKE_CURRENT_SOURCE_DIR}/cmake/config.guess) +# execute_process(COMMAND sh ${config_guess} +# RESULT_VARIABLE TT_RV +# OUTPUT_VARIABLE TT_OUT +# OUTPUT_STRIP_TRAILING_WHITESPACE) +# if( NOT TT_RV EQUAL 0 ) +# message(FATAL_ERROR "Failed to execute ${config_guess}") +# endif( NOT TT_RV EQUAL 0 ) + set( value "x86_64-unknown-linux-gnu") endif( MSVC ) set( ${var} ${value} PARENT_SCOPE ) endfunction( get_host_triple var ) diff --git a/runtime/libpgmath/cmake/modules/HandleOutOfTreeLLVM.cmake b/runtime/libpgmath/cmake/modules/HandleOutOfTreeLLVM.cmake index 83948b14fd..3e16e263a9 100644 --- a/runtime/libpgmath/cmake/modules/HandleOutOfTreeLLVM.cmake +++ b/runtime/libpgmath/cmake/modules/HandleOutOfTreeLLVM.cmake @@ -14,8 +14,7 @@ macro(find_llvm_parts) set(LIBCXX_USING_INSTALLED_LLVM 1) set(CONFIG_COMMAND ${LLVM_CONFIG_PATH} "--includedir" - "--prefix" - "--src-root") + "--prefix") execute_process( COMMAND ${CONFIG_COMMAND} RESULT_VARIABLE HAD_ERROR diff --git a/runtime/libpgmath/lib/CMakeLists.txt b/runtime/libpgmath/lib/CMakeLists.txt index 616b60b740..a433a270cf 100644 --- a/runtime/libpgmath/lib/CMakeLists.txt +++ b/runtime/libpgmath/lib/CMakeLists.txt @@ -4,6 +4,10 @@ # SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception # +if(${ENABLE_RUN_PACKAGE}) + set(RUN_PACKAGE "runtime/") +endif() + # This value will be the same as LIBPGMATH_SYSTEM_PROCESSOR set(PROCESSOR ${LIBPGMATH_SYSTEM_PROCESSOR}) if(${LIBPGMATH_WITH_GENERIC} OR (NOT ${LIBPGMATH_SYSTEM_PROCESSOR} MATCHES "x86_64|aarch64")) @@ -21,13 +25,13 @@ if(${LIBPGMATH_SYSTEM_PROCESSOR} MATCHES "x86_64" AND NOT ${LIBPGMATH_WITH_GENER HOST_LINUX LINUX LINUX86 LINUX8664 MAXCPUS=256 MAXCPUSL=8 MAXCPUSR=8 TARGET_LINUX TARGET_LINUX_X86 TARGET_LINUX_X8664 TARGET_X86 TARGET_X8664 __gnu_linux__ PG_PIC) - set(FLAGS_L1 "-m64 -O3 ") + set(FLAGS_L1 "-m64 -O3 -w ") set(DEFINITIONS_L2 LINUX LINUX86 LINUX8664 MAXCPUS=256 MAXCPUSL=8 MAXCPUSR=8 __gnu_linux__ TARGET_LINUX TARGET_LINUX_X86 TARGET_LINUX_X8664 TARGET_X86 TARGET_X8664 PG_PIC) - set(FLAGS_L2 "-m64 -O3 -mtune=core-avx2 -march=core-avx2 ") + set(FLAGS_L2 "-m64 -O3 -mtune=core-avx2 -march=core-avx2 -w ") # common # Definitions and compiler flags for level 1 directories @@ -252,6 +256,6 @@ else() set_target_properties(${LIBPGMATH_LIBRARY_NAME}_static PROPERTIES OUTPUT_NAME ${LIBPGMATH_LIBRARY_NAME}) endif() install(TARGETS ${LIBPGMATH_LIBRARY_NAME} - LIBRARY DESTINATION lib) + LIBRARY DESTINATION ${RUN_PACKAGE}${CMAKE_INSTALL_LIBDIR}) install(TARGETS ${LIBPGMATH_LIBRARY_NAME}_static - ARCHIVE DESTINATION lib) + ARCHIVE DESTINATION ${RUN_PACKAGE}${CMAKE_INSTALL_LIBDIR}) diff --git a/runtime/libpgmath/lib/aarch64/CMakeLists.txt b/runtime/libpgmath/lib/aarch64/CMakeLists.txt index 4fe7cafa8c..6f1bb823a6 100644 --- a/runtime/libpgmath/lib/aarch64/CMakeLists.txt +++ b/runtime/libpgmath/lib/aarch64/CMakeLists.txt @@ -16,3 +16,4 @@ add_subdirectory("sin") add_subdirectory("sinh") add_subdirectory("tan") add_subdirectory("tanh") +add_subdirectory("cotan") diff --git a/runtime/libpgmath/lib/common/CMakeLists.txt b/runtime/libpgmath/lib/common/CMakeLists.txt index 731cdba3cd..8590701f6b 100644 --- a/runtime/libpgmath/lib/common/CMakeLists.txt +++ b/runtime/libpgmath/lib/common/CMakeLists.txt @@ -3,6 +3,12 @@ # See https://llvm.org/LICENSE.txt for license information. # SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception # +# Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +# Notified per clause 4(b) of the license. +# +# +#Complex type support for acosh , asinh , atanh +#Modified on 07 January 2020 include_directories(${CMAKE_CURRENT_SOURCE_DIR}) @@ -36,9 +42,10 @@ if(${LIBPGMATH_SYSTEM_PROCESSOR} MATCHES "x86_64" AND NOT ${LIBPGMATH_WITH_GENER if(${LIBPGMATH_SYSTEM_NAME} MATCHES "Linux") add_subdirectory("sincosf") add_subdirectory("tanf") + add_subdirectory("cotanf") # Specific definition, will probably need to remove when we create a single file for each def - set_property(SOURCE dispatch.c APPEND_STRING PROPERTY COMPILE_FLAGS "-fno-builtin-c{sqrt,pow,log,exp,acos,asin,atan,cos,sin,tan,cosh,sinh,tanh}{,f} -fno-builtin-{ceil,floor}{,f}") + set_property(SOURCE dispatch.c APPEND_STRING PROPERTY COMPILE_FLAGS "-fno-builtin-c{sqrt,pow,log,exp,acos,asin,atan,cos,sin,tan,cosh,sinh,tanh,cotan}{,f} -fno-builtin-{ceil,floor}{,f}") set_property(SOURCE dispatch.c APPEND PROPERTY COMPILE_DEFINITIONS PGFLANG) set_property(SOURCE mth_xintrinsics.c APPEND_STRING PROPERTY COMPILE_FLAGS "-march=core2 ") set_property(SOURCE mth_yintrinsics.c APPEND_STRING PROPERTY COMPILE_FLAGS "-march=sandybridge ") @@ -76,9 +83,10 @@ if(${LIBPGMATH_SYSTEM_PROCESSOR} MATCHES "x86_64" AND NOT ${LIBPGMATH_WITH_GENER elseif(${LIBPGMATH_SYSTEM_NAME} MATCHES "Darwin|Windows") add_subdirectory("sincosf") add_subdirectory("tanf") + add_subdirectory("cotanf") # Specific definition, will probably need to remove when we create a single file for each def - set_property(SOURCE dispatch.c APPEND_STRING PROPERTY COMPILE_FLAGS "-fno-builtin-c{sqrt,pow,log,exp,acos,asin,atan,cos,sin,tan,cosh,sinh,tanh}{,f} -fno-builtin-{ceil,floor}{,f}") + set_property(SOURCE dispatch.c APPEND_STRING PROPERTY COMPILE_FLAGS "-fno-builtin-c{sqrt,pow,log,exp,acos,asin,atan,cos,sin,tan,cosh,sinh,tanh,cotan}{,f} -fno-builtin-{ceil,floor}{,f}") set_property(SOURCE dispatch.c APPEND PROPERTY COMPILE_DEFINITIONS PGFLANG) set_property(SOURCE mth_xintrinsics.c APPEND_STRING PROPERTY COMPILE_FLAGS "-msse2 ") set_property(SOURCE mth_yintrinsics.c APPEND_STRING PROPERTY COMPILE_FLAGS "-mavx ") @@ -172,6 +180,12 @@ set(MTH_CMPLX_SRCS catan.c ccos.c ccosh.c + #AOCC Begin + casinh.c + cacosh.c + catanh.c + catan2.c + #AOCC End cdabs.c cdacos.c cdasin.c @@ -191,6 +205,7 @@ set(MTH_CMPLX_SRCS cdsinh.c cdsqrt.c cdtan.c + cdcotan.c cdtanh.c cexp.c clog.c @@ -201,7 +216,11 @@ set(MTH_CMPLX_SRCS csinh.c csqrt.c ctan.c - ctanh.c) + ccotan.c + ctanh.c + cqdiv.c + cqpowi.c + cqpowk.c) set(SRCS ${SRCS} @@ -224,41 +243,62 @@ set(SRCS dasind.c datan2d.c datand.c + qacosd.c + qasind.c + qatan2d.c + qatand.c dbessel_j0.c dbessel_j1.c dbessel_jn.c dbessel_y0.c dbessel_y1.c dbessel_yn.c + qbessel_j0.c + qbessel_j1.c + qbessel_jn.c + qbessel_y0.c + qbessel_y1.c + qbessel_yn.c + qnint.c dceil.c dcosd.c + qcosd.c dfloor.c dmod.c dpowi.c + qpowi.c dpowk.c dsign.c dsind.c + qsind.c dtand.c + qtand.c erf.c erfc.c erfc_scaled.c erfc_scaledf.c erfcf.c erff.c + erfc_scaledq.c + erfcq.c + erfq.c floor.c fltfenv.c fltmanip.c fpcvt.c gamma.c gammaf.c + gammaq.c hypot.c hypotf.c + hypotq.c i2powi.c ipowi.c kpowi.c kpowk.c log_gamma.c log_gammaf.c + log_gammaq.c mod.c mth_vreturns.c mth_xintrinsics.c @@ -268,7 +308,11 @@ set(SRCS rpowk.c sign.c sind.c - tand.c) + tand.c + cotand.c + dcotand.c + qcotand.c + qcotan.c) libmath_add_object_library("${SRCS}" "${FLAGS}" "${DEFINITIONS}" "") set(DEFINITIONS_CMPLX ${DEFINITIONS} MTH_CMPLX_C99_ABI) diff --git a/runtime/libpgmath/lib/common/arm64intrin.h b/runtime/libpgmath/lib/common/arm64intrin.h index 9c9a73170b..d99a7be96f 100644 --- a/runtime/libpgmath/lib/common/arm64intrin.h +++ b/runtime/libpgmath/lib/common/arm64intrin.h @@ -26,6 +26,10 @@ */ struct __s128f { + at (*fptr)(float); + fptr = (float(*)(float))MTH_DISPATCH_TBL[func_tan][sv_ss][frp_f]; + return __ZGVxN4v__mth_i_vr4( x, fptr); +} typedef float vrs4_t __attribute__((vector_size(4 * sizeof(float)))); typedef double vrd2_t __attribute__((vector_size(2 * sizeof(double)))); union { diff --git a/runtime/libpgmath/lib/common/cacosh.c b/runtime/libpgmath/lib/common/cacosh.c new file mode 100644 index 0000000000..2dc7f6f67e --- /dev/null +++ b/runtime/libpgmath/lib/common/cacosh.c @@ -0,0 +1,25 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Support for complex datatype arguments + * Date of Modification: 08 January 2020 + * + */ +#pragma global - Mx, 6, 0x100 + +#include "mthdecls.h" + +CMPLXFUNC_C(__mth_i_cacosh) +{ + CMPLXARGS_C; + float_complex_t f; + f = cacoshf(carg); + CRETURN_C(f); +} diff --git a/runtime/libpgmath/lib/common/casinh.c b/runtime/libpgmath/lib/common/casinh.c new file mode 100644 index 0000000000..443316e96d --- /dev/null +++ b/runtime/libpgmath/lib/common/casinh.c @@ -0,0 +1,25 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Support for complex datatype argumentts + * Date of Modification: 08 January 2020 + * + */ +#pragma global - Mx, 6, 0x100 + +#include "mthdecls.h" + +CMPLXFUNC_C(__mth_i_casinh) +{ + CMPLXARGS_C; + float_complex_t f; + f = casinhf(carg); + CRETURN_C(f); +} diff --git a/runtime/libpgmath/lib/common/catan2.c b/runtime/libpgmath/lib/common/catan2.c new file mode 100644 index 0000000000..3ecfeeb954 --- /dev/null +++ b/runtime/libpgmath/lib/common/catan2.c @@ -0,0 +1,57 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * + * Complex datatype support for atan2 under flag f2008 + * Modified on 13th March 2020 + * + */ + +/* inhibit floating point copy propagation */ +#pragma global - Mx, 6, 0x100 + +#include "mthdecls.h" + +CMPLXFUNC_C_C(__mth_i_catan2) +{ + CMPLXARGS_C_C; + + float_complex_t ir; + float_complex_t r; + static double pi = 3.1415926535897932e+00, piby2 = 1.5707963267948966e+00; + double _Complex cpi = PGMATH_CMPLX_CONST(pi, 0); + double _Complex cpiby2 = PGMATH_CMPLX_CONST(piby2, 0); + double _Complex comp = PGMATH_CMPLX_CONST(0, 0); + + double x = __builtin_creal(carg1); + double y = __builtin_creal(carg2); + + CMPLX_CALL_CR_C_C(__mth_i_cdiv, ir, carg1, carg2); + r = catan(ir); + + if (x > 0) { + CRETURN_C(r); + } + else if((x < 0) && (y >= 0)) { + float_complex_t res = r + cpi; + CRETURN_C(res); + } + else if((x < 0) && (y < 0)) { + float_complex_t res = r - cpi; + CRETURN_C(res); + } + else if((x == 0) && (y > 0)) { + CRETURN_C(cpiby2); + } + else if((x == 0) && (y < 0)) { + float_complex_t res = -cpiby2; + CRETURN_C(res); + } +} diff --git a/runtime/libpgmath/lib/common/catanh.c b/runtime/libpgmath/lib/common/catanh.c new file mode 100644 index 0000000000..17173536d7 --- /dev/null +++ b/runtime/libpgmath/lib/common/catanh.c @@ -0,0 +1,25 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Support for complex datatype arguments + * Date of Modification: 08 January 2020 + * + */ +#pragma global - Mx, 6, 0x100 + +#include "mthdecls.h" + +CMPLXFUNC_C(__mth_i_catanh) +{ + CMPLXARGS_C; + float_complex_t f; + f = catanhf(carg); + CRETURN_C(f); +} diff --git a/runtime/libpgmath/lib/common/ccotan.c b/runtime/libpgmath/lib/common/ccotan.c new file mode 100644 index 0000000000..c550571069 --- /dev/null +++ b/runtime/libpgmath/lib/common/ccotan.c @@ -0,0 +1,19 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + +/* inhibit floating point copy propagation */ +#pragma global - Mx, 6, 0x100 + +#include "mthdecls.h" + +CMPLXFUNC_C(__mth_i_ccotan) +{ + CMPLXARGS_C; + float_complex_t f; + f = 1.0/ctanf(carg); + CRETURN_C(f); +} diff --git a/runtime/libpgmath/lib/common/ccotanf.c b/runtime/libpgmath/lib/common/ccotanf.c new file mode 100644 index 0000000000..14b95b8365 --- /dev/null +++ b/runtime/libpgmath/lib/common/ccotanf.c @@ -0,0 +1,15 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + +/* inhibit floating point copy propagation */ + +#include "mthdecls.h" + +float_complex_t +ccotanf(float_complex_t arg) { + return 1.0/ctanf(arg); +} diff --git a/runtime/libpgmath/lib/common/cdcotan.c b/runtime/libpgmath/lib/common/cdcotan.c new file mode 100644 index 0000000000..b1c8852170 --- /dev/null +++ b/runtime/libpgmath/lib/common/cdcotan.c @@ -0,0 +1,19 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + +/* inhibit floating point copy propagation */ +#pragma global - Mx, 6, 0x100 + +#include "mthdecls.h" + +ZMPLXFUNC_Z(__mth_i_cdcotan) +{ + ZMPLXARGS_Z; + double_complex_t d; + d = 1.0/ctan(zarg); + ZRETURN_Z(d); +} diff --git a/runtime/libpgmath/lib/common/cotand.c b/runtime/libpgmath/lib/common/cotand.c new file mode 100644 index 0000000000..c186c4a1ab --- /dev/null +++ b/runtime/libpgmath/lib/common/cotand.c @@ -0,0 +1,14 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + +#include "mthdecls.h" + +float +__mth_i_cotand(float f) +{ + return 1.0/tanf(CNVRTDEG(f)); +} diff --git a/runtime/libpgmath/lib/common/cotanf/CMakeLists.txt b/runtime/libpgmath/lib/common/cotanf/CMakeLists.txt new file mode 100644 index 0000000000..7aa7baa9b4 --- /dev/null +++ b/runtime/libpgmath/lib/common/cotanf/CMakeLists.txt @@ -0,0 +1,24 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +# Set compiler flags and definitions +get_property(DEFINITIONS GLOBAL PROPERTY "DEFINITIONS_L1") +get_property(FLAGS GLOBAL PROPERTY "FLAGS_L1") + +# Set source files and compilation flags +set(COREAVX2_SRCS fs_cotan_1_avx2.cpp fs_cotan_4_avx2.cpp fs_cotan_8_avx2.cpp) +set_property(SOURCE ${COREAVX2_SRCS} APPEND_STRING PROPERTY COMPILE_FLAGS "-mtune=core-avx2 -march=core-avx2 ") +set(SKYLAKE_SRCS fs_cotan_16_avx512.cpp) +set_property(SOURCE ${SKYLAKE_SRCS} APPEND_STRING PROPERTY COMPILE_FLAGS "-mtune=skylake-avx512 -march=skylake-avx512 ") + +# Set source files +set(SRCS + ${COREAVX2_SRCS} + ${SKYLAKE_SRCS}) +set_property(SOURCE ${SRCS} APPEND_STRING PROPERTY COMPILE_FLAGS "-Wno-attributes ") +set_property(SOURCE ${SRCS} APPEND_STRING PROPERTY COMPILE_DEFINITIONS "PGI ") + +libmath_add_object_library("${SRCS}" "${FLAGS}" "${DEFINITIONS}" "") diff --git a/runtime/libpgmath/lib/common/cotanf/common_cotanf.h b/runtime/libpgmath/lib/common/cotanf/common_cotanf.h new file mode 100644 index 0000000000..de93a5b360 --- /dev/null +++ b/runtime/libpgmath/lib/common/cotanf/common_cotanf.h @@ -0,0 +1,75 @@ + +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + + +#ifndef COMMON_H_H63T0LSL +#define COMMON_H_H63T0LSL + +#include + +#define FMAF __builtin_fmaf + +/* Constants for Cody-Waite argument reduction */ +#define _2_OVER_PI_F 6.36619772e-01f +#define PI_2_HI_F 1.57079601e+00f +#define PI_2_MI_F 3.13916473e-07f +#define PI_2_LO_F 5.38561632e-15f +#define THRESHOLD_F 1.00000000e+04f + +/* Coefficents of approximate tan on [-PI/4,+PI/4] */ +#define A_F 9.42561682e-03f +#define B_F 3.06017953e-03f +#define C_F 2.44512185e-02f +#define D_F 5.34108058e-02f +#define E_F 1.33389056e-01f +#define F_F 3.33331138e-01f + +/* 192 bits of 2/PI for Payne-Hanek argument reduction. */ +static uint32_t i2opi_f [] = { + 0x3c439041, + 0xdb629599, + 0xf534ddc0, + 0xfc2757d1, + 0x4e441529, + 0xa2f9836e, +}; + +#define PI_2_M64 1.70306079004327746902e-19 + +/* -fno-strict-aliasing */ +static int32_t +float_as_int(float f) +{ + return *(int32_t*)&f; +} + +/* -fno-strict-aliasing */ +static float +int_as_float(int32_t i) +{ + return *(float*)&i; +} + +typedef struct { + uint32_t x; + uint32_t y; +} uint2; + +/* -fno-strict-aliasing */ +static uint2 +umad32wide(uint32_t a, uint32_t b, uint32_t c) +{ + union { + uint2 ui2; + uint64_t ull; + } res; + res.ull = (uint64_t)a * b + c; + return res.ui2; +} + +#endif diff --git a/runtime/libpgmath/lib/common/cotanf/cotan_f_vec.h b/runtime/libpgmath/lib/common/cotanf/cotan_f_vec.h new file mode 100644 index 0000000000..90f91e1b92 --- /dev/null +++ b/runtime/libpgmath/lib/common/cotanf/cotan_f_vec.h @@ -0,0 +1,184 @@ + +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + + +#include +#include + +//static vmask i2opi_vec[] = { +// vcast_vm_i_i(0, i2opi_f[0]), +// vcast_vm_i_i(0, i2opi_f[1]), +// vcast_vm_i_i(0, i2opi_f[2]), +// vcast_vm_i_i(0, i2opi_f[3]), +// vcast_vm_i_i(0, i2opi_f[4]), +// vcast_vm_i_i(0, i2opi_f[5]), +//}; + +vfloat static INLINE +__reduction_slowpath(vfloat const a, vmask *h) +{ + vint2 ia, e, idx, q, p, s; + vint2 ia_a, ia_b, p_a, p_b, hi_a, hi_b; + vint2 hi, lo, ll, prev, prev2; + + vmask i2opi_vec[] = { + vcast_vm_i_i(0, i2opi_f[0]), + vcast_vm_i_i(0, i2opi_f[1]), + vcast_vm_i_i(0, i2opi_f[2]), + vcast_vm_i_i(0, i2opi_f[3]), + vcast_vm_i_i(0, i2opi_f[4]), + vcast_vm_i_i(0, i2opi_f[5]), + }; + + ia = (vint2)a; + s = vand_vi2_vi2_vi2(ia, vcast_vi2_i(0x80000000)); + /* e = ((ia >> 23) & 0xff) - 127; */ + e = vsrl_vi2_vi2_i(ia, 23); + e = vand_vi2_vi2_vi2(e, vcast_vi2_i(0xff)); + e = vsub_vi2_vi2_vi2(e, vcast_vi2_i(127)); + /* ia = (ia << 8) | 0x80000000; */ + ia = vsll_vi2_vi2_i(ia, 8); + ia = vor_vi2_vi2_vi2(ia, vcast_vi2_i(0x80000000)); + + /* compute x * 1/pi */ + /* idx = 6 - ((e >> 5) & 3); */ + idx = vsrl_vi2_vi2_i(e, 5); + idx = vand_vi2_vi2_vi2(idx, vcast_vi2_i(3)); + idx = vsub_vi2_vi2_vi2(vcast_vi2_i(6), idx); + + ia_a = vsrl64_vi2_vi2_i(ia, 32); + ia_b = ia; + hi_a = vcast_vi2_i(0); + hi_b = vcast_vi2_i(0); + + q = vcast_vi2_i(0); + for (int i = 0; i < 6; i++) { + p_a = vmulu_vi2_vi2_vi2((vint2)i2opi_vec[i], ia_a); + p_b = vmulu_vi2_vi2_vi2((vint2)i2opi_vec[i], ia_b); + p_a = vadd64_vi2_vi2_vi2(p_a, hi_a); + p_b = vadd64_vi2_vi2_vi2(p_b, hi_b); + + hi_a = vsrl64_vi2_vi2_i(p_a, 32); + hi_b = vsrl64_vi2_vi2_i(p_b, 32); + + p_a = vsll64_vi2_vi2_i(p_a, 32); + p_b = vand_vi2_vi2_vi2(p_b, vcast_vm_i_i(0, 0xffffffff)); + + p = vor_vi2_vi2_vi2(p_a, p_b); + + vopmask m = veq_vo_vi2_vi2(idx, q); + hi = vsel_vi2_vo_vi2_vi2(m, p, hi); + lo = vsel_vi2_vo_vi2_vi2(m, prev, lo); + ll = vsel_vi2_vo_vi2_vi2(m, prev2, ll); + + prev2 = prev; + prev = p; + + q = vadd_vi2_vi2_vi2(q, vcast_vi2_i(1)); + } + p = vor_vi2_vi2_vi2(vsll64_vi2_vi2_i(hi_a, 32), hi_b); + + vopmask m = veq_vo_vi2_vi2(idx, q); + hi = vsel_vi2_vo_vi2_vi2(m, p, hi); + lo = vsel_vi2_vo_vi2_vi2(m, prev, lo); + ll = vsel_vi2_vo_vi2_vi2(m, prev2, ll); + + e = vand_vi2_vi2_vi2(e, vcast_vi2_i(31)); + + union { + vint2 v; + uint32_t t[sizeof(vint2) / sizeof(uint32_t)]; + } ue, uhi, ulo, ull, uh, ur; + ue.v = e; uhi.v = hi; ulo.v = lo; ull.v = ll; + for (unsigned i = 0; i < sizeof(vint2) / sizeof(uint32_t); i++) { + uint32_t e = ue.t[i], q; + uint64_t p; + p = (uint64_t)uhi.t[i] << 32; + p |= ulo.t[i]; + + if (e) { + q = 32 - e; + p = (p << e) | (ull.t[i] >> q); + } + + q = (uhi.t[i] << e) & 0x80000000; + p &= 0x7fffffffffffffffULL; + + if (p & 0x4000000000000000ULL) { + p |= 0x8000000000000000ULL; + q ^= 0x80000000; + } + uh.t[i] = q; + + double d = (double)(int64_t)p; + d *= PI_2_M64; + float r = (float)d; + ur.t[i] = float_as_int(r); + } + vstore_v_p_vf((float*)h, (vfloat)uh.v); + return (vfloat)vxor_vi2_vi2_vi2(ur.v, s); +} + +vfloat static INLINE +__tan_kernel(vfloat const a, vint2 const h) +{ + vfloat s, r, rd, t; + vopmask cmp; + + s = vmul_vf_vf_vf(a, a); + r = vcast_vf_f(A_F); + r = vfma_vf_vf_vf_vf(r, s, vcast_vf_f(B_F)); + r = vfma_vf_vf_vf_vf(r, s, vcast_vf_f(C_F)); + r = vfma_vf_vf_vf_vf(r, s, vcast_vf_f(D_F)); + r = vfma_vf_vf_vf_vf(r, s, vcast_vf_f(E_F)); + r = vfma_vf_vf_vf_vf(r, s, vcast_vf_f(F_F)); + t = vmul_vf_vf_vf(s, a); + r = vfma_vf_vf_vf_vf(r, t, a); + + rd = vdiv_vf_vf_vf(vcast_vf_f(-1.0f), r); + cmp = veq_vo_vi2_vi2((vint2)h, vcast_vi2_i(0)); + r = vsel_vf_vo_vf_vf(cmp, r, rd); + + return r; +} + +vfloat static INLINE +__cotan_f_vec(vfloat const x) +{ + + vfloat a, k, r; + vopmask m; + vint2 p, h; + + k = vfma_vf_vf_vf_vf(x, vcast_vf_f(_2_OVER_PI_F), vcast_vf_f(12582912.0f)); + h = vsll_vi2_vi2_i((vint2)k, 31); + k = vsub_vf_vf_vf(k, vcast_vf_f(12582912.0f)); + + a = vfma_vf_vf_vf_vf(k, vcast_vf_f(-PI_2_HI_F), x); + a = vfma_vf_vf_vf_vf(k, vcast_vf_f(-PI_2_MI_F), a); + a = vfma_vf_vf_vf_vf(k, vcast_vf_f(-PI_2_LO_F), a); + + r = __tan_kernel(a, h); + + p = vand_vi2_vi2_vi2((vint2)x, vcast_vi2_i(0x7fffffff)); + m = vgt_vo_vi2_vi2(p, (vint2)vcast_vf_f(THRESHOLD_F)); + if (__builtin_expect(!vtestz_i_vo(m), 0)) { + vfloat res; + vopmask ninf; + vmask half; + + res = __reduction_slowpath(x, &half); + res = __tan_kernel(res, half); + ninf = vgt_vo_vi2_vi2(vcast_vi2_i(0x7f800000), p); + res = vsel_vf_vo_vf_vf(ninf, res, vmul_vf_vf_vf(x, vcast_vf_f(0.0f))); + + r = vsel_vf_vo_vf_vf(m, res, r); + } + + return 1.0/r; +} diff --git a/runtime/libpgmath/lib/common/cotanf/fs_cotan_16_avx512.cpp b/runtime/libpgmath/lib/common/cotanf/fs_cotan_16_avx512.cpp new file mode 100644 index 0000000000..7202c808bb --- /dev/null +++ b/runtime/libpgmath/lib/common/cotanf/fs_cotan_16_avx512.cpp @@ -0,0 +1,36 @@ + +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + + +#ifndef __COTAN_F_AVX512_H__ +#define __COTAN_F_AVX512_H__ + +#include +#include +#define CONFIG 1 +#include "helperavx512f.h" +#ifndef TARGET_OSX_X8664 +#include "common_cotanf.h" +#include "cotan_f_vec.h" +#endif + +extern "C" vfloat __attribute__ ((noinline)) __fs_cotan_16_avx512(vfloat const a); + +vfloat __attribute__ ((noinline)) +__fs_cotan_16_avx512(vfloat const a) +{ +#ifndef TARGET_OSX_X8664 + return __cotan_f_vec(a); +#else + assert(0); + return 1.0/((vfloat) _mm512_set1_epi32(0)); +#endif +} + +#endif // __COTAN_F_AVX512_H__ + diff --git a/runtime/libpgmath/lib/common/cotanf/fs_cotan_1_avx2.cpp b/runtime/libpgmath/lib/common/cotanf/fs_cotan_1_avx2.cpp new file mode 100644 index 0000000000..6f9bd2541e --- /dev/null +++ b/runtime/libpgmath/lib/common/cotanf/fs_cotan_1_avx2.cpp @@ -0,0 +1,112 @@ + +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + + +#ifndef __COTAN_F_SCALAR_H__ +#define __COTAN_F_SCALAR_H__ + + +#include +#include +#include +#include +#include "common_cotanf.h" + +extern "C" float __attribute__ ((noinline)) __fs_cotan_1_avx2(float const a); + + +/* Payne-Hanek style argument reduction. */ +static float +reduction_slowpath(float const a, int32_t *h) +{ + uint2 m; + uint32_t ia = float_as_int(a); + uint32_t s = ia & 0x80000000; + uint32_t result[7]; + uint32_t hi, lo; + uint32_t e; + int32_t idx; + int32_t q; + e = ((ia >> 23) & 0xff) - 127; + ia = (ia << 8) | 0x80000000; + + /* compute x * 2/pi */ + idx = 4 - ((e >> 5) & 3); + + hi = 0; + for (q = 0; q < 6; q++) { + m = umad32wide(i2opi_f[q], ia, hi); + lo = m.x; + hi = m.y; + result[q] = lo; + } + result[q] = hi; + + e = e & 31; + /* shift result such that hi:lo<63:63> is the least significant + integer bit, and hi:lo<62:0> are the fractional bits of the result + */ + uint64_t p = ((uint64_t)result[idx + 2] << 32) | result[idx + 1]; + + if (e) { + q = 32 - e; + p = (p << e) | (result[idx] >> q); + } + + /* fraction */ + q = (result[idx + 2] << e) & 0x80000000; + p &= 0x7fffffffffffffffULL; + + if (p & 0x4000000000000000ULL) { + p |= 0x8000000000000000ULL; + q ^= 0x80000000; + } + *h = q; + + double d = (double)(int64_t)p; + d *= PI_2_M64; + float r = (float)d; + + return int_as_float(float_as_int(r) ^ s); +} + +float __attribute__ ((noinline)) +__fs_cotan_1_avx2(float x) +{ + + float p, k, r, s, t; + int h = 0; + + p = int_as_float(float_as_int(x) & 0x7fffffff); + if (float_as_int(p) > float_as_int(THRESHOLD_F)) { + x = float_as_int(p) >= 0x7f800000 ? x * 0.0f : reduction_slowpath(x, &h); + } else { + k = FMAF(x, _2_OVER_PI_F, 12582912.0f); + h = float_as_int(k) << 31; + k -= 12582912.0f; + x = FMAF(k, -PI_2_HI_F, x); + x = FMAF(k, -PI_2_MI_F, x); + x = FMAF(k, -PI_2_LO_F, x); + } + s = x * x; + r = A_F; + r = FMAF(r, s, B_F); + r = FMAF(r, s, C_F); + r = FMAF(r, s, D_F); + r = FMAF(r, s, E_F); + r = FMAF(r, s, F_F); + t = s * x; + r = FMAF(r, t, x); + + if (h) r = -1.0f / r; + + return 1.0/r; +} + +#endif // __COTAN_F_SCALAR_H__ + diff --git a/runtime/libpgmath/lib/common/cotanf/fs_cotan_4_avx2.cpp b/runtime/libpgmath/lib/common/cotanf/fs_cotan_4_avx2.cpp new file mode 100644 index 0000000000..8ad989242e --- /dev/null +++ b/runtime/libpgmath/lib/common/cotanf/fs_cotan_4_avx2.cpp @@ -0,0 +1,28 @@ + +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + + +#ifndef __COTAN_F_AVX2_128_H__ +#define __COTAN_F_AVX2_128_H__ + +#include +#include "common_cotanf.h" +#define CONFIG 1 +#include "helperavx2_128.h" +#include "cotan_f_vec.h" + +extern "C" vfloat __attribute__ ((noinline)) __fs_cotan_4_avx2(vfloat const a); + +vfloat __attribute__ ((noinline)) +__fs_cotan_4_avx2(vfloat const a) +{ + return __cotan_f_vec(a); +} + +#endif // __COTAN_F_AVX2_128_H__ + diff --git a/runtime/libpgmath/lib/common/cotanf/fs_cotan_8_avx2.cpp b/runtime/libpgmath/lib/common/cotanf/fs_cotan_8_avx2.cpp new file mode 100644 index 0000000000..34c3e0e108 --- /dev/null +++ b/runtime/libpgmath/lib/common/cotanf/fs_cotan_8_avx2.cpp @@ -0,0 +1,28 @@ + +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + + +#ifndef __COTAN_F_AVX2_H__ +#define __COTAN_F_AVX2_H__ + +#include +#include "common_cotanf.h" +#define CONFIG 1 +#include "helperavx2.h" +#include "cotan_f_vec.h" + +extern "C" vfloat __attribute__ ((noinline)) __fs_cotan_8_avx2(vfloat const a); + +vfloat __attribute__ ((noinline)) +__fs_cotan_8_avx2(vfloat const a) +{ + return __cotan_f_vec(a); +} + +#endif // __COTAN_F_AVX2_H__ + diff --git a/runtime/libpgmath/lib/common/cqdiv.c b/runtime/libpgmath/lib/common/cqdiv.c new file mode 100644 index 0000000000..0cb5e7c856 --- /dev/null +++ b/runtime/libpgmath/lib/common/cqdiv.c @@ -0,0 +1,39 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified: June 2020 + */ + +#include "mthdecls.h" + +QMPLXFUNC_Q_Q(__mth_i_cqdiv) +{ + QMPLXARGS_Q_Q; + __float128 x, y; + __float128 r, d, r_mag, i_mag; + + r_mag = real2; + if (r_mag < 0) + r_mag = -r_mag; + i_mag = imag2; + if (i_mag < 0) + i_mag = -i_mag; + /* avoid overflow */ + if (r_mag <= i_mag) { + r = real2 / imag2; + d = 1.0 / (imag2 * (1 + r * r)); + x = (real1 * r + imag1) * d; + y = (imag1 * r - real1) * d; + } else { + r = imag2 / real2; + d = 1.0 / (real2 * (1 + r * r)); + x = (real1 + imag1 * r) * d; + y = (imag1 - real1 * r) * d; + } + QRETURN_Q_Q(x, y); +} diff --git a/runtime/libpgmath/lib/common/cqpowi.c b/runtime/libpgmath/lib/common/cqpowi.c new file mode 100644 index 0000000000..e95509a49e --- /dev/null +++ b/runtime/libpgmath/lib/common/cqpowi.c @@ -0,0 +1,49 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified: June 2020 + * + */ + +#include "mthdecls.h" + +QMPLXFUNC_C_I(__mth_i_cqpowi) +{ + QMPLXARGS_C_I; + int k; + __float128 fr, fi, gr, gi, tr, ti; + static const quad_complex_t c1plusi0 = PGMATH_CMPLX_CONST(1.0, 0.0); + + fr = 1; + fi = 0; + k = i; + gr = real; + gi = imag; + if (k < 0) + k = -k; + while (k) { + if (k & 1) { + tr = fr * gr - fi * gi; + ti = fr * gi + fi * gr; + fr = tr; + fi = ti; + } + k = (unsigned)k >> 1; + tr = gr * gr - gi * gi; + ti = 2.0 * gr * gi; + gr = tr; + gi = ti; + } + + quad_complex_t q = pgmath_cmplxq(fr, fi); + if (i < 0) { + QMPLX_CALL_QR_Q_Q(__mth_i_cqdiv,q,c1plusi0,q); + } + QRETURN_C(q); + +} diff --git a/runtime/libpgmath/lib/common/cqpowk.c b/runtime/libpgmath/lib/common/cqpowk.c new file mode 100644 index 0000000000..c3a0da91d4 --- /dev/null +++ b/runtime/libpgmath/lib/common/cqpowk.c @@ -0,0 +1,49 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified: June 2020 + * + */ + +#include "mthdecls.h" + +QMPLXFUNC_C_K(__mth_i_cqpowk) +{ + QMPLXARGS_C_K; + long long k; + __float128 fr, fi, gr, gi, tr, ti; + static const quad_complex_t c1plusi0 = PGMATH_CMPLX_CONST(1.0, 0.0); + + fr = 1; + fi = 0; + k = i; + gr = real; + gi = imag; + if (k < 0) + k = -k; + while (k) { + if (k & 1) { + tr = fr * gr - fi * gi; + ti = fr * gi + fi * gr; + fr = tr; + fi = ti; + } + k >>= 1; + tr = gr * gr - gi * gi; + ti = 2.0 * gr * gi; + gr = tr; + gi = ti; + } + + quad_complex_t q = pgmath_cmplxq(fr, fi); + if (i < 0) { + QMPLX_CALL_QR_Q_Q(__mth_i_cqdiv,q,c1plusi0,q); + } + QRETURN_C(q); + +} diff --git a/runtime/libpgmath/lib/common/dcotand.c b/runtime/libpgmath/lib/common/dcotand.c new file mode 100644 index 0000000000..11bdbbe09f --- /dev/null +++ b/runtime/libpgmath/lib/common/dcotand.c @@ -0,0 +1,13 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + +#include "mthdecls.h" +double +__mth_i_dcotand(double d) +{ + return 1.0/(tan(CNVRTDEG(d))); +} diff --git a/runtime/libpgmath/lib/common/dispatch.c b/runtime/libpgmath/lib/common/dispatch.c index 0e0572cb5b..d38f1f9569 100644 --- a/runtime/libpgmath/lib/common/dispatch.c +++ b/runtime/libpgmath/lib/common/dispatch.c @@ -235,6 +235,7 @@ static char *cfunc[] = { [func_aint] = "aint", [func_ceil] = "ceil", [func_floor] = "floor", + [func_cotan] = "cotan", }; #undef SLEEF @@ -260,6 +261,7 @@ static char *cfunc[] = { #include "math_tables/mth_aintdefs.h" #include "math_tables/mth_ceildefs.h" #include "math_tables/mth_floordefs.h" +#include "math_tables/mth_cotandefs.h" #ifdef SLEEF #include "math_tables/mth_sleef.h" #endif @@ -302,6 +304,7 @@ static mth_intrins_defs_t mth_intrins_defs[] = { #include "math_tables/mth_aintdefs.h" #include "math_tables/mth_ceildefs.h" #include "math_tables/mth_floordefs.h" +#include "math_tables/mth_cotandefs.h" #else #include "math_tables/mth_sleef.h" #endif diff --git a/runtime/libpgmath/lib/common/erfc_scaledq.c b/runtime/libpgmath/lib/common/erfc_scaledq.c new file mode 100644 index 0000000000..27151edabd --- /dev/null +++ b/runtime/libpgmath/lib/common/erfc_scaledq.c @@ -0,0 +1,143 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ +/* inhibit floating point copy propagation */ +#pragma global - Mx, 6, 0x100 + +#include "mthdecls.h" +#include +#include + +#define pi 3.1415926535897932384626434 +#define sqrtpi 1.77245385090551602729 +#define epsr16 2.2204460492503131e-016 +#define xinfr16 FLT128_MAX +#define xminr16 FLT128_MIN +#define xsmallr16 epsr16 / 2.0 +#define xmaxr16 1.0 / (sqrtpi * xminr16) + +/* mathematical constants */ +#define zero 0.0e0 +#define four 4.0e0 +#define one 1.0e0 +#define half 0.5e0 +#define two 2.0e0 +#define sqrpi 5.6418958354775628695e-1 +#define thresh 0.46875e0 +#define sixten 16.0e0 + +/* machine-dependent constants: ieee __float128 precision values */ +#define xneg -26.628e0 +#define xbig 26.543e0 +#define xhuge 6.71e7 + +/* coefficients for approximation to erf in first interval */ + +static __float128 a[5] = {3.16112374387056560e00, 1.13864154151050156e02, + 3.77485237685302021e02, 3.20937758913846947e03, + 1.85777706184603153e-1}; +static __float128 b[4] = {2.36012909523441209e01, 2.44024637934444173e02, + 1.28261652607737228e03, 2.84423683343917062e03}; + +/* coefficients for approximation to erfc in second interval */ +static __float128 c[9] = { + 5.64188496988670089e-1, 8.88314979438837594e00, 6.61191906371416295e01, + 2.98635138197400131e02, 8.81952221241769090e02, 1.71204761263407058e03, + 2.05107837782607147e03, 1.23033935479799725e03, 2.15311535474403846e-8}; +static __float128 d[8] = {1.57449261107098347e01, 1.17693950891312499e02, + 5.37181101862009858e02, 1.62138957456669019e03, + 3.29079923573345963e03, 4.36261909014324716e03, + 3.43936767414372164e03, 1.23033935480374942e03}; + +/* coefficients for approximation to erfc in third interval */ +static __float128 p[6] = {3.05326634961232344e-1, 3.60344899949804439e-1, + 1.25781726111229246e-1, 1.60837851487422766e-2, + 6.58749161529837803e-4, 1.63153871373020978e-2}; +static __float128 q[5] = {2.56852019228982242e00, 1.87295284992346047e00, + 5.27905102951428412e-1, 6.05183413124413191e-2, + 2.33520497626869185e-3}; + +__float128 +__mth_i_qerfc_scaled(__float128 arg) +{ + __float128 x, y, ysq, xnum, xden, del; + int i; + __float128 result; + + x = arg; + y = fabs(x); + + if (y <= thresh) { + /* evaluate erf for |x| <= 0.46875 */ + ysq = zero; + if (y > xsmallr16) + ysq = y * y; + xnum = a[4] * ysq; + xden = ysq; + for (i = 0; i < 3; i++) { + xnum = (xnum + a[i]) * ysq; + xden = (xden + b[i]) * ysq; + } + result = x * (xnum + a[3]) / (xden + b[3]); + result = one - result; + result = exp(ysq) * result; + goto ret; + } else if (y <= four) { + /* evaluate erfc for 0.46875 <= |x| <= 4.0 */ + xnum = c[8] * y; + xden = y; + for (i = 0; i < 7; i++) { + xnum = (xnum + c[i]) * y; + xden = (xden + d[i]) * y; + } + result = (xnum + c[7]) / (xden + d[7]); + } else { + /* evaluate erfc for |x| > 4.0 */ + result = zero; + if (y >= xbig) { + if (y > xmaxr16) + goto negval; + if (y >= xhuge) { + result = sqrpi / y; + goto negval; + } + } + ysq = one / (y * y); + xnum = p[5] * ysq; + xden = ysq; + for (i = 0; i < 4; i++) { + xnum = (xnum + p[i]) * ysq; + xden = (xden + q[i]) * ysq; + } + result = ysq * (xnum + p[4]) / (xden + q[4]); + result = (sqrpi - result) / y; + } +negval: + /* fix up for negative argument, erf, etc. */ + if (x < zero) { + if (x < xneg) { + result = xinfr16; + } else { +#if defined(TARGET_WIN) + __float128 tmp = x * sixten; + long l = tmp; + tmp = l; + ysq = tmp / sixten; +#else + ysq = trunc(x * sixten) / sixten; +#endif + del = (x - ysq) * (x + ysq); + y = exp(ysq * ysq) * exp(del); + result = (y + y) - result; + } + } +ret: + return result; +} diff --git a/runtime/libpgmath/lib/common/erfcq.c b/runtime/libpgmath/lib/common/erfcq.c new file mode 100644 index 0000000000..c9abc9025d --- /dev/null +++ b/runtime/libpgmath/lib/common/erfcq.c @@ -0,0 +1,23 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ +/* inhibit floating point copy propagation */ +#pragma global - Mx, 6, 0x100 + +#include "mthdecls.h" + +__float128 __attribute__((weak)) erfcq(__float128); + +__float128 +__mth_i_qerfc(__float128 arg) +{ + double f = erfcq(arg); + return f; +} diff --git a/runtime/libpgmath/lib/common/erfq.c b/runtime/libpgmath/lib/common/erfq.c new file mode 100644 index 0000000000..5ed4fa3860 --- /dev/null +++ b/runtime/libpgmath/lib/common/erfq.c @@ -0,0 +1,25 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ + +/* inhibit floating point copy propagation */ +#pragma global - Mx, 6, 0x100 + +#include "mthdecls.h" + +__float128 __attribute__((weak)) erfq(__float128); + +__float128 +__mth_i_qerf(__float128 arg) +{ + __float128 f = erfq(arg); + return f; +} + diff --git a/runtime/libpgmath/lib/common/gammaq.c b/runtime/libpgmath/lib/common/gammaq.c new file mode 100644 index 0000000000..815a631343 --- /dev/null +++ b/runtime/libpgmath/lib/common/gammaq.c @@ -0,0 +1,23 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ + +/* inhibit floating point copy propagation */ +#pragma global - Mx, 6, 0x100 + +#include "mthdecls.h" +__float128 __attribute__((weak)) tgammaq(__float128); + +__float128 +__mth_i_qgamma(__float128 arg) +{ + __float128 f = tgammaq(arg); + return f; +} diff --git a/runtime/libpgmath/lib/common/hypotq.c b/runtime/libpgmath/lib/common/hypotq.c new file mode 100644 index 0000000000..5343283cd7 --- /dev/null +++ b/runtime/libpgmath/lib/common/hypotq.c @@ -0,0 +1,24 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ + +/* inhibit floating point copy propagation */ +#pragma global - Mx, 6, 0x100 + +#include "mthdecls.h" + +__float128 __attribute__((weak)) hypotq(__float128 x, __float128 y); + +__float128 +__mth_i_qhypot(__float128 x, __float128 y) +{ + __float128 f = hypotq(x, y); + return f; +} diff --git a/runtime/libpgmath/lib/common/log_gammaq.c b/runtime/libpgmath/lib/common/log_gammaq.c new file mode 100644 index 0000000000..420f028099 --- /dev/null +++ b/runtime/libpgmath/lib/common/log_gammaq.c @@ -0,0 +1,23 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ +/* inhibit floating point copy propagation */ +#pragma global - Mx, 6, 0x100 + +#include "mthdecls.h" + +__float128 __attribute__((weak)) lgammaq(__float128); + +__float128 +__mth_i_qlog_gamma(__float128 arg) +{ + __float128 f = lgammaq(arg); + return f; +} diff --git a/runtime/libpgmath/lib/common/math_common.h b/runtime/libpgmath/lib/common/math_common.h index 97163d304d..102a176779 100644 --- a/runtime/libpgmath/lib/common/math_common.h +++ b/runtime/libpgmath/lib/common/math_common.h @@ -192,6 +192,15 @@ double my_copysign(double x, double y) { return L2D( (D2L(x) & DB_ABS_MASK) | (D2L(y) & DB_SIGN_BIT) ); } +// AOCC begin +#undef copysignq +#define copysignq(x, y) my_copysignq(x, y) +static INLINE +__float128 my_copysignq(__float128 x, __float128 y) +{ + return L2D( (D2L(x) & DB_ABS_MASK) | (D2L(y) & DB_SIGN_BIT) ); +} +// AOCC end #undef isnanf #define isnanf(x) my_isnanf(x) @@ -278,4 +287,19 @@ float my_cimagf(float _Complex x) return *(1 + (float *)&x); } +#undef crealq +#define crealq my_crealq +static INLINE +__float128 my_crealq(__float128 x) +{ + return *(0 + (__float128 *)&x); +} + +#undef cimagq +#define cimagq my_cimagq +static INLINE +__float128 my_cimagq(__float128 x) +{ + return *(1 + (__float128 *)&x); +} #endif //!(defined __MATH_COMMON_H_INCLUDED__) diff --git a/runtime/libpgmath/lib/common/mth_128defs.c b/runtime/libpgmath/lib/common/mth_128defs.c index 84ba5426b5..48456607dc 100644 --- a/runtime/libpgmath/lib/common/mth_128defs.c +++ b/runtime/libpgmath/lib/common/mth_128defs.c @@ -1154,6 +1154,7 @@ MTH_DISPATCH_FUNC(__pd_sin_2m)(vrd2_t x, vid2_t m) return (fptr(x, m)); } + vrs1_t MTH_DISPATCH_FUNC(__fs_tan_1)(vrs1_t x) { @@ -1334,6 +1335,186 @@ MTH_DISPATCH_FUNC(__pd_tan_2m)(vrd2_t x, vid2_t m) return (fptr(x, m)); } +vrs1_t +MTH_DISPATCH_FUNC(__fs_cotan_1)(vrs1_t x) +{ + vrs1_t (*fptr)(vrs1_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_ss,frp_f); + fptr = (vrs1_t(*)(vrs1_t))MTH_DISPATCH_TBL[func_cotan][sv_ss][frp_f]; + return (fptr(x)); +} + +vrs1_t +MTH_DISPATCH_FUNC(__rs_cotan_1)(vrs1_t x) +{ + vrs1_t (*fptr)(vrs1_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_ss,frp_r); + fptr = (vrs1_t(*)(vrs1_t))MTH_DISPATCH_TBL[func_cotan][sv_ss][frp_r]; + return (fptr(x)); +} + +vrs1_t +MTH_DISPATCH_FUNC(__ps_cotan_1)(vrs1_t x) +{ + vrs1_t (*fptr)(vrs1_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_ss,frp_p); + fptr = (vrs1_t(*)(vrs1_t))MTH_DISPATCH_TBL[func_cotan][sv_ss][frp_p]; + return (fptr(x)); +} + +vrs4_t +MTH_DISPATCH_FUNC(__fs_cotan_4)(vrs4_t x) +{ + vrs4_t (*fptr)(vrs4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv4,frp_f); + fptr = (vrs4_t(*)(vrs4_t))MTH_DISPATCH_TBL[func_cotan][sv_sv4][frp_f]; + return (fptr(x)); +} + +vrs4_t +MTH_DISPATCH_FUNC(__rs_cotan_4)(vrs4_t x) +{ + vrs4_t (*fptr)(vrs4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv4,frp_r); + fptr = (vrs4_t(*)(vrs4_t))MTH_DISPATCH_TBL[func_cotan][sv_sv4][frp_r]; + return (fptr(x)); +} + +vrs4_t +MTH_DISPATCH_FUNC(__ps_cotan_4)(vrs4_t x) +{ + vrs4_t (*fptr)(vrs4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv4,frp_p); + fptr = (vrs4_t(*)(vrs4_t))MTH_DISPATCH_TBL[func_cotan][sv_sv4][frp_p]; + return (fptr(x)); +} + +vrs4_t +MTH_DISPATCH_FUNC(__fs_cotan_4m)(vrs4_t x, vis4_t m) +{ + vrs4_t (*fptr)(vrs4_t, vis4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_tan,sv_sv4m,frp_f); + fptr = (vrs4_t(*)())MTH_DISPATCH_TBL[func_tan][sv_sv4m][frp_f]; + return (fptr(x, m)); +} + +vrs4_t +MTH_DISPATCH_FUNC(__rs_cotan_4m)(vrs4_t x, vis4_t m) +{ + vrs4_t (*fptr)(vrs4_t, vis4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv4m,frp_r); + fptr = (vrs4_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv4m][frp_r]; + return (fptr(x, m)); +} + +vrs4_t +MTH_DISPATCH_FUNC(__ps_cotan_4m)(vrs4_t x, vis4_t m) +{ + vrs4_t (*fptr)(vrs4_t, vis4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv4m,frp_p); + fptr = (vrs4_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv4m][frp_p]; + return (fptr(x, m)); +} + +vrd1_t +MTH_DISPATCH_FUNC(__fd_cotan_1)(vrd1_t x) +{ + vrd1_t (*fptr)(vrd1_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_ds,frp_f); + fptr = (vrd1_t(*)(vrd1_t))MTH_DISPATCH_TBL[func_cotan][sv_ds][frp_f]; + return (fptr(x)); +} + +vrd1_t +MTH_DISPATCH_FUNC(__rd_cotan_1)(vrd1_t x) +{ + vrd1_t (*fptr)(vrd1_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_ds,frp_r); + fptr = (vrd1_t(*)(vrd1_t))MTH_DISPATCH_TBL[func_cotan][sv_ds][frp_r]; + return (fptr(x)); +} + +vrd1_t +MTH_DISPATCH_FUNC(__pd_cotan_1)(vrd1_t x) +{ + vrd1_t (*fptr)(vrd1_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_ds,frp_p); + fptr = (vrd1_t(*)(vrd1_t))MTH_DISPATCH_TBL[func_cotan][sv_ds][frp_p]; + return (fptr(x)); +} + +vrd2_t +MTH_DISPATCH_FUNC(__fd_cotan_2)(vrd2_t x) +{ + vrd2_t (*fptr)(vrd2_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv2,frp_f); + fptr = (vrd2_t(*)(vrd2_t))MTH_DISPATCH_TBL[func_cotan][sv_dv2][frp_f]; + return (fptr(x)); +} + +vrd2_t +MTH_DISPATCH_FUNC(__rd_cotan_2)(vrd2_t x) +{ + vrd2_t (*fptr)(vrd2_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv2,frp_r); + fptr = (vrd2_t(*)(vrd2_t))MTH_DISPATCH_TBL[func_cotan][sv_dv2][frp_r]; + return (fptr(x)); +} + +vrd2_t +MTH_DISPATCH_FUNC(__pd_cotan_2)(vrd2_t x) +{ + vrd2_t (*fptr)(vrd2_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv2,frp_p); + fptr = (vrd2_t(*)(vrd2_t))MTH_DISPATCH_TBL[func_cotan][sv_dv2][frp_p]; + return (fptr(x)); +} + +vrd2_t +MTH_DISPATCH_FUNC(__fd_cotan_2m)(vrd2_t x, vid2_t m) +{ + vrd2_t (*fptr)(vrd2_t, vid2_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv2m,frp_f); + fptr = (vrd2_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv2m][frp_f]; + return (fptr(x, m)); +} + +vrd2_t +MTH_DISPATCH_FUNC(__rd_cotan_2m)(vrd2_t x, vid2_t m) +{ + vrd2_t (*fptr)(vrd2_t, vid2_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv2m,frp_r); + fptr = (vrd2_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv2m][frp_r]; + return (fptr(x, m)); +} + +vrd2_t +MTH_DISPATCH_FUNC(__pd_cotan_2m)(vrd2_t x, vid2_t m) +{ + vrd2_t (*fptr)(vrd2_t, vid2_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv2m,frp_p); + fptr = (vrd2_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv2m][frp_p]; + return (fptr(x, m)); +} + vrs1_t MTH_DISPATCH_FUNC(__fs_cosh_1)(vrs1_t x) { diff --git a/runtime/libpgmath/lib/common/mth_128defs_init.c b/runtime/libpgmath/lib/common/mth_128defs_init.c index 84ba5426b5..a3d5320146 100644 --- a/runtime/libpgmath/lib/common/mth_128defs_init.c +++ b/runtime/libpgmath/lib/common/mth_128defs_init.c @@ -1334,6 +1334,186 @@ MTH_DISPATCH_FUNC(__pd_tan_2m)(vrd2_t x, vid2_t m) return (fptr(x, m)); } +vrs1_t +MTH_DISPATCH_FUNC(__fs_cotan_1)(vrs1_t x) +{ + vrs1_t (*fptr)(vrs1_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_ss,frp_f); + fptr = (vrs1_t(*)(vrs1_t))MTH_DISPATCH_TBL[func_cotan][sv_ss][frp_f]; + return (fptr(x)); +} + +vrs1_t +MTH_DISPATCH_FUNC(__rs_cotan_1)(vrs1_t x) +{ + vrs1_t (*fptr)(vrs1_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_ss,frp_r); + fptr = (vrs1_t(*)(vrs1_t))MTH_DISPATCH_TBL[func_cotan][sv_ss][frp_r]; + return (fptr(x)); +} + +vrs1_t +MTH_DISPATCH_FUNC(__ps_cotan_1)(vrs1_t x) +{ + vrs1_t (*fptr)(vrs1_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_ss,frp_p); + fptr = (vrs1_t(*)(vrs1_t))MTH_DISPATCH_TBL[func_cotan][sv_ss][frp_p]; + return (fptr(x)); +} + +vrs4_t +MTH_DISPATCH_FUNC(__fs_cotan_4)(vrs4_t x) +{ + vrs4_t (*fptr)(vrs4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv4,frp_f); + fptr = (vrs4_t(*)(vrs4_t))MTH_DISPATCH_TBL[func_cotan][sv_sv4][frp_f]; + return (fptr(x)); +} + +vrs4_t +MTH_DISPATCH_FUNC(__rs_cotan_4)(vrs4_t x) +{ + vrs4_t (*fptr)(vrs4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv4,frp_r); + fptr = (vrs4_t(*)(vrs4_t))MTH_DISPATCH_TBL[func_cotan][sv_sv4][frp_r]; + return (fptr(x)); +} + +vrs4_t +MTH_DISPATCH_FUNC(__ps_cotan_4)(vrs4_t x) +{ + vrs4_t (*fptr)(vrs4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv4,frp_p); + fptr = (vrs4_t(*)(vrs4_t))MTH_DISPATCH_TBL[func_cotan][sv_sv4][frp_p]; + return (fptr(x)); +} + +vrs4_t +MTH_DISPATCH_FUNC(__fs_cotan_4m)(vrs4_t x, vis4_t m) +{ + vrs4_t (*fptr)(vrs4_t, vis4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv4m,frp_f); + fptr = (vrs4_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv4m][frp_f]; + return (fptr(x, m)); +} + +vrs4_t +MTH_DISPATCH_FUNC(__rs_cotan_4m)(vrs4_t x, vis4_t m) +{ + vrs4_t (*fptr)(vrs4_t, vis4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv4m,frp_r); + fptr = (vrs4_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv4m][frp_r]; + return (fptr(x, m)); +} + +vrs4_t +MTH_DISPATCH_FUNC(__ps_cotan_4m)(vrs4_t x, vis4_t m) +{ + vrs4_t (*fptr)(vrs4_t, vis4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv4m,frp_p); + fptr = (vrs4_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv4m][frp_p]; + return (fptr(x, m)); +} + +vrd1_t +MTH_DISPATCH_FUNC(__fd_cotan_1)(vrd1_t x) +{ + vrd1_t (*fptr)(vrd1_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_ds,frp_f); + fptr = (vrd1_t(*)(vrd1_t))MTH_DISPATCH_TBL[func_cotan][sv_ds][frp_f]; + return (fptr(x)); +} + +vrd1_t +MTH_DISPATCH_FUNC(__rd_cotan_1)(vrd1_t x) +{ + vrd1_t (*fptr)(vrd1_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_ds,frp_r); + fptr = (vrd1_t(*)(vrd1_t))MTH_DISPATCH_TBL[func_cotan][sv_ds][frp_r]; + return (fptr(x)); +} + +vrd1_t +MTH_DISPATCH_FUNC(__pd_cotan_1)(vrd1_t x) +{ + vrd1_t (*fptr)(vrd1_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_ds,frp_p); + fptr = (vrd1_t(*)(vrd1_t))MTH_DISPATCH_TBL[func_cotan][sv_ds][frp_p]; + return (fptr(x)); +} + +vrd2_t +MTH_DISPATCH_FUNC(__fd_cotan_2)(vrd2_t x) +{ + vrd2_t (*fptr)(vrd2_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv2,frp_f); + fptr = (vrd2_t(*)(vrd2_t))MTH_DISPATCH_TBL[func_cotan][sv_dv2][frp_f]; + return (fptr(x)); +} + +vrd2_t +MTH_DISPATCH_FUNC(__rd_cotan_2)(vrd2_t x) +{ + vrd2_t (*fptr)(vrd2_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv2,frp_r); + fptr = (vrd2_t(*)(vrd2_t))MTH_DISPATCH_TBL[func_cotan][sv_dv2][frp_r]; + return (fptr(x)); +} + +vrd2_t +MTH_DISPATCH_FUNC(__pd_cotan_2)(vrd2_t x) +{ + vrd2_t (*fptr)(vrd2_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv2,frp_p); + fptr = (vrd2_t(*)(vrd2_t))MTH_DISPATCH_TBL[func_cotan][sv_dv2][frp_p]; + return (fptr(x)); +} + +vrd2_t +MTH_DISPATCH_FUNC(__fd_cotan_2m)(vrd2_t x, vid2_t m) +{ + vrd2_t (*fptr)(vrd2_t, vid2_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv2m,frp_f); + fptr = (vrd2_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv2m][frp_f]; + return (fptr(x, m)); +} + +vrd2_t +MTH_DISPATCH_FUNC(__rd_cotan_2m)(vrd2_t x, vid2_t m) +{ + vrd2_t (*fptr)(vrd2_t, vid2_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv2m,frp_r); + fptr = (vrd2_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv2m][frp_r]; + return (fptr(x, m)); +} + +vrd2_t +MTH_DISPATCH_FUNC(__pd_cotan_2m)(vrd2_t x, vid2_t m) +{ + vrd2_t (*fptr)(vrd2_t, vid2_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv2m,frp_p); + fptr = (vrd2_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv2m][frp_p]; + return (fptr(x, m)); +} + vrs1_t MTH_DISPATCH_FUNC(__fs_cosh_1)(vrs1_t x) { diff --git a/runtime/libpgmath/lib/common/mth_128defs_stats.c b/runtime/libpgmath/lib/common/mth_128defs_stats.c index 84ba5426b5..a3d5320146 100644 --- a/runtime/libpgmath/lib/common/mth_128defs_stats.c +++ b/runtime/libpgmath/lib/common/mth_128defs_stats.c @@ -1334,6 +1334,186 @@ MTH_DISPATCH_FUNC(__pd_tan_2m)(vrd2_t x, vid2_t m) return (fptr(x, m)); } +vrs1_t +MTH_DISPATCH_FUNC(__fs_cotan_1)(vrs1_t x) +{ + vrs1_t (*fptr)(vrs1_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_ss,frp_f); + fptr = (vrs1_t(*)(vrs1_t))MTH_DISPATCH_TBL[func_cotan][sv_ss][frp_f]; + return (fptr(x)); +} + +vrs1_t +MTH_DISPATCH_FUNC(__rs_cotan_1)(vrs1_t x) +{ + vrs1_t (*fptr)(vrs1_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_ss,frp_r); + fptr = (vrs1_t(*)(vrs1_t))MTH_DISPATCH_TBL[func_cotan][sv_ss][frp_r]; + return (fptr(x)); +} + +vrs1_t +MTH_DISPATCH_FUNC(__ps_cotan_1)(vrs1_t x) +{ + vrs1_t (*fptr)(vrs1_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_ss,frp_p); + fptr = (vrs1_t(*)(vrs1_t))MTH_DISPATCH_TBL[func_cotan][sv_ss][frp_p]; + return (fptr(x)); +} + +vrs4_t +MTH_DISPATCH_FUNC(__fs_cotan_4)(vrs4_t x) +{ + vrs4_t (*fptr)(vrs4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv4,frp_f); + fptr = (vrs4_t(*)(vrs4_t))MTH_DISPATCH_TBL[func_cotan][sv_sv4][frp_f]; + return (fptr(x)); +} + +vrs4_t +MTH_DISPATCH_FUNC(__rs_cotan_4)(vrs4_t x) +{ + vrs4_t (*fptr)(vrs4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv4,frp_r); + fptr = (vrs4_t(*)(vrs4_t))MTH_DISPATCH_TBL[func_cotan][sv_sv4][frp_r]; + return (fptr(x)); +} + +vrs4_t +MTH_DISPATCH_FUNC(__ps_cotan_4)(vrs4_t x) +{ + vrs4_t (*fptr)(vrs4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv4,frp_p); + fptr = (vrs4_t(*)(vrs4_t))MTH_DISPATCH_TBL[func_cotan][sv_sv4][frp_p]; + return (fptr(x)); +} + +vrs4_t +MTH_DISPATCH_FUNC(__fs_cotan_4m)(vrs4_t x, vis4_t m) +{ + vrs4_t (*fptr)(vrs4_t, vis4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv4m,frp_f); + fptr = (vrs4_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv4m][frp_f]; + return (fptr(x, m)); +} + +vrs4_t +MTH_DISPATCH_FUNC(__rs_cotan_4m)(vrs4_t x, vis4_t m) +{ + vrs4_t (*fptr)(vrs4_t, vis4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv4m,frp_r); + fptr = (vrs4_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv4m][frp_r]; + return (fptr(x, m)); +} + +vrs4_t +MTH_DISPATCH_FUNC(__ps_cotan_4m)(vrs4_t x, vis4_t m) +{ + vrs4_t (*fptr)(vrs4_t, vis4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv4m,frp_p); + fptr = (vrs4_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv4m][frp_p]; + return (fptr(x, m)); +} + +vrd1_t +MTH_DISPATCH_FUNC(__fd_cotan_1)(vrd1_t x) +{ + vrd1_t (*fptr)(vrd1_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_ds,frp_f); + fptr = (vrd1_t(*)(vrd1_t))MTH_DISPATCH_TBL[func_cotan][sv_ds][frp_f]; + return (fptr(x)); +} + +vrd1_t +MTH_DISPATCH_FUNC(__rd_cotan_1)(vrd1_t x) +{ + vrd1_t (*fptr)(vrd1_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_ds,frp_r); + fptr = (vrd1_t(*)(vrd1_t))MTH_DISPATCH_TBL[func_cotan][sv_ds][frp_r]; + return (fptr(x)); +} + +vrd1_t +MTH_DISPATCH_FUNC(__pd_cotan_1)(vrd1_t x) +{ + vrd1_t (*fptr)(vrd1_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_ds,frp_p); + fptr = (vrd1_t(*)(vrd1_t))MTH_DISPATCH_TBL[func_cotan][sv_ds][frp_p]; + return (fptr(x)); +} + +vrd2_t +MTH_DISPATCH_FUNC(__fd_cotan_2)(vrd2_t x) +{ + vrd2_t (*fptr)(vrd2_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv2,frp_f); + fptr = (vrd2_t(*)(vrd2_t))MTH_DISPATCH_TBL[func_cotan][sv_dv2][frp_f]; + return (fptr(x)); +} + +vrd2_t +MTH_DISPATCH_FUNC(__rd_cotan_2)(vrd2_t x) +{ + vrd2_t (*fptr)(vrd2_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv2,frp_r); + fptr = (vrd2_t(*)(vrd2_t))MTH_DISPATCH_TBL[func_cotan][sv_dv2][frp_r]; + return (fptr(x)); +} + +vrd2_t +MTH_DISPATCH_FUNC(__pd_cotan_2)(vrd2_t x) +{ + vrd2_t (*fptr)(vrd2_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv2,frp_p); + fptr = (vrd2_t(*)(vrd2_t))MTH_DISPATCH_TBL[func_cotan][sv_dv2][frp_p]; + return (fptr(x)); +} + +vrd2_t +MTH_DISPATCH_FUNC(__fd_cotan_2m)(vrd2_t x, vid2_t m) +{ + vrd2_t (*fptr)(vrd2_t, vid2_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv2m,frp_f); + fptr = (vrd2_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv2m][frp_f]; + return (fptr(x, m)); +} + +vrd2_t +MTH_DISPATCH_FUNC(__rd_cotan_2m)(vrd2_t x, vid2_t m) +{ + vrd2_t (*fptr)(vrd2_t, vid2_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv2m,frp_r); + fptr = (vrd2_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv2m][frp_r]; + return (fptr(x, m)); +} + +vrd2_t +MTH_DISPATCH_FUNC(__pd_cotan_2m)(vrd2_t x, vid2_t m) +{ + vrd2_t (*fptr)(vrd2_t, vid2_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv2m,frp_p); + fptr = (vrd2_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv2m][frp_p]; + return (fptr(x, m)); +} + vrs1_t MTH_DISPATCH_FUNC(__fs_cosh_1)(vrs1_t x) { diff --git a/runtime/libpgmath/lib/common/mth_256defs.c b/runtime/libpgmath/lib/common/mth_256defs.c index 25c467de1c..b9f53a6cba 100644 --- a/runtime/libpgmath/lib/common/mth_256defs.c +++ b/runtime/libpgmath/lib/common/mth_256defs.c @@ -847,6 +847,126 @@ MTH_DISPATCH_FUNC(__pd_tan_4m)(vrd4_t x, vid4_t m) return (fptr(x, m)); } +vrs8_t +MTH_DISPATCH_FUNC(__fs_cotan_8)(vrs8_t x) +{ + vrs8_t (*fptr)(vrs8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv8,frp_f); + fptr = (vrs8_t(*)(vrs8_t))MTH_DISPATCH_TBL[func_cotan][sv_sv8][frp_f]; + return (fptr(x)); +} + +vrs8_t +MTH_DISPATCH_FUNC(__rs_cotan_8)(vrs8_t x) +{ + vrs8_t (*fptr)(vrs8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv8,frp_r); + fptr = (vrs8_t(*)(vrs8_t))MTH_DISPATCH_TBL[func_cotan][sv_sv8][frp_r]; + return (fptr(x)); +} + +vrs8_t +MTH_DISPATCH_FUNC(__ps_cotan_8)(vrs8_t x) +{ + vrs8_t (*fptr)(vrs8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv8,frp_p); + fptr = (vrs8_t(*)(vrs8_t))MTH_DISPATCH_TBL[func_cotan][sv_sv8][frp_p]; + return (fptr(x)); +} + +vrs8_t +MTH_DISPATCH_FUNC(__fs_cotan_8m)(vrs8_t x, vis8_t m) +{ + vrs8_t (*fptr)(vrs8_t, vis8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv8m,frp_f); + fptr = (vrs8_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv8m][frp_f]; + return (fptr(x, m)); +} + +vrs8_t +MTH_DISPATCH_FUNC(__rs_cotan_8m)(vrs8_t x, vis8_t m) +{ + vrs8_t (*fptr)(vrs8_t, vis8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv8m,frp_r); + fptr = (vrs8_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv8m][frp_r]; + return (fptr(x, m)); +} + +vrs8_t +MTH_DISPATCH_FUNC(__ps_cotan_8m)(vrs8_t x, vis8_t m) +{ + vrs8_t (*fptr)(vrs8_t, vis8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv8m,frp_p); + fptr = (vrs8_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv8m][frp_p]; + return (fptr(x, m)); +} + +vrd4_t +MTH_DISPATCH_FUNC(__fd_cotan_4)(vrd4_t x) +{ + vrd4_t (*fptr)(vrd4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv4,frp_f); + fptr = (vrd4_t(*)(vrd4_t))MTH_DISPATCH_TBL[func_cotan][sv_dv4][frp_f]; + return (fptr(x)); +} + +vrd4_t +MTH_DISPATCH_FUNC(__rd_cotan_4)(vrd4_t x) +{ + vrd4_t (*fptr)(vrd4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv4,frp_r); + fptr = (vrd4_t(*)(vrd4_t))MTH_DISPATCH_TBL[func_cotan][sv_dv4][frp_r]; + return (fptr(x)); +} + +vrd4_t +MTH_DISPATCH_FUNC(__pd_cotan_4)(vrd4_t x) +{ + vrd4_t (*fptr)(vrd4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv4,frp_p); + fptr = (vrd4_t(*)(vrd4_t))MTH_DISPATCH_TBL[func_cotan][sv_dv4][frp_p]; + return (fptr(x)); +} + +vrd4_t +MTH_DISPATCH_FUNC(__fd_cotan_4m)(vrd4_t x, vid4_t m) +{ + vrd4_t (*fptr)(vrd4_t, vid4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv4m,frp_f); + fptr = (vrd4_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv4m][frp_f]; + return (fptr(x, m)); +} + +vrd4_t +MTH_DISPATCH_FUNC(__rd_cotan_4m)(vrd4_t x, vid4_t m) +{ + vrd4_t (*fptr)(vrd4_t, vid4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv4m,frp_r); + fptr = (vrd4_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv4m][frp_r]; + return (fptr(x, m)); +} + +vrd4_t +MTH_DISPATCH_FUNC(__pd_cotan_4m)(vrd4_t x, vid4_t m) +{ + vrd4_t (*fptr)(vrd4_t, vid4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv4m,frp_p); + fptr = (vrd4_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv4m][frp_p]; + return (fptr(x, m)); +} + vrs8_t MTH_DISPATCH_FUNC(__fs_cosh_8)(vrs8_t x) { diff --git a/runtime/libpgmath/lib/common/mth_256defs_init.c b/runtime/libpgmath/lib/common/mth_256defs_init.c index 25c467de1c..b9f53a6cba 100644 --- a/runtime/libpgmath/lib/common/mth_256defs_init.c +++ b/runtime/libpgmath/lib/common/mth_256defs_init.c @@ -847,6 +847,126 @@ MTH_DISPATCH_FUNC(__pd_tan_4m)(vrd4_t x, vid4_t m) return (fptr(x, m)); } +vrs8_t +MTH_DISPATCH_FUNC(__fs_cotan_8)(vrs8_t x) +{ + vrs8_t (*fptr)(vrs8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv8,frp_f); + fptr = (vrs8_t(*)(vrs8_t))MTH_DISPATCH_TBL[func_cotan][sv_sv8][frp_f]; + return (fptr(x)); +} + +vrs8_t +MTH_DISPATCH_FUNC(__rs_cotan_8)(vrs8_t x) +{ + vrs8_t (*fptr)(vrs8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv8,frp_r); + fptr = (vrs8_t(*)(vrs8_t))MTH_DISPATCH_TBL[func_cotan][sv_sv8][frp_r]; + return (fptr(x)); +} + +vrs8_t +MTH_DISPATCH_FUNC(__ps_cotan_8)(vrs8_t x) +{ + vrs8_t (*fptr)(vrs8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv8,frp_p); + fptr = (vrs8_t(*)(vrs8_t))MTH_DISPATCH_TBL[func_cotan][sv_sv8][frp_p]; + return (fptr(x)); +} + +vrs8_t +MTH_DISPATCH_FUNC(__fs_cotan_8m)(vrs8_t x, vis8_t m) +{ + vrs8_t (*fptr)(vrs8_t, vis8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv8m,frp_f); + fptr = (vrs8_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv8m][frp_f]; + return (fptr(x, m)); +} + +vrs8_t +MTH_DISPATCH_FUNC(__rs_cotan_8m)(vrs8_t x, vis8_t m) +{ + vrs8_t (*fptr)(vrs8_t, vis8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv8m,frp_r); + fptr = (vrs8_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv8m][frp_r]; + return (fptr(x, m)); +} + +vrs8_t +MTH_DISPATCH_FUNC(__ps_cotan_8m)(vrs8_t x, vis8_t m) +{ + vrs8_t (*fptr)(vrs8_t, vis8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv8m,frp_p); + fptr = (vrs8_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv8m][frp_p]; + return (fptr(x, m)); +} + +vrd4_t +MTH_DISPATCH_FUNC(__fd_cotan_4)(vrd4_t x) +{ + vrd4_t (*fptr)(vrd4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv4,frp_f); + fptr = (vrd4_t(*)(vrd4_t))MTH_DISPATCH_TBL[func_cotan][sv_dv4][frp_f]; + return (fptr(x)); +} + +vrd4_t +MTH_DISPATCH_FUNC(__rd_cotan_4)(vrd4_t x) +{ + vrd4_t (*fptr)(vrd4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv4,frp_r); + fptr = (vrd4_t(*)(vrd4_t))MTH_DISPATCH_TBL[func_cotan][sv_dv4][frp_r]; + return (fptr(x)); +} + +vrd4_t +MTH_DISPATCH_FUNC(__pd_cotan_4)(vrd4_t x) +{ + vrd4_t (*fptr)(vrd4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv4,frp_p); + fptr = (vrd4_t(*)(vrd4_t))MTH_DISPATCH_TBL[func_cotan][sv_dv4][frp_p]; + return (fptr(x)); +} + +vrd4_t +MTH_DISPATCH_FUNC(__fd_cotan_4m)(vrd4_t x, vid4_t m) +{ + vrd4_t (*fptr)(vrd4_t, vid4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv4m,frp_f); + fptr = (vrd4_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv4m][frp_f]; + return (fptr(x, m)); +} + +vrd4_t +MTH_DISPATCH_FUNC(__rd_cotan_4m)(vrd4_t x, vid4_t m) +{ + vrd4_t (*fptr)(vrd4_t, vid4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv4m,frp_r); + fptr = (vrd4_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv4m][frp_r]; + return (fptr(x, m)); +} + +vrd4_t +MTH_DISPATCH_FUNC(__pd_cotan_4m)(vrd4_t x, vid4_t m) +{ + vrd4_t (*fptr)(vrd4_t, vid4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv4m,frp_p); + fptr = (vrd4_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv4m][frp_p]; + return (fptr(x, m)); +} + vrs8_t MTH_DISPATCH_FUNC(__fs_cosh_8)(vrs8_t x) { diff --git a/runtime/libpgmath/lib/common/mth_256defs_stats.c b/runtime/libpgmath/lib/common/mth_256defs_stats.c index 25c467de1c..b9f53a6cba 100644 --- a/runtime/libpgmath/lib/common/mth_256defs_stats.c +++ b/runtime/libpgmath/lib/common/mth_256defs_stats.c @@ -847,6 +847,126 @@ MTH_DISPATCH_FUNC(__pd_tan_4m)(vrd4_t x, vid4_t m) return (fptr(x, m)); } +vrs8_t +MTH_DISPATCH_FUNC(__fs_cotan_8)(vrs8_t x) +{ + vrs8_t (*fptr)(vrs8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv8,frp_f); + fptr = (vrs8_t(*)(vrs8_t))MTH_DISPATCH_TBL[func_cotan][sv_sv8][frp_f]; + return (fptr(x)); +} + +vrs8_t +MTH_DISPATCH_FUNC(__rs_cotan_8)(vrs8_t x) +{ + vrs8_t (*fptr)(vrs8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv8,frp_r); + fptr = (vrs8_t(*)(vrs8_t))MTH_DISPATCH_TBL[func_cotan][sv_sv8][frp_r]; + return (fptr(x)); +} + +vrs8_t +MTH_DISPATCH_FUNC(__ps_cotan_8)(vrs8_t x) +{ + vrs8_t (*fptr)(vrs8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv8,frp_p); + fptr = (vrs8_t(*)(vrs8_t))MTH_DISPATCH_TBL[func_cotan][sv_sv8][frp_p]; + return (fptr(x)); +} + +vrs8_t +MTH_DISPATCH_FUNC(__fs_cotan_8m)(vrs8_t x, vis8_t m) +{ + vrs8_t (*fptr)(vrs8_t, vis8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv8m,frp_f); + fptr = (vrs8_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv8m][frp_f]; + return (fptr(x, m)); +} + +vrs8_t +MTH_DISPATCH_FUNC(__rs_cotan_8m)(vrs8_t x, vis8_t m) +{ + vrs8_t (*fptr)(vrs8_t, vis8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv8m,frp_r); + fptr = (vrs8_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv8m][frp_r]; + return (fptr(x, m)); +} + +vrs8_t +MTH_DISPATCH_FUNC(__ps_cotan_8m)(vrs8_t x, vis8_t m) +{ + vrs8_t (*fptr)(vrs8_t, vis8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv8m,frp_p); + fptr = (vrs8_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv8m][frp_p]; + return (fptr(x, m)); +} + +vrd4_t +MTH_DISPATCH_FUNC(__fd_cotan_4)(vrd4_t x) +{ + vrd4_t (*fptr)(vrd4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv4,frp_f); + fptr = (vrd4_t(*)(vrd4_t))MTH_DISPATCH_TBL[func_cotan][sv_dv4][frp_f]; + return (fptr(x)); +} + +vrd4_t +MTH_DISPATCH_FUNC(__rd_cotan_4)(vrd4_t x) +{ + vrd4_t (*fptr)(vrd4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv4,frp_r); + fptr = (vrd4_t(*)(vrd4_t))MTH_DISPATCH_TBL[func_cotan][sv_dv4][frp_r]; + return (fptr(x)); +} + +vrd4_t +MTH_DISPATCH_FUNC(__pd_cotan_4)(vrd4_t x) +{ + vrd4_t (*fptr)(vrd4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv4,frp_p); + fptr = (vrd4_t(*)(vrd4_t))MTH_DISPATCH_TBL[func_cotan][sv_dv4][frp_p]; + return (fptr(x)); +} + +vrd4_t +MTH_DISPATCH_FUNC(__fd_cotan_4m)(vrd4_t x, vid4_t m) +{ + vrd4_t (*fptr)(vrd4_t, vid4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv4m,frp_f); + fptr = (vrd4_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv4m][frp_f]; + return (fptr(x, m)); +} + +vrd4_t +MTH_DISPATCH_FUNC(__rd_cotan_4m)(vrd4_t x, vid4_t m) +{ + vrd4_t (*fptr)(vrd4_t, vid4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv4m,frp_r); + fptr = (vrd4_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv4m][frp_r]; + return (fptr(x, m)); +} + +vrd4_t +MTH_DISPATCH_FUNC(__pd_cotan_4m)(vrd4_t x, vid4_t m) +{ + vrd4_t (*fptr)(vrd4_t, vid4_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv4m,frp_p); + fptr = (vrd4_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv4m][frp_p]; + return (fptr(x, m)); +} + vrs8_t MTH_DISPATCH_FUNC(__fs_cosh_8)(vrs8_t x) { diff --git a/runtime/libpgmath/lib/common/mth_512defs.c b/runtime/libpgmath/lib/common/mth_512defs.c index 722ca7ee2b..353ad09215 100644 --- a/runtime/libpgmath/lib/common/mth_512defs.c +++ b/runtime/libpgmath/lib/common/mth_512defs.c @@ -847,6 +847,126 @@ MTH_DISPATCH_FUNC(__pd_tan_8m)(vrd8_t x, vid8_t m) return (fptr(x, m)); } +vrs16_t +MTH_DISPATCH_FUNC(__fs_cotan_16)(vrs16_t x) +{ + vrs16_t (*fptr)(vrs16_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv16,frp_f); + fptr = (vrs16_t(*)(vrs16_t))MTH_DISPATCH_TBL[func_cotan][sv_sv16][frp_f]; + return (fptr(x)); +} + +vrs16_t +MTH_DISPATCH_FUNC(__rs_cotan_16)(vrs16_t x) +{ + vrs16_t (*fptr)(vrs16_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv16,frp_r); + fptr = (vrs16_t(*)(vrs16_t))MTH_DISPATCH_TBL[func_cotan][sv_sv16][frp_r]; + return (fptr(x)); +} + +vrs16_t +MTH_DISPATCH_FUNC(__ps_cotan_16)(vrs16_t x) +{ + vrs16_t (*fptr)(vrs16_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv16,frp_p); + fptr = (vrs16_t(*)(vrs16_t))MTH_DISPATCH_TBL[func_cotan][sv_sv16][frp_p]; + return (fptr(x)); +} + +vrs16_t +MTH_DISPATCH_FUNC(__fs_cotan_16m)(vrs16_t x, vis16_t m) +{ + vrs16_t (*fptr)(vrs16_t, vis16_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv16m,frp_f); + fptr = (vrs16_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv16m][frp_f]; + return (fptr(x, m)); +} + +vrs16_t +MTH_DISPATCH_FUNC(__rs_cotan_16m)(vrs16_t x, vis16_t m) +{ + vrs16_t (*fptr)(vrs16_t, vis16_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv16m,frp_r); + fptr = (vrs16_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv16m][frp_r]; + return (fptr(x, m)); +} + +vrs16_t +MTH_DISPATCH_FUNC(__ps_cotan_16m)(vrs16_t x, vis16_t m) +{ + vrs16_t (*fptr)(vrs16_t, vis16_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv16m,frp_p); + fptr = (vrs16_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv16m][frp_p]; + return (fptr(x, m)); +} + +vrd8_t +MTH_DISPATCH_FUNC(__fd_cotan_8)(vrd8_t x) +{ + vrd8_t (*fptr)(vrd8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv8,frp_f); + fptr = (vrd8_t(*)(vrd8_t))MTH_DISPATCH_TBL[func_cotan][sv_dv8][frp_f]; + return (fptr(x)); +} + +vrd8_t +MTH_DISPATCH_FUNC(__rd_cotan_8)(vrd8_t x) +{ + vrd8_t (*fptr)(vrd8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv8,frp_r); + fptr = (vrd8_t(*)(vrd8_t))MTH_DISPATCH_TBL[func_cotan][sv_dv8][frp_r]; + return (fptr(x)); +} + +vrd8_t +MTH_DISPATCH_FUNC(__pd_cotan_8)(vrd8_t x) +{ + vrd8_t (*fptr)(vrd8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv8,frp_p); + fptr = (vrd8_t(*)(vrd8_t))MTH_DISPATCH_TBL[func_cotan][sv_dv8][frp_p]; + return (fptr(x)); +} + +vrd8_t +MTH_DISPATCH_FUNC(__fd_cotan_8m)(vrd8_t x, vid8_t m) +{ + vrd8_t (*fptr)(vrd8_t, vid8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv8m,frp_f); + fptr = (vrd8_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv8m][frp_f]; + return (fptr(x, m)); +} + +vrd8_t +MTH_DISPATCH_FUNC(__rd_cotan_8m)(vrd8_t x, vid8_t m) +{ + vrd8_t (*fptr)(vrd8_t, vid8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv8m,frp_r); + fptr = (vrd8_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv8m][frp_r]; + return (fptr(x, m)); +} + +vrd8_t +MTH_DISPATCH_FUNC(__pd_cotan_8m)(vrd8_t x, vid8_t m) +{ + vrd8_t (*fptr)(vrd8_t, vid8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv8m,frp_p); + fptr = (vrd8_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv8m][frp_p]; + return (fptr(x, m)); +} + vrs16_t MTH_DISPATCH_FUNC(__fs_cosh_16)(vrs16_t x) { diff --git a/runtime/libpgmath/lib/common/mth_512defs_init.c b/runtime/libpgmath/lib/common/mth_512defs_init.c index 722ca7ee2b..353ad09215 100644 --- a/runtime/libpgmath/lib/common/mth_512defs_init.c +++ b/runtime/libpgmath/lib/common/mth_512defs_init.c @@ -847,6 +847,126 @@ MTH_DISPATCH_FUNC(__pd_tan_8m)(vrd8_t x, vid8_t m) return (fptr(x, m)); } +vrs16_t +MTH_DISPATCH_FUNC(__fs_cotan_16)(vrs16_t x) +{ + vrs16_t (*fptr)(vrs16_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv16,frp_f); + fptr = (vrs16_t(*)(vrs16_t))MTH_DISPATCH_TBL[func_cotan][sv_sv16][frp_f]; + return (fptr(x)); +} + +vrs16_t +MTH_DISPATCH_FUNC(__rs_cotan_16)(vrs16_t x) +{ + vrs16_t (*fptr)(vrs16_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv16,frp_r); + fptr = (vrs16_t(*)(vrs16_t))MTH_DISPATCH_TBL[func_cotan][sv_sv16][frp_r]; + return (fptr(x)); +} + +vrs16_t +MTH_DISPATCH_FUNC(__ps_cotan_16)(vrs16_t x) +{ + vrs16_t (*fptr)(vrs16_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv16,frp_p); + fptr = (vrs16_t(*)(vrs16_t))MTH_DISPATCH_TBL[func_cotan][sv_sv16][frp_p]; + return (fptr(x)); +} + +vrs16_t +MTH_DISPATCH_FUNC(__fs_cotan_16m)(vrs16_t x, vis16_t m) +{ + vrs16_t (*fptr)(vrs16_t, vis16_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv16m,frp_f); + fptr = (vrs16_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv16m][frp_f]; + return (fptr(x, m)); +} + +vrs16_t +MTH_DISPATCH_FUNC(__rs_cotan_16m)(vrs16_t x, vis16_t m) +{ + vrs16_t (*fptr)(vrs16_t, vis16_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv16m,frp_r); + fptr = (vrs16_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv16m][frp_r]; + return (fptr(x, m)); +} + +vrs16_t +MTH_DISPATCH_FUNC(__ps_cotan_16m)(vrs16_t x, vis16_t m) +{ + vrs16_t (*fptr)(vrs16_t, vis16_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv16m,frp_p); + fptr = (vrs16_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv16m][frp_p]; + return (fptr(x, m)); +} + +vrd8_t +MTH_DISPATCH_FUNC(__fd_cotan_8)(vrd8_t x) +{ + vrd8_t (*fptr)(vrd8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv8,frp_f); + fptr = (vrd8_t(*)(vrd8_t))MTH_DISPATCH_TBL[func_cotan][sv_dv8][frp_f]; + return (fptr(x)); +} + +vrd8_t +MTH_DISPATCH_FUNC(__rd_cotan_8)(vrd8_t x) +{ + vrd8_t (*fptr)(vrd8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv8,frp_r); + fptr = (vrd8_t(*)(vrd8_t))MTH_DISPATCH_TBL[func_cotan][sv_dv8][frp_r]; + return (fptr(x)); +} + +vrd8_t +MTH_DISPATCH_FUNC(__pd_cotan_8)(vrd8_t x) +{ + vrd8_t (*fptr)(vrd8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv8,frp_p); + fptr = (vrd8_t(*)(vrd8_t))MTH_DISPATCH_TBL[func_cotan][sv_dv8][frp_p]; + return (fptr(x)); +} + +vrd8_t +MTH_DISPATCH_FUNC(__fd_cotan_8m)(vrd8_t x, vid8_t m) +{ + vrd8_t (*fptr)(vrd8_t, vid8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv8m,frp_f); + fptr = (vrd8_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv8m][frp_f]; + return (fptr(x, m)); +} + +vrd8_t +MTH_DISPATCH_FUNC(__rd_cotan_8m)(vrd8_t x, vid8_t m) +{ + vrd8_t (*fptr)(vrd8_t, vid8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv8m,frp_r); + fptr = (vrd8_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv8m][frp_r]; + return (fptr(x, m)); +} + +vrd8_t +MTH_DISPATCH_FUNC(__pd_cotan_8m)(vrd8_t x, vid8_t m) +{ + vrd8_t (*fptr)(vrd8_t, vid8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv8m,frp_p); + fptr = (vrd8_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv8m][frp_p]; + return (fptr(x, m)); +} + vrs16_t MTH_DISPATCH_FUNC(__fs_cosh_16)(vrs16_t x) { diff --git a/runtime/libpgmath/lib/common/mth_512defs_stats.c b/runtime/libpgmath/lib/common/mth_512defs_stats.c index 722ca7ee2b..353ad09215 100644 --- a/runtime/libpgmath/lib/common/mth_512defs_stats.c +++ b/runtime/libpgmath/lib/common/mth_512defs_stats.c @@ -847,6 +847,126 @@ MTH_DISPATCH_FUNC(__pd_tan_8m)(vrd8_t x, vid8_t m) return (fptr(x, m)); } +vrs16_t +MTH_DISPATCH_FUNC(__fs_cotan_16)(vrs16_t x) +{ + vrs16_t (*fptr)(vrs16_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv16,frp_f); + fptr = (vrs16_t(*)(vrs16_t))MTH_DISPATCH_TBL[func_cotan][sv_sv16][frp_f]; + return (fptr(x)); +} + +vrs16_t +MTH_DISPATCH_FUNC(__rs_cotan_16)(vrs16_t x) +{ + vrs16_t (*fptr)(vrs16_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv16,frp_r); + fptr = (vrs16_t(*)(vrs16_t))MTH_DISPATCH_TBL[func_cotan][sv_sv16][frp_r]; + return (fptr(x)); +} + +vrs16_t +MTH_DISPATCH_FUNC(__ps_cotan_16)(vrs16_t x) +{ + vrs16_t (*fptr)(vrs16_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv16,frp_p); + fptr = (vrs16_t(*)(vrs16_t))MTH_DISPATCH_TBL[func_cotan][sv_sv16][frp_p]; + return (fptr(x)); +} + +vrs16_t +MTH_DISPATCH_FUNC(__fs_cotan_16m)(vrs16_t x, vis16_t m) +{ + vrs16_t (*fptr)(vrs16_t, vis16_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv16m,frp_f); + fptr = (vrs16_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv16m][frp_f]; + return (fptr(x, m)); +} + +vrs16_t +MTH_DISPATCH_FUNC(__rs_cotan_16m)(vrs16_t x, vis16_t m) +{ + vrs16_t (*fptr)(vrs16_t, vis16_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv16m,frp_r); + fptr = (vrs16_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv16m][frp_r]; + return (fptr(x, m)); +} + +vrs16_t +MTH_DISPATCH_FUNC(__ps_cotan_16m)(vrs16_t x, vis16_t m) +{ + vrs16_t (*fptr)(vrs16_t, vis16_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_sv16m,frp_p); + fptr = (vrs16_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_sv16m][frp_p]; + return (fptr(x, m)); +} + +vrd8_t +MTH_DISPATCH_FUNC(__fd_cotan_8)(vrd8_t x) +{ + vrd8_t (*fptr)(vrd8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv8,frp_f); + fptr = (vrd8_t(*)(vrd8_t))MTH_DISPATCH_TBL[func_cotan][sv_dv8][frp_f]; + return (fptr(x)); +} + +vrd8_t +MTH_DISPATCH_FUNC(__rd_cotan_8)(vrd8_t x) +{ + vrd8_t (*fptr)(vrd8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv8,frp_r); + fptr = (vrd8_t(*)(vrd8_t))MTH_DISPATCH_TBL[func_cotan][sv_dv8][frp_r]; + return (fptr(x)); +} + +vrd8_t +MTH_DISPATCH_FUNC(__pd_cotan_8)(vrd8_t x) +{ + vrd8_t (*fptr)(vrd8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv8,frp_p); + fptr = (vrd8_t(*)(vrd8_t))MTH_DISPATCH_TBL[func_cotan][sv_dv8][frp_p]; + return (fptr(x)); +} + +vrd8_t +MTH_DISPATCH_FUNC(__fd_cotan_8m)(vrd8_t x, vid8_t m) +{ + vrd8_t (*fptr)(vrd8_t, vid8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv8m,frp_f); + fptr = (vrd8_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv8m][frp_f]; + return (fptr(x, m)); +} + +vrd8_t +MTH_DISPATCH_FUNC(__rd_cotan_8m)(vrd8_t x, vid8_t m) +{ + vrd8_t (*fptr)(vrd8_t, vid8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv8m,frp_r); + fptr = (vrd8_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv8m][frp_r]; + return (fptr(x, m)); +} + +vrd8_t +MTH_DISPATCH_FUNC(__pd_cotan_8m)(vrd8_t x, vid8_t m) +{ + vrd8_t (*fptr)(vrd8_t, vid8_t); + _MTH_I_INIT(); + _MTH_I_STATS_INC(func_cotan,sv_dv8m,frp_p); + fptr = (vrd8_t(*)())MTH_DISPATCH_TBL[func_cotan][sv_dv8m][frp_p]; + return (fptr(x, m)); +} + vrs16_t MTH_DISPATCH_FUNC(__fs_cosh_16)(vrs16_t x) { diff --git a/runtime/libpgmath/lib/common/mth_tbldefs.h b/runtime/libpgmath/lib/common/mth_tbldefs.h index 208132e9c8..2792848ce0 100644 --- a/runtime/libpgmath/lib/common/mth_tbldefs.h +++ b/runtime/libpgmath/lib/common/mth_tbldefs.h @@ -131,6 +131,7 @@ typedef enum { func_aint, func_ceil, func_floor, + func_cotan, func_size, } func_e; diff --git a/runtime/libpgmath/lib/common/mthdecls.h b/runtime/libpgmath/lib/common/mthdecls.h index a7f5e60e23..a8662ff750 100644 --- a/runtime/libpgmath/lib/common/mthdecls.h +++ b/runtime/libpgmath/lib/common/mthdecls.h @@ -4,6 +4,20 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Complex type support for acosh , asinh , atanh + * Date of Modification: 08 January 2020 + * + * Complex datatype support for atan2 under flag f2008 + * Modified on 13th March 2020 + * + * Last Modified : Jun 2020 + * + */ + /** * \file @@ -29,6 +43,7 @@ #endif #include #endif +#include /* * Windows does not recognize the "_Complex" keyword for complex types but does @@ -52,10 +67,12 @@ #if defined(TARGET_WIN_X8664) && defined(__clang__) typedef _Fcomplex float_complex_t; typedef _Dcomplex double_complex_t; +typedef _Qcomplex quad_complex_t; #define PGMATH_CMPLX_CONST(r,i) {r, i} #else typedef float _Complex float_complex_t; typedef double _Complex double_complex_t; +typedef __complex128 quad_complex_t; // AOCC #define PGMATH_CMPLX_CONST(r,i) r + I*i #endif @@ -69,6 +86,11 @@ typedef struct { double imag; } dcmplx_t; +typedef struct { + __float128 real; + __float128 imag; +} qcmplx_t; + #if defined(__PGIC__) #undef creal #define creal(x) __builtin_creal(x) @@ -86,6 +108,13 @@ float __builtin_crealf(float _Complex); #define cimagf(x) __builtin_cimagf(x) float __builtin_cimagf(float _Complex); +#undef crealq +#define crealq(x) __builtin_crealq(x) +__float128 __builtin_crealq(__float128 _Complex); + +#undef cimagq +#define cimagq(x) __builtin_cimagq(x) +__float128 __builtin_cimagq(__float128 _Complex); #endif #define MTHCONCAT___(l,r) l##r @@ -131,6 +160,26 @@ static inline __attribute__((always_inline)) double_complex_t pgmath_cmplx(doub return _zd._z; } +// AOCC begin +/* + * \brief pgmath_cmplxq - return type quad_complex_t from quad arguments. + * + * Common method across all platforms. Does not use "real + I*imag". + */ + +static inline __attribute__((always_inline)) quad_complex_t pgmath_cmplxq(__float128 r, __float128 i) +{ + struct { + union { + quad_complex_t _z; + __float128 _q[2]; + }; + } _cq ; + _cq._q[0] = r; + _cq._q[1] = i; + return _cq._z; +} +// AOCC end /* * Complex ABI conventions. * @@ -179,6 +228,19 @@ static inline __attribute__((always_inline)) double_complex_t pgmath_cmplx(doub #define ZMPLXFUNC_Z_K_(_f) \ void _f(dcmplx_t *dcmplx, double real, double imag, long long i) +// AOCC begin +#define QMPLXFUNC_Q_(_f) \ + void _f(qcmplx_t *qcmplx, __float128 real, __float128 imag) +#define QMPLXFUNC_Q_Q_(_f) \ + void _f(qcmplx_t *qcmplx, __float128 real1, __float128 imag1, \ + __float128 real2, __float128 imag2) +#define QMPLXFUNC_C_Q_(_f) \ + void _f(qcmplx_t *qcmplx, __float128 real, __float128 imag, __float128 d) +#define QMPLXFUNC_C_I_(_f) \ + void _f(qcmplx_t *qcmplx, __float128 real, __float128 imag, int i) +#define QMPLXFUNC_C_K_(_f) \ + void _f(qcmplx_t *qcmplx, __float128 real, __float128 imag, long long i) +// AOCC end /* C99 complex ABI */ #define FLTFUNC_C_C99_(_f) \ float MTHCONCAT__(_f,__MTH_C99_CMPLX_SUFFIX) \ @@ -186,6 +248,9 @@ static inline __attribute__((always_inline)) double_complex_t pgmath_cmplx(doub #define DBLFUNC_C_C99_(_f) \ double MTHCONCAT__(_f,__MTH_C99_CMPLX_SUFFIX) \ (double_complex_t zarg) +#define QUADFUNC_C_C99_(_f) \ + __float128 MTHCONCAT__(_f,__MTH_C99_CMPLX_SUFFIX) \ + (quad_complex_t qarg) #define CMPLXFUNC_C_C99_(_f) \ float_complex_t MTHCONCAT__(_f,__MTH_C99_CMPLX_SUFFIX) \ @@ -219,6 +284,23 @@ static inline __attribute__((always_inline)) double_complex_t pgmath_cmplx(doub double_complex_t MTHCONCAT__(_f,__MTH_C99_CMPLX_SUFFIX) \ (double_complex_t zarg, long long i) +// AOCC begin +#define QMPLXFUNC_Q_C99_(_f) \ + quad_complex_t MTHCONCAT__(_f,__MTH_C99_CMPLX_SUFFIX) \ + (quad_complex_t qarg) +#define QMPLXFUNC_Q_Q_C99_(_f) \ + quad_complex_t MTHCONCAT__(_f,__MTH_C99_CMPLX_SUFFIX) \ + (quad_complex_t qarg1, quad_complex_t qarg2) +#define QMPLXFUNC_C_Q_C99_(_f) \ + quad_complex_t MTHCONCAT__(_f,__MTH_C99_CMPLX_SUFFIX) \ + (quad_complex_t qarg, __float128 q) +#define QMPLXFUNC_C_I_C99_(_f) \ + quad_complex_t MTHCONCAT__(_f,__MTH_C99_CMPLX_SUFFIX) \ + (quad_complex_t qarg, int i) +#define QMPLXFUNC_C_K_C99_(_f) \ + quad_complex_t MTHCONCAT__(_f,__MTH_C99_CMPLX_SUFFIX) \ + (quad_complex_t qarg, long long i) +// AOCC end #ifndef MTH_CMPLX_C99_ABI #define FLTFUNC_C(_f) FLTFUNC_C_(_f) @@ -236,10 +318,22 @@ static inline __attribute__((always_inline)) double_complex_t pgmath_cmplx(doub #define ZMPLXFUNC_Z_I(_f) ZMPLXFUNC_Z_I_(_f) #define ZMPLXFUNC_Z_K(_f) ZMPLXFUNC_Z_K_(_f) +// AOCC begin +#define QMPLXFUNC_Q(_f) QMPLXFUNC_Q_(_f) +#define QMPLXFUNC_Q_Q(_f) QMPLXFUNC_Q_Q_(_f) +#define QMPLXFUNC_C_Q(_f) QMPLXFUNC_C_Q_(_f) +#define QMPLXFUNC_C_I(_f) QMPLXFUNC_C_I_(_f) +#define QMPLXFUNC_C_K(_f) QMPLXFUNC_C_K_(_f) +// AOCC end + #define CMPLXARGS_C float_complex_t \ carg = pgmath_cmplxf(real, imag) #define ZMPLXARGS_Z double_complex_t \ zarg = pgmath_cmplx(real, imag) + +#define QMPLXARGS_Q quad_complex_t \ + qarg = pgmath_cmplxq(real, imag) + #define CMPLXARGS_C_C float_complex_t \ carg1 = pgmath_cmplxf(real1, imag1),\ carg2 = pgmath_cmplxf(real2, imag2) @@ -253,12 +347,24 @@ static inline __attribute__((always_inline)) double_complex_t pgmath_cmplx(doub #define ZMPLXARGS_Z_I #define ZMPLXARGS_Z_K +// AOCC begin +#define QMPLXARGS_Q_Q quad_complex_t \ + qarg1 = pgmath_cmplxq(real1, imag1),\ + qarg2 = pgmath_cmplxq(real2, imag2) +#define QMPLXARGS_C_Q +#define QMPLXARGS_C_I +#define QMPLXARGS_C_K +// AOCC end + #define CRETURN_F_F(_r, _i) do { cmplx->real = (_r); cmplx->imag = (_i); return; } while (0) #define ZRETURN_D_D(_r, _i) do { dcmplx->real = (_r); dcmplx->imag = (_i); return; } while (0) +#define QRETURN_Q_Q(_r, _i) do { qcmplx->real = (_r); qcmplx->imag = (_i); return; } while (0) #define CRETURN_C(_c) do { (*cmplx = *((cmplx_t *)&(_c))); return; } while (0) #define ZRETURN_Z(_z) do { (*dcmplx = *((dcmplx_t *)&(_z))); return; } while (0) +#define QRETURN_C(_c) do { (*qcmplx = *((qcmplx_t *)&(_c))); return; } while (0) #define CRETURN_F(_f) return (_f) #define ZRETURN_D(_d) return (_d) +#define QRETURN_Q(_q) return (_q) #define CMPLX_CALL_CR_C_C(_f,_cr,_c1,_c2) \ { _f(cmplx, crealf(_c1), cimagf(_c1), crealf(_c2), cimagf(_c2)); \ @@ -266,6 +372,9 @@ static inline __attribute__((always_inline)) double_complex_t pgmath_cmplx(doub #define ZMPLX_CALL_ZR_Z_Z(_f,_zr,_z1,_z2) \ { _f(dcmplx, creal(_z1), cimag(_z1), creal(_z2), cimag(_z2)); \ *(dcmplx_t *)&_zr = *dcmplx; } +#define QMPLX_CALL_QR_Q_Q(_f,_qr,_q1,_q2) \ +{ _f(qcmplx, crealq(_q1), cimagq(_q1), crealq(_q2), cimagq(_q2)); \ + __real__ _qr = qcmplx->real; __imag__ _qr = qcmplx->imag; } #else /* #ifdef MTH_CMPLX_C99_ABI */ @@ -284,6 +393,12 @@ static inline __attribute__((always_inline)) double_complex_t pgmath_cmplx(doub #define ZMPLXFUNC_Z_I(_f) ZMPLXFUNC_Z_I_C99_(_f) #define ZMPLXFUNC_Z_K(_f) ZMPLXFUNC_Z_K_C99_(_f) +#define QMPLXFUNC_Q(_f) QMPLXFUNC_Q_C99_(_f) +#define QMPLXFUNC_Q_Q(_f) QMPLXFUNC_Q_Q_C99_(_f) +#define QMPLXFUNC_C_Q(_f) QMPLXFUNC_C_Q_C99_(_f) +#define QMPLXFUNC_C_I(_f) QMPLXFUNC_C_I_C99_(_f) +#define QMPLXFUNC_C_K(_f) QMPLXFUNC_C_K_C99_(_f) + #define CMPLXARGS_C float real = crealf(carg), imag = cimagf(carg) #define CMPLXARGS_C_C float real1 = crealf(carg1), imag1 = cimagf(carg1), \ real2 = crealf(carg2), imag2 = cimagf(carg2) @@ -298,10 +413,20 @@ static inline __attribute__((always_inline)) double_complex_t pgmath_cmplx(doub #define ZMPLXARGS_Z_I ZMPLXARGS_Z #define ZMPLXARGS_Z_K ZMPLXARGS_Z +#define QMPLXARGS_Q __float128 real = crealq(qarg), imag = cimagq(qarg) +#define QMPLXARGS_Q_Q __float128 real1 = crealq(qarg1), imag1 = cimagq(qarg1), \ + real2 = crealq(qarg2), imag2 = cimagq(qarg2) +#define QMPLXARGS_C_Q QMPLXARGS_Q +#define QMPLXARGS_C_I QMPLXARGS_Q +#define QMPLXARGS_C_K QMPLXARGS_Q + #define CRETURN_F_F(_r, _i) { float_complex_t __r = pgmath_cmplxf(_r, _i); return __r; } #define ZRETURN_D_D(_r, _i) { double_complex_t __r = pgmath_cmplx(_r, _i); return __r; } +#define QRETURN_Q_Q(_r, _i) { quad_complex_t __r = pgmath_cmplxq(_r, _i); return __r; } #define CRETURN_C(_c) return (_c) #define ZRETURN_Z(_z) return (_z) +#define QRETURN_C(_c) return (_c) +#define QRETURN_Q(_q) return (_q) #define CRETURN_F(_f) return (_f) #define ZRETURN_D(_d) return (_d) @@ -309,6 +434,8 @@ static inline __attribute__((always_inline)) double_complex_t pgmath_cmplx(doub {_cr = MTHCONCAT__(_f,__MTH_C99_CMPLX_SUFFIX)(_c1, _c2); } #define ZMPLX_CALL_ZR_Z_Z(_f,_zr,_z1,_z2) \ {_zr = MTHCONCAT__(_f,__MTH_C99_CMPLX_SUFFIX)(_z1, _z2); } +#define QMPLX_CALL_QR_Q_Q(_f,_qr,_q1,_q2) \ +{_qr = MTHCONCAT__(_f,__MTH_C99_CMPLX_SUFFIX)(_q1, _q2); } #endif /* #ifdef MTH_CMPLX_C99_ABI */ @@ -334,6 +461,12 @@ static inline __attribute__((always_inline)) double_complex_t pgmath_cmplx(doub #define ZMPLXDECL_Z_I(_f) ZMPLXFUNC_Z_I_(_f) ; ZMPLXFUNC_Z_I_C99_(_f); #define ZMPLXDECL_Z_K(_f) ZMPLXFUNC_Z_K_(_f) ; ZMPLXFUNC_Z_K_C99_(_f); +#define QMPLXDECL_Q(_f) QMPLXFUNC_Q_(_f) ; QMPLXFUNC_Q_C99_(_f); +#define QMPLXDECL_Q_Q(_f) QMPLXFUNC_Q_Q_(_f) ; QMPLXFUNC_Q_Q_C99_(_f); +#define QMPLXDECL_C_Q(_f) QMPLXFUNC_C_Q_(_f) ; QMPLXFUNC_C_Q_C99_(_f); +#define QMPLXDECL_C_I(_f) QMPLXFUNC_C_I_(_f) ; QMPLXFUNC_C_I_C99_(_f); +#define QMPLXDECL_C_K(_f) QMPLXFUNC_C_K_(_f) ; QMPLXFUNC_C_K_C99_(_f); + /* * Universal set of CPP object macros that map the Bessel functions * to the different entry points for the various architectures. @@ -385,6 +518,13 @@ static inline __attribute__((always_inline)) double_complex_t pgmath_cmplx(doub #define BESSEL_Y1F y1f #define BESSEL_YNF ynf +#define BESSEL_J0Q j0q +#define BESSEL_J1Q j1q +#define BESSEL_JNQ jnq +#define BESSEL_Y0Q y0q +#define BESSEL_Y1Q y1q +#define BESSEL_YNQ ynq + #define BESSEL_J0 j0 #define BESSEL_J1 j1 #define BESSEL_JN jn @@ -409,6 +549,7 @@ float __mth_i_rpowr(float f, float g); float __mth_i_sin(float f); float __mth_i_sinh(float f); float __mth_i_sqrt(float f); +float __mth_i_cotan(float f); float __mth_i_tan(float f); float __mth_i_tanh(float f); float __mth_i_amod(float f, float g); @@ -426,6 +567,7 @@ float __mth_i_atand(float f); float __mth_i_atan2d(float f, float g); float __mth_i_sind(float f); float __mth_i_tand(float f); +float __mth_i_cotand(float f); float __mth_i_cosd(float f); float __mth_i_erf(float f); float __mth_i_erfc(float f); @@ -447,6 +589,7 @@ float __mth_i_floor(float); int __mth_i_idnint(double d); int __mth_i_mod(int i, int j); int __mth_i_nint(float d); +int __mth_i_qnint(__float128 q); int __mth_i_ipowi(int x, int i); double __mth_i_dacos(double d); @@ -466,6 +609,7 @@ double __mth_i_dsin(double d); double __mth_i_dsinh(double d); double __mth_i_dsqrt(double d); double __mth_i_dtan(double d); +double __mth_i_dcotan(double d); double __mth_i_dtanh(double d); double __mth_i_dmod(double f, double g); double __mth_i_dint(double d); @@ -480,12 +624,14 @@ double __mth_i_datand(double f); double __mth_i_datan2d(double f, double g); double __mth_i_dsind(double f); double __mth_i_dtand(double f); +double __mth_i_dcotand(double f); double __mth_i_dcosd(double f); double __mth_i_derf(double f); double __mth_i_derfc(double f); double __mth_i_derfc_scaled(double f); double __mth_i_dgamma(double f); double __mth_i_dlog_gamma(double f); +__float128 __mth_i_qlog_gamma(__float128 f); double __mth_i_dhypot(double, double); double __mth_i_pow(double, double); double __mth_i_dbessel_j0(double arg); @@ -496,6 +642,14 @@ double __mth_i_dbessel_y0(double arg); double __mth_i_dbessel_y1(double arg); double __mth_i_dbessel_yn(int n, double arg); double __f90_dbessel_yn(int n1, int n, double d); +__float128 __mth_i_qbessel_j0(__float128 arg); +__float128 __mth_i_qbessel_j1(__float128 arg); +__float128 __mth_i_qbessel_jn(int n, __float128 arg); +__float128 __f90_qbessel_jn(int n1, int n, __float128 d); +__float128 __mth_i_qbessel_y0(__float128 arg); +__float128 __mth_i_qbessel_y1(__float128 arg); +__float128 __mth_i_qbessel_yn(int n, __float128 arg); +__float128 __f90_qbessel_yn(int n1, int n, __float128 d); double __mth_i_dceil(double); double __mth_i_dfloor(double); @@ -507,9 +661,12 @@ static inline void __mth_sincos(float angle, float *s, float *c) __attribute__((always_inline)); static inline void __mth_dsincos(double angle, double *s, double *c) __attribute__((always_inline)); +static inline void __mth_qsincos(__float128 angle, __float128 *s, __float128 *c) + __attribute__((always_inline)); #else /* ! defined (TARGET_X8664) && ! defined(LINUX8664) */ void __mth_sincos(float, float *, float *); void __mth_dsincos(double, double *, double *); +void __mth_qsincos(__float128, __float128 *, __float128 *); #endif /* ! defined (TARGET_X8664) && ! defined(LINUX8664) */ #if defined(__CDECL) @@ -537,7 +694,14 @@ CMPLXDECL_C(__mth_i_csin); CMPLXDECL_C(__mth_i_csinh); CMPLXDECL_C(__mth_i_csqrt); CMPLXDECL_C(__mth_i_ctan); +CMPLXDECL_C(__mth_i_ccotan); CMPLXDECL_C(__mth_i_ctanh); +//AOCC Begin +CMPLXDECL_C(__mth_i_cacosh); +CMPLXDECL_C(__mth_i_casinh); +CMPLXDECL_C(__mth_i_catanh); +CMPLXDECL_C_C(__mth_i_catan2); +//AOCC End DBLDECL_C(__mth_i_cdabs); ZMPLXDECL_Z(__mth_i_cdacos); @@ -556,7 +720,13 @@ ZMPLXDECL_Z(__mth_i_cdsin); ZMPLXDECL_Z(__mth_i_cdsinh); ZMPLXDECL_Z(__mth_i_cdsqrt); ZMPLXDECL_Z(__mth_i_cdtan); +ZMPLXDECL_Z(__mth_i_cdcotan); ZMPLXDECL_Z(__mth_i_cdtanh); +// AOCC begin +__CDECL QMPLXDECL_Q_Q(__mth_i_cqdiv); +QMPLXDECL_C_I(__mth_i_cqpowi); +QMPLXDECL_C_K(__mth_i_cqpowk); +// AOCC end @@ -579,6 +749,16 @@ extern float_complex_t ctanhf(float_complex_t); extern double_complex_t ctanh(double_complex_t); extern float_complex_t ctanf(float_complex_t); extern double_complex_t ctan(double_complex_t); +//AOCC begin +extern float_complex_t cacoshf(float_complex_t); +extern double_complex_t cacosh(double_complex_t); +extern float_complex_t casinhf(float_complex_t); +extern double_complex_t casinh(double_complex_t); +extern float_complex_t catanhf(float_complex_t); +extern double_complex_t catanh(double_complex_t); +extern double_complex_t catan2(double_complex_t, double_complex_t); +//AOCC end + #endif /* #if ! defined(_C_COMPLEX_T) */ #endif /* #if defined(TARGET_WIN) */ @@ -624,10 +804,19 @@ static inline void __attribute__((always_inline)) __mth_dsincos(double angle, do *s = sin(angle); *c = cos(angle); } +// AOCC begin +static inline void __attribute__((always_inline)) __mth_qsincos(__float128 angle, __float128 *s, __float128 *c) +{ + *s = sin(angle); + *c = cos(angle); +} +// AOCC end #elif defined (TARGET_OSX_X8664) /* if defined(TARGET_WIN_X8664) */ #define __mth_sincos(_a,_s,_c) __sincosf(_a,_s,_c) #define __mth_dsincos(_a,_s,_c) __sincos(_a,_s,_c) +#define __mth_qsincos(_a,_s,_c) __sincosq(_a,_s,_c) #else /* if defined(TARGET_WIN_X8664) */ #define __mth_sincos(_a,_s,_c) sincosf(_a,_s,_c) #define __mth_dsincos(_a,_s,_c) sincos(_a,_s,_c) +#define __mth_qsincos(_a,_s,_c) __sincosq(_a,_s,_c) #endif/* if defined(TARGET_WIN_X8664) */ diff --git a/runtime/libpgmath/lib/common/pow/fma3/vdpow4.cpp b/runtime/libpgmath/lib/common/pow/fma3/vdpow4.cpp index 3741a82967..3c768c7f36 100644 --- a/runtime/libpgmath/lib/common/pow/fma3/vdpow4.cpp +++ b/runtime/libpgmath/lib/common/pow/fma3/vdpow4.cpp @@ -71,7 +71,7 @@ __m256d __internal_fast_int2dbl(__m256i a) __m256d const INT2DBL = (__m256d)_mm256_set1_epi64x(INT2DBL_D); __m256i t = _mm256_xor_si256(INT2DBL_LO, a); - t = _mm256_blend_epi32(INT2DBL_HI, t, 0x55); + t = _mm256_blend_epi32(INT2DBL_HI, t, 0x55); return _mm256_sub_pd((__m256d)t, INT2DBL); } diff --git a/runtime/libpgmath/lib/common/qacosd.c b/runtime/libpgmath/lib/common/qacosd.c new file mode 100644 index 0000000000..f85429ae74 --- /dev/null +++ b/runtime/libpgmath/lib/common/qacosd.c @@ -0,0 +1,21 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ + +#include "mthdecls.h" +#include + +__float128 __attribute__((weak)) acosq( __float128); + +__float128 +__mth_i_qacosd(__float128 q) +{ + return (CNVRTRAD(acosq(q))); +} diff --git a/runtime/libpgmath/lib/common/qasind.c b/runtime/libpgmath/lib/common/qasind.c new file mode 100644 index 0000000000..6b9ff73378 --- /dev/null +++ b/runtime/libpgmath/lib/common/qasind.c @@ -0,0 +1,22 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ + +#include "mthdecls.h" +#include + +__float128 __attribute__((weak)) asinq( __float128); + +__float128 +__mth_i_qasind(__float128 q) +{ + return (CNVRTRAD(asinq(q))); +} diff --git a/runtime/libpgmath/lib/common/qatan2d.c b/runtime/libpgmath/lib/common/qatan2d.c new file mode 100644 index 0000000000..e01c412789 --- /dev/null +++ b/runtime/libpgmath/lib/common/qatan2d.c @@ -0,0 +1,22 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ + +#include "mthdecls.h" +#include + +__float128 __attribute__((weak)) atan2q( __float128, __float128); + +__float128 +__mth_i_qatan2d(__float128 x, __float128 y) +{ + return (CNVRTRAD(atan2q(x,y))); +} diff --git a/runtime/libpgmath/lib/common/qatand.c b/runtime/libpgmath/lib/common/qatand.c new file mode 100644 index 0000000000..6d001f5e9c --- /dev/null +++ b/runtime/libpgmath/lib/common/qatand.c @@ -0,0 +1,22 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ + +#include "mthdecls.h" +#include + +__float128 __attribute__((weak)) atanq( __float128); + +__float128 +__mth_i_qatand(__float128 q) +{ + return (CNVRTRAD(atanq(q))); +} diff --git a/runtime/libpgmath/lib/common/qbessel_j0.c b/runtime/libpgmath/lib/common/qbessel_j0.c new file mode 100644 index 0000000000..c7cd4f3460 --- /dev/null +++ b/runtime/libpgmath/lib/common/qbessel_j0.c @@ -0,0 +1,25 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ + +/* inhibit floating point copy propagation */ +#pragma global - Mx, 6, 0x100 + +#include "mthdecls.h" +#include + +__float128 __attribute__((weak)) BESSEL_J0Q( __float128); + +__float128 +__mth_i_qbessel_j0(__float128 arg) +{ + __float128 f = BESSEL_J0Q(arg); + return f; +} diff --git a/runtime/libpgmath/lib/common/qbessel_j1.c b/runtime/libpgmath/lib/common/qbessel_j1.c new file mode 100644 index 0000000000..0342b91954 --- /dev/null +++ b/runtime/libpgmath/lib/common/qbessel_j1.c @@ -0,0 +1,25 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ + +/* inhibit floating point copy propagation */ +#pragma global - Mx, 6, 0x100 + +#include "mthdecls.h" +#include + +__float128 __attribute__((weak)) BESSEL_J1Q( __float128); + +__float128 +__mth_i_qbessel_j1(__float128 arg) +{ + __float128 f = BESSEL_J1Q(arg); + return f; +} diff --git a/runtime/libpgmath/lib/common/qbessel_jn.c b/runtime/libpgmath/lib/common/qbessel_jn.c new file mode 100644 index 0000000000..8c928da619 --- /dev/null +++ b/runtime/libpgmath/lib/common/qbessel_jn.c @@ -0,0 +1,25 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ + +/* inhibit floating point copy propagation */ +#pragma global - Mx, 6, 0x100 + +#include "mthdecls.h" +#include + +__float128 __attribute__((weak)) BESSEL_JNQ(int, __float128); + +__float128 +__mth_i_qbessel_jn(int n, __float128 arg) +{ + __float128 f = BESSEL_JNQ(n, arg); + return f; +} diff --git a/runtime/libpgmath/lib/common/qbessel_y0.c b/runtime/libpgmath/lib/common/qbessel_y0.c new file mode 100644 index 0000000000..a6b4f8a8e6 --- /dev/null +++ b/runtime/libpgmath/lib/common/qbessel_y0.c @@ -0,0 +1,25 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ + +/* inhibit floating point copy propagation */ +#pragma global - Mx, 6, 0x100 + +#include "mthdecls.h" +#include + +__float128 __attribute__((weak)) BESSEL_Y0Q( __float128); + +__float128 +__mth_i_qbessel_y0(__float128 arg) +{ + __float128 f = BESSEL_Y0Q(arg); + return f; +} diff --git a/runtime/libpgmath/lib/common/qbessel_y1.c b/runtime/libpgmath/lib/common/qbessel_y1.c new file mode 100644 index 0000000000..914ebbee46 --- /dev/null +++ b/runtime/libpgmath/lib/common/qbessel_y1.c @@ -0,0 +1,25 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ + +/* inhibit floating point copy propagation */ +#pragma global - Mx, 6, 0x100 + +#include "mthdecls.h" +#include + +__float128 __attribute__((weak)) BESSEL_Y1Q( __float128); + +__float128 +__mth_i_qbessel_y1(__float128 arg) +{ + __float128 f = BESSEL_Y1Q(arg); + return f; +} diff --git a/runtime/libpgmath/lib/common/qbessel_yn.c b/runtime/libpgmath/lib/common/qbessel_yn.c new file mode 100644 index 0000000000..f42ca3822c --- /dev/null +++ b/runtime/libpgmath/lib/common/qbessel_yn.c @@ -0,0 +1,25 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ + +/* inhibit floating point copy propagation */ +#pragma global - Mx, 6, 0x100 + +#include "mthdecls.h" +#include + +__float128 __attribute__((weak)) BESSEL_YNQ(int, __float128); + +__float128 +__mth_i_qbessel_yn(int n, __float128 arg) +{ + __float128 f = BESSEL_YNQ(n, arg); + return f; +} diff --git a/runtime/libpgmath/lib/common/qcosd.c b/runtime/libpgmath/lib/common/qcosd.c new file mode 100644 index 0000000000..b35259b76e --- /dev/null +++ b/runtime/libpgmath/lib/common/qcosd.c @@ -0,0 +1,21 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ + +#include "mthdecls.h" +#include + +__float128 __attribute__((weak)) cosq( __float128); + +__float128 +__mth_i_qcosd(__float128 q) +{ + return (cosq(CNVRTDEG(q))); +} diff --git a/runtime/libpgmath/lib/common/qcotan.c b/runtime/libpgmath/lib/common/qcotan.c new file mode 100644 index 0000000000..107806cf49 --- /dev/null +++ b/runtime/libpgmath/lib/common/qcotan.c @@ -0,0 +1,21 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ + +#include "mthdecls.h" +#include + +__float128 __attribute__((weak)) tanq( __float128); + +__float128 +__mth_i_qcotan(__float128 q) +{ + return 1.0/(tanq(q)); +} diff --git a/runtime/libpgmath/lib/common/qcotand.c b/runtime/libpgmath/lib/common/qcotand.c new file mode 100644 index 0000000000..52746eb921 --- /dev/null +++ b/runtime/libpgmath/lib/common/qcotand.c @@ -0,0 +1,21 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ + +#include "mthdecls.h" +#include + +__float128 __attribute__((weak)) tanq( __float128); + +__float128 +__mth_i_qcotand(__float128 q) +{ + return 1.0/(tanq(CNVRTDEG(q))); +} diff --git a/runtime/libpgmath/lib/common/qnint.c b/runtime/libpgmath/lib/common/qnint.c new file mode 100644 index 0000000000..fba6770bfb --- /dev/null +++ b/runtime/libpgmath/lib/common/qnint.c @@ -0,0 +1,20 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ + +#include "mthdecls.h" +#include + +__float128 __attribute__((weak)) roundq(__float128); +int +__mth_i_qnint(__float128 q) +{ + return (int)(roundq(q)); +} diff --git a/runtime/libpgmath/lib/common/qpowi.c b/runtime/libpgmath/lib/common/qpowi.c new file mode 100644 index 0000000000..cb5c173b98 --- /dev/null +++ b/runtime/libpgmath/lib/common/qpowi.c @@ -0,0 +1,34 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ +#include "mthdecls.h" + +__float128 +__mth_i_qpowi(__float128 x, int i) +{ + int k; + __float128 f; + + f = 1; + k = i; + if (k < 0) + k = -k; + for (;;) { + if (k & 1) + f *= x; + k = (unsigned)k >> 1; + if (k == 0) + break; + x *= x; + } + if (i < 0) + f = 1.0 / f; + return f; +} diff --git a/runtime/libpgmath/lib/common/qsind.c b/runtime/libpgmath/lib/common/qsind.c new file mode 100644 index 0000000000..0237b400be --- /dev/null +++ b/runtime/libpgmath/lib/common/qsind.c @@ -0,0 +1,17 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + +#include "mthdecls.h" +#include "quadmath.h" + +__float128 __attribute__((weak)) sinq( __float128); + +__float128 +__mth_i_qsind(__float128 q) +{ + return (sinq(CNVRTDEG(q))); +} diff --git a/runtime/libpgmath/lib/common/qtand.c b/runtime/libpgmath/lib/common/qtand.c new file mode 100644 index 0000000000..86107aac91 --- /dev/null +++ b/runtime/libpgmath/lib/common/qtand.c @@ -0,0 +1,21 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ + +#include "mthdecls.h" +#include + +__float128 __attribute__((weak)) tanq( __float128); + +__float128 +__mth_i_qtand(__float128 q) +{ + return (tanq(CNVRTDEG(q))); +} diff --git a/runtime/libpgmath/lib/common/quadmath.h b/runtime/libpgmath/lib/common/quadmath.h new file mode 100644 index 0000000000..1555304c7f --- /dev/null +++ b/runtime/libpgmath/lib/common/quadmath.h @@ -0,0 +1,201 @@ +/* GCC Quad-Precision Math Library + Copyright (C) 2010, 2011 Free Software Foundation, Inc. + Written by Francois-Xavier Coudert + +This file is part of the libquadmath library. +Libquadmath is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +Libquadmath is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with libquadmath; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 51 Franklin Street - Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#ifndef QUADMATH_H +#define QUADMATH_H + +#include + +#ifdef __cplusplus +extern "C" { +#endif + +/* Define the complex type corresponding to __float128 + ("_Complex __float128" is not allowed) */ +typedef _Complex float __attribute__((mode(TC))) __complex128; + +#ifdef __cplusplus +# define __quadmath_throw throw () +# define __quadmath_nth(fct) fct throw () +#else +# define __quadmath_throw __attribute__((__nothrow__)) +# define __quadmath_nth(fct) __attribute__((__nothrow__)) fct +#endif + +/* Prototypes for real functions */ +extern __float128 acosq (__float128) __quadmath_throw; +extern __float128 acoshq (__float128) __quadmath_throw; +extern __float128 asinq (__float128) __quadmath_throw; +extern __float128 asinhq (__float128) __quadmath_throw; +extern __float128 atanq (__float128) __quadmath_throw; +extern __float128 atanhq (__float128) __quadmath_throw; +extern __float128 atan2q (__float128, __float128) __quadmath_throw; +extern __float128 cbrtq (__float128) __quadmath_throw; +extern __float128 ceilq (__float128) __quadmath_throw; +extern __float128 copysignq (__float128, __float128) __quadmath_throw; +extern __float128 coshq (__float128) __quadmath_throw; +extern __float128 cosq (__float128) __quadmath_throw; +extern __float128 erfq (__float128) __quadmath_throw; +extern __float128 erfcq (__float128) __quadmath_throw; +extern __float128 expq (__float128) __quadmath_throw; +extern __float128 expm1q (__float128) __quadmath_throw; +extern __float128 fabsq (__float128) __quadmath_throw; +extern __float128 fdimq (__float128, __float128) __quadmath_throw; +extern int finiteq (__float128) __quadmath_throw; +extern __float128 floorq (__float128) __quadmath_throw; +extern __float128 fmaq (__float128, __float128, __float128) __quadmath_throw; +extern __float128 fmaxq (__float128, __float128) __quadmath_throw; +extern __float128 fminq (__float128, __float128) __quadmath_throw; +extern __float128 fmodq (__float128, __float128) __quadmath_throw; +extern __float128 frexpq (__float128, int *) __quadmath_throw; +extern __float128 hypotq (__float128, __float128) __quadmath_throw; +extern int isinfq (__float128) __quadmath_throw; +extern int ilogbq (__float128) __quadmath_throw; +extern int isnanq (__float128) __quadmath_throw; +extern __float128 j0q (__float128) __quadmath_throw; +extern __float128 j1q (__float128) __quadmath_throw; +extern __float128 jnq (int, __float128) __quadmath_throw; +extern __float128 ldexpq (__float128, int) __quadmath_throw; +extern __float128 lgammaq (__float128) __quadmath_throw; +extern long long int llrintq (__float128) __quadmath_throw; +extern long long int llroundq (__float128) __quadmath_throw; +extern __float128 logbq (__float128) __quadmath_throw; +extern __float128 logq (__float128) __quadmath_throw; +extern __float128 log10q (__float128) __quadmath_throw; +extern __float128 log2q (__float128) __quadmath_throw; +extern __float128 log1pq (__float128) __quadmath_throw; +extern long int lrintq (__float128) __quadmath_throw; +extern long int lroundq (__float128) __quadmath_throw; +extern __float128 modfq (__float128, __float128 *) __quadmath_throw; +extern __float128 nanq (const char *) __quadmath_throw; +extern __float128 nearbyintq (__float128) __quadmath_throw; +extern __float128 nextafterq (__float128, __float128) __quadmath_throw; +extern __float128 powq (__float128, __float128) __quadmath_throw; +extern __float128 remainderq (__float128, __float128) __quadmath_throw; +extern __float128 remquoq (__float128, __float128, int *) __quadmath_throw; +extern __float128 rintq (__float128) __quadmath_throw; +extern __float128 roundq (__float128) __quadmath_throw; +extern __float128 scalblnq (__float128, long int) __quadmath_throw; +extern __float128 scalbnq (__float128, int) __quadmath_throw; +extern int signbitq (__float128) __quadmath_throw; +extern void sincosq (__float128, __float128 *, __float128 *) __quadmath_throw; +extern __float128 sinhq (__float128) __quadmath_throw; +extern __float128 sinq (__float128) __quadmath_throw; +extern __float128 sqrtq (__float128) __quadmath_throw; +extern __float128 tanq (__float128) __quadmath_throw; +extern __float128 tanhq (__float128) __quadmath_throw; +extern __float128 tgammaq (__float128) __quadmath_throw; +extern __float128 truncq (__float128) __quadmath_throw; +extern __float128 y0q (__float128) __quadmath_throw; +extern __float128 y1q (__float128) __quadmath_throw; +extern __float128 ynq (int, __float128) __quadmath_throw; + + +/* Prototypes for complex functions */ +extern __float128 cabsq (__complex128) __quadmath_throw; +extern __float128 cargq (__complex128) __quadmath_throw; +extern __float128 cimagq (__complex128) __quadmath_throw; +extern __float128 crealq (__complex128) __quadmath_throw; +extern __complex128 cacosq (__complex128) __quadmath_throw; +extern __complex128 cacoshq (__complex128) __quadmath_throw; +extern __complex128 casinq (__complex128) __quadmath_throw; +extern __complex128 casinhq (__complex128) __quadmath_throw; +extern __complex128 catanq (__complex128) __quadmath_throw; +extern __complex128 catanhq (__complex128) __quadmath_throw; +extern __complex128 ccosq (__complex128) __quadmath_throw; +extern __complex128 ccoshq (__complex128) __quadmath_throw; +extern __complex128 cexpq (__complex128) __quadmath_throw; +extern __complex128 cexpiq (__float128) __quadmath_throw; +extern __complex128 clogq (__complex128) __quadmath_throw; +extern __complex128 clog10q (__complex128) __quadmath_throw; +extern __complex128 conjq (__complex128) __quadmath_throw; +extern __complex128 cpowq (__complex128, __complex128) __quadmath_throw; +extern __complex128 cprojq (__complex128) __quadmath_throw; +extern __complex128 csinq (__complex128) __quadmath_throw; +extern __complex128 csinhq (__complex128) __quadmath_throw; +extern __complex128 csqrtq (__complex128) __quadmath_throw; +extern __complex128 ctanq (__complex128) __quadmath_throw; +extern __complex128 ctanhq (__complex128) __quadmath_throw; + + +/* Prototypes for string <-> __float128 conversion functions */ +extern __float128 strtoflt128 (const char *, char **) __quadmath_throw; +extern int quadmath_snprintf (char *str, size_t size, + const char *format, ...) __quadmath_throw; + + +/* Macros */ +#define FLT128_MAX 1.18973149535723176508575932662800702e4932Q +#define FLT128_MIN 3.36210314311209350626267781732175260e-4932Q +#define FLT128_EPSILON 1.92592994438723585305597794258492732e-34Q +#define FLT128_DENORM_MIN 6.475175119438025110924438958227646552e-4966Q +#define FLT128_MANT_DIG 113 +#define FLT128_MIN_EXP (-16381) +#define FLT128_MAX_EXP 16384 +#define FLT128_DIG 33 +#define FLT128_MIN_10_EXP (-4931) +#define FLT128_MAX_10_EXP 4932 + + +#define HUGE_VALQ __builtin_huge_valq() +/* The following alternative is valid, but brings the warning: + (floating constant exceeds range of ‘__float128’) */ +/* #define HUGE_VALQ (__extension__ 0x1.0p32767Q) */ + +#define M_Eq 2.7182818284590452353602874713526625Q /* e */ +#define M_LOG2Eq 1.4426950408889634073599246810018921Q /* log_2 e */ +#define M_LOG10Eq 0.4342944819032518276511289189166051Q /* log_10 e */ +#define M_LN2q 0.6931471805599453094172321214581766Q /* log_e 2 */ +#define M_LN10q 2.3025850929940456840179914546843642Q /* log_e 10 */ +#define M_PIq 3.1415926535897932384626433832795029Q /* pi */ +#define M_PI_2q 1.5707963267948966192313216916397514Q /* pi/2 */ +#define M_PI_4q 0.7853981633974483096156608458198757Q /* pi/4 */ +#define M_1_PIq 0.3183098861837906715377675267450287Q /* 1/pi */ +#define M_2_PIq 0.6366197723675813430755350534900574Q /* 2/pi */ +#define M_2_SQRTPIq 1.1283791670955125738961589031215452Q /* 2/sqrt(pi) */ +#define M_SQRT2q 1.4142135623730950488016887242096981Q /* sqrt(2) */ +#define M_SQRT1_2q 0.7071067811865475244008443621048490Q /* 1/sqrt(2) */ + +#define __quadmath_extern_inline \ + extern inline __attribute__ ((__gnu_inline__)) + +__quadmath_extern_inline __float128 +__quadmath_nth (cimagq (__complex128 __z)) +{ + return __imag__ __z; +} + +__quadmath_extern_inline __float128 +__quadmath_nth (crealq (__complex128 __z)) +{ + return __real__ __z; +} + +__quadmath_extern_inline __complex128 +__quadmath_nth (conjq (__complex128 __z)) +{ + return __extension__ ~__z; +} + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/runtime/libpgmath/lib/common/sincos/fd_sincos_scalar.cpp b/runtime/libpgmath/lib/common/sincos/fd_sincos_scalar.cpp index 5154ef05ed..334efef209 100644 --- a/runtime/libpgmath/lib/common/sincos/fd_sincos_scalar.cpp +++ b/runtime/libpgmath/lib/common/sincos/fd_sincos_scalar.cpp @@ -6,6 +6,17 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * + * Bug fixes. + * + * Date of Modification: October 2018 + * + */ + #include #include @@ -28,7 +39,7 @@ #define S(...) __VA_ARGS__ #define C(...) __VA_ARGS__ #define FNAME sincos -#include +#include #undef SINCOS_COMMA #define SINCOS_COMMA , #else diff --git a/runtime/libpgmath/lib/common/tanf/fs_tan_16_avx512.cpp b/runtime/libpgmath/lib/common/tanf/fs_tan_16_avx512.cpp index f1d710d522..4cd36fb5cf 100644 --- a/runtime/libpgmath/lib/common/tanf/fs_tan_16_avx512.cpp +++ b/runtime/libpgmath/lib/common/tanf/fs_tan_16_avx512.cpp @@ -34,3 +34,4 @@ __fs_tan_16_avx512(vfloat const a) #endif // __TAN_F_AVX512_H__ + diff --git a/runtime/libpgmath/lib/generic/CMakeLists.txt b/runtime/libpgmath/lib/generic/CMakeLists.txt index 19c350077f..9c77cda9c2 100644 --- a/runtime/libpgmath/lib/generic/CMakeLists.txt +++ b/runtime/libpgmath/lib/generic/CMakeLists.txt @@ -55,6 +55,8 @@ set(GENERIC_SRCS dsinh.c dsqrt.c dtan.c + dcotan.c + dcan.c dtanh.c exp.c fabs.c @@ -64,6 +66,7 @@ set(GENERIC_SRCS log.c mthi64.c nint.c + qnint.c remainder.c round.c rpowr.c @@ -71,6 +74,7 @@ set(GENERIC_SRCS sinh.c sqrt.c tan.c + cotan.c tanh.c) set(GENERIC_FLAGS "${FLAGS} -ffast-math ") libmath_add_object_library("${GENERIC_SRCS}" "${GENERIC_FLAGS}" "${DEFINITIONS}" "") diff --git a/runtime/libpgmath/lib/generic/cotan.c b/runtime/libpgmath/lib/generic/cotan.c new file mode 100644 index 0000000000..40a78a5692 --- /dev/null +++ b/runtime/libpgmath/lib/generic/cotan.c @@ -0,0 +1,14 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + +#include "mthdecls.h" + +float +__mth_i_cotan(float f) +{ + return 1.0/tanf(f); +} diff --git a/runtime/libpgmath/lib/generic/dcotan.c b/runtime/libpgmath/lib/generic/dcotan.c new file mode 100644 index 0000000000..8e2cc415fc --- /dev/null +++ b/runtime/libpgmath/lib/generic/dcotan.c @@ -0,0 +1,13 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + +#include "mthdecls.h" +double +__mth_i_dcotan(double d) +{ + return 1.0/tan(d); +} diff --git a/runtime/libpgmath/lib/generic/math_tables/CMakeLists.txt b/runtime/libpgmath/lib/generic/math_tables/CMakeLists.txt index b7ecc682b2..3d91e0a751 100644 --- a/runtime/libpgmath/lib/generic/math_tables/CMakeLists.txt +++ b/runtime/libpgmath/lib/generic/math_tables/CMakeLists.txt @@ -39,6 +39,7 @@ set(SRCS mth_tanhdefs.h mth_ceildefs.h mth_floordefs.h + mth_cotandefs.h ) set(NEW_SRCS) diff --git a/runtime/libpgmath/lib/generic/math_tables/mth_cotandefs.h b/runtime/libpgmath/lib/generic/math_tables/mth_cotandefs.h new file mode 100644 index 0000000000..7f944ea238 --- /dev/null +++ b/runtime/libpgmath/lib/generic/math_tables/mth_cotandefs.h @@ -0,0 +1,35 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + +/****************************************************************************** + * * + * Background: * + * The POWERPC ABI does not provide for tail calls. Thus, the math dispatch * + * table processing incurs overhead with the saving and restoration of GPR 2 * + * that can severely affect application performance. For POWERPC, we use an * + * optimized assembly dispatch set of routines that make tail calls to all of * + * the routines defined in the math dispatch configuration files but do not * + * saveand /restore GPR 2. * + * * + * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * + * * + * If any entry (routine ) in any of the dispatch tables is not present * + * in i.e. not satisfied by, libpgmath, in order to properly preserve/restore* + * GRP 2 when calling routine , the actual function must first be * + * encapsulated in a routine present in libpgmath. * + * * + * No doubt there are pathological cases that will show this engineering * + * choice to be wrong, but current performance testing shows otherwise. * + * * + *****************************************************************************/ + +MTHINTRIN(cotan , ss , any , __mth_i_cotan , __mth_i_cotan , __mth_i_cotan ,__math_dispatch_error) +MTHINTRIN(cotan , ds , any , __mth_i_dcotan , __mth_i_dcotan , __mth_i_dcotan ,__math_dispatch_error) +MTHINTRIN(cotan , sv4 , any , __gs_cotan_4_f , __gs_cotan_4_r , __gs_cotan_4_p ,__math_dispatch_error) +MTHINTRIN(cotan , dv2 , any , __gd_cotan_2_f , __gd_cotan_2_r , __gd_cotan_2_p ,__math_dispatch_error) +MTHINTRIN(cotan , sv4m , any , __fs_cotan_4_mn , __rs_cotan_4_mn , __ps_cotan_4_mn ,__math_dispatch_error) +MTHINTRIN(cotan , dv2m , any , __fd_cotan_2_mn , __rd_cotan_2_mn , __pd_cotan_2_mn ,__math_dispatch_error) diff --git a/runtime/libpgmath/lib/generic/qnint.c b/runtime/libpgmath/lib/generic/qnint.c new file mode 100644 index 0000000000..61c733b3a7 --- /dev/null +++ b/runtime/libpgmath/lib/generic/qnint.c @@ -0,0 +1,77 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + */ + +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Support for qnint + * Date of modification: 16th September 2020 + * + */ + +#include "mthdecls.h" + +/* + * libm's round() could also be used if compiled with: + * _ISOC99_SOURCE || _POSIX_C_SOURCE >= 200112L + */ + +#if defined(TARGET_LINUX_POWER) +__float128 +__mth_i_qnint(__float128 f) +{ + __float128 x; + asm("frin %0, %1" + : "=ld"(x) + : "ld"(f) + : + ); + return x; +} + +#elif defined(__aarch64__) +__float128 +__mth_i_qnint(__float128 f) +{ + __float128 r; + asm("frinta %ld0, %ld1" + : "=w"(r) + : "w"(f) + :); + return r; +} + +#else /* #if defined(TARGET_LINUX_POWER) */ +#include +#include + +__float128 +__mth_i_qnint(__float128 f) +{ + __float128 x = f; /* Cases where f == 0.0, or f == NaN */ + union ieee854_long_double *u = (union ieee854_long_double *)&x; + + /* + * Depending on the default rounding mode of the processor, the logic + * below with modf(f + 0.5) can result in a bogus rounding when 0.5 + * is normalized such that it falls within the guard or round bits. + * + * Fast return if the exponent guarantees that the floating point number + * is a whole integer. + * + * This quick exit also catches infinities and NaNs. + */ + + if (u->ieee.exponent >= IEEE854_LONG_DOUBLE_BIAS+112) return x; + + if (f > 0.0) + (void)modf(f + 0.5, &x); + else if (f < 0.0) + (void)modf(f - 0.5, &x); + return x; +} +#endif /* #if defined(TARGET_LINUX_POWER) */ diff --git a/runtime/libpgmath/lib/x86_64/CMakeLists.txt b/runtime/libpgmath/lib/x86_64/CMakeLists.txt index c96c8357ff..ab84d07c1f 100644 --- a/runtime/libpgmath/lib/x86_64/CMakeLists.txt +++ b/runtime/libpgmath/lib/x86_64/CMakeLists.txt @@ -21,6 +21,8 @@ add_subdirectory("relaxed") get_property(FLAGS GLOBAL PROPERTY "FLAGS_X8664_L1") get_property(DEFINITIONS GLOBAL PROPERTY "DEFINITIONS_X8664_L1") +enable_language(C ASM) + set(ASM_SRCS aint.S anint.S @@ -73,6 +75,7 @@ set(SRCS dsincosp.c dsinh.c dtan.c + dcotan.c dtanh.c exp.c log.c @@ -80,6 +83,7 @@ set(SRCS sincosp.c sinh.c tan.c + cotan.c tanh.c) list(APPEND DEFINITIONS _GNU_SOURCE _ISOC99_SOURCE) if(${LIBPGMATH_SYSTEM_NAME} MATCHES "Linux") @@ -122,6 +126,7 @@ set(SRCS dsincosp.c dsinh.c dtan.c + dcotan.c dtanh.c exp.c log.c @@ -129,6 +134,7 @@ set(SRCS sincosp.c sinh.c tan.c + cotan.c tanh.c) set(FLAGS "${FLAGS} -mavx2 -mfma") if(NOT ${LIBPGMATH_SYSTEM_NAME} MATCHES "Windows") diff --git a/runtime/libpgmath/lib/x86_64/cotan.c b/runtime/libpgmath/lib/x86_64/cotan.c new file mode 100644 index 0000000000..2d5359b97e --- /dev/null +++ b/runtime/libpgmath/lib/x86_64/cotan.c @@ -0,0 +1,184 @@ +/* ============================================================ +Copyright (c) 2002-2015 Advanced Micro Devices, Inc. + +All rights reserved. + +Redistribution and use in source and binary forms, with or +without modification, are permitted provided that the +following conditions are met: + ++ Redistributions of source code must retain the above + copyright notice, this list of conditions and the + following disclaimer. + ++ Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the + following disclaimer in the documentation and/or other + materials provided with the distribution. + ++ Neither the name of Advanced Micro Devices, Inc. nor the + names of its contributors may be used to endorse or + promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND +CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL ADVANCED MICRO DEVICES, +INC. OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +It is licensee's responsibility to comply with any export +regulations applicable in licensee's jurisdiction. +============================================================ */ + +#include "libm_amd.h" +#include "libm_util_amd.h" + +#define USE_REMAINDER_PIBY2F_INLINE +#define USE_VALF_WITH_FLAGS +#define USE_NANF_WITH_FLAGS +#define USE_HANDLE_ERRORF +#include "libm_inlines_amd.h" +#undef USE_VALF_WITH_FLAGS +#undef USE_NANF_WITH_FLAGS +#undef USE_REMAINDER_PIBY2F_INLINE +#undef USE_HANDLE_ERRORF + +/* tan(x) approximation valid on the interval [-pi/4,pi/4]. + If recip is true return -1/tan(x) instead. */ +static inline double +tanf_piby4(double x, int recip) +{ + double r, t; + + /* Core Remez [1,2] approximation to tan(x) on the + interval [0,pi/4]. */ + r = x * x; + t = x + + x * r * + (0.385296071263995406715129e0 - 0.172032480471481694693109e-1 * r) / + (0.115588821434688393452299e+1 + + (-0.51396505478854532132342e0 + 0.1844239256901656082986661e-1 * r) * + r); + + if (recip) + return -1.0 / t; + else + return t; +} + +float FN_PROTOTYPE(mth_i_cotan)(float x) +{ + double r, dx; + int region, xneg; + + __UINT8_T ux, ax; + + dx = x; + + GET_BITS_DP64(dx, ux); + ax = (ux & ~SIGNBIT_DP64); + + if (ax <= 0x3fe921fb54442d18) /* abs(x) <= pi/4 */ + { + if (ax < 0x3f80000000000000) /* abs(x) < 2.0^(-7) */ + { + if (ax < 0x3f20000000000000) /* abs(x) < 2.0^(-13) */ + { + if (ax == 0x0000000000000000) + return x; + else + return valf_with_flags(x, AMD_F_INEXACT); + } else + return (float)(dx + dx * dx * dx * 0.333333333333333333); + } else + return (float)tanf_piby4(x, 0); + } else if ((ux & EXPBITS_DP64) == EXPBITS_DP64) { + /* x is either NaN or infinity */ + if (ux & MANTBITS_DP64) { + /* x is NaN */ + return x + x; /* Raise invalid if it is a signalling NaN */ + } else { + /* x is infinity. Return a NaN */ + return nanf_with_flags(AMD_F_INVALID); + } + } + + xneg = (int)(ux >> 63); + + if (xneg) + dx = -dx; + + if (dx < 5.0e5) { + /* For these size arguments we can just carefully subtract the + appropriate multiple of pi/2, using extra precision where + dx is close to an exact multiple of pi/2 */ + static const double twobypi = + 6.36619772367581382433e-01, /* 0x3fe45f306dc9c883 */ + piby2_1 = 1.57079632673412561417e+00, /* 0x3ff921fb54400000 */ + piby2_1tail = 6.07710050650619224932e-11, /* 0x3dd0b4611a626331 */ + piby2_2 = 6.07710050630396597660e-11, /* 0x3dd0b4611a600000 */ + piby2_2tail = 2.02226624879595063154e-21, /* 0x3ba3198a2e037073 */ + piby2_3 = 2.02226624871116645580e-21, /* 0x3ba3198a2e000000 */ + piby2_3tail = 8.47842766036889956997e-32; /* 0x397b839a252049c1 */ + double t, rhead, rtail; + int npi2; + __UINT8_T uy, xexp, expdiff; + xexp = ax >> EXPSHIFTBITS_DP64; + /* How many pi/2 is dx a multiple of? */ + if (ax <= 0x400f6a7a2955385e) /* 5pi/4 */ + { + if (ax <= 0x4002d97c7f3321d2) /* 3pi/4 */ + npi2 = 1; + else + npi2 = 2; + } else if (ax <= 0x401c463abeccb2bb) /* 9pi/4 */ + { + if (ax <= 0x4015fdbbe9bba775) /* 7pi/4 */ + npi2 = 3; + else + npi2 = 4; + } else + npi2 = (int)(dx * twobypi + 0.5); + /* Subtract the multiple from dx to get an extra-precision remainder */ + rhead = dx - npi2 * piby2_1; + rtail = npi2 * piby2_1tail; + GET_BITS_DP64(rhead, uy); + expdiff = xexp - ((uy & EXPBITS_DP64) >> EXPSHIFTBITS_DP64); + if (expdiff > 15) { + /* The remainder is pretty small compared with dx, which + implies that dx is a near multiple of pi/2 + (dx matches the multiple to at least 15 bits) */ + t = rhead; + rtail = npi2 * piby2_2; + rhead = t - rtail; + rtail = npi2 * piby2_2tail - ((t - rhead) - rtail); + if (expdiff > 48) { + /* dx matches a pi/2 multiple to at least 48 bits */ + t = rhead; + rtail = npi2 * piby2_3; + rhead = t - rtail; + rtail = npi2 * piby2_3tail - ((t - rhead) - rtail); + } + } + r = rhead - rtail; + region = npi2 & 3; + } else { + /* Reduce x into range [-pi/4,pi/4] */ + __remainder_piby2f_inline(ax, &r, ®ion); + } + + if (xneg) + return 1.0/(float)-tanf_piby4(r, region & 1); + else + return 1.0/(float)tanf_piby4(r, region & 1); +} diff --git a/runtime/libpgmath/lib/x86_64/dcotan.c b/runtime/libpgmath/lib/x86_64/dcotan.c new file mode 100644 index 0000000000..b001ca8b5b --- /dev/null +++ b/runtime/libpgmath/lib/x86_64/dcotan.c @@ -0,0 +1,233 @@ +/* ============================================================ +Copyright (c) 2002-2015 Advanced Micro Devices, Inc. + +All rights reserved. + +Redistribution and use in source and binary forms, with or +without modification, are permitted provided that the +following conditions are met: + ++ Redistributions of source code must retain the above + copyright notice, this list of conditions and the + following disclaimer. + ++ Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the + following disclaimer in the documentation and/or other + materials provided with the distribution. + ++ Neither the name of Advanced Micro Devices, Inc. nor the + names of its contributors may be used to endorse or + promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND +CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL ADVANCED MICRO DEVICES, +INC. OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +It is licensee's responsibility to comply with any export +regulations applicable in licensee's jurisdiction. +============================================================ */ + +#include "libm_amd.h" +#include "libm_util_amd.h" + +#define USE_REMAINDER_PIBY2_INLINE +#define USE_NAN_WITH_FLAGS +#define USE_VAL_WITH_FLAGS +#define USE_HANDLE_ERROR +#include "libm_inlines_amd.h" +#undef USE_NAN_WITH_FLAGS +#undef USE_VAL_WITH_FLAGS +#undef USE_HANDLE_ERROR +#undef USE_REMAINDER_PIBY2_INLINE + +/* tan(x + xx) approximation valid on the interval [-pi/4,pi/4]. + If recip is true return -1/tan(x + xx) instead. */ +static inline double +tan_piby4(double x, double xx, int recip) +{ + double r, t1, t2, xl; + int transform = 0; + static const double piby4_lead = + 7.85398163397448278999e-01, /* 0x3fe921fb54442d18 */ + piby4_tail = 3.06161699786838240164e-17; /* 0x3c81a62633145c06 */ + + /* In order to maintain relative precision transform using the identity: + tan(pi/4-x) = (1-tan(x))/(1+tan(x)) for arguments close to pi/4. + Similarly use tan(x-pi/4) = (tan(x)-1)/(tan(x)+1) close to -pi/4. */ + + if (x > 0.68) { + transform = 1; + x = piby4_lead - x; + xl = piby4_tail - xx; + x += xl; + xx = 0.0; + } else if (x < -0.68) { + transform = -1; + x = piby4_lead + x; + xl = piby4_tail + xx; + x += xl; + xx = 0.0; + } + + /* Core Remez [2,3] approximation to tan(x+xx) on the + interval [0,0.68]. */ + + r = x * x + 2.0 * x * xx; + t1 = x; + t2 = xx + + x * r * (0.372379159759792203640806338901e0 + + (-0.229345080057565662883358588111e-1 + + 0.224044448537022097264602535574e-3 * r) * + r) / + (0.111713747927937668539901657944e1 + + (-0.515658515729031149329237816945e0 + + (0.260656620398645407524064091208e-1 - + 0.232371494088563558304549252913e-3 * r) * + r) * + r); + + /* Reconstruct tan(x) in the transformed case. */ + + if (transform) { + double t; + t = t1 + t2; + if (recip) + return transform * (2 * t / (t - 1) - 1.0); + else + return transform * (1.0 - 2 * t / (1 + t)); + } + + if (recip) { + /* Compute -1.0/(t1 + t2) accurately */ + double trec, trec_top, z1, z2, t; + __UINT8_T u; + t = t1 + t2; + GET_BITS_DP64(t, u); + u &= 0xffffffff00000000; + PUT_BITS_DP64(u, z1); + z2 = t2 - (z1 - t1); + trec = -1.0 / t; + GET_BITS_DP64(trec, u); + u &= 0xffffffff00000000; + PUT_BITS_DP64(u, trec_top); + return trec_top + trec * ((1.0 + trec_top * z1) + trec_top * z2); + + } else + return t1 + t2; +} + +double FN_PROTOTYPE(mth_i_dcotan)(double x) +{ + double r, rr; + int region, xneg; + + __UINT8_T ux, ax; + GET_BITS_DP64(x, ux); + ax = (ux & ~SIGNBIT_DP64); + if (ax <= 0x3fe921fb54442d18) /* abs(x) <= pi/4 */ + { + if (ax < 0x3f20000000000000) /* abs(x) < 2.0^(-13) */ + { + if (ax < 0x3e40000000000000) /* abs(x) < 2.0^(-27) */ + { + if (ax == 0x0000000000000000) + return x; + else + return val_with_flags(x, AMD_F_INEXACT); + } else { + return x + x * x * x * 0.333333333333333333; + } + } else + return tan_piby4(x, 0.0, 0); + } else if ((ux & EXPBITS_DP64) == EXPBITS_DP64) { + /* x is either NaN or infinity */ + if (ux & MANTBITS_DP64) + /* x is NaN */ + return x + x; /* Raise invalid if it is a signalling NaN */ + else + /* x is infinity. Return a NaN */ + return nan_with_flags(AMD_F_INVALID); + } + xneg = (ax != ux); + + if (xneg) + x = -x; + + if (x < 5.0e5) { + /* For these size arguments we can just carefully subtract the + appropriate multiple of pi/2, using extra precision where + x is close to an exact multiple of pi/2 */ + static const double twobypi = + 6.36619772367581382433e-01, /* 0x3fe45f306dc9c883 */ + piby2_1 = 1.57079632673412561417e+00, /* 0x3ff921fb54400000 */ + piby2_1tail = 6.07710050650619224932e-11, /* 0x3dd0b4611a626331 */ + piby2_2 = 6.07710050630396597660e-11, /* 0x3dd0b4611a600000 */ + piby2_2tail = 2.02226624879595063154e-21, /* 0x3ba3198a2e037073 */ + piby2_3 = 2.02226624871116645580e-21, /* 0x3ba3198a2e000000 */ + piby2_3tail = 8.47842766036889956997e-32; /* 0x397b839a252049c1 */ + double t, rhead, rtail; + int npi2; + __UINT8_T uy, xexp, expdiff; + xexp = ax >> EXPSHIFTBITS_DP64; + /* How many pi/2 is x a multiple of? */ + if (ax <= 0x400f6a7a2955385e) /* 5pi/4 */ + { + if (ax <= 0x4002d97c7f3321d2) /* 3pi/4 */ + npi2 = 1; + else + npi2 = 2; + } else if (ax <= 0x401c463abeccb2bb) /* 9pi/4 */ + { + if (ax <= 0x4015fdbbe9bba775) /* 7pi/4 */ + npi2 = 3; + else + npi2 = 4; + } else + npi2 = (int)(x * twobypi + 0.5); + /* Subtract the multiple from x to get an extra-precision remainder */ + rhead = x - npi2 * piby2_1; + rtail = npi2 * piby2_1tail; + GET_BITS_DP64(rhead, uy); + expdiff = xexp - ((uy & EXPBITS_DP64) >> EXPSHIFTBITS_DP64); + if (expdiff > 15) { + /* The remainder is pretty small compared with x, which + implies that x is a near multiple of pi/2 + (x matches the multiple to at least 15 bits) */ + t = rhead; + rtail = npi2 * piby2_2; + rhead = t - rtail; + rtail = npi2 * piby2_2tail - ((t - rhead) - rtail); + if (expdiff > 48) { + /* x matches a pi/2 multiple to at least 48 bits */ + t = rhead; + rtail = npi2 * piby2_3; + rhead = t - rtail; + rtail = npi2 * piby2_3tail - ((t - rhead) - rtail); + } + } + r = rhead - rtail; + rr = (rhead - r) - rtail; + region = npi2 & 3; + } else { + /* Reduce x into range [-pi/4,pi/4] */ + __remainder_piby2_inline(x, &r, &rr, ®ion); + } + + if (xneg) + return 1.0/-tan_piby4(r, rr, region & 1); + else + return 1.0/tan_piby4(r, rr, region & 1); +} diff --git a/runtime/libpgmath/lib/x86_64/fast/fastmath_vex.h b/runtime/libpgmath/lib/x86_64/fast/fastmath_vex.h index b149d069c7..6d645d7dcd 100644 --- a/runtime/libpgmath/lib/x86_64/fast/fastmath_vex.h +++ b/runtime/libpgmath/lib/x86_64/fast/fastmath_vex.h @@ -13498,6 +13498,226 @@ ENT(ASM_CONCAT3(__fvd_pow_,TARGET_VEX_OR_FMA,_256)): ELF_SIZE(ASM_CONCAT3(__fvd_pow_,TARGET_VEX_OR_FMA,_256)) +/* ------------------------------------------------------------------------- + * vector single precision cotangent - 128 bit + * + * Prototype: + * + * float * __fvs_cotan_[fma4/vex](float *x); + * + * ------------------------------------------------------------------------- */ + + .text + ALN_FUNC + .globl ENT(ASM_CONCAT(__fvs_cotan_,TARGET_VEX_OR_FMA)) +ENT(ASM_CONCAT(__fvs_cotan_,TARGET_VEX_OR_FMA)): + + + subq $40, %rsp + + vmovupd %xmm0, (%rsp) /* Save xmm0 */ +#if ! defined(TARGET_WIN_X8664) + vzeroupper +#endif + + CALL(ENT(__mth_i_cotan)) + vmovss %xmm0, 16(%rsp) + + vmovss 4(%rsp),%xmm0 + CALL(ENT(__mth_i_cotan)) + vmovss %xmm0, 20(%rsp) + + vmovss 8(%rsp),%xmm0 + CALL(ENT(__mth_i_cotan)) + vmovss %xmm0, 24(%rsp) + + vmovss 12(%rsp),%xmm0 + CALL(ENT(__mth_i_cotan)) + vmovss %xmm0, 28(%rsp) + + vmovupd 16(%rsp), %xmm0 + + addq $40, %rsp + ret + + ELF_FUNC(ASM_CONCAT(__fvs_cotan_,TARGET_VEX_OR_FMA)) + ELF_SIZE(ASM_CONCAT(__fvs_cotan_,TARGET_VEX_OR_FMA)) + +/* ------------------------------------------------------------------------- + * vector single precision cotangent - 256 bit + * + * Prototype: + * + * float * __fvs_cotan_[fma4/vex]_256(float *x); + * + * ------------------------------------------------------------------------- */ + + .text + ALN_FUNC + .globl ENT(ASM_CONCAT3(__fvs_cotan_,TARGET_VEX_OR_FMA,_256)) +ENT(ASM_CONCAT3(__fvs_cotan_,TARGET_VEX_OR_FMA,_256)): + + + subq $72, %rsp + + vmovups %ymm0, (%rsp) +#if ! defined(TARGET_WIN_X8664) + vzeroupper +#endif + + CALL(ENT(ASM_CONCAT(__fvs_cotan_,TARGET_VEX_OR_FMA))) + + + vmovups (%rsp), %ymm2 + vmovaps %xmm0, %xmm1 + vextractf128 $1, %ymm2, %xmm0 + vmovups %ymm1, 32(%rsp) + + CALL(ENT(ASM_CONCAT(__fvs_cotan_,TARGET_VEX_OR_FMA))) + + vmovups 32(%rsp), %ymm1 + vinsertf128 $1, %xmm0, %ymm1, %ymm0 + + addq $72, %rsp + ret + + ELF_FUNC(ASM_CONCAT3(__fvs_cotan_,TARGET_VEX_OR_FMA,_256)) + ELF_SIZE(ASM_CONCAT3(__fvs_cotan_,TARGET_VEX_OR_FMA,_256)) + + +/* ------------------------------------------------------------------------- + * scalar single precision cotangent + * + * Prototype: + * + * float __fss_cotan_[fma4/vex](float *x); + * + * ------------------------------------------------------------------------- */ + + .text + ALN_FUNC + .globl ENT(ASM_CONCAT(__fss_cotan_,TARGET_VEX_OR_FMA)) +ENT(ASM_CONCAT(__fss_cotan_,TARGET_VEX_OR_FMA)): + + subq $8, %rsp + + CALL(ENT(__mth_i_cotan)) + + addq $8, %rsp + ret + + ELF_FUNC(ASM_CONCAT(__fss_cotan_,TARGET_VEX_OR_FMA)) + ELF_SIZE(ASM_CONCAT(__fss_cotan_,TARGET_VEX_OR_FMA)) + + +/* ------------------------------------------------------------------------- + * vector double precision cotangent - 128 bit + * + * Prototype: + * + * double * __fvd_cotan_[fma4/vex](double *x); + * + * ------------------------------------------------------------------------- */ + + + .text + ALN_FUNC + .globl ENT(ASM_CONCAT(__fvd_cotan_,TARGET_VEX_OR_FMA)) +ENT(ASM_CONCAT(__fvd_cotan_,TARGET_VEX_OR_FMA)): + + + subq $40, %rsp + + vmovupd %xmm0, (%rsp) /* Save xmm0 */ +#if ! defined(TARGET_WIN_X8664) + vzeroupper +#endif + + CALL(ENT(__mth_i_dcotan)) + vmovsd %xmm0, 16(%rsp) + + vmovsd 8(%rsp),%xmm0 + CALL(ENT(__mth_i_dcotan)) + vmovsd %xmm0, 24(%rsp) + + vmovupd 16(%rsp), %xmm0 + + addq $40, %rsp + ret + + ELF_FUNC(ASM_CONCAT(__fvd_cotan_,TARGET_VEX_OR_FMA)) + ELF_SIZE(ASM_CONCAT(__fvd_cotan_,TARGET_VEX_OR_FMA)) + + + +/* ------------------------------------------------------------------------- + * vector double precision cotangent - 256 bit + * + * Prototype: + * + * double * __fvd_cotan_[fma4/vex]_256(double *x); + * + * ------------------------------------------------------------------------- */ + + .text + ALN_FUNC + .globl ENT(ASM_CONCAT3(__fvd_cotan_,TARGET_VEX_OR_FMA,_256)) +ENT(ASM_CONCAT3(__fvd_cotan_,TARGET_VEX_OR_FMA,_256)): + + + subq $72, %rsp + + vmovups %ymm0, (%rsp) +#if ! defined(TARGET_WIN_X8664) + vzeroupper +#endif + + CALL(ENT(ASM_CONCAT(__fvd_cotan_,TARGET_VEX_OR_FMA))) + + + vmovups (%rsp), %ymm2 + vmovaps %xmm0, %xmm1 + vextractf128 $1, %ymm2, %xmm0 + vmovups %ymm1, 32(%rsp) + + CALL(ENT(ASM_CONCAT(__fvd_cotan_,TARGET_VEX_OR_FMA))) + + vmovups 32(%rsp), %ymm1 + vinsertf128 $1, %xmm0, %ymm1, %ymm0 + + addq $72, %rsp + ret + + ELF_FUNC(ASM_CONCAT3(__fvd_cotan_,TARGET_VEX_OR_FMA,_256)) + ELF_SIZE(ASM_CONCAT3(__fvd_cotan_,TARGET_VEX_OR_FMA,_256)) + + +/* ------------------------------------------------------------------------- + * scalar double precision cotangent + * + * Prototype: + * + * double __fsd_cotan_[fma4/vex](double *x); + * + * ------------------------------------------------------------------------- */ + + .text + ALN_FUNC + .globl ENT(ASM_CONCAT(__fsd_cotan_,TARGET_VEX_OR_FMA)) +ENT(ASM_CONCAT(__fsd_cotan_,TARGET_VEX_OR_FMA)): + + subq $8, %rsp + + CALL(ENT(__mth_i_dcotan)) + + addq $8, %rsp + ret + + ELF_FUNC(ASM_CONCAT(__fsd_cotan_,TARGET_VEX_OR_FMA)) + ELF_SIZE(ASM_CONCAT(__fsd_cotan_,TARGET_VEX_OR_FMA)) + + + /* ------------------------------------------------------------------------- * vector single precision tangent - 128 bit * diff --git a/runtime/libpgmath/lib/x86_64/fast/fastmath_vex_mask.h b/runtime/libpgmath/lib/x86_64/fast/fastmath_vex_mask.h index 1802d93d0f..7067b11112 100644 --- a/runtime/libpgmath/lib/x86_64/fast/fastmath_vex_mask.h +++ b/runtime/libpgmath/lib/x86_64/fast/fastmath_vex_mask.h @@ -1445,7 +1445,127 @@ LBL(.L_done_fvd_log10): ELF_FUNC(ASM_CONCAT3(__fvd_log10_,TARGET_VEX_OR_FMA,_mask)) ELF_SIZE(ASM_CONCAT3(__fvd_log10_,TARGET_VEX_OR_FMA,_mask)) +/* + * __fvd_cotan_vex_256_mask(argument, mask) + * __fvd_cotan_fma4_256_mask(argument, mask) + * + * argument: ymm0 + * mask: ymm1 + * + * Compute the cotangent of the arguments whose mask is non-zero + * + */ + .text + ALN_FUNC + .globl ENT(ASM_CONCAT3(__fvd_cotan_,TARGET_VEX_OR_FMA,_256_mask)) +ENT(ASM_CONCAT3(__fvd_cotan_,TARGET_VEX_OR_FMA,_256_mask):) + + + subq $8, %rsp + + vptest .L_zeromask(%rip), %ymm1 + je LBL(.L_fvd_cotan_256_done) + + vandpd %ymm0,%ymm1,%ymm0 + CALL(ENT(ASM_CONCAT3(__fvd_cotan_,TARGET_VEX_OR_FMA,_256))) + +LBL(.L_fvd_cotan_256_done): + + addq $8, %rsp + ret + + ELF_FUNC(ASM_CONCAT3(__fvd_cotan_,TARGET_VEX_OR_FMA,_256_mask)) + ELF_SIZE(ASM_CONCAT3(__fvd_cotan_,TARGET_VEX_OR_FMA,_256_mask)) + + +/* + * __fvd_cotan_vex_mask(argument, mask) + * __fvd_cotan_fma4_mask(argument, mask) + * + * argument: xmm0 + * mask: xmm1 + * + * Compute the cotangent of the arguments whose mask is non-zero + * + */ + .text + ALN_FUNC + .globl ENT(ASM_CONCAT3(__fvd_cotan_,TARGET_VEX_OR_FMA,_mask)) +ENT(ASM_CONCAT3(__fvd_cotan_,TARGET_VEX_OR_FMA,_mask):) + + subq $8, %rsp + + vptest .L_zeromask(%rip), %xmm1 + je LBL(.L_fvd_cotan_done) + + vandpd %xmm0,%xmm1,%xmm0 + CALL(ENT(ASM_CONCAT(__fvd_cotan_,TARGET_VEX_OR_FMA))) + +LBL(.L_fvd_cotan_done): + addq $8, %rsp + ret + + ELF_FUNC(ASM_CONCAT3(__fvd_cotan_,TARGET_VEX_OR_FMA,_mask)) + ELF_SIZE(ASM_CONCAT3(__fvd_cotan_,TARGET_VEX_OR_FMA,_mask)) + +/* + * __fvs_cotan_vex_256_mask(argument, mask) + * + * argument: ymm0 + * mask: ymm1 + * + * Compute the cotangent of the arguments whose mask is non-zero + * + */ + .text + ALN_FUNC + .globl ENT(ASM_CONCAT3(__fvs_cotan_,TARGET_VEX_OR_FMA,_256_mask)) +ENT(ASM_CONCAT3(__fvs_cotan_,TARGET_VEX_OR_FMA,_256_mask):) + + subq $8, %rsp + + vptest .L_s_zeromask(%rip), %ymm1 + je LBL(.L_fvs_cotan_256_done) + + vandps %ymm0,%ymm1,%ymm0 + CALL(ENT(ASM_CONCAT3(__fvs_cotan_,TARGET_VEX_OR_FMA,_256))) + +LBL(.L_fvs_cotan_256_done): + addq $8, %rsp + ret + + ELF_FUNC(ASM_CONCAT3(__fvs_cotan_,TARGET_VEX_OR_FMA,_256_mask)) + ELF_SIZE(ASM_CONCAT3(__fvs_cotan_,TARGET_VEX_OR_FMA,_256_mask)) + +/* + * __fvs_cotan_vex_mask(argument, mask) + * __fvs_cotan_fma4_mask(argument, mask) + * + * argument: xmm0 + * mask: xmm1 + * + * Compute the cotangent of the arguments whose mask is non-zero + * + */ + .text + ALN_FUNC + .globl ENT(ASM_CONCAT3(__fvs_cotan_,TARGET_VEX_OR_FMA,_mask)) +ENT(ASM_CONCAT3(__fvs_cotan_,TARGET_VEX_OR_FMA,_mask):) + + subq $8, %rsp + + vptest .L_s_zeromask(%rip), %xmm1 + je LBL(.L_fvs_cotan_done) + + vandps %xmm0,%xmm1,%xmm0 + CALL(ENT(ASM_CONCAT(__fvs_cotan_,TARGET_VEX_OR_FMA))) + +LBL(.L_fvs_cotan_done): + addq $8, %rsp + ret + ELF_FUNC(ASM_CONCAT3(__fvs_cotan_,TARGET_VEX_OR_FMA,_mask)) + ELF_SIZE(ASM_CONCAT3(__fvs_cotan_,TARGET_VEX_OR_FMA,_mask)) /* * __fvd_tan_vex_256_mask(argument, mask) diff --git a/runtime/libpgmath/lib/x86_64/libm_amd.h b/runtime/libpgmath/lib/x86_64/libm_amd.h index 28f07cf14a..4517fb9281 100644 --- a/runtime/libpgmath/lib/x86_64/libm_amd.h +++ b/runtime/libpgmath/lib/x86_64/libm_amd.h @@ -125,6 +125,7 @@ extern float chgsignf(float x); extern double copysign(double x, double y); extern float copysignf(float x, float y); +extern float copysignq(__float128 x, __float128 y); extern double cos(double x); extern float cosf(float x); @@ -161,6 +162,7 @@ extern float fminf(float x, float y); extern double fmod(double x, double y); extern float fmodf(float x, float y); +extern double hypotq(__float128 x, __float128 y); extern double hypot(double x, double y); extern float hypotf(float x, float y); @@ -207,6 +209,7 @@ extern float sinhf(float x); extern double sqrt(double x); extern float sqrtf(float x); +extern float sqrtq(__float128 x); extern double tan(double x); extern float tanf(float x); diff --git a/runtime/libpgmath/lib/x86_64/math_tables/CMakeLists.txt b/runtime/libpgmath/lib/x86_64/math_tables/CMakeLists.txt index 438f2fbf96..70a7037e7a 100644 --- a/runtime/libpgmath/lib/x86_64/math_tables/CMakeLists.txt +++ b/runtime/libpgmath/lib/x86_64/math_tables/CMakeLists.txt @@ -31,6 +31,7 @@ set(SRCS mth_moddefs.h mth_ceildefs.h mth_floordefs.h + mth_cotandefs.h ) set(NEW_SRCS) diff --git a/runtime/libpgmath/lib/x86_64/math_tables/mth_cotandefs.h b/runtime/libpgmath/lib/x86_64/math_tables/mth_cotandefs.h new file mode 100644 index 0000000000..dd7aaf1bd1 --- /dev/null +++ b/runtime/libpgmath/lib/x86_64/math_tables/mth_cotandefs.h @@ -0,0 +1,126 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + +MTHINTRIN(cotan , ss , em64t , __mth_i_cotan , __mth_i_cotan , __mth_i_cotan ,__math_dispatch_error) +MTHINTRIN(cotan , ds , em64t , __mth_i_dcotan , __mth_i_dcotan , __mth_i_dcotan ,__math_dispatch_error) +MTHINTRIN(cotan , sv4 , em64t , __gs_cotan_4_f , __gs_cotan_4_r , __gs_cotan_4_p ,__math_dispatch_error) +MTHINTRIN(cotan , dv2 , em64t , __gd_cotan_2_f , __gd_cotan_2_r , __gd_cotan_2_p ,__math_dispatch_error) +MTHINTRIN(cotan , sv4m , em64t , __fs_cotan_4_mn , __rs_cotan_4_mn , __ps_cotan_4_mn ,__math_dispatch_error) +MTHINTRIN(cotan , dv2m , em64t , __fd_cotan_2_mn , __rd_cotan_2_mn , __pd_cotan_2_mn ,__math_dispatch_error) + +MTHINTRIN(cotan , ss , sse4 , __mth_i_cotan , __mth_i_cotan , __mth_i_cotan ,__math_dispatch_error) +MTHINTRIN(cotan , ds , sse4 , __mth_i_dcotan , __mth_i_dcotan , __mth_i_dcotan ,__math_dispatch_error) +MTHINTRIN(cotan , sv4 , sse4 , __gs_cotan_4_f , __gs_cotan_4_r , __gs_cotan_4_p ,__math_dispatch_error) +MTHINTRIN(cotan , dv2 , sse4 , __gd_cotan_2_f , __gd_cotan_2_r , __gd_cotan_2_p ,__math_dispatch_error) +MTHINTRIN(cotan , sv4m , sse4 , __fs_cotan_4_mn , __rs_cotan_4_mn , __ps_cotan_4_mn ,__math_dispatch_error) +MTHINTRIN(cotan , dv2m , sse4 , __fd_cotan_2_mn , __rd_cotan_2_mn , __pd_cotan_2_mn ,__math_dispatch_error) + +MTHINTRIN(cotan , ss , avx , __fss_cotan_vex , __rss_cotan_vex , __mth_i_cotan ,__math_dispatch_error) +MTHINTRIN(cotan , ds , avx , __fsd_cotan_vex , __rsd_cotan_vex , __mth_i_dcotan ,__math_dispatch_error) +MTHINTRIN(cotan , sv4 , avx , __fvs_cotan_vex , __rvs_cotan_vex , __gs_cotan_4_p ,__math_dispatch_error) +MTHINTRIN(cotan , dv2 , avx , __fvd_cotan_vex , __rvd_cotan_vex , __gd_cotan_2_p ,__math_dispatch_error) +MTHINTRIN(cotan , sv8 , avx , __fvs_cotan_vex_256 , __rvs_cotan_vex_256 , __gs_cotan_8_p ,__math_dispatch_error) +MTHINTRIN(cotan , dv4 , avx , __fvd_cotan_vex_256 , __rvd_cotan_vex_256 , __gd_cotan_4_p ,__math_dispatch_error) +MTHINTRIN(cotan , sv4m , avx , __fs_cotan_4_mn , __rs_cotan_4_mn , __ps_cotan_4_mn ,__math_dispatch_error) +MTHINTRIN(cotan , dv2m , avx , __fd_cotan_2_mn , __rd_cotan_2_mn , __pd_cotan_2_mn ,__math_dispatch_error) +MTHINTRIN(cotan , sv8m , avx , __fs_cotan_8_mn , __rs_cotan_8_mn , __ps_cotan_8_mn ,__math_dispatch_error) +MTHINTRIN(cotan , dv4m , avx , __fd_cotan_4_mn , __rd_cotan_4_mn , __pd_cotan_4_mn ,__math_dispatch_error) + +MTHINTRIN(cotan , ss , avxfma4 , __fss_cotan_fma4 , __rss_cotan_fma4 , __mth_i_cotan ,__math_dispatch_error) +MTHINTRIN(cotan , ds , avxfma4 , __fsd_cotan_fma4 , __rsd_cotan_fma4 , __mth_i_dcotan ,__math_dispatch_error) +MTHINTRIN(cotan , sv4 , avxfma4 , __fvs_cotan_fma4 , __rvs_cotan_fma4 , __gs_cotan_4_p ,__math_dispatch_error) +MTHINTRIN(cotan , dv2 , avxfma4 , __fvd_cotan_fma4 , __rvd_cotan_fma4 , __gd_cotan_2_p ,__math_dispatch_error) +MTHINTRIN(cotan , sv8 , avxfma4 , __fvs_cotan_fma4_256 , __rvs_cotan_fma4_256 , __gs_cotan_8_p ,__math_dispatch_error) +MTHINTRIN(cotan , dv4 , avxfma4 , __fvd_cotan_fma4_256 , __rvd_cotan_fma4_256 , __gd_cotan_4_p ,__math_dispatch_error) +MTHINTRIN(cotan , sv4m , avxfma4 , __fs_cotan_4_mn , __rs_cotan_4_mn , __ps_cotan_4_mn ,__math_dispatch_error) +MTHINTRIN(cotan , dv2m , avxfma4 , __fd_cotan_2_mn , __rd_cotan_2_mn , __pd_cotan_2_mn ,__math_dispatch_error) +MTHINTRIN(cotan , sv8m , avxfma4 , __fs_cotan_8_mn , __rs_cotan_8_mn , __ps_cotan_8_mn ,__math_dispatch_error) +MTHINTRIN(cotan , dv4m , avxfma4 , __fd_cotan_4_mn , __rd_cotan_4_mn , __pd_cotan_4_mn ,__math_dispatch_error) + +MTHINTRIN(cotan , ss , avx2 , __fs_cotan_1_avx2 , __rss_cotan_vex , __mth_i_cotan_avx2 ,__math_dispatch_error) +MTHINTRIN(cotan , ds , avx2 , __mth_i_dcotan_avx2 , __rsd_cotan_vex , __mth_i_dcotan_avx2 ,__math_dispatch_error) +MTHINTRIN(cotan , sv4 , avx2 , __fs_cotan_4_avx2 , __rvs_cotan_vex , __gs_cotan_4_p ,__math_dispatch_error) +MTHINTRIN(cotan , dv2 , avx2 , __gd_cotan_2_f , __rvd_cotan_vex , __gd_cotan_2_p ,__math_dispatch_error) +MTHINTRIN(cotan , sv8 , avx2 , __fs_cotan_8_avx2 , __rvs_cotan_vex_256 , __gs_cotan_8_p ,__math_dispatch_error) +MTHINTRIN(cotan , dv4 , avx2 , __gd_cotan_4_f , __rvd_cotan_vex_256 , __gd_cotan_4_p ,__math_dispatch_error) +MTHINTRIN(cotan , sv4m , avx2 , __fs_cotan_4_mn , __rs_cotan_4_mn , __ps_cotan_4_mn ,__math_dispatch_error) +MTHINTRIN(cotan , dv2m , avx2 , __fd_cotan_2_mn , __rd_cotan_2_mn , __pd_cotan_2_mn ,__math_dispatch_error) +MTHINTRIN(cotan , sv8m , avx2 , __fs_cotan_8_mn , __rs_cotan_8_mn , __ps_cotan_8_mn ,__math_dispatch_error) +MTHINTRIN(cotan , dv4m , avx2 , __fd_cotan_4_mn , __rd_cotan_4_mn , __pd_cotan_4_mn ,__math_dispatch_error) + +MTHINTRIN(cotan , ss , avx512knl , __fs_cotan_1_avx2 , __rss_cotan_vex , __mth_i_cotan_avx2 ,__math_dispatch_error) +MTHINTRIN(cotan , ds , avx512knl , __mth_i_dcotan_avx2 , __rsd_cotan_vex , __mth_i_dcotan_avx2 ,__math_dispatch_error) +MTHINTRIN(cotan , sv4 , avx512knl , __fs_cotan_4_avx2 , __rvs_cotan_vex , __gs_cotan_4_p ,__math_dispatch_error) +MTHINTRIN(cotan , dv2 , avx512knl , __gd_cotan_2_f , __rvd_cotan_vex , __gd_cotan_2_p ,__math_dispatch_error) +MTHINTRIN(cotan , sv8 , avx512knl , __fs_cotan_8_avx2 , __rvs_cotan_vex_256 , __gs_cotan_8_p ,__math_dispatch_error) +MTHINTRIN(cotan , dv4 , avx512knl , __gd_cotan_4_f , __rvd_cotan_vex_256 , __gd_cotan_4_p ,__math_dispatch_error) +MTHINTRIN(cotan , sv16 , avx512knl , __fs_cotan_16_z2yy , __rs_cotan_16_z2yy , __gs_cotan_16_p ,__math_dispatch_error) +MTHINTRIN(cotan , dv8 , avx512knl , __gd_cotan_8_f , __rd_cotan_8_z2yy , __gd_cotan_8_p ,__math_dispatch_error) +MTHINTRIN(cotan , sv4m , avx512knl , __fs_cotan_4_mn , __rs_cotan_4_mn , __ps_cotan_4_mn ,__math_dispatch_error) +MTHINTRIN(cotan , dv2m , avx512knl , __fd_cotan_2_mn , __rd_cotan_2_mn , __pd_cotan_2_mn ,__math_dispatch_error) +MTHINTRIN(cotan , sv8m , avx512knl , __fs_cotan_8_mn , __rs_cotan_8_mn , __ps_cotan_8_mn ,__math_dispatch_error) +MTHINTRIN(cotan , dv4m , avx512knl , __fd_cotan_4_mn , __rd_cotan_4_mn , __pd_cotan_4_mn ,__math_dispatch_error) +MTHINTRIN(cotan , sv16m, avx512knl , __fs_cotan_16_mn , __rs_cotan_16_mn , __ps_cotan_16_mn ,__math_dispatch_error) +MTHINTRIN(cotan , dv8m , avx512knl , __fd_cotan_8_mn , __rd_cotan_8_mn , __pd_cotan_8_mn ,__math_dispatch_error) + +MTHINTRIN(cotan , ss , avx512 , __fs_cotan_1_avx2 , __rss_cotan_vex , __mth_i_cotan_avx2 ,__math_dispatch_error) +MTHINTRIN(cotan , ds , avx512 , __mth_i_dcotan_avx2 , __rsd_cotan_vex , __mth_i_dcotan_avx2 ,__math_dispatch_error) +MTHINTRIN(cotan , sv4 , avx512 , __fs_cotan_4_avx2 , __rvs_cotan_vex , __gs_cotan_4_p ,__math_dispatch_error) +MTHINTRIN(cotan , dv2 , avx512 , __gd_cotan_2_f , __rvd_cotan_vex , __gd_cotan_2_p ,__math_dispatch_error) +MTHINTRIN(cotan , sv8 , avx512 , __fs_cotan_8_avx2 , __rvs_cotan_vex_256 , __gs_cotan_8_p ,__math_dispatch_error) +MTHINTRIN(cotan , dv4 , avx512 , __gd_cotan_4_f , __rvd_cotan_vex_256 , __gd_cotan_4_p ,__math_dispatch_error) +MTHINTRIN(cotan , sv16 , avx512 , __fs_cotan_16_avx512 , __rs_cotan_16_z2yy , __gs_cotan_16_p ,__math_dispatch_error) +MTHINTRIN(cotan , dv8 , avx512 , __gd_cotan_8_f , __rd_cotan_8_z2yy , __gd_cotan_8_p ,__math_dispatch_error) +MTHINTRIN(cotan , sv4m , avx512 , __fs_cotan_4_mn , __rs_cotan_4_mn , __ps_cotan_4_mn ,__math_dispatch_error) +MTHINTRIN(cotan , dv2m , avx512 , __fd_cotan_2_mn , __rd_cotan_2_mn , __pd_cotan_2_mn ,__math_dispatch_error) +MTHINTRIN(cotan , sv8m , avx512 , __fs_cotan_8_mn , __rs_cotan_8_mn , __ps_cotan_8_mn ,__math_dispatch_error) +MTHINTRIN(cotan , dv4m , avx512 , __fd_cotan_4_mn , __rd_cotan_4_mn , __pd_cotan_4_mn ,__math_dispatch_error) +MTHINTRIN(cotan , sv16m, avx512 , __fs_cotan_16_mn , __rs_cotan_16_mn , __ps_cotan_16_mn ,__math_dispatch_error) +MTHINTRIN(cotan , dv8m , avx512 , __fd_cotan_8_mn , __rd_cotan_8_mn , __pd_cotan_8_mn ,__math_dispatch_error) + +MTHINTRIN(cotan , cs , em64t , tanf , tanf , tanf ,__math_dispatch_error) +MTHINTRIN(cotan , zs , em64t , tanf , tanf , tanf ,__math_dispatch_error) +MTHINTRIN(cotan , zv1 , em64t , __gz_cotan_1v_f , __gz_cotan_1v_r , __gz_cotan_1v_p ,__math_dispatch_error) +MTHINTRIN(cotan , cv2 , em64t , __gc_cotan_2_f , __gc_cotan_2_r , __gc_cotan_2_p ,__math_dispatch_error) +MTHINTRIN(cotan , cs , sse4 , tanf , tanf , tanf ,__math_dispatch_error) +MTHINTRIN(cotan , zs , sse4 , tanf , tanf , tanf ,__math_dispatch_error) +MTHINTRIN(cotan , zv1 , sse4 , __gz_cotan_1v_f , __gz_cotan_1v_r , __gz_cotan_1v_p ,__math_dispatch_error) +MTHINTRIN(cotan , cv2 , sse4 , __gc_cotan_2_f , __gc_cotan_2_r , __gc_cotan_2_p ,__math_dispatch_error) +MTHINTRIN(cotan , cs , avx , tanf , tanf , tanf ,__math_dispatch_error) +MTHINTRIN(cotan , zs , avx , tanf , tanf , tanf ,__math_dispatch_error) +MTHINTRIN(cotan , zv1 , avx , __gz_cotan_1v_f , __gz_cotan_1v_r , __gz_cotan_1v_p ,__math_dispatch_error) +MTHINTRIN(cotan , cv2 , avx , __gc_cotan_2_f , __gc_cotan_2_r , __gc_cotan_2_p ,__math_dispatch_error) +MTHINTRIN(cotan , cv4 , avx , __gc_cotan_4_f , __gc_cotan_4_r , __gc_cotan_4_p ,__math_dispatch_error) +MTHINTRIN(cotan , zv2 , avx , __gz_cotan_2_f , __gz_cotan_2_r , __gz_cotan_2_p ,__math_dispatch_error) +MTHINTRIN(cotan , cs , avxfma4 , tanf , tanf , tanf ,__math_dispatch_error) +MTHINTRIN(cotan , zs , avxfma4 , tanf , tanf , tanf ,__math_dispatch_error) +MTHINTRIN(cotan , zv1 , avxfma4 , __gz_cotan_1v_f , __gz_cotan_1v_r , __gz_cotan_1v_p ,__math_dispatch_error) +MTHINTRIN(cotan , cv2 , avxfma4 , __gc_cotan_2_f , __gc_cotan_2_r , __gc_cotan_2_p ,__math_dispatch_error) +MTHINTRIN(cotan , cv4 , avxfma4 , __gc_cotan_4_f , __gc_cotan_4_r , __gc_cotan_4_p ,__math_dispatch_error) +MTHINTRIN(cotan , zv2 , avxfma4 , __gz_cotan_2_f , __gz_cotan_2_r , __gz_cotan_2_p ,__math_dispatch_error) +MTHINTRIN(cotan , cs , avx2 , tanf , tanf , tanf ,__math_dispatch_error) +MTHINTRIN(cotan , zs , avx2 , tanf , tanf , tanf ,__math_dispatch_error) +MTHINTRIN(cotan , zv1 , avx2 , __gz_cotan_1v_f , __gz_cotan_1v_r , __gz_cotan_1v_p ,__math_dispatch_error) +MTHINTRIN(cotan , cv2 , avx2 , __gc_cotan_2_f , __gc_cotan_2_r , __gc_cotan_2_p ,__math_dispatch_error) +MTHINTRIN(cotan , cv4 , avx2 , __gc_cotan_4_f , __gc_cotan_4_r , __gc_cotan_4_p ,__math_dispatch_error) +MTHINTRIN(cotan , zv2 , avx2 , __gz_cotan_2_f , __gz_cotan_2_r , __gz_cotan_2_p ,__math_dispatch_error) +MTHINTRIN(cotan , cs , avx512knl , tanf , tanf , tanf ,__math_dispatch_error) +MTHINTRIN(cotan , zs , avx512knl , tanf , tanf , tanf ,__math_dispatch_error) +MTHINTRIN(cotan , zv1 , avx512knl , __gz_cotan_1v_f , __gz_cotan_1v_r , __gz_cotan_1v_p ,__math_dispatch_error) +MTHINTRIN(cotan , cv2 , avx512knl , __gc_cotan_2_f , __gc_cotan_2_r , __gc_cotan_2_p ,__math_dispatch_error) +MTHINTRIN(cotan , cv4 , avx512knl , __gc_cotan_4_f , __gc_cotan_4_r , __gc_cotan_4_p ,__math_dispatch_error) +MTHINTRIN(cotan , cv8 , avx512knl , __gc_cotan_8_f , __gc_cotan_8_r , __gc_cotan_8_p ,__math_dispatch_error) +MTHINTRIN(cotan , zv2 , avx512knl , __gz_cotan_2_f , __gz_cotan_2_r , __gz_cotan_2_p ,__math_dispatch_error) +MTHINTRIN(cotan , zv4 , avx512knl , __gz_cotan_4_f , __gz_cotan_4_r , __gz_cotan_4_p ,__math_dispatch_error) +MTHINTRIN(cotan , cs , avx512 , tanf , tanf , tanf ,__math_dispatch_error) +MTHINTRIN(cotan , zs , avx512 , tanf , tanf , tanf ,__math_dispatch_error) +MTHINTRIN(cotan , zv1 , avx512 , __gz_cotan_1v_f , __gz_cotan_1v_r , __gz_cotan_1v_p ,__math_dispatch_error) +MTHINTRIN(cotan , cv2 , avx512 , __gc_cotan_2_f , __gc_cotan_2_r , __gc_cotan_2_p ,__math_dispatch_error) +MTHINTRIN(cotan , cv4 , avx512 , __gc_cotan_4_f , __gc_cotan_4_r , __gc_cotan_4_p ,__math_dispatch_error) +MTHINTRIN(cotan , cv8 , avx512 , __gc_cotan_8_f , __gc_cotan_8_r , __gc_cotan_8_p ,__math_dispatch_error) +MTHINTRIN(cotan , zv2 , avx512 , __gz_cotan_2_f , __gz_cotan_2_r , __gz_cotan_2_p ,__math_dispatch_error) +MTHINTRIN(cotan , zv4 , avx512 , __gz_cotan_4_f , __gz_cotan_4_r , __gz_cotan_4_p ,__math_dispatch_error) diff --git a/runtime/libpgmath/lib/x86_64/mthdecls.h b/runtime/libpgmath/lib/x86_64/mthdecls.h index a7f5e60e23..efd9c1f70c 100644 --- a/runtime/libpgmath/lib/x86_64/mthdecls.h +++ b/runtime/libpgmath/lib/x86_64/mthdecls.h @@ -4,7 +4,17 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ - +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Complex type support for acosh , asinh , atanh + * Date of Modification: 08 January 2020 + * + * Complex datatype support for atan2 under flag f2008 + * Modified on 13th March 2020` + * + */ /** * \file * \brief mthdecls.h - Fortran math support (all platforms/targets) @@ -409,6 +419,7 @@ float __mth_i_rpowr(float f, float g); float __mth_i_sin(float f); float __mth_i_sinh(float f); float __mth_i_sqrt(float f); +float __mth_i_cotan(float f); float __mth_i_tan(float f); float __mth_i_tanh(float f); float __mth_i_amod(float f, float g); @@ -484,6 +495,9 @@ double __mth_i_dcosd(double f); double __mth_i_derf(double f); double __mth_i_derfc(double f); double __mth_i_derfc_scaled(double f); +__float128 __mth_i_qerf(__float128 f); +__float128 __mth_i_qerfc(__float128 f); +__float128 __mth_i_qerfc_scaled(__float128 f); double __mth_i_dgamma(double f); double __mth_i_dlog_gamma(double f); double __mth_i_dhypot(double, double); @@ -496,6 +510,14 @@ double __mth_i_dbessel_y0(double arg); double __mth_i_dbessel_y1(double arg); double __mth_i_dbessel_yn(int n, double arg); double __f90_dbessel_yn(int n1, int n, double d); +__float128 __mth_i_qbessel_j0(__float128 arg); +__float128 __mth_i_qbessel_j1(__float128 arg); +__float128 __mth_i_qbessel_jn(int n, __float128 arg); +__float128 __f90_qbessel_jn(int n1, int n, __float128 d); +__float128 __mth_i_qbessel_y0(__float128 arg); +__float128 __mth_i_qbessel_y1(__float128 arg); +__float128 __mth_i_qbessel_yn(int n, __float128 arg); +__float128 __f90_qbessel_yn(int n1, int n, __float128 d); double __mth_i_dceil(double); double __mth_i_dfloor(double); @@ -538,6 +560,12 @@ CMPLXDECL_C(__mth_i_csinh); CMPLXDECL_C(__mth_i_csqrt); CMPLXDECL_C(__mth_i_ctan); CMPLXDECL_C(__mth_i_ctanh); +//AOCC Begin +CMPLXDECL_C(__mth_i_cacosh); +CMPLXDECL_C(__mth_i_casinh); +CMPLXDECL_C(__mth_i_catanh); +CMPLXDECL_C_C(__mth_i_catan2); +//AOCC End DBLDECL_C(__mth_i_cdabs); ZMPLXDECL_Z(__mth_i_cdacos); @@ -558,8 +586,6 @@ ZMPLXDECL_Z(__mth_i_cdsqrt); ZMPLXDECL_Z(__mth_i_cdtan); ZMPLXDECL_Z(__mth_i_cdtanh); - - #if defined(TARGET_WIN) #if ! defined(_C_COMPLEX_T) /* @@ -579,6 +605,16 @@ extern float_complex_t ctanhf(float_complex_t); extern double_complex_t ctanh(double_complex_t); extern float_complex_t ctanf(float_complex_t); extern double_complex_t ctan(double_complex_t); +extern double_complex_t ccotan(double_complex_t); +//AOCC begin +extern float_complex_t cacoshf(float_complex_t); +extern double_complex_t cacosh(double_complex_t); +extern float_complex_t casinhf(float_complex_t); +extern double_complex_t casinh(double_complex_t); +extern float_complex_t catanhf(float_complex_t); +extern double_complex_t catanh(double_complex_t); +extern double_complex_t catan2(double_complex_t, double_complex_t); +//AOCC end #endif /* #if ! defined(_C_COMPLEX_T) */ #endif /* #if defined(TARGET_WIN) */ diff --git a/runtime/libpgmath/lib/x86_64/relaxed/relaxedmath_vex.h b/runtime/libpgmath/lib/x86_64/relaxed/relaxedmath_vex.h index 9a81ea590d..abe83f05ad 100644 --- a/runtime/libpgmath/lib/x86_64/relaxed/relaxedmath_vex.h +++ b/runtime/libpgmath/lib/x86_64/relaxed/relaxedmath_vex.h @@ -1486,6 +1486,220 @@ ENT(ASM_CONCAT3(__rvd_exp_,TARGET_VEX_OR_FMA,_256)): ELF_SIZE(ASM_CONCAT3(__rvd_exp_,TARGET_VEX_OR_FMA,_256)) +/* + * vector single precision cotangent - 128 + * + * Prototype: + * + * single __rvs_cotan_vex/fma4(float *x); + * + */ + +/* ------------------------------------------------------------------------- */ + + .text + ALN_FUNC + .globl ENT(ASM_CONCAT(__rvs_cotan_,TARGET_VEX_OR_FMA)) +ENT(ASM_CONCAT(__rvs_cotan_,TARGET_VEX_OR_FMA)): + + + subq $8, %rsp + + CALL(ENT(ASM_CONCAT(__fvs_sincos_,TARGET_VEX_OR_FMA))) + + + vdivps %xmm1, %xmm0, %xmm0 + + addq $8, %rsp + ret + + ELF_FUNC(ASM_CONCAT(__rvs_cotan_,TARGET_VEX_OR_FMA)) + ELF_SIZE(ASM_CONCAT(__rvs_cotan_,TARGET_VEX_OR_FMA)) + + +/* ------------------------------------------------------------------------- */ + +/* ------------------------------------------------------------------------- */ + +/* + * vector single precision cotangent - 256 + * + * Prototype: + * + * single __rvs_cotan_vex/fma4_256(float *x); + * + */ + +/* ------------------------------------------------------------------------- */ + .text + ALN_FUNC + .globl ENT(ASM_CONCAT3(__rvs_cotan_,TARGET_VEX_OR_FMA,_256)) +ENT(ASM_CONCAT3(__rvs_cotan_,TARGET_VEX_OR_FMA,_256)): + + + subq $136, %rsp + + vmovups %ymm0, 32(%rsp) + + CALL(ENT(ASM_CONCAT(__fvs_sincos_,TARGET_VEX_OR_FMA))) + + + vmovups 32(%rsp), %ymm2 + vmovaps %xmm0, %xmm3 + vmovaps %xmm1, %xmm4 + vextractf128 $1, %ymm2, %xmm0 + vmovups %xmm3, 64(%rsp) + vmovups %xmm4, 96(%rsp) + + CALL(ENT(ASM_CONCAT(__fvs_sincos_,TARGET_VEX_OR_FMA))) + vmovups 64(%rsp), %xmm3 + vinsertf128 $1, %xmm0, %ymm3, %ymm0 + vmovups 96(%rsp), %xmm4 + vinsertf128 $1, %xmm1, %ymm4, %ymm1 + + vdivps %ymm1, %ymm0, %ymm0 + + addq $136, %rsp + ret + + ELF_FUNC(ASM_CONCAT3(__rvs_cotan_,TARGET_VEX_OR_FMA,_256)) + ELF_SIZE(ASM_CONCAT3(__rvs_cotan_,TARGET_VEX_OR_FMA,_256)) + + +/* ------------------------------------------------------------------------- */ + +/* + * scalar single precision cotangent + * + * Prototype: + * + * single __rss_cotan_vex/fma4(float *x); + * + */ + + .text + ALN_FUNC + .globl ENT(ASM_CONCAT(__rss_cotan_,TARGET_VEX_OR_FMA)) +ENT(ASM_CONCAT(__rss_cotan_,TARGET_VEX_OR_FMA)): + + + subq $8, %rsp + + CALL(ENT(ASM_CONCAT(__fss_sincos_,TARGET_VEX_OR_FMA))) + + + vdivss %xmm1, %xmm0, %xmm0 + + addq $8, %rsp + ret + + ELF_FUNC(ASM_CONCAT(__rss_cotan_,TARGET_VEX_OR_FMA)) + ELF_SIZE(ASM_CONCAT(__rss_cotan_,TARGET_VEX_OR_FMA)) + + + +/* ------------------------------------------------------------------------- */ + +/* + * vector double precision cotangent + * + * Prototype: + * + * single __rvd_cotan_vex/fma4(double *x); + * + */ + +/* ------------------------------------------------------------------------- */ + + .text + ALN_FUNC + .globl ENT(ASM_CONCAT(__rvd_cotan_,TARGET_VEX_OR_FMA)) +ENT(ASM_CONCAT(__rvd_cotan_,TARGET_VEX_OR_FMA)): + + + subq $8, %rsp + + CALL(ENT(ASM_CONCAT(__fvd_sincos_,TARGET_VEX_OR_FMA))) + + + vdivpd %xmm1, %xmm0, %xmm0 + + addq $8, %rsp + ret + + ELF_FUNC(ASM_CONCAT(__rvd_cotan_,TARGET_VEX_OR_FMA)) + ELF_SIZE(ASM_CONCAT(__rvd_cotan_,TARGET_VEX_OR_FMA)) + + +/* ------------------------------------------------------------------------- */ + +/* + * vector double precision cotangent + * + * Prototype: + * + * single __rvd_cotan_vex/fma4_256(double *x); + * + */ + +/* ------------------------------------------------------------------------- */ + .text + ALN_FUNC + .globl ENT(ASM_CONCAT3(__rvd_cotan_,TARGET_VEX_OR_FMA,_256)) +ENT(ASM_CONCAT3(__rvd_cotan_,TARGET_VEX_OR_FMA,_256)): + + + subq $136, %rsp + + vmovupd %ymm0, 32(%rsp) + + CALL(ENT(ASM_CONCAT(__fvd_sincos_,TARGET_VEX_OR_FMA))) + + + vmovupd 32(%rsp), %ymm2 + vmovapd %xmm0, %xmm3 + vmovapd %xmm1, %xmm4 + vextractf128 $1, %ymm2, %xmm0 + vmovupd %xmm3, 64(%rsp) + vmovupd %xmm4, 96(%rsp) + + CALL(ENT(ASM_CONCAT(__fvd_sincos_,TARGET_VEX_OR_FMA))) + + vmovupd 64(%rsp), %xmm3 + vinsertf128 $1, %xmm0, %ymm3, %ymm0 + vmovupd 96(%rsp), %xmm4 + vinsertf128 $1, %xmm1, %ymm4, %ymm1 + + vdivpd %ymm1, %ymm0, %ymm0 + + addq $136, %rsp + ret + + ELF_FUNC(ASM_CONCAT3(__rvd_cotan_,TARGET_VEX_OR_FMA,_256)) + ELF_SIZE(ASM_CONCAT3(__rvd_cotan_,TARGET_VEX_OR_FMA,_256)) + + +/* ------------------------------------------------------------------------- */ + + .text + ALN_FUNC + .globl ENT(ASM_CONCAT(__rsd_cotan_,TARGET_VEX_OR_FMA)) +ENT(ASM_CONCAT(__rsd_cotan_,TARGET_VEX_OR_FMA)): + + + subq $8, %rsp + + CALL(ENT(ASM_CONCAT(__fsd_sincos_,TARGET_VEX_OR_FMA))) + + + vdivsd %xmm1, %xmm0, %xmm0 + + addq $8, %rsp + ret + + ELF_FUNC(ASM_CONCAT(__rsd_cotan_,TARGET_VEX_OR_FMA)) + ELF_SIZE(ASM_CONCAT(__rsd_cotan_,TARGET_VEX_OR_FMA)) + /* ------------------------------------------------------------------------- */ diff --git a/runtime/libpgmath/lib/x86_64/relaxed/relaxedmath_vex_mask.h b/runtime/libpgmath/lib/x86_64/relaxed/relaxedmath_vex_mask.h index 63b970fe88..60991a6149 100644 --- a/runtime/libpgmath/lib/x86_64/relaxed/relaxedmath_vex_mask.h +++ b/runtime/libpgmath/lib/x86_64/relaxed/relaxedmath_vex_mask.h @@ -198,6 +198,69 @@ LBL(.L_rvd_exp_256_done): ELF_SIZE(ASM_CONCAT3(__rvd_exp_,TARGET_VEX_OR_FMA,_256_mask)) +/* + * __rvs_cotan_vex_256_mask(argument, mask) + * __rvs_cotan_fma4_256_mask(argument, mask) + * + * argument: ymm0 + * mask: ymm1 + * + * Compute the cotangent of the arguments whose mask is non-zero + * + */ + .text + ALN_FUNC + .globl ENT(ASM_CONCAT3(__rvs_cotan_,TARGET_VEX_OR_FMA,_256_mask)) +ENT(ASM_CONCAT3(__rvs_cotan_,TARGET_VEX_OR_FMA,_256_mask)): + + subq $8, %rsp + + vptest .L_zeromask(%rip), %ymm1 + je LBL(.L_rvs_cotan_256_done) + + vandpd %ymm0,%ymm1,%ymm0 + CALL(ENT(ASM_CONCAT3(__rvs_cotan_,TARGET_VEX_OR_FMA,_256))) + + +LBL(.L_rvs_cotan_256_done): + addq $8, %rsp + ret + + ELF_FUNC(ASM_CONCAT3(__rvs_cotan_,TARGET_VEX_OR_FMA,_256_mask)) + ELF_SIZE(ASM_CONCAT3(__rvs_cotan_,TARGET_VEX_OR_FMA,_256_mask)) + + +/* + * __rvs_cotan_vex_mask(argument, mask) + * __rvs_cotan_fma4_mask(argument, mask) + * + * argument: ymm0 + * mask: ymm1 + * + * Compute the cotangent of the arguments whose mask is non-zero + * + */ + .text + ALN_FUNC + .globl ENT(ASM_CONCAT3(__rvs_cotan_,TARGET_VEX_OR_FMA,_mask)) +ENT(ASM_CONCAT3(__rvs_cotan_,TARGET_VEX_OR_FMA,_mask)): + + subq $8, %rsp + + vptest .L_zeromask(%rip), %xmm1 + je LBL(.L_rvs_cotan_done) + + vandpd %xmm0,%xmm1,%xmm0 + CALL(ENT(ASM_CONCAT(__rvs_cotan_,TARGET_VEX_OR_FMA))) + + +LBL(.L_rvs_cotan_done): + addq $8, %rsp + ret + + ELF_FUNC(ASM_CONCAT3(__rvs_cotan_,TARGET_VEX_OR_FMA,_mask)) + ELF_SIZE(ASM_CONCAT3(__rvs_cotan_,TARGET_VEX_OR_FMA,_mask)) + /* * __rvs_tan_vex_256_mask(argument, mask) diff --git a/runtime/libpgmath/test/pgmath_test.h b/runtime/libpgmath/test/pgmath_test.h index a02fcce5bf..938508a26e 100644 --- a/runtime/libpgmath/test/pgmath_test.h +++ b/runtime/libpgmath/test/pgmath_test.h @@ -11,12 +11,16 @@ * Real. */ -typedef double vrd1_t; +sypedef double vrd1_t; +at (*fptr)(float); + fptr = (float(*)(float))MTH_DISPATCH_TBL[func_tan][sv_ss][frp_p]; + return __ZGVxN4v__mth_i_vr4( x, fptr); + } typedef double vrd2_t __attribute__((vector_size(2*sizeof(double)))); typedef double vrd4_t __attribute__((vector_size(4*sizeof(double)))); -typedef double vrd8_t __attribute__((vector_size(8*sizeof(double)))); +typede double vrd8_t __attribute__((vector_size(8*sizeof(double)))); typedef float vrs1_t; -typedef float vrs4_t __attribute__((vector_size(4*sizeof(float)))); +tnypedef float vrs4_t __attribute__((vector_size(4*sizeof(float)))); typedef float vrs8_t __attribute__((vector_size(8*sizeof(float)))); typedef float vrs16_t __attribute__((vector_size(16*sizeof(float)))); diff --git a/runtime/libpgmath/tools/mth_generic_frp.awk b/runtime/libpgmath/tools/mth_generic_frp.awk index c6371f47ac..356ba631e1 100644 --- a/runtime/libpgmath/tools/mth_generic_frp.awk +++ b/runtime/libpgmath/tools/mth_generic_frp.awk @@ -150,6 +150,7 @@ function do_all_rr() func_rr_def("aint", frp, sd, one_arg) func_rr_def("ceil", frp, sd, one_arg) func_rr_def("floor", frp, sd, one_arg) + func_rr_def("cotan", frp, sd, one_arg) } } } @@ -301,7 +302,8 @@ if (0) { old_do_all_rr("div", two_args) old_do_all_rr("sqrt", one_arg) old_do_all_rr("mod", two_args) - + old_do_all_rr("cotan", one_arg) + } # if (MAX_VREG_SIZE == 128) { do_all_rr() diff --git a/runtime/libpgmath/tools/mth_mask.awk b/runtime/libpgmath/tools/mth_mask.awk index 9f0a279b83..df2e1ecf43 100644 --- a/runtime/libpgmath/tools/mth_mask.awk +++ b/runtime/libpgmath/tools/mth_mask.awk @@ -398,6 +398,7 @@ BEGIN { do_all_rr("aint", 0, one_arg) do_all_rr("ceil", 0, one_arg) do_all_rr("floor", 0, one_arg) + do_all_rr("cotan", 0, one_arg) do_all_pow_r2i() } diff --git a/runtime/libpgmath/tools/mth_z2yy.awk b/runtime/libpgmath/tools/mth_z2yy.awk index c2a2758896..6e3d478535 100644 --- a/runtime/libpgmath/tools/mth_z2yy.awk +++ b/runtime/libpgmath/tools/mth_z2yy.awk @@ -515,6 +515,7 @@ BEGIN { do_all_rr("aint", 0, one_arg) do_all_rr("ceil", 0, one_arg) do_all_rr("floor", 0, one_arg) + do_all_rr("cotan", 0, one_arg) #not used do_all_rr("div", 1, two_args) #not used do_all_rr("sqrt", 0, one_arg) diff --git a/t1 b/t1 new file mode 100644 index 0000000000..b017f20237 --- /dev/null +++ b/t1 @@ -0,0 +1,188 @@ + runtime/flang/cmplx_intrinsic_wrapper.c + runtime/flang/gather_cmplx32.F95 + runtime/flang/itrailz.c + runtime/flang/itrailzi.c + runtime/flang/ktrailz.c + runtime/flang/mmcmplx32.c + runtime/flang/mmul_cplx32contmxm.F95 + runtime/flang/mmul_cplx32contmxv.F95 + runtime/flang/mmul_cplx32contvxm.F95 + runtime/flang/mmul_cplx32str1.F95 + runtime/flang/mmul_cplx32str1_t.F95 + runtime/flang/mmul_real16contmxm.F95 + runtime/flang/mmul_real16contmxv.F95 + runtime/flang/mmul_real16contvxm.F95 + runtime/flang/mmul_real16str1.F95 + runtime/flang/mmul_real16str1_t.F95 + runtime/flang/mmulcplx32.c + runtime/flang/mmulcplx32_t.c + runtime/flang/mmulreal16.c + runtime/flang/mmulreal16_t.c + runtime/flang/mnaxnb_cmplx32.F95 + runtime/flang/mnaxtb_cmplx32.F95 + runtime/flang/mtaxnb_cmplx32.F95 + runtime/flang/mtaxtb_cmplx32.F95 + runtime/flang/mvmul_cmplx32.F95 + runtime/flang/pgf90_mmul_cmplx32.h + runtime/flang/transpose_cmplx32.F95 + runtime/flang/vmmul_cmplx32.F95 + runtime/flangrti/mcopy16.c + runtime/flangrti/mzero16.c + runtime/flangrti/qbessel_tjn.c + runtime/flangrti/qbessel_tyn.c + runtime/libpgmath/lib/common/catan2.c + runtime/libpgmath/lib/common/ccotan.c + runtime/libpgmath/lib/common/ccotanf.c + runtime/libpgmath/lib/common/cdcotan.c + runtime/libpgmath/lib/common/cotand.c + runtime/libpgmath/lib/common/cotanf/ + runtime/libpgmath/lib/common/cqdiv.c + runtime/libpgmath/lib/common/cqpowi.c + runtime/libpgmath/lib/common/cqpowk.c + runtime/libpgmath/lib/common/dcotand.c + runtime/libpgmath/lib/common/erfc_scaledq.c + runtime/libpgmath/lib/common/erfcq.c + runtime/libpgmath/lib/common/erfq.c + runtime/libpgmath/lib/common/gammaq.c + runtime/libpgmath/lib/common/hypotq.c + runtime/libpgmath/lib/common/log_gammaq.c + runtime/libpgmath/lib/common/qacosd.c + runtime/libpgmath/lib/common/qasind.c + runtime/libpgmath/lib/common/qatan2d.c + runtime/libpgmath/lib/common/qatand.c + runtime/libpgmath/lib/common/qbessel_j0.c + runtime/libpgmath/lib/common/qbessel_j1.c + runtime/libpgmath/lib/common/qbessel_jn.c + runtime/libpgmath/lib/common/qbessel_y0.c + runtime/libpgmath/lib/common/qbessel_y1.c + runtime/libpgmath/lib/common/qbessel_yn.c + runtime/libpgmath/lib/common/qcosd.c + runtime/libpgmath/lib/common/qcotan.c + runtime/libpgmath/lib/common/qcotand.c + runtime/libpgmath/lib/common/qnint.c + runtime/libpgmath/lib/common/qpowi.c + runtime/libpgmath/lib/common/qsind.c + runtime/libpgmath/lib/common/qtand.c + runtime/libpgmath/lib/generic/cotan.c + runtime/libpgmath/lib/generic/dcotan.c + runtime/libpgmath/lib/generic/math_tables/mth_cotandefs.h + runtime/libpgmath/lib/generic/qnint.c + runtime/libpgmath/lib/x86_64/cotan.c + runtime/libpgmath/lib/x86_64/dcotan.c + runtime/libpgmath/lib/x86_64/math_tables/mth_cotandefs.h + t1 + test/debug_info/allocatable_arr_param.f90 + test/debug_info/allocated_nodup.f90 + test/debug_info/assumed_len.f90 + test/debug_info/assumed_rank.f90 + test/debug_info/assumed_size_array.f90 + test/debug_info/call_site_parameter.f90 + test/debug_info/character.f90 + test/debug_info/cray_ptr_param.f90 + test/debug_info/module_allocatable_arr.f90 + test/debug_info/module_pointer_arr.f90 + test/debug_info/pointer_arr_param.f90 + test/debug_info/test_inline.f90 + test/directives/ + test/f08_correct/ + test/f90_correct/inc/eoshift.mk + test/f90_correct/inc/f2008_tbp.mk + test/f90_correct/inc/floor_ceil.mk + test/f90_correct/inc/mm_prefetch00.mk + test/f90_correct/inc/modarraycon.mk + test/f90_correct/inc/nearest_intrin.mk + test/f90_correct/inc/quad01.mk + test/f90_correct/inc/quad02.mk + test/f90_correct/inc/quad03.mk + test/f90_correct/inc/quad_epsilon.mk + test/f90_correct/inc/quad_math_intrin.mk + test/f90_correct/inc/quadcmplx01.mk + test/f90_correct/inc/quadsupport.mk + test/f90_correct/inc/real128_init.mk + test/f90_correct/inc/real128_int_init.mk + test/f90_correct/inc/test_cotan.mk + test/f90_correct/inc/test_dasinh.mk + test/f90_correct/inc/trailz.mk + test/f90_correct/inc/trailz_elemental.mk + test/f90_correct/inc/trailz_kind.mk + test/f90_correct/lit/eoshift.sh + test/f90_correct/lit/f2008_tbp.sh + test/f90_correct/lit/floor_ceil.sh + test/f90_correct/lit/mm_prefetch00.sh + test/f90_correct/lit/modarraycon.sh + test/f90_correct/lit/nearest_intrin.sh + test/f90_correct/lit/quad01.sh + test/f90_correct/lit/quad02.sh + test/f90_correct/lit/quad03.sh + test/f90_correct/lit/quad_epsilon.sh + test/f90_correct/lit/quad_math_intrin.sh + test/f90_correct/lit/quadcmplx01.sh + test/f90_correct/lit/quadsupport.sh + test/f90_correct/lit/real128_init.sh + test/f90_correct/lit/real128_int_init.sh + test/f90_correct/lit/test_cotan.sh + test/f90_correct/lit/test_dasinh.sh + test/f90_correct/lit/trailz.sh + test/f90_correct/lit/trailz_elemental.sh + test/f90_correct/lit/trailz_kind.sh + test/f90_correct/src/eoshift.f90 + test/f90_correct/src/f2008_tbp.f90 + test/f90_correct/src/floor_ceil.f90 + test/f90_correct/src/mm_prefetch00.f90 + test/f90_correct/src/modarraycon.f90 + test/f90_correct/src/nearest_intrin.f90 + test/f90_correct/src/quad01.f90 + test/f90_correct/src/quad02.f90 + test/f90_correct/src/quad03.f90 + test/f90_correct/src/quad_epsilon.f90 + test/f90_correct/src/quad_math_intrin.f90 + test/f90_correct/src/quadcmplx01.f90 + test/f90_correct/src/quadsupport.f90 + test/f90_correct/src/real128_init.f90 + test/f90_correct/src/real128_int_init.f90 + test/f90_correct/src/test_cotan.f90 + test/f90_correct/src/test_dasinh.f90 + test/f90_correct/src/trailz.f90 + test/f90_correct/src/trailz_elemental.f90 + test/f90_correct/src/trailz_kind.f90 + test/offloading/amdgpu/cmn_blk_decl_target.F90 + test/offloading/amdgpu/common_block.F90 + test/offloading/amdgpu/declare_target.F90 + test/offloading/amdgpu/default_map.F90 + test/offloading/amdgpu/do_simd.F90 + test/offloading/amdgpu/mul_red.F90 + test/offloading/amdgpu/pardo_reduction.F90 + test/offloading/amdgpu/reduction_max.F90 + test/offloading/amdgpu/run_tests.sh + test/offloading/amdgpu/shuffle_red.F90 + test/offloading/amdgpu/simple_red.F90 + test/offloading/amdgpu/target_ptr.F90 + test/offloading/amdgpu/target_simd.F90 + test/offloading/amdgpu/test_reshape_ido.F90 + test/offloading/amdgpu/use_device_ptr.F90 + test/x86_64_offloading/inc/misc1.mk + test/x86_64_offloading/inc/misc2.mk + test/x86_64_offloading/inc/misc3.mk + test/x86_64_offloading/inc/misc4.mk + test/x86_64_offloading/inc/nested_parallel1.mk + test/x86_64_offloading/inc/reduction2.mk + test/x86_64_offloading/inc/target_if1.mk + test/x86_64_offloading/inc/teams_distribute2.mk + test/x86_64_offloading/lit/misc1.sh + test/x86_64_offloading/lit/misc2.sh + test/x86_64_offloading/lit/misc3.sh + test/x86_64_offloading/lit/misc4.sh + test/x86_64_offloading/lit/nested_parallel1.sh + test/x86_64_offloading/lit/reduction2.sh + test/x86_64_offloading/lit/target_if1.sh + test/x86_64_offloading/lit/teams_distribute2.sh + test/x86_64_offloading/src/misc1.f90 + test/x86_64_offloading/src/misc2.f90 + test/x86_64_offloading/src/misc3.f90 + test/x86_64_offloading/src/misc4.f90 + test/x86_64_offloading/src/nested_parallel1.f90 + test/x86_64_offloading/src/reduction2.f90 + test/x86_64_offloading/src/target_if1.f90 + test/x86_64_offloading/src/teams_distribute2.f90 + tools/flang1/flang1exe/fcprop.c + diff --git a/test/debug_info/allocatable_arr_param.f90 b/test/debug_info/allocatable_arr_param.f90 new file mode 100644 index 0000000000..5c05bc8a11 --- /dev/null +++ b/test/debug_info/allocatable_arr_param.f90 @@ -0,0 +1,42 @@ +!RUN: %flang -gdwarf-4 -S -emit-llvm %s -o - | FileCheck %s + +!CHECK-LABEL: define void @callee_ +!CHECK: call void @llvm.dbg.declare(metadata i64* %"array$p", metadata [[DLOC:![0-9]+]] +!CHECK-NEXT: call void @llvm.dbg.declare(metadata i64* %"array$p", metadata [[ALLOCATED:![0-9]+]] +!CHECK-NEXT: call void @llvm.dbg.declare(metadata i64* %"array$sd", metadata [[ARRAY:![0-9]+]], metadata !DIExpression()) +!CHECK: [[ARRAY]] = !DILocalVariable(name: "array", +!CHECK-SAME: arg: 2, +!CHECK-SAME: type: [[TYPE:![0-9]+]] +!CHECK: [[TYPE]] = !DICompositeType(tag: DW_TAG_array_type, +!CHECK-SAME: dataLocation: [[DLOC]], allocated: [[ALLOCATED]] + +subroutine callee (array) + integer, allocatable :: array(:, :) + integer :: local = 4 + + do i=LBOUND (array, 2), UBOUND (array, 2), 1 + do j=LBOUND (array, 1), UBOUND (array, 1), 1 + write(*, fmt="(i4)", advance="no") array (j, i) + end do + print *, "" + end do + + local = local / 2 + print *, "local = ", local +end subroutine callee + +program caller + + interface + subroutine callee (array) + integer, allocatable :: array(:, :) + end subroutine callee + end interface + + integer, allocatable :: caller_arr(:, :) + allocate(caller_arr(10, 10)) + caller_arr = 99 + caller_arr(2,2) = 88 + call callee (caller_arr) + print *, "" +end program caller diff --git a/test/debug_info/allocated.f90 b/test/debug_info/allocated.f90 new file mode 100644 index 0000000000..04e870d82b --- /dev/null +++ b/test/debug_info/allocated.f90 @@ -0,0 +1,14 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + +!CHECK: !DILocalVariable(name: "arr", scope: {{![0-9]+}}, file: {{![0-9]+}}, line: 14, type: [[TYPE:![0-9]+]]) +!CHECK: [[TYPE]] = !DICompositeType(tag: DW_TAG_array_type, baseType: {{![0-9]+}}, size: 32, align: 32, elements: [[ELEM:![0-9]+]], dataLocation: {{![0-9]+}}, allocated: {{![0-9]+}}) +!CHECK: [[ELEM]] = !{[[ELEM1:![0-9]+]], [[ELEM2:![0-9]+]]} +!CHECK: [[ELEM1]] = !DISubrange(lowerBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 80, DW_OP_deref), upperBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 120, DW_OP_deref), stride: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 112, DW_OP_deref, DW_OP_push_object_address, DW_OP_plus_uconst, 24, DW_OP_deref, DW_OP_mul)) +!CHECK: [[ELEM2]] = !DISubrange(lowerBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 128, DW_OP_deref), upperBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 168, DW_OP_deref), stride: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 160, DW_OP_deref, DW_OP_push_object_address, DW_OP_plus_uconst, 24, DW_OP_deref, DW_OP_mul)) +program main + integer(kind=4), allocatable :: arr(:, :) + + allocate (arr(10,10)) + arr(1,1) = 99 + print *, arr(1,1) +end program main diff --git a/test/debug_info/allocated_nodup.f90 b/test/debug_info/allocated_nodup.f90 new file mode 100644 index 0000000000..4d9cf57be8 --- /dev/null +++ b/test/debug_info/allocated_nodup.f90 @@ -0,0 +1,32 @@ +!RUN: %flang -gdwarf-4 -S -emit-llvm %s -o - | FileCheck %s + +!CHECK: distinct !DIGlobalVariable(name: "arr", +!CHECK-SAME: type: [[TYPE:![0-9]+]] +!CHECK: [[TYPE]] = !DICompositeType(tag: DW_TAG_array_type, baseType: [[DTYPE:![0-9]+]] +!CHECK: [[DTYPE]] = !DICompositeType(tag: DW_TAG_structure_type, name: "dtype" +!CHECK-SAME: elements: [[MEMBERS:![0-9]+]] +!CHECK: [[MEMBERS]] = !{[[MEM1:![0-9]+]] +!CHECK: [[MEM1]] = !DIDerivedType(tag: DW_TAG_member, name: "memfunptr", +!CHECK-SAME: baseType: [[FUNPTRTYPE:![0-9]+]] +!CHECK: [[FUNPTRTYPE]] = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: [[FUNTYPE:![0-9]+]] +!CHECK: [[FUNTYPE]] = !DISubroutineType(types: [[FUNSIGNATURE:![0-9]+]]) +!CHECK: [[FUNSIGNATURE]] = !{[[DTYPE]] + +module pdt + type dtype + procedure (func), pointer, nopass :: memfunptr + integer, allocatable :: memalcarr(:) + end type dtype +contains + function func() + class (dtype), allocatable :: func + end function func +end module pdt + +program main + use pdt + type (dtype) arr(3) + allocate(arr(1)%memalcarr(10)) + arr(1)%memalcarr=9 + print *, arr(1)%memalcarr +end program main diff --git a/test/debug_info/associate.f90 b/test/debug_info/associate.f90 new file mode 100644 index 0000000000..2f20e1702d --- /dev/null +++ b/test/debug_info/associate.f90 @@ -0,0 +1,22 @@ +!RUN: %flang %s -g -S -emit-llvm -o - | FileCheck %s + +!Ensure that for an associated variable, we're taking the type of +!associated variable as DW_TAG_pointer_type. +!CHECK: call void @llvm.dbg.declare(metadata i32** %{{.*}}, metadata ![[DILocalVariable:[0-9]+]], metadata !DIExpression()) +!CHECK: ![[DILocalVariable]] = !DILocalVariable(name: "gama", {{.*}}, type: ![[PTRTYPE:[0-9]+]] +!CHECK: ![[PTRTYPE]] = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: ![[TYPE:[0-9]+]] +!CHECK: ![[TYPE]] = !DIBasicType(name: "integer",{{.*}} + +PROGRAM associate_simple + IMPLICIT NONE + integer alpha + + alpha = 4 + + ASSOCIATE(gama => alpha) + PRINT*, gama + 1 + PRINT*, alpha + END ASSOCIATE + + PRINT*, alpha +END PROGRAM diff --git a/test/debug_info/associated.f90 b/test/debug_info/associated.f90 new file mode 100644 index 0000000000..67be5e949d --- /dev/null +++ b/test/debug_info/associated.f90 @@ -0,0 +1,15 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + +!CHECK !DILocalVariable(name: "ptr", scope: {{![0-9]+}}, file: {{![0-9]+}}, type: {{![0-9]+}}) +!CHECK: !DICompositeType(tag: DW_TAG_array_type, baseType: {{![0-9]+}}, size: 32, align: 32, elements: [[ELEM:![0-9]+]], dataLocation: {{![0-9]+}}, associated: {{![0-9]+}}) +!CHECK: [[ELEM]] = !{[[ELEM1:![0-9]+]], [[ELEM2:![0-9]+]]} +!CHECK: [[ELEM1]] = !DISubrange(lowerBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 80, DW_OP_deref), upperBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 120, DW_OP_deref), stride: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 112, DW_OP_deref, DW_OP_push_object_address, DW_OP_plus_uconst, 24, DW_OP_deref, DW_OP_mul)) +!CHECK: [[ELEM2]] = !DISubrange(lowerBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 128, DW_OP_deref), upperBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 168, DW_OP_deref), stride: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 160, DW_OP_deref, DW_OP_push_object_address, DW_OP_plus_uconst, 24, DW_OP_deref, DW_OP_mul)) +program main + integer, target :: arr(10, 10) + integer, pointer :: ptr(:, :) + + arr(1,1) = 99 + ptr => arr + print *, ptr(1,1) +end program main diff --git a/test/debug_info/assumed_len.f90 b/test/debug_info/assumed_len.f90 new file mode 100644 index 0000000000..b9e7651bc7 --- /dev/null +++ b/test/debug_info/assumed_len.f90 @@ -0,0 +1,15 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + +!Verify the DebugInfo metadata contains DIStringType followed by DILocalVariable +!CHECK: !DIStringType(name: "character(*)!2", stringLength: [[N:![0-9]+]] +!CHECK: [[N]] = !DILocalVariable(arg: 2 + +program assumedLength + call sub('Hello') + contains + subroutine sub(string) + implicit none + character(len=*), intent(in) :: string + print *, string + end subroutine sub +end program assumedLength diff --git a/test/debug_info/assumed_rank.f90 b/test/debug_info/assumed_rank.f90 new file mode 100644 index 0000000000..e38f08f36d --- /dev/null +++ b/test/debug_info/assumed_rank.f90 @@ -0,0 +1,40 @@ +!Check debug info generation for assumed rank arrays with DWARF5 and lower. + +!RUN: %flang -gdwarf-4 -S -emit-llvm %s -o - | FileCheck %s --check-prefix=DWARF4 +!RUN: %flang -gdwarf-5 -S -emit-llvm %s -o - | FileCheck %s --check-prefix=DWARF5 +!RUN: %flang -gdwarf-4 -std=f2008 -S -emit-llvm %s -o - | FileCheck %s --check-prefix=F2K8 + +!DWARF4: call void @llvm.dbg.value(metadata i64* %ararray, metadata [[DLOC:![0-9]+]], metadata !DIExpression()) +!DWARF4: !DILocalVariable(name: "ararray" +!DWARF4-SAME: arg: 2 +!DWARF4-SAME: type: [[ARTYPE:![0-9]+]]) +!DWARF4: [[ARTYPE]] = !DICompositeType(tag: DW_TAG_array_type, baseType: !{{[0-9]+}}, size: {{[0-9]+}}, align: {{[0-9]+}}, elements: [[ELEMS:![0-9]+]], dataLocation: [[DLOC:![0-9]+]]) +!DWARF4: [[ELEMS]] = !{[[ELEM1:![0-9]+]], [[ELEM2:![0-9]+]], [[ELEM3:![0-9]+]], [[ELEM4:![0-9]+]], [[ELEM5:![0-9]+]], [[ELEM6:![0-9]+]], [[ELEM7:![0-9]+]]} +!DWARF4: [[ELEM1]] = !DISubrange(lowerBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 80, DW_OP_deref), upperBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 120, DW_OP_deref), stride: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 112, DW_OP_deref, DW_OP_push_object_address, DW_OP_plus_uconst, 24, DW_OP_deref, DW_OP_mul)) +!DWARF4: [[ELEM2]] = !DISubrange(lowerBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 128, DW_OP_deref), upperBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 168, DW_OP_deref), stride: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 160, DW_OP_deref, DW_OP_push_object_address, DW_OP_plus_uconst, 24, DW_OP_deref, DW_OP_mul)) +!DWARF4: [[ELEM3]] = !DISubrange(lowerBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 176, DW_OP_deref), upperBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 216, DW_OP_deref), stride: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 208, DW_OP_deref, DW_OP_push_object_address, DW_OP_plus_uconst, 24, DW_OP_deref, DW_OP_mul)) +!DWARF4: [[ELEM4]] = !DISubrange(lowerBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 224, DW_OP_deref), upperBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 264, DW_OP_deref), stride: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 256, DW_OP_deref, DW_OP_push_object_address, DW_OP_plus_uconst, 24, DW_OP_deref, DW_OP_mul)) +!DWARF4: [[ELEM5]] = !DISubrange(lowerBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 272, DW_OP_deref), upperBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 312, DW_OP_deref), stride: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 304, DW_OP_deref, DW_OP_push_object_address, DW_OP_plus_uconst, 24, DW_OP_deref, DW_OP_mul)) +!DWARF4: [[ELEM6]] = !DISubrange(lowerBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 320, DW_OP_deref), upperBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 360, DW_OP_deref), stride: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 352, DW_OP_deref, DW_OP_push_object_address, DW_OP_plus_uconst, 24, DW_OP_deref, DW_OP_mul)) +!DWARF4: [[ELEM7]] = !DISubrange(lowerBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 368, DW_OP_deref), upperBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 408, DW_OP_deref), stride: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 400, DW_OP_deref, DW_OP_push_object_address, DW_OP_plus_uconst, 24, DW_OP_deref, DW_OP_mul)) + + +!DWARF5: call void @llvm.dbg.value(metadata i64* %ararray, metadata [[DLOC:![0-9]+]], metadata !DIExpression()) +!DWARF5: !DILocalVariable(name: "ararray" +!DWARF5-SAME: arg: 2 +!DWARF5-SAME: type: [[ARTYPE:![0-9]+]]) +!DWARF5: [[ARTYPE]] = !DICompositeType(tag: DW_TAG_array_type, baseType: !{{[0-9]+}}, size: {{[0-9]+}}, align: {{[0-9]+}}, elements: [[ELEMS:![0-9]+]], dataLocation: [[DLOC:![0-9]+]], rank: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 8, DW_OP_deref, DW_OP_constu, 7, DW_OP_and)) +!DWARF5: [[ELEMS]] = !{[[ELEM1:![0-9]+]]} +!DWARF5: [[ELEM1]] = !DIGenericSubrange(lowerBound: !DIExpression(DW_OP_push_object_address, DW_OP_over, DW_OP_constu, 48, DW_OP_mul, DW_OP_plus_uconst, 80, DW_OP_plus, DW_OP_deref), upperBound: !DIExpression(DW_OP_push_object_address, DW_OP_over, DW_OP_constu, 48, DW_OP_mul, DW_OP_plus_uconst, 120, DW_OP_plus, DW_OP_deref), stride: !DIExpression(DW_OP_push_object_address, DW_OP_over, DW_OP_constu, 48, DW_OP_mul, DW_OP_plus_uconst, 112, DW_OP_plus, DW_OP_deref, DW_OP_push_object_address, DW_OP_plus_uconst, 24, DW_OP_deref, DW_OP_mul)) + +!F2K8: call void @llvm.dbg.value(metadata i64* %ararray, metadata [[DLOC:![0-9]+]], metadata !DIExpression()) +!F2K8: !DILocalVariable(name: "ararray" +!F2K8-SAME: arg: 2 +!F2K8-SAME: type: [[ARTYPE:![0-9]+]]) +!F2K8: [[ARTYPE]] = !DICompositeType(tag: DW_TAG_array_type, baseType: !{{[0-9]+}}, size: {{[0-9]+}}, align: {{[0-9]+}}, elements: [[ELEMS:![0-9]+]], dataLocation: [[DLOC:![0-9]+]]) +!F2K8: [[ELEMS]] = !{[[ELEM1:![0-9]+]], [[ELEM2:![0-9]+]], [[ELEM3:![0-9]+]], [[ELEM4:![0-9]+]], [[ELEM5:![0-9]+]], [[ELEM6:![0-9]+]], [[ELEM7:![0-9]+]], [[ELEM8:![0-9]+]], [[ELEM9:![0-9]+]], [[ELEM10:![0-9]+]], [[ELEM11:![0-9]+]], [[ELEM12:![0-9]+]], [[ELEM13:![0-9]+]], [[ELEM14:![0-9]+]], [[ELEM15:![0-9]+]]} + +subroutine sub(ararray) + real :: ararray(..) + print *, rank(ararray) +end diff --git a/test/debug_info/assumed_shape.f90 b/test/debug_info/assumed_shape.f90 new file mode 100644 index 0000000000..e97d062450 --- /dev/null +++ b/test/debug_info/assumed_shape.f90 @@ -0,0 +1,18 @@ + +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + +!CHECK: call void @llvm.dbg.declare(metadata i64* %assume, metadata [[ASSUME:![0-9]+]], metadata !DIExpression()) +!CHECK: [[TYPE:![0-9]+]] = !DICompositeType(tag: DW_TAG_array_type, baseType: {{![0-9]+}}, size: 32, align: 32, elements: [[ELEMS:![0-9]+]]) +!CHECK: [[ELEMS]] = !{[[ELEM1:![0-9]+]], [[ELEM2:![0-9]+]], [[ELEM3:![0-9]+]], [[ELEM4:![0-9]+]] +!CHECK: [[ELEM1]] = !DISubrange(lowerBound: 1, upperBound: 5) +!CHECK: [[ELEM2]] = !DISubrange(lowerBound: 1, upperBound: [[N1:![0-9]+]]) +!CHECK: [[N1]] = distinct !DILocalVariable +!CHECK: [[ELEM3]] = !DISubrange(lowerBound: [[N2:![0-9]+]], upperBound: 9) +!CHECK: [[N2]] = distinct !DILocalVariable +!CHECK: [[ELEM4]] = !DISubrange(lowerBound: [[N3:![0-9]+]], upperBound: [[N4:![0-9]+]]) +!CHECK: [[N3]] = distinct !DILocalVariable +!CHECK: [[N4]] = distinct !DILocalVariable +subroutine sub(assume,n1,n2,n3,n4) + integer(kind=4) :: assume(5,n1,n2:9,n3:n4) + assume(1,1,1,1) = 7 +end subroutine sub diff --git a/test/debug_info/assumed_shape_non_contiguous.f90 b/test/debug_info/assumed_shape_non_contiguous.f90 new file mode 100644 index 0000000000..ea6c82ce5a --- /dev/null +++ b/test/debug_info/assumed_shape_non_contiguous.f90 @@ -0,0 +1,35 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + +!CHECK: call void @llvm.dbg.value(metadata i64* %array, metadata [[ARRAYDL:![0-9]+]], metadata !DIExpression()) +!CHECK: call void @llvm.dbg.declare(metadata i64* %"array$sd", metadata [[ARRAY:![0-9]+]], metadata !DIExpression()) +!CHECK-LABEL: distinct !DICompileUnit(language: DW_LANG_Fortran90, +!CHECK: [[ARRAY]] = !DILocalVariable(name: "array" +!CHECK-SAME: arg: 3 +!CHECK-SAME: type: [[TYPE:![0-9]+]]) +!CHECK: [[TYPE]] = !DICompositeType(tag: DW_TAG_array_type, baseType: {{![0-9]+}}, size: 32, align: 32, elements: [[ELEM:![0-9]+]], dataLocation: [[ARRAYDL]]) +!CHECK: [[ELEM]] = !{[[ELEM1:![0-9]+]], [[ELEM2:![0-9]+]]} +!CHECK: [[ELEM1]] = !DISubrange(count: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 88, DW_OP_deref), lowerBound: 1, stride: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 112, DW_OP_deref, DW_OP_push_object_address, DW_OP_plus_uconst, 24, DW_OP_deref, DW_OP_mul)) +!CHECK: [[ELEM2]] = !DISubrange(count: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 136, DW_OP_deref), lowerBound: 1, stride: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 160, DW_OP_deref, DW_OP_push_object_address, DW_OP_plus_uconst, 24, DW_OP_deref, DW_OP_mul)) + +subroutine show (message, array) + character (len=*) :: message + integer :: array(:,:) + + print *, message + print *, array + +end subroutine show + +program test + + interface + subroutine show (message, array) + character (len=*) :: message + integer :: array(:,:) + end subroutine show + end interface + + integer :: parray(4,4) = reshape((/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/),(/4,4/)) + + call show ("parray", parray(1:2,1:2)) +end program test diff --git a/test/debug_info/assumed_shape_noopt.f90 b/test/debug_info/assumed_shape_noopt.f90 new file mode 100644 index 0000000000..3ca753382b --- /dev/null +++ b/test/debug_info/assumed_shape_noopt.f90 @@ -0,0 +1,32 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | llc -O0 -fast-isel=false -global-isel=false -filetype=obj -o %t +!RUN: llvm-dwarfdump %t | FileCheck %s + +!CHECK-LABEL: DW_TAG_subprogram +!COM: make sure DLOC's DW_AT_location is available +!CHECK-LABEL: DW_TAG_subprogram + !CHECK: DW_AT_name ("show") + !CHECK:[[DLOC:0x[0-9a-f]+]]: DW_TAG_formal_parameter + !CHECK: DW_AT_location + !CHECK:[[ARRAY:0x[0-9a-f]+]]: DW_TAG_formal_parameter + !CHECK: DW_AT_location + !CHECK: DW_AT_type ([[TYPE:0x[0-9a-f]+]] + !CHECK: [[TYPE]]: DW_TAG_array_type + !CHECK: DW_AT_data_location ([[DLOC]]) + +subroutine show (array) + integer :: array(:,:) + + print *, array +end subroutine show + +program test + interface + subroutine show (array) + integer :: array(:,:) + end subroutine show + end interface + + integer :: parray(4,4) = reshape((/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/),(/4,4/)) + + call show (parray(1:2,1:2)) +end program test diff --git a/test/debug_info/assumed_size_array.f90 b/test/debug_info/assumed_size_array.f90 new file mode 100644 index 0000000000..094c0cafdd --- /dev/null +++ b/test/debug_info/assumed_size_array.f90 @@ -0,0 +1,22 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + +!CHECK: call void @llvm.dbg.declare(metadata i64* %array1, metadata [[ARRAY1:![0-9]+]], metadata !DIExpression()) +!CHECK: call void @llvm.dbg.declare(metadata i64* %array2, metadata [[ARRAY2:![0-9]+]], metadata !DIExpression()) +!CHECK: [[TYPE1:![0-9]+]] = !DICompositeType(tag: DW_TAG_array_type, baseType: {{![0-9]+}}, align: 32, elements: [[ELEMS1:![0-9]+]]) +!CHECK: [[ELEMS1]] = !{[[ELEM11:![0-9]+]]} +!CHECK: [[ELEM11]] = !DISubrange(lowerBound: 1) +!CHECK: [[TYPE2:![0-9]+]] = !DICompositeType(tag: DW_TAG_array_type, baseType: {{![0-9]+}}, align: 32, elements: [[ELEMS2:![0-9]+]]) +!CHECK: [[ELEMS2]] = !{[[ELEM21:![0-9]+]], [[ELEM22:![0-9]+]]} +!CHECK: [[ELEM21]] = !DISubrange(lowerBound: 4, upperBound: 9) +!CHECK: [[ELEM22]] = !DISubrange(lowerBound: 10) +!CHECK: [[ARRAY1]] = !DILocalVariable(name: "array1" +!CHECK-SAME: type: [[TYPE1]] +!CHECK: [[ARRAY2]] = !DILocalVariable(name: "array2" +!CHECK-SAME: type: [[TYPE2]] +subroutine sub (array1, array2) + integer :: array1 (*) + integer :: array2 (4:9, 10:*) + + array1(7:8) = 9 + array2(5, 10) = 10 +end subroutine diff --git a/test/debug_info/byval-name.f90 b/test/debug_info/byval-name.f90 new file mode 100644 index 0000000000..d37cde74da --- /dev/null +++ b/test/debug_info/byval-name.f90 @@ -0,0 +1,19 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + +!Verify the IR contains _V_ (flang)convention naming and the +! operation using them are well formed. +!CHECK: sub_(i32 [[PREFIXED_ARG_NAME:%_V_arg_abc.arg]]) +!CHECK: [[PREFIXED_LOCAL_NAME:%_V_arg_abc.addr]] = alloca i32, align 4 +!CHECK: call void @llvm.dbg.declare(metadata i32* [[PREFIXED_LOCAL_NAME]] +!CHECK: store i32 [[PREFIXED_ARG_NAME]], i32* [[PREFIXED_LOCAL_NAME]], align 4 + +!Verify the DebugInfo metadata contains prefix _V_ truncated names. +!CHECK: DILocalVariable(name: "arg_abc" +!CHECK-NOT: DILocalVariable(name: "_V_arg_abc" + +subroutine sub(arg_abc) + integer,value :: arg_abc + integer :: abc_local + abc_local = arg_abc + print*, arg_abc +end subroutine diff --git a/test/debug_info/call_site_parameter.f90 b/test/debug_info/call_site_parameter.f90 new file mode 100644 index 0000000000..73f32f7e0a --- /dev/null +++ b/test/debug_info/call_site_parameter.f90 @@ -0,0 +1,68 @@ +!RUN: %flang -gdwarf-3 -S -emit-llvm %s -o - | FileCheck %s --check-prefix=DWARF3 +!RUN: %flang -gdwarf-4 -S -emit-llvm %s -o - | FileCheck %s --check-prefix=DWARF45 +!RUN: %flang -gdwarf-5 -S -emit-llvm %s -o - | FileCheck %s --check-prefix=DWARF45 +!RUN: %flang -gdwarf-4 -O3 %s -o %t +!RUN: llvm-dwarfdump %t -o - | FileCheck %s --check-prefix=DWARFDUMP4 +!RUN: %flang -gdwarf-5 -O3 %s -o %t +!RUN: llvm-dwarfdump %t -o - | FileCheck %s --check-prefix=DWARFDUMP5 + +! Flag DIFlagAllCallsDescribed should not be generated for dwarf version < 4 +!DWARF3-NOT: DIFlagAllCallsDescribed + +! check whether flag DIFlagAllCallsDescribed is generated for function "caller" +! for dwarf version >= 4 +!DWARF45: !DISubprogram(name: "caller" +!DWARF45-SAME: DIFlagAllCallsDescribed + +! check if DWARF attributes are dumped correctly on dwarf version 4 +!DWARFDUMP4-LABEL: DW_TAG_GNU_call_site +!DWARFDUMP4-NEXT: DW_AT_abstract_origin ([[CALLEE:0x[0-9a-f]+]] "callee") +!DWARFDUMP4-NEXT: DW_AT_low_pc +!DWARFDUMP4-LABEL: DW_TAG_GNU_call_site_parameter +!DWARFDUMP4-NEXT: DW_AT_location +!DWARFDUMP4-NEXT: DW_AT_GNU_call_site_value +!DWARFDUMP4: [[CALLEE]]: DW_TAG_subprogram +!DWARFDUMP4-NOT: DW_TAG_subprogram +!DWARFDUMP4: DW_AT_name ("callee") + +! check if DWARF attributes are dumped correctly on dwarf version 5 +!DWARFDUMP5-LABEL: DW_TAG_call_site +!DWARFDUMP5-NEXT: DW_AT_call_origin ([[CALLEE:0x[0-9a-f]+]]) +!DWARFDUMP5-NEXT: DW_AT_call_return_pc +!DWARFDUMP5-LABEL: DW_TAG_call_site_parameter +!DWARFDUMP5-NEXT: DW_AT_location +!DWARFDUMP5-NEXT: DW_AT_call_value +!DWARFDUMP5: [[CALLEE]]: DW_TAG_subprogram +!DWARFDUMP5-NOT: DW_TAG_subprogram +!DWARFDUMP5: DW_AT_name ("callee") + +subroutine callee (array) + integer, dimension (:,:) :: array + + do i=LBOUND (array, 2), UBOUND (array, 2), 1 + do j=LBOUND (array, 1), UBOUND (array, 1), 1 + write(*, fmt="(i4)", advance="no") array (j, i) + end do + print *, "" + end do + + print *, "this line does not use argument array !!!" + +end subroutine callee + +program caller + + interface + subroutine callee (array) + integer, dimension(:,:) :: array + end subroutine callee + end interface + + integer, dimension (1:10,1:10) :: array + array = 99 + array(2,2) = 88 + + call callee (array) + + print *, "" +end program caller diff --git a/test/debug_info/character.f90 b/test/debug_info/character.f90 new file mode 100644 index 0000000000..4aabd6fb50 --- /dev/null +++ b/test/debug_info/character.f90 @@ -0,0 +1,10 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + +!CHECK: !DILocalVariable(name: "cvar", scope: {{![0-9]+}}, file: {{![0-9]+}}, line: 8, type: [[TYPE:![0-9]+]]) +!CHECK: [[TYPE]] = !DIBasicType(tag: DW_TAG_string_type, name: "character", + + +program main + character :: cvar + cvar = 'a' +end program main diff --git a/test/debug_info/common.f90 b/test/debug_info/common.f90 new file mode 100644 index 0000000000..4778d3514a --- /dev/null +++ b/test/debug_info/common.f90 @@ -0,0 +1,15 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + +!CHECK: distinct !DIGlobalVariable(name: "cvar1", scope: [[CBLOCK:![0-9]+]] +!CHECK: [[CBLOCK]] = distinct !DICommonBlock(scope: !3, declaration: null, name: "cname") +!CHECK-NOT: distinct !DIGlobalVariable(name: "cname" +!CHECK: distinct !DIGlobalVariable(name: "cvar2", scope: [[CBLOCK]] + +program main + integer :: cvar1, cvar2 + common /cname/ cvar1, cvar2 + cvar1 = 1 + cvar2 = 2 + print *, cvar1 + print *, cvar2 +end program main diff --git a/test/debug_info/conststring.f90 b/test/debug_info/conststring.f90 new file mode 100644 index 0000000000..06562afd63 --- /dev/null +++ b/test/debug_info/conststring.f90 @@ -0,0 +1,21 @@ +!! check if conststrings are stored correctly for special characters +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + +!! \0 = 0 , " = 34 = 0x22 +!CHECK: call void @llvm.dbg.value(metadata [10 x i8] c"a\00d\22g ", metadata [[CONSTR1:![0-9a-f]+]], metadata !DIExpression()) +!CHECK: call void @llvm.dbg.value(metadata [10 x i8] c"h i~j ", metadata [[CONSTR2:![0-9a-f]+]], metadata !DIExpression()) +!! \n = 10 \r = 13 +!CHECK: call void @llvm.dbg.value(metadata [10 x i8] c"k\0Al\0Dm ", metadata [[CONSTR3:![0-9a-f]+]], metadata !DIExpression()) +!CHECK: [[CONSTR1]] = !DILocalVariable(name: "constr1", +!CHECK: [[CONSTR2]] = !DILocalVariable(name: "constr2", +!CHECK: [[CONSTR3]] = !DILocalVariable(name: "constr3", + +program main + character(10),parameter :: constr1 = "a"//achar(0)//"d"//achar(34)//"g" + character(10),parameter :: constr2 = "h i~j" + character(10),parameter :: constr3 = "k"//achar(10)//"l"//achar(13)//"m" + + print *,constr1 + print *,constr2 + print *,constr3 +end diff --git a/test/debug_info/cray_ptr_param.f90 b/test/debug_info/cray_ptr_param.f90 new file mode 100644 index 0000000000..086aff5b7a --- /dev/null +++ b/test/debug_info/cray_ptr_param.f90 @@ -0,0 +1,25 @@ +!RUN: %flang -gdwarf-4 -S -emit-llvm %s -o - | FileCheck %s + +!CHECK-LABEL: define internal void @main_callee +!CHECK: call void @llvm.dbg.declare(metadata i64* %callee_ptr, metadata [[CALLEE_PTR:![0-9]+]] +!CHECK: [[CALLEE_PTR]] = !DILocalVariable(name: "callee_ptr" +!CHECK-SAME: arg: 1 + +program main + pointer (ptr, b) + integer :: a(10), b(10) + a = (/1,2,3,4,5,6,7,8,9,10/) + call callee(ptr) + print *, b + print *, a + print *, ptr +contains + subroutine callee(callee_ptr) + pointer(callee_ptr, callee_pte) + integer, allocatable :: callee_pte(:) + allocate (callee_pte(10)) + callee_pte = (/5,4,5,4,5,4,5,4,5,4/) + print *,callee_ptr + print *,callee_pte + end subroutine +end diff --git a/test/debug_info/deferred_len.f90 b/test/debug_info/deferred_len.f90 new file mode 100644 index 0000000000..a4bcc15c7f --- /dev/null +++ b/test/debug_info/deferred_len.f90 @@ -0,0 +1,17 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + +!CHECK: !DILocalVariable(name: "defl_string"{{.*}}, type: ![[DERIVEDSTRING:[0-9]+]] +!CHECK: ![[DERIVEDSTRING]] = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: ![[STRING:[0-9]+]] +!CHECK: ![[STRING]] = !DIStringType(name: "character(*)", stringLength: !{{[0-9]+}} + +program deferredlength + + character(len=100) :: buffer + character(len=:), allocatable :: defl_string + + read(*,*) buffer + defl_string = trim(buffer) + print *,defl_string + +end program deferredlength + diff --git a/test/debug_info/dertyp_member_ptr.f90 b/test/debug_info/dertyp_member_ptr.f90 new file mode 100644 index 0000000000..7b1b910c17 --- /dev/null +++ b/test/debug_info/dertyp_member_ptr.f90 @@ -0,0 +1,57 @@ +!RUN: %flang -gdwarf-4 -S -emit-llvm %s -o - | FileCheck %s + +!CHECK: distinct !DIGlobalVariable(name: "dvar", +!CHECK-SAME: type: [[TYPE:![0-9]+]] +!CHECK: [[TYPE]] = !DICompositeType(tag: DW_TAG_structure_type, name: "dtype" +!CHECK-SAME: elements: [[MEMBERS:![0-9]+]] +!CHECK: [[MEMBERS]] = !{[[MEM1:![0-9]+]], [[MEM2:![0-9]+]], [[MEM3:![0-9]+]], [[MEM4:![0-9]+]], [[MEM5:![0-9]+]] +!CHECK: [[MEM1]] = !DIDerivedType(tag: DW_TAG_member, name: "i", +!CHECK-SAME: baseType: [[INTTYP:![0-9]+]] +!CHECK: [[MEM2]] = !DIDerivedType(tag: DW_TAG_member, name: "sclrptr", +!CHECK-SAME: baseType: [[SCLRPTRTYP:![0-9]+]] +!CHECK: [[SCLRPTRTYP]] = !DIDerivedType(tag: DW_TAG_pointer_type, +!CHECK-SAME: baseType: [[REALTYP:![0-9]+]] +!CHECK: [[REALTYP]] = !DIBasicType(name: "real" +!CHECK: [[MEM3]] = !DIDerivedType(tag: DW_TAG_member, name: "arrptr", +!CHECK-SAME: baseType: [[ARRTYP:![0-9]+]] +!CHECK: [[ARRTYP]] = !DICompositeType(tag: DW_TAG_array_type, +!CHECK: [[MEM4]] = !DIDerivedType(tag: DW_TAG_member, name: "dtptr", +!CHECK-SAME: baseType: [[DTTYP:![0-9]+]] +!CHECK: [[DTTYP]] = !DIDerivedType(tag: DW_TAG_pointer_type, +!CHECK: [[MEM5]] = !DIDerivedType(tag: DW_TAG_member, name: "dtarrptr", +!CHECK-SAME: baseType: [[DTARRTYP:![0-9]+]] +!CHECK: [[DTARRTYP]] = !DICompositeType(tag: DW_TAG_array_type, + +program main + implicit none + + type dtyp1 + integer :: scalar + integer :: arr(10) + end type dtyp1 + + type dtype + integer :: i + real, pointer :: sclrptr + integer, pointer :: arrptr(:) + type(dtyp1), pointer :: dtptr + type(dtyp1), pointer :: dtarrptr(:) + end type dtype + + real, target :: rval + integer, target :: arr(10) = (/0,2,4,6,8,1,3,5,7,9/) + type(dtyp1), target :: dtvar + type(dtyp1), target :: dtarr(10) + type(dtype) :: dvar + + dtvar%scalar = 5 + dtvar%arr = 99 + dtarr = dtvar + dtarr(5)%scalar = 55 + dvar%i = 4 + dvar%sclrptr => rval + dvar%arrptr => arr + dvar%dtptr => dtvar + dvar%dtarrptr => dtarr + +end program main diff --git a/test/debug_info/dertyp_sclr_ptr.f90 b/test/debug_info/dertyp_sclr_ptr.f90 new file mode 100644 index 0000000000..e017cc62c4 --- /dev/null +++ b/test/debug_info/dertyp_sclr_ptr.f90 @@ -0,0 +1,28 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + + +!CHECK: call void @llvm.dbg.declare(metadata %struct.dtype** %"dptr$p_{{[0-9]+}}", metadata [[DVAR:![0-9]+]], metadata !DIExpression()) +!CHECK: [[DTYPE:![0-9]+]] = !DICompositeType(tag: DW_TAG_structure_type, name: "dtype", file: !3, size: 32, align: 32, elements: [[ELEM:![0-9]+]]) +!CHECK: [[ELEM]] = !{[[ELEM1:![0-9]+]]} +!CHECK: [[ELEM1]] = !DIDerivedType(tag: DW_TAG_member, name: "avar" +!CHECK: [[DVAR]] = !DILocalVariable(name: "dptr", scope: {{![0-9]+}}, file: {{![0-9]+}}, line: 19, type: [[TYPE:![0-9]+]]) +!CHECK: [[TYPE]] = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: {{![0-9]+}}, size: 64, align: 64 + +program main + implicit none + + type :: dtype + integer :: avar + end type dtype + + type (dtype), target :: tvar + type(dtype), pointer :: dptr + + nullify (dptr) + + tvar%avar = 3 + + dptr => tvar + nullify (dptr) + +end program main diff --git a/test/debug_info/dertyp_striding.f90 b/test/debug_info/dertyp_striding.f90 new file mode 100644 index 0000000000..1391cfe291 --- /dev/null +++ b/test/debug_info/dertyp_striding.f90 @@ -0,0 +1,20 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + +!CHECK !DILocalVariable(name: "pvar", scope: {{![0-9]+}}, file: {{![0-9]+}}, type: {{![0-9]+}}) +!CHECK: !DICompositeType(tag: DW_TAG_array_type, baseType: {{![0-9]+}}, size: 64, align: 64, elements: [[ELEM:![0-9]+]], dataLocation: {{![0-9]+}}, associated: {{![0-9]+}}) +!CHECK: [[ELEM]] = !{[[ELEM1:![0-9]+]]} +!CHECK: [[ELEM1]] = !DISubrange(lowerBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 80, DW_OP_deref), upperBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 120, DW_OP_deref), stride: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 112, DW_OP_deref, DW_OP_push_object_address, DW_OP_plus_uconst, 24, DW_OP_deref, DW_OP_mul)) +program main + type dtype + integer(kind=8) :: x + integer(kind=8) :: y + integer(kind=8) :: z + end type + type(dtype), dimension(10), target :: tvar + integer(kind=8), dimension(:), pointer :: pvar => null() + tvar(:)%x = 1 + tvar(:)%y = 2 + tvar(:)%z = 3 + pvar => tvar(1:9)%y + print *, pvar +end program diff --git a/test/debug_info/dimodule.f90 b/test/debug_info/dimodule.f90 new file mode 100644 index 0000000000..63e98b692f --- /dev/null +++ b/test/debug_info/dimodule.f90 @@ -0,0 +1,7 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + +!CHECK: DIModule(scope: !4, name: "dummy", file: !3, line: 5) + +module dummy + integer :: foo +end module dummy diff --git a/test/debug_info/dwarfdump_prolog.f90 b/test/debug_info/dwarfdump_prolog.f90 new file mode 100644 index 0000000000..89d0eaffc9 --- /dev/null +++ b/test/debug_info/dwarfdump_prolog.f90 @@ -0,0 +1,30 @@ +!RUN: %flang -g %s -o %t +!RUN: llvm-dwarfdump --debug-line %t -o - | FileCheck %s + +!CHECK: name: "dwarfdump_prolog.f90" +!CHECK: Address Line Column File ISA Discriminator Flags +!CHECK: {{0x[0-9a-f]+}} 13 1 1 0 0 is_stmt prologue_end +!CHECK: {{0x[0-9a-f]+}} 29 1 1 0 0 is_stmt prologue_end + +subroutine show (message, array) + character (len=*) :: message + integer :: array(:) + + print *, message + print *, array + +end subroutine show + +program prolog + + interface + subroutine show (message, array) + character (len=*) :: message + integer :: array(:) + end subroutine show + end interface + + integer :: array(10) = (/1,2,3,4,5,6,7,8,9,10/) + + call show ("array", array) +end program prolog diff --git a/test/debug_info/entry_functions.f90 b/test/debug_info/entry_functions.f90 new file mode 100644 index 0000000000..d82e50f989 --- /dev/null +++ b/test/debug_info/entry_functions.f90 @@ -0,0 +1,36 @@ +!RUN: %flang %s -g -S -emit-llvm -o - | FileCheck %s + +!CHECK: define float @f2_( +!CHECK: call void @llvm.dbg.declare(metadata i64* %x +!CHECK: define float @f3_( +!CHECK: call void @llvm.dbg.declare(metadata i64* %x + +!CHECK: ![[COMPILER:[0-9]+]] = distinct !DICompileUnit(language: DW_LANG_Fortran90 +!CHECK-COUNT-2: ![[ENTRYFUNCTION1:[0-9]+]] = distinct !DISubprogram(name: "f2", scope: ![[COMPILER]] +!CHECK: !DILocalVariable(name: "x", arg: 1, scope: ![[ENTRYFUNCTION1]] +!CHECK: ![[ENTRYFUNCTION2:[0-9]+]] = distinct !DISubprogram(name: "f3", scope: ![[COMPILER]] +!CHECK: !DILocalVariable(name: "x", arg: 1, scope: ![[ENTRYFUNCTION2]] + +program alternateEntry +interface + REAL FUNCTION F2 ( X ) + REAL , intent(in):: X + end +end interface + + real :: arg,res + arg = 3.0 + res = f2(arg) + res = f3(arg) +end + +REAL FUNCTION F2 ( X ) +REAL , intent(in):: X + F2 = 2.0 * X + RETURN + + ENTRY F3 ( X ) + F3 = 3.0 * X + RETURN + +END function F2 diff --git a/test/debug_info/entry_functions_module.f90 b/test/debug_info/entry_functions_module.f90 new file mode 100644 index 0000000000..1ecb49316a --- /dev/null +++ b/test/debug_info/entry_functions_module.f90 @@ -0,0 +1,34 @@ +!RUN: %flang %s -g -S -emit-llvm -o - | FileCheck %s + +!CHECK: ![[MODULE:[0-9]+]] = !DIModule( +!CHECK-COUNT-2: distinct !DISubprogram(name: "sub1", scope: ![[MODULE]] +!CHECK: distinct !DISubprogram(name: "dummy", scope: ![[MODULE]] + +module mod1 + real :: a=1. +contains + subroutine sub1() + real :: b=3. + write(*,*) a + call internal() + entry dummy() + return + contains + subroutine internal() + real :: a=2. + write(*,*) b + write(*,*) a + end subroutine internal + end subroutine sub1 +end module mod1 + +program prog1 + use mod1 + call internal() +contains + subroutine internal() + write(*,*) a + call sub1() + call dummy() + end subroutine internal +end program diff --git a/test/debug_info/enum.f90 b/test/debug_info/enum.f90 new file mode 100644 index 0000000000..add20e07c6 --- /dev/null +++ b/test/debug_info/enum.f90 @@ -0,0 +1,25 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + +!CHECK: call void @llvm.dbg.value(metadata i32 1, metadata [[ENM1:![0-9]+]], metadata !DIExpression()) +!CHECK: call void @llvm.dbg.value(metadata i32 2, metadata [[ENM2:![0-9]+]], metadata !DIExpression()) +!CHECK: call void @llvm.dbg.value(metadata i32 5, metadata [[ENM3:![0-9]+]], metadata !DIExpression()) +!CHECK: call void @llvm.dbg.value(metadata i32 6, metadata [[ENM4:![0-9]+]], metadata !DIExpression()) +!CHECK: [[ENM1]] = !DILocalVariable(name: "red" +!CHECK: [[ENM2]] = !DILocalVariable(name: "blue" +!CHECK: [[ENM3]] = !DILocalVariable(name: "black" +!CHECK: [[ENM4]] = !DILocalVariable(name: "pink" + +program main + enum, bind(c) + enumerator :: red =1, blue, black =5 + enumerator :: pink + endenum + integer (kind=8) :: svar1, svar2, svar3, svar4 + svar1 = red + svar2 = blue + svar3 = black + svar4 = pink + + print *, svar1, svar2, svar3, svar4 + +end program main diff --git a/test/debug_info/func_return_type.f90 b/test/debug_info/func_return_type.f90 new file mode 100644 index 0000000000..69029e692c --- /dev/null +++ b/test/debug_info/func_return_type.f90 @@ -0,0 +1,16 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + +!Verify the function return type is not of pointer type +!CHECK: !DIBasicType(name: "real" +!CHECK-NOT: !DIDerivedType(tag: DW_TAG_pointer_type + +function square(x) + real, intent(in) :: x + real :: square + square = x * x +end function +program main + real :: a, b, square + a = 2.0 + b = square(a) +end program main diff --git a/test/debug_info/gdwarf_4.f90 b/test/debug_info/gdwarf_4.f90 new file mode 100644 index 0000000000..193b9e040f --- /dev/null +++ b/test/debug_info/gdwarf_4.f90 @@ -0,0 +1,7 @@ +!RUN: %flang -gdwarf-4 -S -emit-llvm %s -o - | FileCheck %s + +!CHECK: !"Dwarf Version", i32 4 + +program main + print *, "hello world !!" +end program main diff --git a/test/debug_info/gdwarf_5.f90 b/test/debug_info/gdwarf_5.f90 new file mode 100644 index 0000000000..07d6d77e1b --- /dev/null +++ b/test/debug_info/gdwarf_5.f90 @@ -0,0 +1,7 @@ +!RUN: %flang -gdwarf-5 -S -emit-llvm %s -o - | FileCheck %s + +!CHECK: !"Dwarf Version", i32 5 + +program main + print *, "hello world !!" +end program main diff --git a/test/debug_info/gdwarf_default.f90 b/test/debug_info/gdwarf_default.f90 new file mode 100644 index 0000000000..f4b1138ed9 --- /dev/null +++ b/test/debug_info/gdwarf_default.f90 @@ -0,0 +1,7 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + +!CHECK: !"Dwarf Version", i32 4 + +program main + print *, "hello world !!" +end program main diff --git a/test/debug_info/gdwarf_multiple.f90 b/test/debug_info/gdwarf_multiple.f90 new file mode 100644 index 0000000000..850c4e5c02 --- /dev/null +++ b/test/debug_info/gdwarf_multiple.f90 @@ -0,0 +1,7 @@ +!RUN: %flang -gdwarf-2 -gdwarf-3 -S -emit-llvm %s -o - | FileCheck %s + +!CHECK: !"Dwarf Version", i32 3 + +program main + print *, "hello world !!" +end program main diff --git a/test/debug_info/lit.local.cfg b/test/debug_info/lit.local.cfg new file mode 100644 index 0000000000..876bd6dbd0 --- /dev/null +++ b/test/debug_info/lit.local.cfg @@ -0,0 +1,4 @@ +#debug info test configuration + +config.suffixes = ['.f', '.FOR', '.for', '.f77', '.f90', '.f95', '.F', '.fpp', + '.FPP'] diff --git a/test/debug_info/module_allocatable_arr.f90 b/test/debug_info/module_allocatable_arr.f90 new file mode 100644 index 0000000000..6aa8285268 --- /dev/null +++ b/test/debug_info/module_allocatable_arr.f90 @@ -0,0 +1,19 @@ +!RUN: %flang -gdwarf-4 -S -emit-llvm %s -o - | FileCheck %s + +!CHECK-LABEL: distinct !DIGlobalVariable(name: "alc_arr", {{.*}}, line: 11 +!CHECK-SAME: type: [[TYPE:![0-9]+]] +!CHECK: [[TYPE]] = !DICompositeType(tag: DW_TAG_array_type, +!CHECK-SAME: elements: [[ELEMENTS:![0-9]+]], dataLocation: !DIExpression(DW_OP_push_object_address, DW_OP_deref), allocated: !DIExpression(DW_OP_push_object_address, DW_OP_deref) +!CHECK: [[ELEMENTS]] = !{[[ELEMENT:![0-9]+]]} +!CHECK: [[ELEMENT]] = !DISubrange(lowerBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 96, DW_OP_deref), upperBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 136, DW_OP_deref), stride: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 128, DW_OP_deref, DW_OP_push_object_address, DW_OP_plus_uconst, 40, DW_OP_deref, DW_OP_mul)) + +module mod_vars + integer, allocatable :: alc_arr(:) +end module + +program main + use mod_vars + allocate (alc_arr(10)) + alc_arr = 99 + print *, alc_arr +end program diff --git a/test/debug_info/module_parameter.f90 b/test/debug_info/module_parameter.f90 new file mode 100644 index 0000000000..42e1fe1bc3 --- /dev/null +++ b/test/debug_info/module_parameter.f90 @@ -0,0 +1,28 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s --check-prefix=LLVMIR +!RUN: %flang -g -S -emit-llvm %s -o - | llc -filetype=obj -o - | llvm-dwarfdump - | FileCheck %s --check-prefix=DWARF + +!LLVMIR-DAG: ![[MODULE_SCOPE:.*]] = !DIModule(scope: !4, name: "dummy", file: !{{.*}}, line: 15) +!LLVMIR-DAG: !DIGlobalVariableExpression(var: ![[POSITIVE:.*]], expr: !DIExpression(DW_OP_consts, 42, DW_OP_stack_value)) +!LLVMIR-DAG: !DIGlobalVariableExpression(var: ![[NEGATIVE:.*]], expr: !DIExpression(DW_OP_consts, 18446744073709551574, DW_OP_stack_value)) +!LLVMIR-DAG: ![[POSITIVE]] = distinct !DIGlobalVariable(name: "positive_foo", scope: ![[MODULE_SCOPE]], file: !{{.*}}, line: 17, type: !9, isLocal: false, isDefinition: true) +!LLVMIR-DAG: ![[NEGATIVE]] = distinct !DIGlobalVariable(name: "negative_foo", scope: ![[MODULE_SCOPE]], file: !{{.*}}, line: 18, type: !9, isLocal: false, isDefinition: true) + +!DWARF-LABEL: DW_AT_name ("positive_foo") +!DWARF: DW_AT_const_value (42) +!DWARF-LABEL: DW_AT_name ("negative_foo") +!DWARF: DW_AT_const_value (-42) + +module dummy + integer :: bar + integer, parameter :: positive_foo = 42 + integer, parameter :: negative_foo = -42 + contains + subroutine pass() + print*, bar, foo + end subroutine +end module dummy + +program main + use dummy + print*, foo +end diff --git a/test/debug_info/module_pointer_arr.f90 b/test/debug_info/module_pointer_arr.f90 new file mode 100644 index 0000000000..5ce96572d6 --- /dev/null +++ b/test/debug_info/module_pointer_arr.f90 @@ -0,0 +1,21 @@ +!RUN: %flang -gdwarf-4 -S -emit-llvm %s -o - | FileCheck %s + +!CHECK-LABEL: distinct !DIGlobalVariable(name: "ptr_arr", {{.*}}, line: 11 +!CHECK-SAME: type: [[TYPE:![0-9]+]] +!CHECK: [[TYPE]] = !DICompositeType(tag: DW_TAG_array_type, +!CHECK-SAME: elements: [[ELEMENTS:![0-9]+]], dataLocation: !DIExpression(DW_OP_push_object_address, DW_OP_deref), associated: !DIExpression(DW_OP_push_object_address, DW_OP_deref) +!CHECK: [[ELEMENTS]] = !{[[ELEMENT:![0-9]+]]} +!CHECK: [[ELEMENT]] = !DISubrange(lowerBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 96, DW_OP_deref), upperBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 136, DW_OP_deref), stride: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 128, DW_OP_deref, DW_OP_push_object_address, DW_OP_plus_uconst, 40, DW_OP_deref, DW_OP_mul)) + +module mod_vars1 + integer, pointer :: ptr_arr(:) +end module + +program main +use mod_vars1 + integer, target :: tgtarr(20) + tgtarr(1:20:2) = 22 + tgtarr(2:20:2) = 33 + ptr_arr => tgtarr(1:20:2) + print *, ptr_arr +end program diff --git a/test/debug_info/nametable.f90 b/test/debug_info/nametable.f90 new file mode 100644 index 0000000000..9d41fe6ccc --- /dev/null +++ b/test/debug_info/nametable.f90 @@ -0,0 +1,20 @@ +!RUN: %flang %s -gdwarf-5 -S -emit-llvm -o - | FileCheck %s --check-prefix=NONAMESECTION +!RUN: %flang %s -g -S -emit-llvm -o - | FileCheck %s --check-prefix=NOPUBNAMESECTION + +!Ensure that "nameTableKind: None" field is present in DICompileUnit. +!NONAMESECTION-DAG: !DICompileUnit({{.*}}, nameTableKind: None +!NONAMESECTION-DAG: {i32 2, !"Dwarf Version", i32 5} +!NOPUBNAMESECTION-DAG: !DICompileUnit({{.*}}, nameTableKind: None +!NOPUBNAMESECTION-DAG: {i32 2, !"Dwarf Version", i32 4} + +!RUN: %flang %s -gdwarf-5 -gpubnames -S -emit-llvm -o - | FileCheck %s --check-prefix=NAMESECTION +!RUN: %flang %s -g -gpubnames -S -emit-llvm -o - | FileCheck %s --check-prefix=PUBNAMESECTION + +!Ensure that "nameTableKind: None" field is not present in DICompileUnit. +!NAMESECTION-NOT: !DICompileUnit({{.*}}, nameTableKind: None +!NAMESECTION-DAG: {i32 2, !"Dwarf Version", i32 5} +!PUBNAMESECTION-NOT: !DICompileUnit({{.*}}, nameTableKind: None +!PUBNAMESECTION-DAG: {i32 2, !"Dwarf Version", i32 4} +PROGRAM main +END PROGRAM main + diff --git a/test/debug_info/outervar.f90 b/test/debug_info/outervar.f90 new file mode 100644 index 0000000000..3fcaef7a83 --- /dev/null +++ b/test/debug_info/outervar.f90 @@ -0,0 +1,14 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + +!CHECK: distinct !DIGlobalVariable(name: "prog_i" +!CHECK-NOT: distinct !DIGlobalVariable(name: "prog_i" + +program main + integer :: prog_i + prog_i = 99 + call sub() +contains + subroutine sub() + print *,prog_i + end subroutine sub +end program main diff --git a/test/debug_info/parameter.f90 b/test/debug_info/parameter.f90 new file mode 100644 index 0000000000..eb7014529f --- /dev/null +++ b/test/debug_info/parameter.f90 @@ -0,0 +1,17 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + +!CHECK: call void @llvm.dbg.value(metadata i64 99, metadata [[SPAR:![0-9]+]], metadata !DIExpression()) +!CHECK: distinct !DIGlobalVariable(name: "apar" +!CHECK: [[SPAR]] = !DILocalVariable(name: "spar" + +program main + integer (kind=8) :: svar + integer (kind=8) :: avar(5) + integer (kind=8), parameter :: spar = 99 + integer (kind=8), parameter :: apar(5) = (/99, 98, 97, 96, 95/) + svar = spar + avar = apar + + print *, svar, avar, spar, apar + +end program main diff --git a/test/debug_info/pointer.f90 b/test/debug_info/pointer.f90 new file mode 100644 index 0000000000..67a87a5f8d --- /dev/null +++ b/test/debug_info/pointer.f90 @@ -0,0 +1,59 @@ +!RUN: %flang %s -g -S -emit-llvm -o - | FileCheck %s + +!CHECK-DAG: ![[INTEGER:[0-9]+]] = !DIBasicType(name: "integer" +!CHECK-DAG: ![[REAL:[0-9]+]] = !DIBasicType(name: "real" +!CHECK-DAG: ![[DOUBLE:[0-9]+]] = !DIBasicType(name: "double precision" +!CHECK-DAG: ![[COMPLEX:[0-9]+]] = !DIBasicType(name: "complex" +!CHECK-DAG: ![[LOGICAL:[0-9]+]] = !DIBasicType(name: "logical" +!CHECK-DAG: ![[CHARACTER:[0-9]+]] = !DIBasicType(tag: DW_TAG_string_type, name: "character" + +!CHECK-DAG: DILocalVariable(name: "integer_ptr"{{.*}}, type: ![[DERIVEDINTEGER:[0-9]+]] +!CHECK-DAG: ![[DERIVEDINTEGER]] = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: ![[INTEGER]] +!CHECK-DAG: DILocalVariable(name: "real_ptr"{{.*}}, type: ![[DERIVEDREAL:[0-9]+]] +!CHECK-DAG: ![[DERIVEDREAL]] = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: ![[REAL]] +!CHECK-DAG: DILocalVariable(name: "double_ptr"{{.*}}, type: ![[DERIVEDDOUBLE:[0-9]+]] +!CHECK-DAG: ![[DERIVEDDOUBLE]] = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: ![[DOUBLE]] +!CHECK-DAG: DILocalVariable(name: "complex_ptr"{{.*}}, type: ![[DERIVEDCOMPLEX:[0-9]+]] +!CHECK-DAG: ![[DERIVEDCOMPLEX]] = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: ![[COMPLEX]] +!CHECK-DAG: DILocalVariable(name: "logical_ptr"{{.*}}, type: ![[DERIVEDLOGICAL:[0-9]+]] +!CHECK-DAG: ![[DERIVEDLOGICAL]] = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: ![[LOGICAL]] +!CHECK-DAG: DILocalVariable(name: "character_ptr"{{.*}}, type: ![[DERIVEDCHARACTER:[0-9]+]] +!CHECK-DAG: ![[DERIVEDCHARACTER]] = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: ![[CHARACTER]] + +PROGRAM main + + INTEGER, POINTER :: integer_ptr + REAL, POINTER :: real_ptr + DOUBLE PRECISION, POINTER :: double_ptr + COMPLEX, POINTER :: complex_ptr + LOGICAL, POINTER :: logical_ptr + CHARACTER(LEN=3), POINTER :: character_ptr + + INTEGER, TARGET :: integer_target + REAL, TARGET :: real_target + DOUBLE PRECISION, TARGET :: double_target + COMPLEX, TARGET :: complex_target + LOGICAL, TARGET :: logical_target + CHARACTER(LEN=3), TARGET :: character_target + + integer_ptr => integer_target + real_ptr => real_target + double_ptr => double_target + complex_ptr => complex_target + logical_ptr => logical_target + character_ptr => character_target + + integer_target = 5 + real_target = 5 + double_target = 5 + complex_target = CMPLX(1,2) + logical_target = .true. + character_target = 'H' + + PRINT*, integer_target + PRINT*, real_target + PRINT*, double_target + PRINT*, complex_target + PRINT*, logical_target + PRINT*, character_target +END PROGRAM diff --git a/test/debug_info/pointer_arr_param.f90 b/test/debug_info/pointer_arr_param.f90 new file mode 100644 index 0000000000..fc0e8aff4d --- /dev/null +++ b/test/debug_info/pointer_arr_param.f90 @@ -0,0 +1,45 @@ +!RUN: %flang -gdwarf-4 -S -emit-llvm %s -o - | FileCheck %s + +!CHECK-LABEL: define void @callee_ +!CHECK: call void @llvm.dbg.declare(metadata i64* %"array$p", metadata [[DLOC:![0-9]+]] +!CHECK-NEXT: call void @llvm.dbg.declare(metadata i64* %"array$p", metadata [[ASSOCIATED:![0-9]+]] +!CHECK-NEXT: call void @llvm.dbg.declare(metadata i64* %"array$sd", metadata [[ARRAY:![0-9]+]], metadata !DIExpression()) +!CHECK: [[ARRAY]] = !DILocalVariable(name: "array" +!CHECK-SAME: arg: 2 +!CHECK-SAME: type: [[TYPE:![0-9]+]] +!CHECK: [[TYPE]] = !DICompositeType(tag: DW_TAG_array_type, +!CHECK-SAME: dataLocation: [[DLOC]], associated: [[ASSOCIATED]] + +subroutine callee (array) + integer, pointer :: array(:, :) + integer :: local = 4 + + do i=LBOUND (array, 2), UBOUND (array, 2), 1 + do j=LBOUND (array, 1), UBOUND (array, 1), 1 + write(*, fmt="(i4)", advance="no") array (j, i) + end do + print *, "" + end do + + local = local / 2 + print *, "local = ", local +end subroutine callee + +program caller + + interface + subroutine callee (array) + integer, pointer :: array(:, :) + end subroutine callee + end interface + + integer, pointer :: caller_arr(:, :) + integer, target :: tgt_arr(10,10) + tgt_arr = 99 + tgt_arr(2,2) = 88 + + caller_arr => tgt_arr + call callee (caller_arr) + + print *, "" +end program caller diff --git a/test/debug_info/pointer_array_openmp.f90 b/test/debug_info/pointer_array_openmp.f90 new file mode 100644 index 0000000000..09c976c8e9 --- /dev/null +++ b/test/debug_info/pointer_array_openmp.f90 @@ -0,0 +1,30 @@ +!RUN: %flang -g -fopenmp -S -emit-llvm %s -o - | FileCheck %s + +!CHECK: define internal void @main_sub +!CHECK: define internal void @__nv_main_sub_PARALLEL_F1L +!CHECK: call void @llvm.dbg.declare(metadata double** %"res$p +!CHECK-NEXT: call void @llvm.dbg.declare(metadata double** %"res$p +!CHECK-NEXT: call void @llvm.dbg.declare(metadata [16 x i64]* %"res$sd + +program main + type :: dtype + integer(4) :: fdim + real(8), pointer :: fld_ptr(:) + end type dtype + type(dtype) :: dvar + allocate(dvar%fld_ptr(100)) + call sub(dvar) + deallocate(dvar%fld_ptr) + +contains + + subroutine sub(arg) + type(dtype),intent(inout) :: arg + integer:: count ! indices + real(8), pointer :: res(:) +!$OMP PARALLEL DO PRIVATE (COUNT, RES) + do count=1, 100 + res => arg%fld_ptr(1:10) + end do + end subroutine sub +end program main diff --git a/test/debug_info/procedure_pointer.f90 b/test/debug_info/procedure_pointer.f90 new file mode 100644 index 0000000000..f4a64d5b6b --- /dev/null +++ b/test/debug_info/procedure_pointer.f90 @@ -0,0 +1,60 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + +!CHECK: !DIGlobalVariable(name: "gsubptr" +!CHECK-SAME: type: [[SPTRTYPE:![0-9]+]] +!CHECK: !DIGlobalVariable(name: "gfunptr" +!CHECK-SAME: type: [[FPTRTYPE:![0-9]+]] +!CHECK: [[FPTRTYPE]] = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: [[FUNTYPE:![0-9]+]] +!CHECK: [[FUNTYPE]] = !DISubroutineType(types: [[FPARLIST:![0-9]+]]) +!CHECK: [[FPARLIST]] = !{[[INTTYPE:![0-9]+]], [[INTTYPE]], [[REALTYPE:![0-9]+]]} +!CHECK: [[INTTYPE]] = !DIBasicType(name: "integer" +!CHECK: [[REALTYPE]] = !DIBasicType(name: "real" +!CHECK: [[SPTRTYPE]] = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: [[SUBTYPE:![0-9]+]] +!CHECK: [[SUBTYPE]] = !DISubroutineType(types: [[SPARLIST:![0-9]+]]) +!CHECK: [[SPARLIST]] = !{null, [[REALTYPE]]} +!CHECK: !DILocalVariable(name: "lsubptr" +!CHECK-SAME: type: [[SPTRTYPE]] +!CHECK: !DILocalVariable(name: "lfunptr" +!CHECK-SAME: type: [[FPTRTYPE]] + +program test + + interface + integer function fun (farg1, farg2) + integer :: farg1 + real :: farg2 + end function fun + subroutine sub (sarg) + real :: sarg + end subroutine + end interface + + procedure(fun), pointer:: gfunptr => NULL() + procedure(fun), pointer:: lfunptr + procedure(sub), pointer:: gsubptr => NULL() + procedure(sub), pointer:: lsubptr + + gfunptr => fun + lfunptr => fun + print *, gfunptr (3, 2.5) + print *, lfunptr (3, 2.5) + + gsubptr => sub + lsubptr => sub + call gsubptr (2.5) + call lsubptr (2.5) + +end program test + +subroutine sub (a) + real :: a, res + res = 2.1 * a + print *, res +end subroutine + +real function fun (x, y) + implicit none + integer :: x + real :: y + fun = x + y + 1 +end function fun diff --git a/test/debug_info/procptr_ptrarg.f90 b/test/debug_info/procptr_ptrarg.f90 new file mode 100644 index 0000000000..b875809312 --- /dev/null +++ b/test/debug_info/procptr_ptrarg.f90 @@ -0,0 +1,25 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + +!CHECK: !DIDerivedType(tag: DW_TAG_member, name: "proc1" +!CHECK-SAME: baseType: [[SPTRTYPE:![0-9]+]] +!CHECK: [[SPTRTYPE]] = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: [[SUBTYPE:![0-9]+]] +!CHECK: [[SUBTYPE]] = !DISubroutineType(types: [[ARGLIST:![0-9]+]] +!CHECK: [[ARGLIST]] = !{null, [[ARG1:![0-9]+]] +!CHECK: [[ARG1]] = !DICompositeType(tag: DW_TAG_array_type +!CHECK-SAME: dataLocation: +!CHECK-SAME: associated: + +program main + interface + subroutine sub1(arg11) + integer, pointer :: arg11(:) + end subroutine + end interface + type type1 + procedure(sub1), pointer, nopass :: proc1 + end type + type type2 + type(type1) :: mem1 + end type type2 + type(type2) :: arg1 +end program main diff --git a/test/debug_info/prolog.f90 b/test/debug_info/prolog.f90 new file mode 100644 index 0000000000..bd98866f8e --- /dev/null +++ b/test/debug_info/prolog.f90 @@ -0,0 +1,37 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + +! check non debug instructions should not have debug location +!CHECK: define void @show_ +!CHECK: call void @llvm.dbg.declare +!CHECK-SAME: , !dbg {{![0-9]+}} +!CHECK-NOT: bitcast i64* %"array$sd" to i8*, !dbg +!CHECK: store i64 {{%[0-9]+}}, i64* %z_b_3_{{[0-9]+}}, align 8 +!CHECK: br label +!CHECK: ret void, !dbg {{![0-9]+}} +subroutine show (message, array) + character (len=*) :: message + integer :: array(:) + + print *, message + print *, array + +end subroutine show + +!CHECK: define void @MAIN_ +!CHECK-NOT: bitcast void (...)* @fort_init to void (i8*, ...)*, !dbg {{![0-9]+}} +!CHECK: call void @llvm.dbg.declare +!CHECK-SAME: , !dbg {{![0-9]+}} +!CHECK: ret void, !dbg +program prolog + + interface + subroutine show (message, array) + character (len=*) :: message + integer :: array(:) + end subroutine show + end interface + + integer :: array(10) = (/1,2,3,4,5,6,7,8,9,10/) + + call show ("array", array) +end program prolog diff --git a/test/debug_info/ptr_arr_member.f90 b/test/debug_info/ptr_arr_member.f90 new file mode 100644 index 0000000000..6a7a696f0e --- /dev/null +++ b/test/debug_info/ptr_arr_member.f90 @@ -0,0 +1,43 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + + +!CHECK: !DICompositeType(tag: DW_TAG_structure_type, name: "dtype", file: {{![0-9]+}}, size: {{[0-9]+}}, align: {{[0-9]+}}, elements: [[MEMS:![0-9]+]]) +!CHECK: [[MEMS]] = !{[[MEM1:![0-9]+]], [[MEM2:![0-9]+]], [[MEM3:![0-9]+]]} +!CHECK: [[MEM1]] = !DIDerivedType(tag: DW_TAG_member, name: "arrptr1", scope: {{![0-9]+}}, file: {{![0-9]+}}, baseType: [[TYPE1:![0-9]+]] +!CHECK: [[TYPE1]] = !DICompositeType(tag: DW_TAG_array_type, baseType: {{![0-9]+}}, size: 32, align: 32, elements: [[ELEM1:![0-9]+]], dataLocation: !DIExpression(DW_OP_push_object_address, DW_OP_deref), associated: !DIExpression(DW_OP_push_object_address, DW_OP_deref)) +!CHECK: [[ELEM1]] = !{[[ELEM11:![0-9]+]], [[ELEM12:![0-9]+]]} +!CHECK: [[ELEM11]] = !DISubrange(lowerBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 96, DW_OP_deref), upperBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 136, DW_OP_deref), stride: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 128, DW_OP_deref, DW_OP_push_object_address, DW_OP_plus_uconst, 40, DW_OP_deref, DW_OP_mul)) +!CHECK: [[ELEM12]] = !DISubrange(lowerBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 144, DW_OP_deref), upperBound: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 184, DW_OP_deref), stride: !DIExpression(DW_OP_push_object_address, DW_OP_plus_uconst, 176, DW_OP_deref, DW_OP_push_object_address, DW_OP_plus_uconst, 40, DW_OP_deref, DW_OP_mul)) +!CHECK: [[MEM2]] = !DIDerivedType(tag: DW_TAG_member, name: "arrptr2", scope: {{![0-9]+}}, file: {{![0-9]+}}, baseType: [[TYPE1:![0-9]+]] +!CHECK: [[MEM3]] = !DIDerivedType(tag: DW_TAG_member, name: "arralc", scope: {{![0-9]+}}, file: {{![0-9]+}}, baseType: [[TYPE2:![0-9]+]] +!CHECK: [[TYPE2]] = !DICompositeType(tag: DW_TAG_array_type, baseType: {{![0-9]+}}, size: 32, align: 32, elements: [[ELEM1:![0-9]+]], dataLocation: !DIExpression(DW_OP_push_object_address, DW_OP_deref), allocated: !DIExpression(DW_OP_push_object_address, DW_OP_deref)) + +program main + + type dtype + integer, pointer :: arrptr1(:,:) + integer, pointer :: arrptr2(:,:) + integer, allocatable :: arralc(:,:) + end type dtype + type(dtype) :: dvar1 + type(dtype), pointer :: dvar2 + + allocate (dvar1%arrptr1 (5,5)) + + dvar1%arrptr1 (1,1)= 9 + dvar1%arrptr1 (2,3)= 8 + print *, dvar1%arrptr1 + + allocate (dvar1%arralc (3,2)) + dvar1%arralc (1,1)= 29 + dvar1%arralc (3,2)= 28 + print *, dvar1%arralc + + allocate (dvar2) + allocate (dvar2%arrptr2 (3,4)) + dvar2%arrptr2 (1,1)= 19 + dvar2%arrptr2 (2,1)= 18 + dvar2%arrptr2 (2,3)= 17 + print *, dvar2%arrptr2 + +end program main diff --git a/test/debug_info/redundant-lexicalblock.f90 b/test/debug_info/redundant-lexicalblock.f90 new file mode 100644 index 0000000000..bcda29c1fd --- /dev/null +++ b/test/debug_info/redundant-lexicalblock.f90 @@ -0,0 +1,23 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + +!Ensure that there is no redundant LexicalBlock created with scope +!pointing to Subprogram and Local variable is pointing to Subprogram scope. +!CHECK: [[SCOPE_NODE:[0-9]+]] = distinct !DISubprogram(name: "sub", {{.*}}, line: [[LINE_NODE:[0-9]+]] +!CHECK: !DILocalVariable(name: "foo_arg", scope: ![[SCOPE_NODE]], file: !3, line: [[LINE_NODE]], type: !8) +!CHECK-NOT: !DILexicalBlock(scope: ![[SCOPE_NODE]], {{.*}}, line: [[LINE_NODE]] + +!Ensure that there is a LexicalBlock created for the BLOCK statement and +!the local variable `foo_block` has correct scope information i.e +!pointing to LexicalBlock. +!CHECK-DAG: !DILocalVariable(name: "foo_block", scope: ![[BLOCK_NODE:[0-9]+]] +!CHECK-DAG: ![[BLOCK_NODE]] = !DILexicalBlock(scope: ![[SCOPE_NODE]], {{.*}}, line: 19 + +SUBROUTINE sub(foo_arg) + integer,value :: foo_arg + integer :: foo_local + foo_local = arg_foo + BLOCK !line number: 19 + integer :: foo_block + foo_block = 4 + END BLOCK +END SUBROUTINE diff --git a/test/debug_info/redundant_inst.f90 b/test/debug_info/redundant_inst.f90 new file mode 100644 index 0000000000..dd275aa9b1 --- /dev/null +++ b/test/debug_info/redundant_inst.f90 @@ -0,0 +1,19 @@ +!RUN: %flang %s -g -S -emit-llvm -o - | FileCheck %s --check-prefix=STORE +!RUN: %flang %s -g -o - | llvm-dwarfdump --debug-line - | FileCheck %s --check-prefix=LINETABLE + +!Check that `store` instruction is getting emitted for the second assignment. +!STORE: store i32 4, i32* %[[VAR_A:.*]], align 4 +!STORE: %[[TEMP:.*]] = load i32, i32* %[[VAR_A]], align 4 +!STORE: store i32 %[[TEMP]], i32* %[[VAR_A]], align 4 + +!Check the line table entry of the second assignment. +!LINETABLE: Address Line Column File ISA Discriminator Flags +!LINETABLE: 0x{{.*}} 17 1 1 0 0 is_stmt + + +program main + integer :: a + a = 4 + a = a !line no. 17 + print*, a +end diff --git a/test/debug_info/result_var.f90 b/test/debug_info/result_var.f90 new file mode 100644 index 0000000000..ad555855a0 --- /dev/null +++ b/test/debug_info/result_var.f90 @@ -0,0 +1,10 @@ +!RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s + +!CHECK: call void @llvm.dbg.declare(metadata i32* %rvar_{{[0-9]+}}, metadata [[RESULT:![0-9]+]], metadata !DIExpression()) +!CHECK: [[RESULT]] = !DILocalVariable(name: "rvar" + +function func(arg) result(rvar) + integer, intent(in) :: arg ! input + integer :: rvar ! output + rvar = arg + 2 +end function func diff --git a/test/debug_info/scalar_allocatable.f90 b/test/debug_info/scalar_allocatable.f90 new file mode 100644 index 0000000000..5e94a20e88 --- /dev/null +++ b/test/debug_info/scalar_allocatable.f90 @@ -0,0 +1,16 @@ +!RUN: %flang %s -g -S -emit-llvm -o - | FileCheck %s + +!Ensure that for an allocatable variable, we're taking the type of +!allocatable variable as DW_TAG_pointer_type. +!CHECK: call void @llvm.dbg.declare(metadata double** %{{.*}}, metadata ![[DILocalVariable:[0-9]+]], metadata !DIExpression()) +!CHECK: ![[DILocalVariable]] = !DILocalVariable(name: "alcvar" +!CHECK-SAME: type: ![[PTRTYPE:[0-9]+]] +!CHECK: ![[PTRTYPE]] = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: ![[TYPE:[0-9]+]] +!CHECK: ![[TYPE]] = !DIBasicType(name: "double precision",{{.*}} + +program main + real(kind=8), allocatable :: alcvar + allocate(alcvar) + alcvar = 7.7 + print *, alcvar +end program main diff --git a/test/directives/dir_forceinline.f90 b/test/directives/dir_forceinline.f90 new file mode 100644 index 0000000000..bee37d82e5 --- /dev/null +++ b/test/directives/dir_forceinline.f90 @@ -0,0 +1,21 @@ +!! check for pragma support for forced inlining of functions +!RUN: %flang -S -emit-llvm %s -o - | FileCheck %s +!RUN: %flang -O2 -S -emit-llvm %s -o - | FileCheck %s +!RUN: %flang -O3 -S -emit-llvm %s -o - | FileCheck %s + +!CHECK: define void @func_forceinline_(){{.*}} #0 {{.*$}} +!CHECK-NOT: call void @func_forceinline_(), {{.*$}} +!CHECK: attributes #0 = { alwaysinline {{.*$}} + +!DIR$ FORCEINLINE +SUBROUTINE func_forceinline + INTEGER :: i + do i = 0, 5 + WRITE(*, *) "Hello World" + end do +END SUBROUTINE func_forceinline + +PROGRAM test_inline + IMPLICIT NONE + call func_forceinline +END PROGRAM test_inline diff --git a/test/directives/dir_ivdep.f90 b/test/directives/dir_ivdep.f90 new file mode 100644 index 0000000000..8ca390f881 --- /dev/null +++ b/test/directives/dir_ivdep.f90 @@ -0,0 +1,16 @@ +!! check for pragma support for IVDEP (!dir$ ivdep) +!RUN: %flang -S -Menable-vectorize-pragmas=true -emit-llvm %s -o - | FileCheck %s +!CHECK: define void @sumivdep_{{.*$}} +!CHECK: {{.*}}"llvm.loop.vectorize.enable", i1 true{{.*}} +!CHECK: {{.*}}"llvm.loop.vectorize.ivdep.enable", i1 true{{.*}} + +SUBROUTINE sumivdep(myarr1,myarr2,ub) + INTEGER, POINTER :: myarr1(:) + INTEGER, POINTER :: myarr2(:) + INTEGER :: ub + + !DIR$ IVDEP + DO i=1,ub + myarr1(i) = myarr1(i)+myarr2(i) + END DO +END SUBROUTINE \ No newline at end of file diff --git a/test/directives/dir_noinline.f90 b/test/directives/dir_noinline.f90 new file mode 100644 index 0000000000..79630c67e5 --- /dev/null +++ b/test/directives/dir_noinline.f90 @@ -0,0 +1,21 @@ +!! check for pragma support for no inlining of functions +!RUN: %flang -S -emit-llvm %s -o - | FileCheck %s +!RUN: %flang -O2 -S -emit-llvm %s -o - | FileCheck %s +!RUN: %flang -O3 -S -emit-llvm %s -o - | FileCheck %s + +!CHECK: define void @func_noinline_(){{.*}} #0 {{.*$}} +!CHECK: call void @func_noinline_(), {{.*$}} +!CHECK: attributes #{{[0-9]*}} = { noinline {{.*$}} + +!DIR$ NOINLINE +SUBROUTINE func_noinline + INTEGER :: i + do i = 0, 5 + WRITE(*, *) "Hello World" + end do +END SUBROUTINE func_noinline + +PROGRAM test_inline + IMPLICIT NONE + call func_noinline +END PROGRAM test_inline diff --git a/test/directives/dir_nounroll.f90 b/test/directives/dir_nounroll.f90 new file mode 100644 index 0000000000..b0ca46c3ed --- /dev/null +++ b/test/directives/dir_nounroll.f90 @@ -0,0 +1,33 @@ +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +! Check that the NOUNROLL directive generates the correct metadata. +! +! RUN: %flang -S -emit-llvm %s -o - | FileCheck %s --check-prefix=CHECK +! +! CHECK: [[LOOP:L.LB[0-9]_[0-9]+]]:{{[' ',\t]+}}; preds = %[[LOOP]], %L.LB +! CHECK: store float +! CHECK-NOT: store float +! CHECK: br i1 {{.*}}, label %[[LOOP]], label %L.LB +! CHECK-SAME: !llvm.loop +! CHECK: !"llvm.loop.unroll.disable" + +! Check that "-Hx,59,2" disables the NOUNROLL directive. +! +! RUN: %flang -Hx,59,2 -S -emit-llvm %s -o - \ +! RUN: | FileCheck %s --check-prefix=CHECK-NODIRECTIVE +! +! CHECK-NODIRECTIVE-NOT: !llvm.loop +! CHECK-NODIRECTIVE-NOT: !"llvm.loop.unroll.disable" + +program tz + integer :: i + real :: acc(100) + integer :: sz + !dir$ nounroll + do i = 1, sz + acc(i) = i * 2.0 + end do + print *, acc(100) +end program diff --git a/test/directives/dir_nounroll_opti02.f90 b/test/directives/dir_nounroll_opti02.f90 new file mode 100644 index 0000000000..9d256f9d27 --- /dev/null +++ b/test/directives/dir_nounroll_opti02.f90 @@ -0,0 +1,30 @@ +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +! Check that Flang at -O0 does not unroll the loop, and does not generate any +! loop unrolling metadata. +! +! RUN: %flang -O0 -S -emit-llvm %s -o - | FileCheck %s --check-prefix=CHECK-O0 +! +! CHECK-O0: [[LOOP:L.LB[0-9]_[0-9]+]]:{{[ \t]+}}; preds = %[[LOOP]], %L.LB +! CHECK-O0: store float +! CHECK-O0-NOT: store float +! CHECK-O0: br i1 {{.*}}, label %[[LOOP]], label %L.LB +! CHECK-O0-NOT: !llvm.loop !{{[0-9]+}} + +! Check that LLVM vectorizes the loop automatically at -O2. +! +! RUN: %flang -O2 -S -emit-llvm %s -o - | FileCheck %s -check-prefix=CHECK-O2 +! +! CHECK-O2: vector.body:{{[ \t]+}}; preds = %vector.body, %L. +! CHECK-O2: br i1 {{.*}}, label %vector.body, !llvm.loop + +program tz + integer :: i + real ::acc(10000) + do i = 1, 10000 + acc(i) = i * 2.0 + end do + print *, acc(1000) +end program diff --git a/test/directives/dir_novector.f90 b/test/directives/dir_novector.f90 new file mode 100644 index 0000000000..409f643fd9 --- /dev/null +++ b/test/directives/dir_novector.f90 @@ -0,0 +1,17 @@ +! RUN: %flang -S -emit-llvm -Menable-vectorize-pragmas=true -O2 %s -o - | FileCheck %s + +subroutine add(arr1,arr2,arr3,N) + integer :: i,N + integer :: arr1(N) + integer :: arr2(N) + integer :: arr3(N) + + !dir$ novector + do i = 1, N + arr3(i) = arr1(i) - arr2(i) + end do +end subroutine +! CHECK: {{.*}}"llvm.loop.vectorize.width", i1 true{{.*}} +! CHECK-NOT: load <{{.*}} x i32> +! CHECK-NOT: sub {{.*}} <{{.*}} x i32> +! CHECK-NOT: store <{{.*}} x i32> diff --git a/test/directives/dir_simd.f90 b/test/directives/dir_simd.f90 new file mode 100644 index 0000000000..40d572aef3 --- /dev/null +++ b/test/directives/dir_simd.f90 @@ -0,0 +1,35 @@ +!! check for pragma support for (no)simd (!dir$ simd) +!RUN: %flang -S -Menable-vectorize-pragmas=true -O2 -emit-llvm %s -o - | FileCheck %s +!CHECK: define void @sumsimd_{{.*$}} +!CHECK: {{.*}}!llvm.access.group{{.*}} +!CHECK: vector.ph:{{.*}} +!CHECK: {{.*}}shufflevector{{.*}} +!CHECK: vector.body:{{.*}} +!CHECK: {{.*}}add <2 x i64>{{.*}} +!CHECK: define void @sumnosimd_{{.*$}} +!CHECK: {{.*}}add i64{{.*}} +!CHECK: {{.*}}"llvm.loop.vectorize.enable", i1 true{{.*}} +!CHECK: {{.*}}"llvm.loop.parallel_accesses"{{.*}} +!CHECK: {{.*}}"llvm.loop.isvectorized", i32 1{{.*}} + +SUBROUTINE sumsimd(myarr1,myarr2,ub) + INTEGER, POINTER :: myarr1(:) + INTEGER, POINTER :: myarr2(:) + INTEGER :: ub + + !DIR$ SIMD + DO i=1,ub + myarr1(i) = myarr1(i)+myarr2(i) + END DO +END SUBROUTINE + +SUBROUTINE sumnosimd(myarr1,myarr2,ub) + INTEGER, POINTER :: myarr1(:) + INTEGER, POINTER :: myarr2(:) + INTEGER :: ub + + !DIR$ NOSIMD + DO i=1,ub + myarr1(i) = myarr1(i)+myarr2(i) + END DO +END SUBROUTINE \ No newline at end of file diff --git a/test/directives/dir_unroll.f90 b/test/directives/dir_unroll.f90 new file mode 100644 index 0000000000..e653daba34 --- /dev/null +++ b/test/directives/dir_unroll.f90 @@ -0,0 +1,94 @@ +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +! Check that the UNROLL directive generates correct LLVM IR metadata at -O0. +! Each subroutine should have distinct metadata, particularly subroutines with +! different unroll factors specified by the user. +! +! RUN: %flang -O0 -S -emit-llvm %s -o - \ +! RUN: | FileCheck %s --check-prefixes=CHECK,CHECK-O0 + +! Check that LLVM unrolls the first loop fully at -O1, unrolls the other two +! loops the correct number of times, and disables further unrolling on them. +! +! RUN: %flang -O1 -S -emit-llvm %s -o - \ +! RUN: | FileCheck %s --check-prefixes=CHECK,CHECK-O1 + +! Check that "-Hx,59,2" disables both kinds of UNROLL directives. +! +! RUN: %flang -Hx,59,2 -S -emit-llvm %s -o - \ +! RUN: | FileCheck %s --check-prefixes=CHECK,CHECK-DISABLED + +subroutine func1(a, b) + ! CHECK-LABEL: define void @func1_ + integer :: m = 10 + integer :: i, a(m), b(m) + + !dir$ unroll + do i = 1, m + b(i) = a(i) + 1 + end do + ! CHECK-O0: [[BB1:L.LB[0-9]_[0-9]+]]:{{[ \t]+}}; preds = %[[BB1]], + ! CHECK-O0: br i1 {{.*}}, label %[[BB1]] + ! CHECK-O0-SAME: !llvm.loop [[MD_LOOP1:![0-9]+]] + ! CHECK-O1-COUNT-10: store i32 + ! CHECK-O1-NOT: store i32 + ! CHECK-O1-NOT: br i1 {{.*}}, label %{{.*}} + ! CHECK-O1-NOT: !llvm.loop !{{[0-9]+}} + ! CHECK-O1: ret void + ! CHECK-DISABLED: [[BB1:L.LB[0-9]_[0-9]+]]:{{[ \t]+}}; preds = %[[BB1]], + ! CHECK-DISABLED: br i1 {{.*}}, label %[[BB1]] + ! CHECK-DISABLED-NOT: !llvm.loop !{{[0-9]+}} +end subroutine func1 + +subroutine func2(m, a, b) + ! CHECK-LABEL: define void @func2_ + integer :: i, m, a(m), b(m) + + !dir$ unroll(4) + do i = 1, m + b(i) = a(i) + 1 + end do + ! CHECK: [[BB2:L.LB[0-9]_[0-9]+]]:{{[ \t]+}}; preds = %[[BB2]], + ! CHECK-O1-COUNT-4: store i32 + ! CHECK-O1-NOT: store i32 + ! CHECK: br i1 {{.*}}, label %[[BB2]] + ! CHECK-O0-SAME: !llvm.loop [[MD_LOOP2:![0-9]+]] + ! CHECK-O1-SAME: !llvm.loop [[MD_LOOP2:![0-9]+]] + ! CHECK-DISABLED-NOT: !llvm.loop !{{[0-9]+}} +end subroutine func2 + +subroutine func3(m, a, b) + ! CHECK-LABEL: define void @func3_ + integer :: i, m, a(m), b(m) + + ! Use an odd factor to make sure it's picked up. + !dir$ unroll = 7 + do i = 1, m + b(i) = a(i) + 1 + end do + ! CHECK: [[BB3:L.LB[0-9]_[0-9]+]]:{{[ \t]+}}; preds = %[[BB3]], + ! CHECK-O1-COUNT-7: store i32 + ! CHECK-O1-NOT: store i32 + ! CHECK: br i1 {{.*}}, label %[[BB3]] + ! CHECK-O0-SAME: !llvm.loop [[MD_LOOP3:![0-9]+]] + ! CHECK-O1-SAME: !llvm.loop [[MD_LOOP3:![0-9]+]] + ! CHECK-DISABLED-NOT: !llvm.loop !{{[0-9]+}} +end subroutine func3 + +! CHECK-O0: [[MD_LOOP1]] = distinct !{[[MD_LOOP1]], [[MD_ENABLE:![0-9]+]]} +! CHECK-O0: [[MD_ENABLE]] = !{!"llvm.loop.unroll.enable"} +! CHECK-O0: [[MD_COUNT1:![0-9]+]] = !{!"llvm.loop.unroll.count", i32 4} +! CHECK-O0: [[MD_LOOP2]] = distinct !{[[MD_LOOP2]], [[MD_COUNT1]]} +! CHECK-O0: [[MD_COUNT2:![0-9]+]] = !{!"llvm.loop.unroll.count", i32 7} +! CHECK-O0: [[MD_LOOP3]] = distinct !{[[MD_LOOP3]], [[MD_COUNT2]]} + +! CHECK-O1-NOT: !"llvm.loop.unroll.enable" +! CHECK-O1: [[MD_LOOP2]] = distinct !{[[MD_LOOP2]], [[MD_DISABLE:![0-9]+]]} +! CHECK-O1: [[MD_DISABLE]] = !{!"llvm.loop.unroll.disable"} +! CHECK-O1: [[MD_LOOP3]] = distinct !{[[MD_LOOP3]], [[MD_DISABLE]]} + +! CHECK-DISABLED-NOT: !"llvm.loop.unroll.enable" +! CHECK-DISABLED-NOT: !"llvm.loop.unroll.count" +! CHECK-DISABLED-NOT: !"llvm.loop.unroll.disable" diff --git a/test/directives/dir_unroll_override.f90 b/test/directives/dir_unroll_override.f90 new file mode 100644 index 0000000000..9baf206271 --- /dev/null +++ b/test/directives/dir_unroll_override.f90 @@ -0,0 +1,62 @@ +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +! When multiple UNROLL directives are specified for the same loop, check +! that the last one overrides previous ones. +! +! RUN: %flang -S -emit-llvm %s -o - | FileCheck %s + +subroutine func1(m, a, b) + ! CHECK-LABEL: define void @func1_ + integer :: i, m, a(m), b(m) + + !dir$ nounroll + !dir$ unroll + !dir$ unroll = 10 + do i = 1, m + b(i) = a(i) + 1 + end do + ! CHECK: [[BB1:L.LB[0-9]_[0-9]+]]:{{[ \t]+}}; preds = %[[BB1]], + ! CHECK: br i1 {{.*}}, label %[[BB1]] + ! CHECK-SAME: !llvm.loop [[MD_LOOP1:![0-9]+]] +end subroutine func1 + +subroutine func2(m, a, b) + ! CHECK-LABEL: define void @func2_ + integer :: i, m, a(m), b(m) + + !dir$ unroll = 10 + !dir$ nounroll + !dir$ unroll + do i = 1, m + b(i) = a(i) + 1 + end do + ! CHECK: [[BB2:L.LB[0-9]_[0-9]+]]:{{[ \t]+}}; preds = %[[BB2]], + ! CHECK: br i1 {{.*}}, label %[[BB2]] + ! CHECK-SAME: !llvm.loop [[MD_LOOP2:![0-9]+]] +end subroutine func2 + +subroutine func3(m, a, b) + ! CHECK-LABEL: define void @func3_ + integer :: i, m, a(m), b(m) + + !dir$ unroll + !dir$ unroll = 10 + !dir$ nounroll + do i = 1, m + b(i) = a(i) + 1 + end do + ! CHECK: [[BB3:L.LB[0-9]_[0-9]+]]:{{[ \t]+}}; preds = %[[BB3]], + ! CHECK: br i1 {{.*}}, label %[[BB3]] + ! CHECK-SAME: !llvm.loop [[MD_LOOP3:![0-9]+]] +end subroutine func3 + +! Check that metadata are correct. +! +! CHECK: [[MD_COUNT:![0-9]+]] = !{!"llvm.loop.unroll.count", i32 10} +! CHECK: [[MD_LOOP1]] = distinct !{[[MD_LOOP1]], [[MD_COUNT]]} +! CHECK: [[MD_LOOP2]] = distinct !{[[MD_LOOP2]], [[MD_ENABLE:![0-9]+]]} +! CHECK: [[MD_ENABLE]] = !{!"llvm.loop.unroll.enable"} +! CHECK: [[MD_LOOP3]] = distinct !{[[MD_LOOP3]], [[MD_DISABLE:![0-9]+]]} +! CHECK: [[MD_DISABLE]] = !{!"llvm.loop.unroll.disable"} diff --git a/test/directives/dir_vector.f90 b/test/directives/dir_vector.f90 new file mode 100644 index 0000000000..e2288d9fe6 --- /dev/null +++ b/test/directives/dir_vector.f90 @@ -0,0 +1,19 @@ +! RUN: %flang -S -emit-llvm -Menable-vectorize-pragmas=true %s -o - | FileCheck %s -check-prefix=METADATA +! RUN: %flang -Hx,59,2 -S -emit-llvm -Menable-vectorize-pragmas=true %s -o - | FileCheck %s -check-prefix=IGNORE-DIRECTIVES +! RUN: %flang -S -emit-llvm -Menable-vectorize-pragmas=true -O2 %s -o - | FileCheck %s + +subroutine add(arr1,arr2,arr3,N) + integer :: i,N + integer :: arr1(N) + integer :: arr2(N) + integer :: arr3(N) + + !dir$ vector + do i = 1, N + arr3(i) = arr1(i) - arr2(i) + end do +end subroutine +! METADATA: !"llvm.loop.vectorize.enable", i1 true +! IGNORE-DIRECTIVES-NOT: !"llvm.loop.vectorize.enable", i1 true +! CHECK: load <[[VF:[0-9]+]] x i32> +! CHECK: store <[[VF]] x i32> \ No newline at end of file diff --git a/test/directives/dir_vector_always.f90 b/test/directives/dir_vector_always.f90 new file mode 100644 index 0000000000..1365494f51 --- /dev/null +++ b/test/directives/dir_vector_always.f90 @@ -0,0 +1,30 @@ +! RUN: %flang -O2 -S -emit-llvm -Menable-vectorize-pragmas=true %s -o - | FileCheck %s + +subroutine subscript(arr1,arr2,arr3,N) + integer :: arr1(N) + integer :: arr2(N) + integer :: arr3(N) + + !dir$ vector always + do i = 1, N + arr3(i) = arr1(arr2(i)) + end do +end subroutine + +subroutine add(arr1,arr2,arr3,N) + integer :: arr1(N) + integer :: arr2(N) + integer :: arr3(N) + + !dir$ vector always + do i = 1, N + arr3(i) = arr1(arr2(i)) + arr2(arr1(i)) + end do +end subroutine + +!CHECK: {{.*}}!llvm.access.group{{.*}} +!CHECK: vector.ph:{{.*}} +!CHECK: vector.body:{{.*}} +!CHECK: {{.*}}"llvm.loop.parallel_accesses"{{.*}} +!CHECK: {{.*}}"llvm.loop.isvectorized", i32 1{{.*}} +!CHECK: {{.*}}"llvm.loop.unroll.runtime.disable"{{.*}} diff --git a/test/directives/dir_vector_invalid_clause.f90 b/test/directives/dir_vector_invalid_clause.f90 new file mode 100644 index 0000000000..087047f27d --- /dev/null +++ b/test/directives/dir_vector_invalid_clause.f90 @@ -0,0 +1,14 @@ +! RUN: %flang -Menable-vectorize-pragmas=true -O2 -c %s 2>&1 | FileCheck %s -allow-empty --check-prefix=CHECK + +subroutine add(arr1,arr2,arr3,N) + integer :: i,N + integer :: arr1(N) + integer :: arr2(N) + integer :: arr3(N) + + !dir$ vector invalid + do i = 1, N + arr3(i) = arr1(i) - arr2(i) + end do +end subroutine +! CHECK: F90-W-0603-Unsupported clause specified for the vector directive. Only the always/never clauses are supported. \ No newline at end of file diff --git a/test/directives/dir_vector_never.f90 b/test/directives/dir_vector_never.f90 new file mode 100644 index 0000000000..822e6b1135 --- /dev/null +++ b/test/directives/dir_vector_never.f90 @@ -0,0 +1,17 @@ +! RUN: %flang -S -emit-llvm -Menable-vectorize-pragmas=true %s -o - | FileCheck %s --check-prefix=CHECK + +subroutine add(arr1,arr2,arr3,N) + integer :: i,N + integer :: arr1(N) + integer :: arr2(N) + integer :: arr3(N) + + !dir$ vector never + do i = 1, N + arr3(i) = arr1(i) - arr2(i) + end do +end subroutine +! CHECK: {{.*}}"llvm.loop.vectorize.width", i1 true{{.*}} +! CHECK-NOT: load <{{.*}} x i32> +! CHECK-NOT: sub {{.*}} <{{.*}} x i32> +! CHECK-NOT: store <{{.*}} x i32> \ No newline at end of file diff --git a/test/directives/lit.local.cfg b/test/directives/lit.local.cfg new file mode 100644 index 0000000000..f151333989 --- /dev/null +++ b/test/directives/lit.local.cfg @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# +# Directives test configuration + +config.suffixes = ['.f', '.FOR', '.for', '.f77', '.f90', '.f95', '.F', '.fpp', + '.FPP'] diff --git a/test/directives/mem_prefetch.f90 b/test/directives/mem_prefetch.f90 new file mode 100644 index 0000000000..53acb55f9c --- /dev/null +++ b/test/directives/mem_prefetch.f90 @@ -0,0 +1,23 @@ +! RUN: %flang -O1 -S -emit-llvm %s -o - | FileCheck %s --check-prefix=CHECK-PREFETCH +! RUN: %flang -O1 -S -emit-llvm -Hy,59,0x4 %s -o - | FileCheck %s --check-prefix=CHECK-NOPREFETCH + +subroutine prefetch_dir(a1, a2) + integer :: a1(4096) + integer :: a2(4096) + + do i = 128, (4096 - 128) + !$mem prefetch a1, a2(i + 256) + a1(i) = a2(i - 127) + a2(i + 127) + end do +end subroutine prefetch_dir + +!! Ensure that the offset generated for the prefetch of a2(i + 256) is correct. +! CHECK-PREFETCH: [[a1:%[0-9]+]] = bitcast i64* %a1 to i8* +! CHECK-PREFETCH: [[a2:%[0-9]+]] = bitcast i64* %a2 to i8* +! CHECK-PREFETCH: [[a2base:%[0-9]+]] = getelementptr i8, i8* [[a2]], i64 1020 +! CHECK-PREFETCH: call void @llvm.prefetch{{.*}}(i8* [[a1]], i32 0, i32 3, i32 1) +! CHECK-PREFETCH: [[i:%[0-9]+]] = shl nuw nsw i64 %indvars.iv, 2 +! CHECK-PREFETCH: [[a2elem:%[0-9]+]] = getelementptr i8, i8* [[a2base]], i64 [[i]] +! CHECK-PREFETCH: call void @llvm.prefetch{{.*}}(i8* [[a2elem]], i32 0, i32 3, i32 1) +! CHECK-PREFETCH: declare void @llvm.prefetch{{.*}} +! CHECK-NOPREFETCH-NOT: @llvm.prefetch diff --git a/test/directives/omp_simd.f90 b/test/directives/omp_simd.f90 new file mode 100644 index 0000000000..5b4ca7a8c2 --- /dev/null +++ b/test/directives/omp_simd.f90 @@ -0,0 +1,22 @@ +!! check for pragma support for (no)simd (!dir$ simd) +!RUN: %flang -fopenmp -S -Menable-vectorize-pragmas=true -O2 -emit-llvm %s -o - | FileCheck %s +!CHECK: define void @sumsimd_{{.*$}} +!CHECK: {{.*}}!llvm.access.group{{.*}} +!CHECK: vector.ph:{{.*}} +!CHECK: {{.*}}shufflevector{{.*}} +!CHECK: vector.body:{{.*}} +!CHECK: {{.*}}add <2 x i64>{{.*}} +!CHECK: {{.*}}"llvm.loop.parallel_accesses"{{.*}} +!CHECK: {{.*}}"llvm.loop.isvectorized", i32 1{{.*}} +!CHECK: {{.*}}"llvm.loop.unroll.runtime.disable"{{.*}} + +SUBROUTINE sumsimd(myarr1,myarr2,ub) + INTEGER, POINTER :: myarr1(:) + INTEGER, POINTER :: myarr2(:) + INTEGER :: ub + + !$OMP SIMD + DO i=1,ub + myarr1(i) = myarr1(i)+myarr2(i) + END DO +END SUBROUTINE \ No newline at end of file diff --git a/test/directives/omp_simd_collapse.f90 b/test/directives/omp_simd_collapse.f90 new file mode 100644 index 0000000000..da827077c7 --- /dev/null +++ b/test/directives/omp_simd_collapse.f90 @@ -0,0 +1,22 @@ +! XFAIL:* +! RUN: %flang -fopenmp -O2 -Menable-vectorize-pragmas=true -S -emit-llvm %s -o - | FileCheck %s +! RUN: %flang -fopenmp -S -emit-llvm -Menable-vectorize-pragmas=true %s -o - | FileCheck %s -check-prefix=METADATA +! RUN: %flang -fopenmp -O2 -Menable-vectorize-pragmas=true -c %s 2>&1 | FileCheck %s -check-prefix=WARNING + +subroutine sum(myarr1,myarr2,ub) + integer, pointer :: myarr1(:) + integer, pointer :: myarr2(:) + integer :: ub + + !$omp simd collapse(2) + do i=1,ub + myarr1(i) = myarr1(i)+myarr2(i) + end do +end subroutine + +! CHECK-NOT: {{.*}} add nsw <[[VF:[0-9]+]] x i32>{{.*}} +! METADATA-NOT: load {{.*}}, !llvm.mem.parallel_loop_access ![[TAG1:[0-9]+]] +! METADATA-NOT: store {{.*}}, !llvm.mem.parallel_loop_access ![[TAG1]] +! METADATA-NOT: ![[TAG2:[0-9]+]] = !{!"llvm.loop.vectorize.enable", i1 true} +! METADATA-NOT: ![[TAG1:[0-9]+]] = distinct !{![[TAG1]], ![[TAG2]]} +! WARNING: F90-W-0604-Unsupported clause specified for the omp simd directive diff --git a/test/f08_correct/Inputs/input_for_exec_cmdline.txt b/test/f08_correct/Inputs/input_for_exec_cmdline.txt new file mode 100644 index 0000000000..557db03de9 --- /dev/null +++ b/test/f08_correct/Inputs/input_for_exec_cmdline.txt @@ -0,0 +1 @@ +Hello World diff --git a/test/f08_correct/inc/assumedsize_array.mk b/test/f08_correct/inc/assumedsize_array.mk new file mode 100644 index 0000000000..a4e595f78c --- /dev/null +++ b/test/f08_correct/inc/assumedsize_array.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for assumed size array as parameter +# + +########## Make rule for test assumedsize_array ######## + + +assumedsize_array: .run + +assumedsize_array.$(OBJX): $(SRC)/assumedsize_array.f08 + -$(RM) assumedsize_array.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/assumedsize_array.f08 -o assumedsize_array.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) assumedsize_array.$(OBJX) check.$(OBJX) $(LIBS) -o assumedsize_array.$(EXESUFFIX) + + +assumedsize_array.run: assumedsize_array.$(OBJX) + @echo ------------------------------------ executing test assumedsize_array + assumedsize_array.$(EXESUFFIX) + +build: assumedsize_array.$(OBJX) + +verify: ; + +run: assumedsize_array.$(OBJX) + @echo ------------------------------------ executing test assumedsize_array + assumedsize_array.$(EXESUFFIX) + diff --git a/test/f08_correct/inc/bessel.mk b/test/f08_correct/inc/bessel.mk new file mode 100644 index 0000000000..aaf27e8f53 --- /dev/null +++ b/test/f08_correct/inc/bessel.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for bessel intrinsic. +# + +########## Make rule for test bessel ######## + + +bessel: .run + +bessel.$(OBJX): $(SRC)/bessel.f08 + -$(RM) bessel.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bessel.f08 -o bessel.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bessel.$(OBJX) check.$(OBJX) $(LIBS) -o bessel.$(EXESUFFIX) + + +bessel.run: bessel.$(OBJX) + @echo ------------------------------------ executing test bessel + bessel.$(EXESUFFIX) + +build: bessel.$(OBJX) + +verify: ; + +run: bessel.$(OBJX) + @echo ------------------------------------ executing test bessel + bessel.$(EXESUFFIX) + diff --git a/test/f08_correct/inc/bitcmp01.mk b/test/f08_correct/inc/bitcmp01.mk new file mode 100644 index 0000000000..d178403f10 --- /dev/null +++ b/test/f08_correct/inc/bitcmp01.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for Bit Sequence Comparsion intrinsics. +# + +########## Make rule for test bitcmp01 ######## + + +bitcmp01: bitcmp01.run + +bitcmp01.$(OBJX): $(SRC)/bitcmp01.f08 + -$(RM) bitcmp01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitcmp01.f08 -o bitcmp01.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitcmp01.$(OBJX) check.$(OBJX) $(LIBS) -o bitcmp01.$(EXESUFFIX) + + +bitcmp01.run: bitcmp01.$(OBJX) + @echo ------------------------------------ executing test bitcmp01 + bitcmp01.$(EXESUFFIX) + +build: bitcmp01.$(OBJX) + +verify: ; + +run: bitcmp01.$(OBJX) + @echo ------------------------------------ executing test bitcmp01 + bitcmp01.$(EXESUFFIX) diff --git a/test/f08_correct/inc/bitcmp02.mk b/test/f08_correct/inc/bitcmp02.mk new file mode 100644 index 0000000000..eb09b87e30 --- /dev/null +++ b/test/f08_correct/inc/bitcmp02.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for Bit Sequence Comparsion intrinsics. +# + +########## Make rule for test bitcmp02 ######## + + +bitcmp02: bitcmp02.run + +bitcmp02.$(OBJX): $(SRC)/bitcmp02.f08 + -$(RM) bitcmp02.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitcmp02.f08 -o bitcmp02.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitcmp02.$(OBJX) check.$(OBJX) $(LIBS) -o bitcmp02.$(EXESUFFIX) + + +bitcmp02.run: bitcmp02.$(OBJX) + @echo ------------------------------------ executing test bitcmp02 + bitcmp02.$(EXESUFFIX) + +build: bitcmp02.$(OBJX) + +verify: ; + +run: bitcmp02.$(OBJX) + @echo ------------------------------------ executing test bitcmp02 + bitcmp02.$(EXESUFFIX) diff --git a/test/f08_correct/inc/bitcmp03.mk b/test/f08_correct/inc/bitcmp03.mk new file mode 100644 index 0000000000..4aa9b117f4 --- /dev/null +++ b/test/f08_correct/inc/bitcmp03.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for Bit Sequence Comparsion intrinsics. +# + +########## Make rule for test bitcmp03 ######## + + +bitcmp03: bitcmp03.run + +bitcmp03.$(OBJX): $(SRC)/bitcmp03.f08 + -$(RM) bitcmp03.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitcmp03.f08 -o bitcmp03.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitcmp03.$(OBJX) check.$(OBJX) $(LIBS) -o bitcmp03.$(EXESUFFIX) + + +bitcmp03.run: bitcmp03.$(OBJX) + @echo ------------------------------------ executing test bitcmp03 + bitcmp03.$(EXESUFFIX) + +build: bitcmp03.$(OBJX) + +verify: ; + +run: bitcmp03.$(OBJX) + @echo ------------------------------------ executing test bitcmp03 + bitcmp03.$(EXESUFFIX) diff --git a/test/f08_correct/inc/bitint01.mk b/test/f08_correct/inc/bitint01.mk new file mode 100644 index 0000000000..45d4d89d54 --- /dev/null +++ b/test/f08_correct/inc/bitint01.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:37:39 IST 2020 +# + +########## Make rule for test bitint01 ######## + + +bitint01: bitint01.run + +bitint01.$(OBJX): $(SRC)/bitint01.f08 + -$(RM) bitint01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint01.f08 -o bitint01.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint01.$(OBJX) check.$(OBJX) $(LIBS) -o bitint01.$(EXESUFFIX) + + +bitint01.run: bitint01.$(OBJX) + @echo ------------------------------------ executing test bitint01 + bitint01.$(EXESUFFIX) + +build: bitint01.$(OBJX) + +verify: ; + +run: bitint01.$(OBJX) + @echo ------------------------------------ executing test bitint01 + -bitint01.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint02.mk b/test/f08_correct/inc/bitint02.mk new file mode 100644 index 0000000000..635dc0ce81 --- /dev/null +++ b/test/f08_correct/inc/bitint02.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:37:39 IST 2020 +# + +########## Make rule for test bitint02 ######## + + +bitint02: bitint02.run + +bitint02.$(OBJX): $(SRC)/bitint02.f08 + -$(RM) bitint02.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint02.f08 -o bitint02.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint02.$(OBJX) check.$(OBJX) $(LIBS) -o bitint02.$(EXESUFFIX) + + +bitint02.run: bitint02.$(OBJX) + @echo ------------------------------------ executing test bitint02 + bitint02.$(EXESUFFIX) + +build: bitint02.$(OBJX) + +verify: ; + +run: bitint02.$(OBJX) + @echo ------------------------------------ executing test bitint02 + -bitint02.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint03.mk b/test/f08_correct/inc/bitint03.mk new file mode 100644 index 0000000000..287bc7876f --- /dev/null +++ b/test/f08_correct/inc/bitint03.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:37:39 IST 2020 +# + +########## Make rule for test bitint03 ######## + + +bitint03: bitint03.run + +bitint03.$(OBJX): $(SRC)/bitint03.f08 + -$(RM) bitint03.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint03.f08 -o bitint03.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint03.$(OBJX) check.$(OBJX) $(LIBS) -o bitint03.$(EXESUFFIX) + + +bitint03.run: bitint03.$(OBJX) + @echo ------------------------------------ executing test bitint03 + bitint03.$(EXESUFFIX) + +build: bitint03.$(OBJX) + +verify: ; + +run: bitint03.$(OBJX) + @echo ------------------------------------ executing test bitint03 + -bitint03.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint04.mk b/test/f08_correct/inc/bitint04.mk new file mode 100644 index 0000000000..58c068e7cc --- /dev/null +++ b/test/f08_correct/inc/bitint04.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:37:39 IST 2020 +# + +########## Make rule for test bitint04 ######## + + +bitint04: bitint04.run + +bitint04.$(OBJX): $(SRC)/bitint04.f08 + -$(RM) bitint04.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint04.f08 -o bitint04.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint04.$(OBJX) check.$(OBJX) $(LIBS) -o bitint04.$(EXESUFFIX) + + +bitint04.run: bitint04.$(OBJX) + @echo ------------------------------------ executing test bitint04 + bitint04.$(EXESUFFIX) + +build: bitint04.$(OBJX) + +verify: ; + +run: bitint04.$(OBJX) + @echo ------------------------------------ executing test bitint04 + -bitint04.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint05.mk b/test/f08_correct/inc/bitint05.mk new file mode 100644 index 0000000000..76b898fa76 --- /dev/null +++ b/test/f08_correct/inc/bitint05.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:37:39 IST 2020 +# + +########## Make rule for test bitint05 ######## + + +bitint05: bitint05.run + +bitint05.$(OBJX): $(SRC)/bitint05.f08 + -$(RM) bitint05.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint05.f08 -o bitint05.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint05.$(OBJX) check.$(OBJX) $(LIBS) -o bitint05.$(EXESUFFIX) + + +bitint05.run: bitint05.$(OBJX) + @echo ------------------------------------ executing test bitint05 + bitint05.$(EXESUFFIX) + +build: bitint05.$(OBJX) + +verify: ; + +run: bitint05.$(OBJX) + @echo ------------------------------------ executing test bitint05 + -bitint05.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint06.mk b/test/f08_correct/inc/bitint06.mk new file mode 100644 index 0000000000..9def881467 --- /dev/null +++ b/test/f08_correct/inc/bitint06.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +########## Make rule for test bitint06 ######## + + +bitint06: bitint06.run + +bitint06.$(OBJX): $(SRC)/bitint06.f08 + -$(RM) bitint06.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint06.f08 -o bitint06.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint06.$(OBJX) check.$(OBJX) $(LIBS) -o bitint06.$(EXESUFFIX) + + +bitint06.run: bitint06.$(OBJX) + @echo ------------------------------------ executing test bitint06 + bitint06.$(EXESUFFIX) + +build: bitint06.$(OBJX) + +verify: ; + +run: bitint06.$(OBJX) + @echo ------------------------------------ executing test bitint06 + -bitint06.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint07.mk b/test/f08_correct/inc/bitint07.mk new file mode 100644 index 0000000000..d4ede3e3dd --- /dev/null +++ b/test/f08_correct/inc/bitint07.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +########## Make rule for test bitint07 ######## + + +bitint07: bitint07.run + +bitint07.$(OBJX): $(SRC)/bitint07.f08 + -$(RM) bitint07.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint07.f08 -o bitint07.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint07.$(OBJX) check.$(OBJX) $(LIBS) -o bitint07.$(EXESUFFIX) + + +bitint07.run: bitint07.$(OBJX) + @echo ------------------------------------ executing test bitint07 + bitint07.$(EXESUFFIX) + +build: bitint07.$(OBJX) + +verify: ; + +run: bitint07.$(OBJX) + @echo ------------------------------------ executing test bitint07 + -bitint07.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint08.mk b/test/f08_correct/inc/bitint08.mk new file mode 100644 index 0000000000..0df49d20cc --- /dev/null +++ b/test/f08_correct/inc/bitint08.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:37:39 IST 2020 +# + +########## Make rule for test bitint08 ######## + + +bitint08: bitint08.run + +bitint08.$(OBJX): $(SRC)/bitint08.f08 + -$(RM) bitint08.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint08.f08 -o bitint08.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint08.$(OBJX) check.$(OBJX) $(LIBS) -o bitint08.$(EXESUFFIX) + + +bitint08.run: bitint08.$(OBJX) + @echo ------------------------------------ executing test bitint08 + bitint08.$(EXESUFFIX) + +build: bitint08.$(OBJX) + +verify: ; + +run: bitint08.$(OBJX) + @echo ------------------------------------ executing test bitint08 + -bitint08.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint09.mk b/test/f08_correct/inc/bitint09.mk new file mode 100644 index 0000000000..6d78b40bb6 --- /dev/null +++ b/test/f08_correct/inc/bitint09.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:37:39 IST 2020 +# + +########## Make rule for test bitint09 ######## + + +bitint09: bitint09.run + +bitint09.$(OBJX): $(SRC)/bitint09.f08 + -$(RM) bitint09.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint09.f08 -o bitint09.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint09.$(OBJX) check.$(OBJX) $(LIBS) -o bitint09.$(EXESUFFIX) + + +bitint09.run: bitint09.$(OBJX) + @echo ------------------------------------ executing test bitint09 + bitint09.$(EXESUFFIX) + +build: bitint09.$(OBJX) + +verify: ; + +run: bitint09.$(OBJX) + @echo ------------------------------------ executing test bitint09 + -bitint09.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint10.mk b/test/f08_correct/inc/bitint10.mk new file mode 100644 index 0000000000..8e5714bc42 --- /dev/null +++ b/test/f08_correct/inc/bitint10.mk @@ -0,0 +1,38 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control +# +# Date of Modification: Sep 10 2019 +# +########## Make rule for test bitint10 ######## + +bitint10: bitint10.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +bitint10.$(OBJX): $(SRC)/bitint10.f08 + -$(RM) bitint10.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint10.f08 -o bitint10.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) bitint10.$(OBJX) check.$(OBJX) $(LIBS) -o bitint10.$(EXESUFFIX) ||: + +bitint10.run: passok.$(OBJX) + @echo ------------------------------------ executing test bitint10 + -passok.$(EXESUFFIX) ||: + +build: bitint10.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test bitint10 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint11.mk b/test/f08_correct/inc/bitint11.mk new file mode 100644 index 0000000000..f17299aaf1 --- /dev/null +++ b/test/f08_correct/inc/bitint11.mk @@ -0,0 +1,38 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control +# +# Date of Modification: Sep 10 2019 +# +########## Make rule for test bitint11 ######## + +bitint11: bitint11.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +bitint11.$(OBJX): $(SRC)/bitint11.f08 + -$(RM) bitint11.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint11.f08 -o bitint11.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) bitint11.$(OBJX) check.$(OBJX) $(LIBS) -o bitint11.$(EXESUFFIX) ||: + +bitint11.run: passok.$(OBJX) + @echo ------------------------------------ executing test bitint11 + -passok.$(EXESUFFIX) ||: + +build: bitint11.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test bitint11 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint12.mk b/test/f08_correct/inc/bitint12.mk new file mode 100644 index 0000000000..54e5d93bea --- /dev/null +++ b/test/f08_correct/inc/bitint12.mk @@ -0,0 +1,38 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control +# +# Date of Modification: Sep 10 2019 +# +########## Make rule for test bitint12 ######## + +bitint12: bitint12.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +bitint12.$(OBJX): $(SRC)/bitint12.f08 + -$(RM) bitint12.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint12.f08 -o bitint12.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) bitint12.$(OBJX) check.$(OBJX) $(LIBS) -o bitint12.$(EXESUFFIX) ||: + +bitint12.run: passok.$(OBJX) + @echo ------------------------------------ executing test bitint12 + -passok.$(EXESUFFIX) ||: + +build: bitint12.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test bitint12 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint13.mk b/test/f08_correct/inc/bitint13.mk new file mode 100644 index 0000000000..f2eed7c3b4 --- /dev/null +++ b/test/f08_correct/inc/bitint13.mk @@ -0,0 +1,38 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control +# +# Date of Modification: Sep 10 2019 +# +########## Make rule for test bitint13 ######## + +bitint13: bitint13.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +bitint13.$(OBJX): $(SRC)/bitint13.f08 + -$(RM) bitint13.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint13.f08 -o bitint13.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) bitint13.$(OBJX) check.$(OBJX) $(LIBS) -o bitint13.$(EXESUFFIX) ||: + +bitint13.run: passok.$(OBJX) + @echo ------------------------------------ executing test bitint13 + -passok.$(EXESUFFIX) ||: + +build: bitint13.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test bitint13 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint14.mk b/test/f08_correct/inc/bitint14.mk new file mode 100644 index 0000000000..709bd235c8 --- /dev/null +++ b/test/f08_correct/inc/bitint14.mk @@ -0,0 +1,38 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control +# +# Date of Modification: Sep 10 2019 +# +########## Make rule for test bitint14 ######## + +bitint14: bitint14.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +bitint14.$(OBJX): $(SRC)/bitint14.f08 + -$(RM) bitint14.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint14.f08 -o bitint14.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) bitint14.$(OBJX) check.$(OBJX) $(LIBS) -o bitint14.$(EXESUFFIX) ||: + +bitint14.run: passok.$(OBJX) + @echo ------------------------------------ executing test bitint14 + -passok.$(EXESUFFIX) ||: + +build: bitint14.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test bitint14 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint15.mk b/test/f08_correct/inc/bitint15.mk new file mode 100644 index 0000000000..def873084a --- /dev/null +++ b/test/f08_correct/inc/bitint15.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:37:39 IST 2020 +# + +########## Make rule for test bitint15 ######## + + +bitint15: bitint15.run + +bitint15.$(OBJX): $(SRC)/bitint15.f08 + -$(RM) bitint15.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint15.f08 -o bitint15.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint15.$(OBJX) check.$(OBJX) $(LIBS) -o bitint15.$(EXESUFFIX) + + +bitint15.run: bitint15.$(OBJX) + @echo ------------------------------------ executing test bitint15 + bitint15.$(EXESUFFIX) + +build: bitint15.$(OBJX) + +verify: ; + +run: bitint15.$(OBJX) + @echo ------------------------------------ executing test bitint15 + -bitint15.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint16.mk b/test/f08_correct/inc/bitint16.mk new file mode 100644 index 0000000000..2fd3a4f98a --- /dev/null +++ b/test/f08_correct/inc/bitint16.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Inreinsics that support bit operands +# +# Date of Modification: Mon Feb 17 14:37:39 IST 2020 +# + +########## Make rule for test bitint16 ######## + + +bitint16: bitint16.run + +bitint16.$(OBJX): $(SRC)/bitint16.f08 + -$(RM) bitint16.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint16.f08 -o bitint16.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint16.$(OBJX) check.$(OBJX) $(LIBS) -o bitint16.$(EXESUFFIX) + + +bitint16.run: bitint16.$(OBJX) + @echo ------------------------------------ executing test bitint16 + bitint16.$(EXESUFFIX) + +build: bitint16.$(OBJX) + +verify: ; + +run: bitint16.$(OBJX) + @echo ------------------------------------ executing test bitint16 + -bitint16.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint17.mk b/test/f08_correct/inc/bitint17.mk new file mode 100644 index 0000000000..cc759fc23a --- /dev/null +++ b/test/f08_correct/inc/bitint17.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics to support bit processing +# +# Date of Modification: Mon Feb 17 14:37:39 IST 2020 +# + +########## Make rule for test bitint17 ######## + + +bitint17: bitint17.run + +bitint17.$(OBJX): $(SRC)/bitint17.f08 + -$(RM) bitint17.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint17.f08 -o bitint17.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint17.$(OBJX) check.$(OBJX) $(LIBS) -o bitint17.$(EXESUFFIX) + + +bitint17.run: bitint17.$(OBJX) + @echo ------------------------------------ executing test bitint17 + bitint17.$(EXESUFFIX) + +build: bitint17.$(OBJX) + +verify: ; + +run: bitint17.$(OBJX) + @echo ------------------------------------ executing test bitint17 + -bitint17.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint18.mk b/test/f08_correct/inc/bitint18.mk new file mode 100644 index 0000000000..14cdb2f0a1 --- /dev/null +++ b/test/f08_correct/inc/bitint18.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that support bit processing +# +# Date of Modification: Mon Feb 17 14:37:39 IST 2020 +# + +########## Make rule for test bitint18 ######## + + +bitint18: bitint18.run + +bitint18.$(OBJX): $(SRC)/bitint18.f08 + -$(RM) bitint18.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint18.f08 -o bitint18.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint18.$(OBJX) check.$(OBJX) $(LIBS) -o bitint18.$(EXESUFFIX) + + +bitint18.run: bitint18.$(OBJX) + @echo ------------------------------------ executing test bitint18 + bitint18.$(EXESUFFIX) + +build: bitint18.$(OBJX) + +verify: ; + +run: bitint18.$(OBJX) + @echo ------------------------------------ executing test bitint18 + -bitint18.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint19.mk b/test/f08_correct/inc/bitint19.mk new file mode 100644 index 0000000000..2f3fc0f6e6 --- /dev/null +++ b/test/f08_correct/inc/bitint19.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit parameters +# +# Date of Modification: Mon Feb 17 14:37:39 IST 2020 +# + +########## Make rule for test bitint19 ######## + + +bitint19: bitint19.run + +bitint19.$(OBJX): $(SRC)/bitint19.f08 + -$(RM) bitint19.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint19.f08 -o bitint19.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint19.$(OBJX) check.$(OBJX) $(LIBS) -o bitint19.$(EXESUFFIX) + + +bitint19.run: bitint19.$(OBJX) + @echo ------------------------------------ executing test bitint19 + bitint19.$(EXESUFFIX) + +build: bitint19.$(OBJX) + +verify: ; + +run: bitint19.$(OBJX) + @echo ------------------------------------ executing test bitint19 + -bitint19.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint20.mk b/test/f08_correct/inc/bitint20.mk new file mode 100644 index 0000000000..e48bac44c2 --- /dev/null +++ b/test/f08_correct/inc/bitint20.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit parameters +# +# Date of Modification: Mon Feb 17 15:07:29 IST 2020 +# + +########## Make rule for test bitint20 ######## + + +bitint20: bitint20.run + +bitint20.$(OBJX): $(SRC)/bitint20.f08 + -$(RM) bitint20.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint20.f08 -o bitint20.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint20.$(OBJX) check.$(OBJX) $(LIBS) -o bitint20.$(EXESUFFIX) + + +bitint20.run: bitint20.$(OBJX) + @echo ------------------------------------ executing test bitint20 + bitint20.$(EXESUFFIX) + +build: bitint20.$(OBJX) + +verify: ; + +run: bitint20.$(OBJX) + @echo ------------------------------------ executing test bitint20 + -bitint20.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint21.mk b/test/f08_correct/inc/bitint21.mk new file mode 100644 index 0000000000..399de4afc5 --- /dev/null +++ b/test/f08_correct/inc/bitint21.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 15:07:29 IST 2020 +# + +########## Make rule for test bitint21 ######## + + +bitint21: bitint21.run + +bitint21.$(OBJX): $(SRC)/bitint21.f08 + -$(RM) bitint21.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint21.f08 -o bitint21.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint21.$(OBJX) check.$(OBJX) $(LIBS) -o bitint21.$(EXESUFFIX) + + +bitint21.run: bitint21.$(OBJX) + @echo ------------------------------------ executing test bitint21 + bitint21.$(EXESUFFIX) + +build: bitint21.$(OBJX) + +verify: ; + +run: bitint21.$(OBJX) + @echo ------------------------------------ executing test bitint21 + -bitint21.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint22.mk b/test/f08_correct/inc/bitint22.mk new file mode 100644 index 0000000000..cfd4a28622 --- /dev/null +++ b/test/f08_correct/inc/bitint22.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 15:07:29 IST 2020 +# + +########## Make rule for test bitint22 ######## + + +bitint22: bitint22.run + +bitint22.$(OBJX): $(SRC)/bitint22.f08 + -$(RM) bitint22.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint22.f08 -o bitint22.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint22.$(OBJX) check.$(OBJX) $(LIBS) -o bitint22.$(EXESUFFIX) + + +bitint22.run: bitint22.$(OBJX) + @echo ------------------------------------ executing test bitint22 + bitint22.$(EXESUFFIX) + +build: bitint22.$(OBJX) + +verify: ; + +run: bitint22.$(OBJX) + @echo ------------------------------------ executing test bitint22 + -bitint22.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint23.mk b/test/f08_correct/inc/bitint23.mk new file mode 100644 index 0000000000..d4c20d7308 --- /dev/null +++ b/test/f08_correct/inc/bitint23.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Thu Mar 19 10:54:19 IST 2020 +# + +########## Make rule for test bitint23 ######## + + +bitint23: bitint23.run + +bitint23.$(OBJX): $(SRC)/bitint23.f08 + -$(RM) bitint23.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint23.f08 -o bitint23.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint23.$(OBJX) check.$(OBJX) $(LIBS) -o bitint23.$(EXESUFFIX) + + +bitint23.run: bitint23.$(OBJX) + @echo ------------------------------------ executing test bitint23 + bitint23.$(EXESUFFIX) + +build: bitint23.$(OBJX) + +verify: ; + +run: bitint23.$(OBJX) + @echo ------------------------------------ executing test bitint23 + -bitint23.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint24.mk b/test/f08_correct/inc/bitint24.mk new file mode 100644 index 0000000000..d72c87fdbd --- /dev/null +++ b/test/f08_correct/inc/bitint24.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Thu Mar 19 10:54:19 IST 2020 +# + +########## Make rule for test bitint24 ######## + + +bitint24: bitint24.run + +bitint24.$(OBJX): $(SRC)/bitint24.f08 + -$(RM) bitint24.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint24.f08 -o bitint24.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint24.$(OBJX) check.$(OBJX) $(LIBS) -o bitint24.$(EXESUFFIX) + + +bitint24.run: bitint24.$(OBJX) + @echo ------------------------------------ executing test bitint24 + bitint24.$(EXESUFFIX) + +build: bitint24.$(OBJX) + +verify: ; + +run: bitint24.$(OBJX) + @echo ------------------------------------ executing test bitint24 + -bitint24.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint25.mk b/test/f08_correct/inc/bitint25.mk new file mode 100644 index 0000000000..fd44d2b18d --- /dev/null +++ b/test/f08_correct/inc/bitint25.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 15:07:29 IST 2020 +# + +########## Make rule for test bitint25 ######## + + +bitint25: bitint25.run + +bitint25.$(OBJX): $(SRC)/bitint25.f08 + -$(RM) bitint25.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint25.f08 -o bitint25.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint25.$(OBJX) check.$(OBJX) $(LIBS) -o bitint25.$(EXESUFFIX) + + +bitint25.run: bitint25.$(OBJX) + @echo ------------------------------------ executing test bitint25 + bitint25.$(EXESUFFIX) + +build: bitint25.$(OBJX) + +verify: ; + +run: bitint25.$(OBJX) + @echo ------------------------------------ executing test bitint25 + -bitint25.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint26.mk b/test/f08_correct/inc/bitint26.mk new file mode 100644 index 0000000000..a11b5f7094 --- /dev/null +++ b/test/f08_correct/inc/bitint26.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +########## Make rule for test bitint26 ######## + + +bitint26: bitint26.run + +bitint26.$(OBJX): $(SRC)/bitint26.f08 + -$(RM) bitint26.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint26.f08 -o bitint26.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint26.$(OBJX) check.$(OBJX) $(LIBS) -o bitint26.$(EXESUFFIX) + + +bitint26.run: bitint26.$(OBJX) + @echo ------------------------------------ executing test bitint26 + bitint26.$(EXESUFFIX) + +build: bitint26.$(OBJX) + +verify: ; + +run: bitint26.$(OBJX) + @echo ------------------------------------ executing test bitint26 + -bitint26.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint27.mk b/test/f08_correct/inc/bitint27.mk new file mode 100644 index 0000000000..89ea928a19 --- /dev/null +++ b/test/f08_correct/inc/bitint27.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 15:07:29 IST 2020 +# + +########## Make rule for test bitint27 ######## + + +bitint27: bitint27.run + +bitint27.$(OBJX): $(SRC)/bitint27.f08 + -$(RM) bitint27.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint27.f08 -o bitint27.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint27.$(OBJX) check.$(OBJX) $(LIBS) -o bitint27.$(EXESUFFIX) + + +bitint27.run: bitint27.$(OBJX) + @echo ------------------------------------ executing test bitint27 + bitint27.$(EXESUFFIX) + +build: bitint27.$(OBJX) + +verify: ; + +run: bitint27.$(OBJX) + @echo ------------------------------------ executing test bitint27 + -bitint27.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint28.mk b/test/f08_correct/inc/bitint28.mk new file mode 100644 index 0000000000..5652c34bbd --- /dev/null +++ b/test/f08_correct/inc/bitint28.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 15:07:29 IST 2020 +# + +########## Make rule for test bitint28 ######## + + +bitint28: bitint28.run + +bitint28.$(OBJX): $(SRC)/bitint28.f08 + -$(RM) bitint28.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint28.f08 -o bitint28.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint28.$(OBJX) check.$(OBJX) $(LIBS) -o bitint28.$(EXESUFFIX) + + +bitint28.run: bitint28.$(OBJX) + @echo ------------------------------------ executing test bitint28 + bitint28.$(EXESUFFIX) + +build: bitint28.$(OBJX) + +verify: ; + +run: bitint28.$(OBJX) + @echo ------------------------------------ executing test bitint28 + -bitint28.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint29.mk b/test/f08_correct/inc/bitint29.mk new file mode 100644 index 0000000000..fbbb675cb9 --- /dev/null +++ b/test/f08_correct/inc/bitint29.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Sep 10 2019 +# + +########## Make rule for test bitint29 ######## + + +bitint29: bitint29.run + +bitint29.$(OBJX): $(SRC)/bitint29.f08 + -$(RM) bitint29.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint29.f08 -o bitint29.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint29.$(OBJX) check.$(OBJX) $(LIBS) -o bitint29.$(EXESUFFIX) + + +bitint29.run: bitint29.$(OBJX) + @echo ------------------------------------ executing test bitint29 + bitint29.$(EXESUFFIX) + +build: bitint29.$(OBJX) + +verify: ; + +run: bitint29.$(OBJX) + @echo ------------------------------------ executing test bitint29 + -bitint29.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint30.mk b/test/f08_correct/inc/bitint30.mk new file mode 100644 index 0000000000..99e03f02f3 --- /dev/null +++ b/test/f08_correct/inc/bitint30.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 15:20:46 IST 2020 +# + +########## Make rule for test bitint30 ######## + + +bitint30: bitint30.run + +bitint30.$(OBJX): $(SRC)/bitint30.f08 + -$(RM) bitint30.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint30.f08 -o bitint30.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint30.$(OBJX) check.$(OBJX) $(LIBS) -o bitint30.$(EXESUFFIX) + + +bitint30.run: bitint30.$(OBJX) + @echo ------------------------------------ executing test bitint30 + bitint30.$(EXESUFFIX) + +build: bitint30.$(OBJX) + +verify: ; + +run: bitint30.$(OBJX) + @echo ------------------------------------ executing test bitint30 + -bitint30.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint31.mk b/test/f08_correct/inc/bitint31.mk new file mode 100644 index 0000000000..ff7b2ab362 --- /dev/null +++ b/test/f08_correct/inc/bitint31.mk @@ -0,0 +1,38 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control +# +# Date of Modification: Sep 10 2019 +# +########## Make rule for test bitint31 ######## + +bitint31: bitint31.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +bitint31.$(OBJX): $(SRC)/bitint31.f08 + -$(RM) bitint31.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint31.f08 -o bitint31.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) bitint31.$(OBJX) check.$(OBJX) $(LIBS) -o bitint31.$(EXESUFFIX) ||: + +bitint31.run: passok.$(OBJX) + @echo ------------------------------------ executing test bitint31 + -passok.$(EXESUFFIX) ||: + +build: bitint31.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test bitint31 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint32.mk b/test/f08_correct/inc/bitint32.mk new file mode 100644 index 0000000000..7f61d08548 --- /dev/null +++ b/test/f08_correct/inc/bitint32.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Sep 10 2019 +# + +########## Make rule for test bitint32 ######## + + +bitint32: bitint32.run + +bitint32.$(OBJX): $(SRC)/bitint32.f08 + -$(RM) bitint32.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint32.f08 -o bitint32.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint32.$(OBJX) check.$(OBJX) $(LIBS) -o bitint32.$(EXESUFFIX) + + +bitint32.run: bitint32.$(OBJX) + @echo ------------------------------------ executing test bitint32 + bitint32.$(EXESUFFIX) + +build: bitint32.$(OBJX) + +verify: ; + +run: bitint32.$(OBJX) + @echo ------------------------------------ executing test bitint32 + -bitint32.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint33.mk b/test/f08_correct/inc/bitint33.mk new file mode 100644 index 0000000000..f1ba7127d0 --- /dev/null +++ b/test/f08_correct/inc/bitint33.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Fri Apr 10 17:30:08 IST 2020 +# + +########## Make rule for test bitint33 ######## + + +bitint33: bitint33.run + +bitint33.$(OBJX): $(SRC)/bitint33.f08 + -$(RM) bitint33.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint33.f08 -o bitint33.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint33.$(OBJX) check.$(OBJX) $(LIBS) -o bitint33.$(EXESUFFIX) + + +bitint33.run: bitint33.$(OBJX) + @echo ------------------------------------ executing test bitint33 + bitint33.$(EXESUFFIX) + +build: bitint33.$(OBJX) + +verify: ; + +run: bitint33.$(OBJX) + @echo ------------------------------------ executing test bitint33 + -bitint33.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint34.mk b/test/f08_correct/inc/bitint34.mk new file mode 100644 index 0000000000..83194dcb9c --- /dev/null +++ b/test/f08_correct/inc/bitint34.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit data +# +# Date of Modification: Mon Feb 17 15:24:11 IST 2020 +# + +########## Make rule for test bitint34 ######## + + +bitint34: bitint34.run + +bitint34.$(OBJX): $(SRC)/bitint34.f08 + -$(RM) bitint34.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint34.f08 -o bitint34.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint34.$(OBJX) check.$(OBJX) $(LIBS) -o bitint34.$(EXESUFFIX) + + +bitint34.run: bitint34.$(OBJX) + @echo ------------------------------------ executing test bitint34 + bitint34.$(EXESUFFIX) + +build: bitint34.$(OBJX) + +verify: ; + +run: bitint34.$(OBJX) + @echo ------------------------------------ executing test bitint34 + -bitint34.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint35.mk b/test/f08_correct/inc/bitint35.mk new file mode 100644 index 0000000000..9b4c14dc85 --- /dev/null +++ b/test/f08_correct/inc/bitint35.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit data +# +# Date of Modification: Thu Mar 19 10:54:19 IST 2020 +# + +########## Make rule for test bitint35 ######## + + +bitint35: bitint35.run + +bitint35.$(OBJX): $(SRC)/bitint35.f08 + -$(RM) bitint35.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint35.f08 -o bitint35.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint35.$(OBJX) check.$(OBJX) $(LIBS) -o bitint35.$(EXESUFFIX) + + +bitint35.run: bitint35.$(OBJX) + @echo ------------------------------------ executing test bitint35 + bitint35.$(EXESUFFIX) + +build: bitint35.$(OBJX) + +verify: ; + +run: bitint35.$(OBJX) + @echo ------------------------------------ executing test bitint35 + -bitint35.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitint36.mk b/test/f08_correct/inc/bitint36.mk new file mode 100644 index 0000000000..6c699676cc --- /dev/null +++ b/test/f08_correct/inc/bitint36.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit data +# +# Date of Modification: Thu Mar 19 10:54:19 IST 2020 +# + +########## Make rule for test bitint36 ######## + + +bitint36: bitint36.run + +bitint36.$(OBJX): $(SRC)/bitint36.f08 + -$(RM) bitint36.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitint36.f08 -o bitint36.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitint36.$(OBJX) check.$(OBJX) $(LIBS) -o bitint36.$(EXESUFFIX) + + +bitint36.run: bitint36.$(OBJX) + @echo ------------------------------------ executing test bitint36 + bitint36.$(EXESUFFIX) + +build: bitint36.$(OBJX) + +verify: ; + +run: bitint36.$(OBJX) + @echo ------------------------------------ executing test bitint36 + -bitint36.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/bitmask01.mk b/test/f08_correct/inc/bitmask01.mk new file mode 100644 index 0000000000..99fa853bff --- /dev/null +++ b/test/f08_correct/inc/bitmask01.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for Bit Masking intrinsics. +# + +########## Make rule for test bitmask01 ######## + + +bitmask01: bitmask01.run + +bitmask01.$(OBJX): $(SRC)/bitmask01.f08 + -$(RM) bitmask01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitmask01.f08 -o bitmask01.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitmask01.$(OBJX) check.$(OBJX) $(LIBS) -o bitmask01.$(EXESUFFIX) + + +bitmask01.run: bitmask01.$(OBJX) + @echo ------------------------------------ executing test bitmask01 + bitmask01.$(EXESUFFIX) + +build: bitmask01.$(OBJX) + +verify: ; + +run: bitmask01.$(OBJX) + @echo ------------------------------------ executing test bitmask01 + bitmask01.$(EXESUFFIX) diff --git a/test/f08_correct/inc/bitshift01.mk b/test/f08_correct/inc/bitshift01.mk new file mode 100644 index 0000000000..33e04da776 --- /dev/null +++ b/test/f08_correct/inc/bitshift01.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for Bit Shifting intrinsics. +# + +########## Make rule for test bitshift01 ######## + + +bitshift01: bitshift01.run + +bitshift01.$(OBJX): $(SRC)/bitshift01.f08 + -$(RM) bitshift01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/bitshift01.f08 -o bitshift01.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) bitshift01.$(OBJX) check.$(OBJX) $(LIBS) -o bitshift01.$(EXESUFFIX) + + +bitshift01.run: bitshift01.$(OBJX) + @echo ------------------------------------ executing test bitshift01 + bitshift01.$(EXESUFFIX) + +build: bitshift01.$(OBJX) + +verify: ; + +run: bitshift01.$(OBJX) + @echo ------------------------------------ executing test bitshift01 + bitshift01.$(EXESUFFIX) diff --git a/test/f08_correct/inc/blk01.mk b/test/f08_correct/inc/blk01.mk new file mode 100644 index 0000000000..36f337e2ba --- /dev/null +++ b/test/f08_correct/inc/blk01.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2613-F2008: The BLOCK construct allows declarations of +# entities within executable code. +# +# Date of Modification: Fri November 8th, 2019 +# +########## Make rule for test blk01 ######## + +blk01: blk01.run + +blk01.$(OBJX): $(SRC)/blk01.f08 + -$(RM) blk01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/blk01.f08 -o blk01.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) blk01.$(OBJX) check.$(OBJX) $(LIBS) -o blk01.$(EXESUFFIX) + + +blk01.run: blk01.$(OBJX) + @echo ------------------------------------ executing test blk01 + blk01.$(EXESUFFIX) + +build: blk01.$(OBJX) + +verify: ; + +run: blk01.$(OBJX) + @echo ------------------------------------ executing test blk01 + -blk01.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/blk02.mk b/test/f08_correct/inc/blk02.mk new file mode 100644 index 0000000000..662268c8fe --- /dev/null +++ b/test/f08_correct/inc/blk02.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2613-F2008: The BLOCK construct allows declarations of +# entities within executable code. +# +# Date of Modification: Fri November 8th, 2019 +# +########## Make rule for test blk02 ######## + +blk02: blk02.run + +blk02.$(OBJX): $(SRC)/blk02.f08 + -$(RM) blk02.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/blk02.f08 -o blk02.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) blk02.$(OBJX) check.$(OBJX) $(LIBS) -o blk02.$(EXESUFFIX) + + +blk02.run: blk02.$(OBJX) + @echo ------------------------------------ executing test blk02 + blk02.$(EXESUFFIX) + +build: blk02.$(OBJX) + +verify: ; + +run: blk02.$(OBJX) + @echo ------------------------------------ executing test blk02 + -blk02.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/blk03.mk b/test/f08_correct/inc/blk03.mk new file mode 100644 index 0000000000..a481aa597c --- /dev/null +++ b/test/f08_correct/inc/blk03.mk @@ -0,0 +1,39 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2613-F2008: The BLOCK construct allows declarations of +# entities within executable code. +# +# Date of Modification: Fri November 8th, 2019 +# +########## Make rule for test blk03 ######## + +blk03: blk03.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +blk03.$(OBJX): $(SRC)/blk03.f08 + -$(RM) blk03.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/blk03.f08 -o blk03.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) blk03.$(OBJX) check.$(OBJX) $(LIBS) -o blk03.$(EXESUFFIX) ||: + +blk03.run: passok.$(OBJX) + @echo ------------------------------------ executing test blk03 + -passok.$(EXESUFFIX) ||: + +build: blk03.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test blk03 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/blk04.mk b/test/f08_correct/inc/blk04.mk new file mode 100644 index 0000000000..e5abc1b296 --- /dev/null +++ b/test/f08_correct/inc/blk04.mk @@ -0,0 +1,39 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2613-F2008: The BLOCK construct allows declarations of +# entities within executable code. +# +# Date of Modification: Fri November 8th, 2019 +# +########## Make rule for test blk04 ######## + +blk04: blk04.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +blk04.$(OBJX): $(SRC)/blk04.f08 + -$(RM) blk04.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/blk04.f08 -o blk04.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) blk04.$(OBJX) check.$(OBJX) $(LIBS) -o blk04.$(EXESUFFIX) ||: + +blk04.run: passok.$(OBJX) + @echo ------------------------------------ executing test blk04 + -passok.$(EXESUFFIX) ||: + +build: blk04.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test blk04 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/blk05.mk b/test/f08_correct/inc/blk05.mk new file mode 100644 index 0000000000..3c8e37db7e --- /dev/null +++ b/test/f08_correct/inc/blk05.mk @@ -0,0 +1,39 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2613-F2008: The BLOCK construct allows declarations of +# entities within executable code. +# +# Date of Modification: Fri November 8th, 2019 +# +########## Make rule for test blk05 ######## + +blk05: blk05.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +blk05.$(OBJX): $(SRC)/blk05.f08 + -$(RM) blk05.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/blk05.f08 -o blk05.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) blk05.$(OBJX) check.$(OBJX) $(LIBS) -o blk05.$(EXESUFFIX) ||: + +blk05.run: passok.$(OBJX) + @echo ------------------------------------ executing test blk05 + -passok.$(EXESUFFIX) ||: + +build: blk05.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test blk05 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/blk06.mk b/test/f08_correct/inc/blk06.mk new file mode 100644 index 0000000000..f0c821f7db --- /dev/null +++ b/test/f08_correct/inc/blk06.mk @@ -0,0 +1,39 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2613-F2008: The BLOCK construct allows declarations of +# entities within executable code. +# +# Date of Modification: Fri November 8th, 2019 +# +########## Make rule for test blk06 ######## + +blk06: blk06.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +blk06.$(OBJX): $(SRC)/blk06.f08 + -$(RM) blk06.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/blk06.f08 -o blk06.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) blk06.$(OBJX) check.$(OBJX) $(LIBS) -o blk06.$(EXESUFFIX) ||: + +blk06.run: passok.$(OBJX) + @echo ------------------------------------ executing test blk06 + -passok.$(EXESUFFIX) ||: + +build: blk06.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test blk06 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/blk07.mk b/test/f08_correct/inc/blk07.mk new file mode 100644 index 0000000000..71a2c5bc33 --- /dev/null +++ b/test/f08_correct/inc/blk07.mk @@ -0,0 +1,39 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2613-F2008: The BLOCK construct allows declarations of +# entities within executable code. +# +# Date of Modification: Fri November 8th, 2019 +# +########## Make rule for test blk07 ######## + +blk07: blk07.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +blk07.$(OBJX): $(SRC)/blk07.f08 + -$(RM) blk07.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/blk07.f08 -o blk07.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) blk07.$(OBJX) check.$(OBJX) $(LIBS) -o blk07.$(EXESUFFIX) ||: + +blk07.run: passok.$(OBJX) + @echo ------------------------------------ executing test blk07 + -passok.$(EXESUFFIX) ||: + +build: blk07.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test blk07 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/blk08.mk b/test/f08_correct/inc/blk08.mk new file mode 100644 index 0000000000..35c75fca58 --- /dev/null +++ b/test/f08_correct/inc/blk08.mk @@ -0,0 +1,39 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2613-F2008: The BLOCK construct allows declarations of +# entities within executable code. +# +# Date of Modification: Fri November 8th, 2019 +# +########## Make rule for test blk08 ######## + +blk08: blk08.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +blk08.$(OBJX): $(SRC)/blk08.f08 + -$(RM) blk08.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/blk08.f08 -o blk08.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) blk08.$(OBJX) check.$(OBJX) $(LIBS) -o blk08.$(EXESUFFIX) ||: + +blk08.run: passok.$(OBJX) + @echo ------------------------------------ executing test blk08 + -passok.$(EXESUFFIX) ||: + +build: blk08.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test blk08 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/blk09.mk b/test/f08_correct/inc/blk09.mk new file mode 100644 index 0000000000..6b924c8d9a --- /dev/null +++ b/test/f08_correct/inc/blk09.mk @@ -0,0 +1,39 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2613-F2008: The BLOCK construct allows declarations of +# entities within executable code. +# +# Date of Modification: Fri November 8th, 2019 +# +########## Make rule for test blk09 ######## + +blk09: blk09.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +blk09.$(OBJX): $(SRC)/blk09.f08 + -$(RM) blk09.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/blk09.f08 -o blk09.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) blk09.$(OBJX) check.$(OBJX) $(LIBS) -o blk09.$(EXESUFFIX) ||: + +blk09.run: passok.$(OBJX) + @echo ------------------------------------ executing test blk09 + -passok.$(EXESUFFIX) ||: + +build: blk09.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test blk09 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/blk10.mk b/test/f08_correct/inc/blk10.mk new file mode 100644 index 0000000000..4fa62d58b0 --- /dev/null +++ b/test/f08_correct/inc/blk10.mk @@ -0,0 +1,39 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2613-F2008: The BLOCK construct allows declarations of +# entities within executable code. +# +# Date of Modification: Fri November 8th, 2019 +# +########## Make rule for test blk10 ######## + +blk10: blk10.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +blk10.$(OBJX): $(SRC)/blk10.f08 + -$(RM) blk10.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/blk10.f08 -o blk10.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) blk10.$(OBJX) check.$(OBJX) $(LIBS) -o blk10.$(EXESUFFIX) ||: + +blk10.run: passok.$(OBJX) + @echo ------------------------------------ executing test blk10 + -passok.$(EXESUFFIX) ||: + +build: blk10.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test blk10 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/blk11.mk b/test/f08_correct/inc/blk11.mk new file mode 100644 index 0000000000..565a39ae9e --- /dev/null +++ b/test/f08_correct/inc/blk11.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2613-F2008: The BLOCK construct allows declarations of +# entities within executable code. +# +# Date of Modification: Fri November 8th, 2019 +# +########## Make rule for test blk11 ######## + +blk11: blk11.run + +blk11.$(OBJX): $(SRC)/blk11.f08 + -$(RM) blk11.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/blk11.f08 -o blk11.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) blk11.$(OBJX) check.$(OBJX) $(LIBS) -o blk11.$(EXESUFFIX) + + +blk11.run: blk11.$(OBJX) + @echo ------------------------------------ executing test blk11 + blk11.$(EXESUFFIX) + +build: blk11.$(OBJX) + +verify: ; + +run: blk11.$(OBJX) + @echo ------------------------------------ executing test blk11 + -blk11.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/cmplx_hyp.mk b/test/f08_correct/inc/cmplx_hyp.mk new file mode 100644 index 0000000000..d26a26c5bc --- /dev/null +++ b/test/f08_correct/inc/cmplx_hyp.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# [CPUPC-2569]Complex data types support for acosh, asinh and atanh +# +# Date of Modification: 07 January 2020 +# +########## Make rule for test cmplx_hyp ######## + + +cmplx_hyp: cmplx_hyp.run + +cmplx_hyp.$(OBJX): $(SRC)/cmplx_hyp.f08 + -$(RM) cmplx_hyp.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/cmplx_hyp.f08 -o cmplx_hyp.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) cmplx_hyp.$(OBJX) check.$(OBJX) $(LIBS) -o cmplx_hyp.$(EXESUFFIX) + + +cmplx_hyp.run: cmplx_hyp.$(OBJX) + @echo ------------------------------------ executing test cmplx_hyp + cmplx_hyp.$(EXESUFFIX) + +build: cmplx_hyp.$(OBJX) + +verify: ; + +run: cmplx_hyp.$(OBJX) + @echo ------------------------------------ executing test cmplx_hyp + -cmplx_hyp.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/combined_shift01.mk b/test/f08_correct/inc/combined_shift01.mk new file mode 100644 index 0000000000..8a8622c345 --- /dev/null +++ b/test/f08_correct/inc/combined_shift01.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for Combined Bit Shifting intrinsic. +# + +########## Make rule for test combined_shift01 ######## + + +combined_shift01: combined_shift01.run + +combined_shift01.$(OBJX): $(SRC)/combined_shift01.f08 + -$(RM) combined_shift01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/combined_shift01.f08 -o combined_shift01.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) combined_shift01.$(OBJX) check.$(OBJX) $(LIBS) -o combined_shift01.$(EXESUFFIX) + + +combined_shift01.run: combined_shift01.$(OBJX) + @echo ------------------------------------ executing test combined_shift01 + combined_shift01.$(EXESUFFIX) + +build: combined_shift01.$(OBJX) + +verify: ; + +run: combined_shift01.$(OBJX) + @echo ------------------------------------ executing test combined_shift01 + combined_shift01.$(EXESUFFIX) diff --git a/test/f08_correct/inc/editd01.mk b/test/f08_correct/inc/editd01.mk new file mode 100644 index 0000000000..801520b08a --- /dev/null +++ b/test/f08_correct/inc/editd01.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: G0 Edit descriptor - Input/Output extensions +# +# Date of Modification: 31st Aug 2019 + +# +########## Make rule for test editd01 ######## + + +editd01: editd01.run + +editd01.$(OBJX): $(SRC)/editd01.f08 + -$(RM) editd01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/editd01.f08 -o editd01.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) editd01.$(OBJX) check.$(OBJX) $(LIBS) -o editd01.$(EXESUFFIX) + + +editd01.run: editd01.$(OBJX) + @echo ------------------------------------ executing test editd01 + editd01.$(EXESUFFIX) + +build: editd01.$(OBJX) + +verify: ; + +run: editd01.$(OBJX) + @echo ------------------------------------ executing test editd01 + -editd01.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/editd02.mk b/test/f08_correct/inc/editd02.mk new file mode 100644 index 0000000000..a10735bd7a --- /dev/null +++ b/test/f08_correct/inc/editd02.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: G0 Edit descriptor - Input/Output extensions +# +# Date of Modification: 31st Aug 2019 + +# +########## Make rule for test editd02 ######## + + +editd02: editd02.run + +editd02.$(OBJX): $(SRC)/editd02.f08 + -$(RM) editd02.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/editd02.f08 -o editd02.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) editd02.$(OBJX) check.$(OBJX) $(LIBS) -o editd02.$(EXESUFFIX) + + +editd02.run: editd02.$(OBJX) + @echo ------------------------------------ executing test editd02 + editd02.$(EXESUFFIX) + +build: editd02.$(OBJX) + +verify: ; + +run: editd02.$(OBJX) + @echo ------------------------------------ executing test editd02 + -editd02.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/editd03.mk b/test/f08_correct/inc/editd03.mk new file mode 100644 index 0000000000..c509645945 --- /dev/null +++ b/test/f08_correct/inc/editd03.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: G0 Edit descriptor - Input/Output extensions +# +# Date of Modification: 31st Aug 2019 + +# +########## Make rule for test editd03 ######## + + +editd03: editd03.run + +editd03.$(OBJX): $(SRC)/editd03.f08 + -$(RM) editd03.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/editd03.f08 -o editd03.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) editd03.$(OBJX) check.$(OBJX) $(LIBS) -o editd03.$(EXESUFFIX) + + +editd03.run: editd03.$(OBJX) + @echo ------------------------------------ executing test editd03 + editd03.$(EXESUFFIX) + +build: editd03.$(OBJX) + +verify: ; + +run: editd03.$(OBJX) + @echo ------------------------------------ executing test editd03 + -editd03.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/editd04.mk b/test/f08_correct/inc/editd04.mk new file mode 100644 index 0000000000..f97d8ecd60 --- /dev/null +++ b/test/f08_correct/inc/editd04.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: G0 Edit descriptor - Input/Output extensions +# +# Date of Modification: 31st Aug 2019 + +# +########## Make rule for test editd04 ######## + + +editd04: editd04.run + +editd04.$(OBJX): $(SRC)/editd04.f08 + -$(RM) editd04.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/editd04.f08 -o editd04.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) editd04.$(OBJX) check.$(OBJX) $(LIBS) -o editd04.$(EXESUFFIX) + + +editd04.run: editd04.$(OBJX) + @echo ------------------------------------ executing test editd04 + editd04.$(EXESUFFIX) + +build: editd04.$(OBJX) + +verify: ; + +run: editd04.$(OBJX) + @echo ------------------------------------ executing test editd04 + -editd04.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/editd05.mk b/test/f08_correct/inc/editd05.mk new file mode 100644 index 0000000000..233a558b4f --- /dev/null +++ b/test/f08_correct/inc/editd05.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: G0 Edit descriptor - Input/Output extensions +# +# Date of Modification: 31st Aug 2019 + +# +########## Make rule for test editd05 ######## + + +editd05: editd05.run + +editd05.$(OBJX): $(SRC)/editd05.f08 + -$(RM) editd05.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/editd05.f08 -o editd05.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) editd05.$(OBJX) check.$(OBJX) $(LIBS) -o editd05.$(EXESUFFIX) + + +editd05.run: editd05.$(OBJX) + @echo ------------------------------------ executing test editd05 + editd05.$(EXESUFFIX) + +build: editd05.$(OBJX) + +verify: ; + +run: editd05.$(OBJX) + @echo ------------------------------------ executing test editd05 + -editd05.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/estop01.mk b/test/f08_correct/inc/estop01.mk new file mode 100644 index 0000000000..c9469ee149 --- /dev/null +++ b/test/f08_correct/inc/estop01.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Error stop code - Execution control +# +# Date of Modification: 25th July 2019 +# +########## Make rule for test estop01 ######## + + +estop01: estop01.run + +estop01.$(OBJX): $(SRC)/estop01.f08 + -$(RM) estop01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/estop01.f08 -o estop01.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) estop01.$(OBJX) check.$(OBJX) $(LIBS) -o estop01.$(EXESUFFIX) + + +estop01.run: estop01.$(OBJX) + @echo ------------------------------------ executing test estop01 + estop01.$(EXESUFFIX) + +build: estop01.$(OBJX) + +verify: ; + +run: estop01.$(OBJX) + @echo ------------------------------------ executing test estop01 + -estop01.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/estop02.mk b/test/f08_correct/inc/estop02.mk new file mode 100644 index 0000000000..7469699496 --- /dev/null +++ b/test/f08_correct/inc/estop02.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Error stop code - Execution control +# +# Date of Modification: 25th July 2019 +# +########## Make rule for test estop02 ######## + + +estop02: estop02.run + +estop02.$(OBJX): $(SRC)/estop02.f08 + -$(RM) estop02.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/estop02.f08 -o estop02.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) estop02.$(OBJX) check.$(OBJX) $(LIBS) -o estop02.$(EXESUFFIX) + + +estop02.run: estop02.$(OBJX) + @echo ------------------------------------ executing test estop02 + estop02.$(EXESUFFIX) + +build: estop02.$(OBJX) + +verify: ; + +run: estop02.$(OBJX) + @echo ------------------------------------ executing test estop02 + -estop02.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/estop03.mk b/test/f08_correct/inc/estop03.mk new file mode 100644 index 0000000000..db2db160f7 --- /dev/null +++ b/test/f08_correct/inc/estop03.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Error stop code - Execution control +# +# Date of Modification: 25th July 2019 +# +########## Make rule for test estop03 ######## + + +estop03: estop03.run + +estop03.$(OBJX): $(SRC)/estop03.f08 + -$(RM) estop03.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/estop03.f08 -o estop03.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) estop03.$(OBJX) check.$(OBJX) $(LIBS) -o estop03.$(EXESUFFIX) + + +estop03.run: estop03.$(OBJX) + @echo ------------------------------------ executing test estop03 + estop03.$(EXESUFFIX) + +build: estop03.$(OBJX) + +verify: ; + +run: estop03.$(OBJX) + @echo ------------------------------------ executing test estop03 + -estop03.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/estop04.mk b/test/f08_correct/inc/estop04.mk new file mode 100644 index 0000000000..6d8574bf9e --- /dev/null +++ b/test/f08_correct/inc/estop04.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Error stop code - Execution control +# +# Date of Modification: 25th July 2019 +# +########## Make rule for test estop04 ######## + + +estop04: estop04.run + +estop04.$(OBJX): $(SRC)/estop04.f08 + -$(RM) estop04.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/estop04.f08 -o estop04.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) estop04.$(OBJX) check.$(OBJX) $(LIBS) -o estop04.$(EXESUFFIX) + + +estop04.run: estop04.$(OBJX) + @echo ------------------------------------ executing test estop04 + estop04.$(EXESUFFIX) + +build: estop04.$(OBJX) + +verify: ; + +run: estop04.$(OBJX) + @echo ------------------------------------ executing test estop04 + -estop04.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/exec_cmd01.mk b/test/f08_correct/inc/exec_cmd01.mk new file mode 100644 index 0000000000..fa561b1bc8 --- /dev/null +++ b/test/f08_correct/inc/exec_cmd01.mk @@ -0,0 +1,29 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for execute_command_line as per f2008 standard +# + +########## Make rule for test exec_cmd01 ######## + + +exec_cmd01: exec_cmd01.run + +exec_cmd01.$(OBJX): $(SRC)/exec_cmd01.f08 + -$(RM) exec_cmd01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/exec_cmd01.f08 -o exec_cmd01.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) exec_cmd01.$(OBJX) $(LIBS) -o exec_cmd01.$(EXESUFFIX) + + +exec_cmd01.run: exec_cmd01.$(OBJX) + @echo ------------------------------------ executing test exec_cmd01 + exec_cmd01.$(EXESUFFIX) + +build: exec_cmd01.$(OBJX) + +verify: ; + +run: exec_cmd01.$(OBJX) + @echo ------------------------------------ executing test exec_cmd01 + exec_cmd01.$(EXESUFFIX) diff --git a/test/f08_correct/inc/exec_cmd02.mk b/test/f08_correct/inc/exec_cmd02.mk new file mode 100644 index 0000000000..c6fef3ec62 --- /dev/null +++ b/test/f08_correct/inc/exec_cmd02.mk @@ -0,0 +1,29 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for execute_command_line as per f2008 standard +# + +########## Make rule for test exec_cmd02 ######## + + +exec_cmd02: exec_cmd02.run + +exec_cmd02.$(OBJX): $(SRC)/exec_cmd02.f08 + -$(RM) exec_cmd01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/exec_cmd02.f08 -o exec_cmd02.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) exec_cmd02.$(OBJX) $(LIBS) -o exec_cmd02.$(EXESUFFIX) + + +exec_cmd02.run: exec_cmd02.$(OBJX) + @echo ------------------------------------ executing test exec_cmd02 + exec_cmd02.$(EXESUFFIX) + +build: exec_cmd02.$(OBJX) + +verify: ; + +run: exec_cmd02.$(OBJX) + @echo ------------------------------------ executing test exec_cmd02 + exec_cmd02.$(EXESUFFIX) diff --git a/test/f08_correct/inc/exit01.mk b/test/f08_correct/inc/exit01.mk new file mode 100644 index 0000000000..f85ae64d75 --- /dev/null +++ b/test/f08_correct/inc/exit01.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2013: F2008-Exit statement-Execution control. +# +# Date of Modification: 23rd Sep 2019 +# +########## Make rule for test exit01 ######## + + +exit01: exit01.run + +exit01.$(OBJX): $(SRC)/exit01.f08 + -$(RM) exit01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/exit01.f08 -o exit01.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) exit01.$(OBJX) check.$(OBJX) $(LIBS) -o exit01.$(EXESUFFIX) + + +exit01.run: exit01.$(OBJX) + @echo ------------------------------------ executing test exit01 + exit01.$(EXESUFFIX) + +build: exit01.$(OBJX) + +verify: ; + +run: exit01.$(OBJX) + @echo ------------------------------------ executing test exit01 + -exit01.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/exit02.mk b/test/f08_correct/inc/exit02.mk new file mode 100644 index 0000000000..016ffc0a19 --- /dev/null +++ b/test/f08_correct/inc/exit02.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2013: F2008-Exit statement-Execution control. +# +# Date of Modification: 23rd Sep 2019 +# +########## Make rule for test exit02 ######## + + +exit02: exit02.run + +exit02.$(OBJX): $(SRC)/exit02.f08 + -$(RM) exit02.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/exit02.f08 -o exit02.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) exit02.$(OBJX) check.$(OBJX) $(LIBS) -o exit02.$(EXESUFFIX) + + +exit02.run: exit02.$(OBJX) + @echo ------------------------------------ executing test exit02 + exit02.$(EXESUFFIX) + +build: exit02.$(OBJX) + +verify: ; + +run: exit02.$(OBJX) + @echo ------------------------------------ executing test exit02 + -exit02.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/exit03.mk b/test/f08_correct/inc/exit03.mk new file mode 100644 index 0000000000..274bdadf14 --- /dev/null +++ b/test/f08_correct/inc/exit03.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2013: F2008-Exit statement-Execution control. +# +# Date of Modification: 23rd Sep 2019 +# +########## Make rule for test exit03 ######## + + +exit03: exit03.run + +exit03.$(OBJX): $(SRC)/exit03.f08 + -$(RM) exit03.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/exit03.f08 -o exit03.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) exit03.$(OBJX) check.$(OBJX) $(LIBS) -o exit03.$(EXESUFFIX) + + +exit03.run: exit03.$(OBJX) + @echo ------------------------------------ executing test exit03 + exit03.$(EXESUFFIX) + +build: exit03.$(OBJX) + +verify: ; + +run: exit03.$(OBJX) + @echo ------------------------------------ executing test exit03 + -exit03.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/exit04.mk b/test/f08_correct/inc/exit04.mk new file mode 100644 index 0000000000..b31ceba59c --- /dev/null +++ b/test/f08_correct/inc/exit04.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2013: F2008-Exit statement-Execution control. +# +# Date of Modification: 23rd Sep 2019 +# +########## Make rule for test exit04 ######## + + +exit04: exit04.run + +exit04.$(OBJX): $(SRC)/exit04.f08 + -$(RM) exit04.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/exit04.f08 -o exit04.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) exit04.$(OBJX) check.$(OBJX) $(LIBS) -o exit04.$(EXESUFFIX) + + +exit04.run: exit04.$(OBJX) + @echo ------------------------------------ executing test exit04 + exit04.$(EXESUFFIX) + +build: exit04.$(OBJX) + +verify: ; + +run: exit04.$(OBJX) + @echo ------------------------------------ executing test exit04 + -exit04.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/exit05.mk b/test/f08_correct/inc/exit05.mk new file mode 100644 index 0000000000..3fe75bfa61 --- /dev/null +++ b/test/f08_correct/inc/exit05.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2013: F2008-Exit statement-Execution control. +# +# Date of Modification: 23rd Sep 2019 +# +########## Make rule for test exit05 ######## + + +exit05: exit05.run + +exit05.$(OBJX): $(SRC)/exit05.f08 + -$(RM) exit05.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/exit05.f08 -o exit05.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) exit05.$(OBJX) check.$(OBJX) $(LIBS) -o exit05.$(EXESUFFIX) + + +exit05.run: exit05.$(OBJX) + @echo ------------------------------------ executing test exit05 + exit05.$(EXESUFFIX) + +build: exit05.$(OBJX) + +verify: ; + +run: exit05.$(OBJX) + @echo ------------------------------------ executing test exit05 + -exit05.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/exit06.mk b/test/f08_correct/inc/exit06.mk new file mode 100644 index 0000000000..78e107b4ed --- /dev/null +++ b/test/f08_correct/inc/exit06.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2013: F2008-Exit statement-Execution control. +# +# Date of Modification: 23rd Sep 2019 +# +########## Make rule for test exit06 ######## + + +exit06: exit06.run + +exit06.$(OBJX): $(SRC)/exit06.f08 + -$(RM) exit06.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/exit06.f08 -o exit06.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) exit06.$(OBJX) check.$(OBJX) $(LIBS) -o exit06.$(EXESUFFIX) + + +exit06.run: exit06.$(OBJX) + @echo ------------------------------------ executing test exit06 + exit06.$(EXESUFFIX) + +build: exit06.$(OBJX) + +verify: ; + +run: exit06.$(OBJX) + @echo ------------------------------------ executing test exit06 + -exit06.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/gamma.mk b/test/f08_correct/inc/gamma.mk new file mode 100644 index 0000000000..6d18d4c554 --- /dev/null +++ b/test/f08_correct/inc/gamma.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for gamma intrinsic. +# + +########## Make rule for test gamma ######## + + +gamma: .run + +gamma.$(OBJX): $(SRC)/gamma.f08 + -$(RM) gamma.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/gamma.f08 -o gamma.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) gamma.$(OBJX) check.$(OBJX) $(LIBS) -o gamma.$(EXESUFFIX) + + +gamma.run: gamma.$(OBJX) + @echo ------------------------------------ executing test gamma + gamma.$(EXESUFFIX) + +build: gamma.$(OBJX) + +verify: ; + +run: gamma.$(OBJX) + @echo ------------------------------------ executing test gamma + gamma.$(EXESUFFIX) + diff --git a/test/f08_correct/inc/iall.mk b/test/f08_correct/inc/iall.mk new file mode 100644 index 0000000000..04ae67c734 --- /dev/null +++ b/test/f08_correct/inc/iall.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for iall intrinsic. +# + +########## Make rule for test iall ######## + + +iall: .run + +iall.$(OBJX): $(SRC)/iall.f08 + -$(RM) iall.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/iall.f08 -o iall.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) iall.$(OBJX) check.$(OBJX) $(LIBS) -o iall.$(EXESUFFIX) + + +iall.run: iall.$(OBJX) + @echo ------------------------------------ executing test iall + iall.$(EXESUFFIX) + +build: iall.$(OBJX) + +verify: ; + +run: iall.$(OBJX) + @echo ------------------------------------ executing test iall + iall.$(EXESUFFIX) + diff --git a/test/f08_correct/inc/iany.mk b/test/f08_correct/inc/iany.mk new file mode 100644 index 0000000000..12d2d425d0 --- /dev/null +++ b/test/f08_correct/inc/iany.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for iany intrinsic. +# + +########## Make rule for test iany ######## + + +iany: .run + +iany.$(OBJX): $(SRC)/iany.f08 + -$(RM) iany.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/iany.f08 -o iany.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) iany.$(OBJX) check.$(OBJX) $(LIBS) -o iany.$(EXESUFFIX) + + +iany.run: iany.$(OBJX) + @echo ------------------------------------ executing test iany + iany.$(EXESUFFIX) + +build: iany.$(OBJX) + +verify: ; + +run: iany.$(OBJX) + @echo ------------------------------------ executing test iany + iany.$(EXESUFFIX) + diff --git a/test/f08_correct/inc/impure01.mk b/test/f08_correct/inc/impure01.mk new file mode 100644 index 0000000000..025f6fe5f9 --- /dev/null +++ b/test/f08_correct/inc/impure01.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# + +########## Make rule for test impure01 ######## + + +impure01: impure01.run + +impure01.$(OBJX): $(SRC)/impure01.f08 + -$(RM) impure01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/impure01.f08 -o impure01.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) impure01.$(OBJX) check.$(OBJX) $(LIBS) -o impure01.$(EXESUFFIX) + + +impure01.run: impure01.$(OBJX) + @echo ------------------------------------ executing test impure01 + impure01.$(EXESUFFIX) + +build: impure01.$(OBJX) + +verify: ; + +run: impure01.$(OBJX) + @echo ------------------------------------ executing test impure01 + -impure01.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/impure02.mk b/test/f08_correct/inc/impure02.mk new file mode 100644 index 0000000000..40c60435fe --- /dev/null +++ b/test/f08_correct/inc/impure02.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# + +########## Make rule for test impure02 ######## + + +impure02: impure02.run + +impure02.$(OBJX): $(SRC)/impure02.f08 + -$(RM) impure02.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/impure02.f08 -o impure02.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) impure02.$(OBJX) check.$(OBJX) $(LIBS) -o impure02.$(EXESUFFIX) + + +impure02.run: impure02.$(OBJX) + @echo ------------------------------------ executing test impure02 + impure02.$(EXESUFFIX) + +build: impure02.$(OBJX) + +verify: ; + +run: impure02.$(OBJX) + @echo ------------------------------------ executing test impure02 + -impure02.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/impure03.mk b/test/f08_correct/inc/impure03.mk new file mode 100644 index 0000000000..eae8f2cc87 --- /dev/null +++ b/test/f08_correct/inc/impure03.mk @@ -0,0 +1,38 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# +########## Make rule for test impure03 ######## + +impure03: impure03.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +impure03.$(OBJX): $(SRC)/impure03.f08 + -$(RM) impure03.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/impure03.f08 -o impure03.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) impure03.$(OBJX) check.$(OBJX) $(LIBS) -o impure03.$(EXESUFFIX) ||: + +impure03.run: passok.$(OBJX) + @echo ------------------------------------ executing test impure03 + -passok.$(EXESUFFIX) ||: + +build: impure03.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test impure03 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/impure04.mk b/test/f08_correct/inc/impure04.mk new file mode 100644 index 0000000000..d42de36470 --- /dev/null +++ b/test/f08_correct/inc/impure04.mk @@ -0,0 +1,38 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# +########## Make rule for test impure04 ######## + +impure04: impure04.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +impure04.$(OBJX): $(SRC)/impure04.f08 + -$(RM) impure04.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/impure04.f08 -o impure04.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) impure04.$(OBJX) check.$(OBJX) $(LIBS) -o impure04.$(EXESUFFIX) ||: + +impure04.run: passok.$(OBJX) + @echo ------------------------------------ executing test impure04 + -passok.$(EXESUFFIX) ||: + +build: impure04.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test impure04 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/impure05.mk b/test/f08_correct/inc/impure05.mk new file mode 100644 index 0000000000..64176236e6 --- /dev/null +++ b/test/f08_correct/inc/impure05.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# + +########## Make rule for test impure05 ######## + + +impure05: impure05.run + +impure05.$(OBJX): $(SRC)/impure05.f08 + -$(RM) impure05.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/impure05.f08 -o impure05.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) impure05.$(OBJX) check.$(OBJX) $(LIBS) -o impure05.$(EXESUFFIX) + + +impure05.run: impure05.$(OBJX) + @echo ------------------------------------ executing test impure05 + impure05.$(EXESUFFIX) + +build: impure05.$(OBJX) + +verify: ; + +run: impure05.$(OBJX) + @echo ------------------------------------ executing test impure05 + -impure05.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/impure06.mk b/test/f08_correct/inc/impure06.mk new file mode 100644 index 0000000000..bcc9d355b8 --- /dev/null +++ b/test/f08_correct/inc/impure06.mk @@ -0,0 +1,38 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# +########## Make rule for test impure06 ######## + +impure06: impure06.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +impure06.$(OBJX): $(SRC)/impure06.f08 + -$(RM) impure06.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/impure06.f08 -o impure06.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) impure06.$(OBJX) check.$(OBJX) $(LIBS) -o impure06.$(EXESUFFIX) ||: + +impure06.run: passok.$(OBJX) + @echo ------------------------------------ executing test impure06 + -passok.$(EXESUFFIX) ||: + +build: impure06.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test impure06 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/impure07.mk b/test/f08_correct/inc/impure07.mk new file mode 100644 index 0000000000..fb888e3e11 --- /dev/null +++ b/test/f08_correct/inc/impure07.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# + +########## Make rule for test impure07 ######## + + +impure07: impure07.run + +impure07.$(OBJX): $(SRC)/impure07.f08 + -$(RM) impure07.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/impure07.f08 -o impure07.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) impure07.$(OBJX) check.$(OBJX) $(LIBS) -o impure07.$(EXESUFFIX) + + +impure07.run: impure07.$(OBJX) + @echo ------------------------------------ executing test impure07 + impure07.$(EXESUFFIX) + +build: impure07.$(OBJX) + +verify: ; + +run: impure07.$(OBJX) + @echo ------------------------------------ executing test impure07 + -impure07.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/impure08.mk b/test/f08_correct/inc/impure08.mk new file mode 100644 index 0000000000..8c0e4379df --- /dev/null +++ b/test/f08_correct/inc/impure08.mk @@ -0,0 +1,38 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# +########## Make rule for test impure08 ######## + +impure08: impure08.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +impure08.$(OBJX): $(SRC)/impure08.f08 + -$(RM) impure08.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/impure08.f08 -o impure08.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) impure08.$(OBJX) check.$(OBJX) $(LIBS) -o impure08.$(EXESUFFIX) ||: + +impure08.run: passok.$(OBJX) + @echo ------------------------------------ executing test impure08 + -passok.$(EXESUFFIX) ||: + +build: impure08.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test impure08 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/impure09.mk b/test/f08_correct/inc/impure09.mk new file mode 100644 index 0000000000..27136bc4d4 --- /dev/null +++ b/test/f08_correct/inc/impure09.mk @@ -0,0 +1,38 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# +########## Make rule for test impure09 ######## + +impure09: impure09.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +impure09.$(OBJX): $(SRC)/impure09.f08 + -$(RM) impure09.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/impure09.f08 -o impure09.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) impure09.$(OBJX) check.$(OBJX) $(LIBS) -o impure09.$(EXESUFFIX) ||: + +impure09.run: passok.$(OBJX) + @echo ------------------------------------ executing test impure09 + -passok.$(EXESUFFIX) ||: + +build: impure09.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test impure09 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/impure10.mk b/test/f08_correct/inc/impure10.mk new file mode 100644 index 0000000000..60820f84a6 --- /dev/null +++ b/test/f08_correct/inc/impure10.mk @@ -0,0 +1,38 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# +########## Make rule for test impure10 ######## + +impure10: impure10.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +impure10.$(OBJX): $(SRC)/impure10.f08 + -$(RM) impure10.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/impure10.f08 -o impure10.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) impure10.$(OBJX) check.$(OBJX) $(LIBS) -o impure10.$(EXESUFFIX) ||: + +impure10.run: passok.$(OBJX) + @echo ------------------------------------ executing test impure10 + -passok.$(EXESUFFIX) ||: + +build: impure10.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test impure10 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/impure11.mk b/test/f08_correct/inc/impure11.mk new file mode 100644 index 0000000000..31ac0505dd --- /dev/null +++ b/test/f08_correct/inc/impure11.mk @@ -0,0 +1,38 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# +########## Make rule for test impure11 ######## + +impure11: impure11.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +impure11.$(OBJX): $(SRC)/impure11.f08 + -$(RM) impure11.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/impure11.f08 -o impure11.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) impure11.$(OBJX) check.$(OBJX) $(LIBS) -o impure11.$(EXESUFFIX) ||: + +impure11.run: passok.$(OBJX) + @echo ------------------------------------ executing test impure11 + -passok.$(EXESUFFIX) ||: + +build: impure11.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test impure11 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/impure12.mk b/test/f08_correct/inc/impure12.mk new file mode 100644 index 0000000000..f469f0229c --- /dev/null +++ b/test/f08_correct/inc/impure12.mk @@ -0,0 +1,38 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# +########## Make rule for test impure12 ######## + +impure12: impure12.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +impure12.$(OBJX): $(SRC)/impure12.f08 + -$(RM) impure12.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/impure12.f08 -o impure12.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) impure12.$(OBJX) check.$(OBJX) $(LIBS) -o impure12.$(EXESUFFIX) ||: + +impure12.run: passok.$(OBJX) + @echo ------------------------------------ executing test impure12 + -passok.$(EXESUFFIX) ||: + +build: impure12.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test impure12 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/impure13.mk b/test/f08_correct/inc/impure13.mk new file mode 100644 index 0000000000..94bab3ddec --- /dev/null +++ b/test/f08_correct/inc/impure13.mk @@ -0,0 +1,38 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# +########## Make rule for test impure13 ######## + +impure13: impure13.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +impure13.$(OBJX): $(SRC)/impure13.f08 + -$(RM) impure13.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/impure13.f08 -o impure13.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) impure13.$(OBJX) check.$(OBJX) $(LIBS) -o impure13.$(EXESUFFIX) ||: + +impure13.run: passok.$(OBJX) + @echo ------------------------------------ executing test impure13 + -passok.$(EXESUFFIX) ||: + +build: impure13.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test impure13 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/impure14.mk b/test/f08_correct/inc/impure14.mk new file mode 100644 index 0000000000..474be107df --- /dev/null +++ b/test/f08_correct/inc/impure14.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# + +########## Make rule for test impure14 ######## + + +impure14: impure14.run + +impure14.$(OBJX): $(SRC)/impure14.f08 + -$(RM) impure14.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/impure14.f08 -o impure14.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) impure14.$(OBJX) check.$(OBJX) $(LIBS) -o impure14.$(EXESUFFIX) + + +impure14.run: impure14.$(OBJX) + @echo ------------------------------------ executing test impure14 + impure14.$(EXESUFFIX) + +build: impure14.$(OBJX) + +verify: ; + +run: impure14.$(OBJX) + @echo ------------------------------------ executing test impure14 + -impure14.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/impure15.mk b/test/f08_correct/inc/impure15.mk new file mode 100644 index 0000000000..017b8bb9af --- /dev/null +++ b/test/f08_correct/inc/impure15.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# + +########## Make rule for test impure15 ######## + + +impure15: impure15.run + +impure15.$(OBJX): $(SRC)/impure15.f08 + -$(RM) impure15.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/impure15.f08 -o impure15.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) impure15.$(OBJX) check.$(OBJX) $(LIBS) -o impure15.$(EXESUFFIX) + + +impure15.run: impure15.$(OBJX) + @echo ------------------------------------ executing test impure15 + impure15.$(EXESUFFIX) + +build: impure15.$(OBJX) + +verify: ; + +run: impure15.$(OBJX) + @echo ------------------------------------ executing test impure15 + -impure15.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/impure16.mk b/test/f08_correct/inc/impure16.mk new file mode 100644 index 0000000000..7393aaf16a --- /dev/null +++ b/test/f08_correct/inc/impure16.mk @@ -0,0 +1,38 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# +########## Make rule for test impure16 ######## + +impure16: impure16.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +impure16.$(OBJX): $(SRC)/impure16.f08 + -$(RM) impure16.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/impure16.f08 -o impure16.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) impure16.$(OBJX) check.$(OBJX) $(LIBS) -o impure16.$(EXESUFFIX) ||: + +impure16.run: passok.$(OBJX) + @echo ------------------------------------ executing test impure16 + -passok.$(EXESUFFIX) ||: + +build: impure16.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test impure16 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/iparity.mk b/test/f08_correct/inc/iparity.mk new file mode 100644 index 0000000000..7e678ec197 --- /dev/null +++ b/test/f08_correct/inc/iparity.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for iparity intrinsic. +# + +########## Make rule for test iparity ######## + + +iparity: .run + +iparity.$(OBJX): $(SRC)/iparity.f08 + -$(RM) iparity.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/iparity.f08 -o iparity.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) iparity.$(OBJX) check.$(OBJX) $(LIBS) -o iparity.$(EXESUFFIX) + + +iparity.run: iparity.$(OBJX) + @echo ------------------------------------ executing test iparity + iparity.$(EXESUFFIX) + +build: iparity.$(OBJX) + +verify: ; + +run: iparity.$(OBJX) + @echo ------------------------------------ executing test iparity + iparity.$(EXESUFFIX) + diff --git a/test/f08_correct/inc/longintforall.mk b/test/f08_correct/inc/longintforall.mk new file mode 100644 index 0000000000..63881dd510 --- /dev/null +++ b/test/f08_correct/inc/longintforall.mk @@ -0,0 +1,37 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for longintforall intrinsic. +# + +########## Make rule for test longintforall ######## +#===----------------------------------------------------------------------===// +# +# Date of Modification : 19th July 2019 +# Added a new test for use of kind of a forall index +# +#===----------------------------------------------------------------------===// + + +longintforall: .run + +longintforall.$(OBJX): $(SRC)/longintforall.f08 + -$(RM) longintforall.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/longintforall.f08 -o longintforall.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) longintforall.$(OBJX) check.$(OBJX) $(LIBS) -o longintforall.$(EXESUFFIX) + + +longintforall.run: longintforall.$(OBJX) + @echo ------------------------------------ executing test longintforall + longintforall.$(EXESUFFIX) + +build: longintforall.$(OBJX) + +verify: ; + +run: longintforall.$(OBJX) + @echo ------------------------------------ executing test longintforall + longintforall.$(EXESUFFIX) + diff --git a/test/f08_correct/inc/maxdim01.mk b/test/f08_correct/inc/maxdim01.mk new file mode 100644 index 0000000000..eae926b8df --- /dev/null +++ b/test/f08_correct/inc/maxdim01.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for maximum dimension as per f2008 standard +# + +########## Make rule for test maxdim01 ######## + + +maxdim01: maxdim01.run + +maxdim01.$(OBJX): $(SRC)/maxdim01.f08 + -$(RM) maxdim01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/maxdim01.f08 -o maxdim01.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) maxdim01.$(OBJX) check.$(OBJX) $(LIBS) -o maxdim01.$(EXESUFFIX) + + +maxdim01.run: maxdim01.$(OBJX) + @echo ------------------------------------ executing test maxdim01 + maxdim01.$(EXESUFFIX) + +build: maxdim01.$(OBJX) + +verify: ; + +run: maxdim01.$(OBJX) + @echo ------------------------------------ executing test maxdim01 + maxdim01.$(EXESUFFIX) diff --git a/test/f08_correct/inc/maxdim02.mk b/test/f08_correct/inc/maxdim02.mk new file mode 100644 index 0000000000..3c832273eb --- /dev/null +++ b/test/f08_correct/inc/maxdim02.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for maximum dimension as per f2008 standard +# + +########## Make rule for test maxdim02 ######## + + +maxdim02: maxdim02.run + +maxdim02.$(OBJX): $(SRC)/maxdim02.f08 + -$(RM) maxdim02.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/maxdim02.f08 -o maxdim02.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) maxdim02.$(OBJX) check.$(OBJX) $(LIBS) -o maxdim02.$(EXESUFFIX) + + +maxdim02.run: maxdim02.$(OBJX) + @echo ------------------------------------ executing test maxdim02 + maxdim02.$(EXESUFFIX) + +build: maxdim02.$(OBJX) + +verify: ; + +run: maxdim02.$(OBJX) + @echo ------------------------------------ executing test maxdim02 + maxdim02.$(EXESUFFIX) diff --git a/test/f08_correct/inc/maxdim03.mk b/test/f08_correct/inc/maxdim03.mk new file mode 100644 index 0000000000..933735b9be --- /dev/null +++ b/test/f08_correct/inc/maxdim03.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for maximum dimension as per f2008 standard +# + +########## Make rule for test maxdim03 ######## + + +maxdim03: maxdim03.run + +maxdim03.$(OBJX): $(SRC)/maxdim03.f08 + -$(RM) maxdim03.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/maxdim03.f08 -o maxdim03.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) maxdim03.$(OBJX) check.$(OBJX) $(LIBS) -o maxdim03.$(EXESUFFIX) + + +maxdim03.run: maxdim03.$(OBJX) + @echo ------------------------------------ executing test maxdim03 + maxdim03.$(EXESUFFIX) + +build: maxdim03.$(OBJX) + +verify: ; + +run: maxdim03.$(OBJX) + @echo ------------------------------------ executing test maxdim03 + maxdim03.$(EXESUFFIX) diff --git a/test/f08_correct/inc/merge_bits01.mk b/test/f08_correct/inc/merge_bits01.mk new file mode 100644 index 0000000000..ea2e32e016 --- /dev/null +++ b/test/f08_correct/inc/merge_bits01.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for MERGE_BITS intrinsic. +# + +########## Make rule for test merge_bits01 ######## + + +merge_bits01: merge_bits01.run + +merge_bits01.$(OBJX): $(SRC)/merge_bits01.f08 + -$(RM) merge_bits01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/merge_bits01.f08 -o merge_bits01.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) merge_bits01.$(OBJX) check.$(OBJX) $(LIBS) -o merge_bits01.$(EXESUFFIX) + + +merge_bits01.run: merge_bits01.$(OBJX) + @echo ------------------------------------ executing test merge_bits01 + merge_bits01.$(EXESUFFIX) + +build: merge_bits01.$(OBJX) + +verify: ; + +run: merge_bits01.$(OBJX) + @echo ------------------------------------ executing test merge_bits01 + merge_bits01.$(EXESUFFIX) diff --git a/test/f08_correct/inc/mold-source.mk b/test/f08_correct/inc/mold-source.mk new file mode 100644 index 0000000000..19937ab3a3 --- /dev/null +++ b/test/f08_correct/inc/mold-source.mk @@ -0,0 +1,37 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for mold and source. +# + +########## Make rule for test mold-source ######## +#===----------------------------------------------------------------------===// +# +# Date of Modification : 30th September 2019 +# Added a new test for Copying the properties of an object in an allocate statement +# +#===----------------------------------------------------------------------===// + + +mold-source: .run + +mold-source.$(OBJX): $(SRC)/mold-source.f08 + -$(RM) mold-source.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/mold-source.f08 -o mold-source.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) mold-source.$(OBJX) check.$(OBJX) $(LIBS) -o mold-source.$(EXESUFFIX) + + +mold-source.run: mold-source.$(OBJX) + @echo ------------------------------------ executing test mold-source + mold-source.$(EXESUFFIX) + +build: mold-source.$(OBJX) + +verify: ; + +run: mold-source.$(OBJX) + @echo ------------------------------------ executing test mold-source + mold-source.$(EXESUFFIX) + diff --git a/test/f08_correct/inc/newunit01.mk b/test/f08_correct/inc/newunit01.mk new file mode 100644 index 0000000000..03986ab19d --- /dev/null +++ b/test/f08_correct/inc/newunit01.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008-New Unit Specifier feature compliance test +# + +########## Make rule for test newunit01 ######## + + +newunit01: newunit01.run + +newunit01.$(OBJX): $(SRC)/newunit01.f08 + -$(RM) newunit01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/newunit01.f08 -o newunit01.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) newunit01.$(OBJX) check.$(OBJX) $(LIBS) -o newunit01.$(EXESUFFIX) + + +newunit01.run: newunit01.$(OBJX) + @echo ------------------------------------ executing test newunit01 + newunit01.$(EXESUFFIX) + +build: newunit01.$(OBJX) + +verify: ; + +run: newunit01.$(OBJX) + @echo ------------------------------------ executing test newunit01 + newunit01.$(EXESUFFIX) diff --git a/test/f08_correct/inc/newunit02.mk b/test/f08_correct/inc/newunit02.mk new file mode 100644 index 0000000000..ec4dbe625b --- /dev/null +++ b/test/f08_correct/inc/newunit02.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Revert to the old value when newunit has errors. +# + +########## Make rule for test newunit02 ######## + + +newunit02: newunit02.run + +newunit02.$(OBJX): $(SRC)/newunit02.f08 + -$(RM) newunit02.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/newunit02.f08 -o newunit02.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) newunit02.$(OBJX) check.$(OBJX) $(LIBS) -o newunit02.$(EXESUFFIX) + + +newunit02.run: newunit02.$(OBJX) + @echo ------------------------------------ executing test newunit02 + newunit02.$(EXESUFFIX) + +build: newunit02.$(OBJX) + +verify: ; + +run: newunit02.$(OBJX) + @echo ------------------------------------ executing test newunit02 + newunit02.$(EXESUFFIX) diff --git a/test/f08_correct/inc/nm01.mk b/test/f08_correct/inc/nm01.mk new file mode 100644 index 0000000000..07d002d6a0 --- /dev/null +++ b/test/f08_correct/inc/nm01.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2018, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for DNORM intrinsic +# +# Date of Modification: 21st February 2019 +# + +########## Make rule for test nm01 ######## + + +nm01: nm01.run + +nm01.$(OBJX): $(SRC)/nm01.f08 + -$(RM) nm01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/nm01.f08 -o nm01.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) nm01.$(OBJX) check.$(OBJX) $(LIBS) -o nm01.$(EXESUFFIX) + + +nm01.run: nm01.$(OBJX) + @echo ------------------------------------ executing test nm01 + nm01.$(EXESUFFIX) + +build: nm01.$(OBJX) + +verify: ; + +run: nm01.$(OBJX) + @echo ------------------------------------ executing test nm01 + nm01.$(EXESUFFIX) diff --git a/test/f08_correct/inc/nm02.mk b/test/f08_correct/inc/nm02.mk new file mode 100644 index 0000000000..6471ac331b --- /dev/null +++ b/test/f08_correct/inc/nm02.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2018, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for DNORM intrinsic +# +# Date of Modification: 21st February 2019 +# + +########## Make rule for test nm02 ######## + + +nm02: nm02.run + +nm02.$(OBJX): $(SRC)/nm02.f08 + -$(RM) nm02.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/nm02.f08 -o nm02.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) nm02.$(OBJX) check.$(OBJX) $(LIBS) -o nm02.$(EXESUFFIX) + + +nm02.run: nm02.$(OBJX) + @echo ------------------------------------ executing test nm02 + nm02.$(EXESUFFIX) + +build: nm02.$(OBJX) + +verify: ; + +run: nm02.$(OBJX) + @echo ------------------------------------ executing test nm02 + nm02.$(EXESUFFIX) diff --git a/test/f08_correct/inc/nm03.mk b/test/f08_correct/inc/nm03.mk new file mode 100644 index 0000000000..a4f2baac0b --- /dev/null +++ b/test/f08_correct/inc/nm03.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2018, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for DNORM intrinsic +# +# Date of Modification: 21st February 2019 +# + +########## Make rule for test nm03 ######## + + +nm03: nm03.run + +nm03.$(OBJX): $(SRC)/nm03.f08 + -$(RM) nm03.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/nm03.f08 -o nm03.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) nm03.$(OBJX) check.$(OBJX) $(LIBS) -o nm03.$(EXESUFFIX) + + +nm03.run: nm03.$(OBJX) + @echo ------------------------------------ executing test nm03 + nm03.$(EXESUFFIX) + +build: nm03.$(OBJX) + +verify: ; + +run: nm03.$(OBJX) + @echo ------------------------------------ executing test nm03 + nm03.$(EXESUFFIX) diff --git a/test/f08_correct/inc/nm04.mk b/test/f08_correct/inc/nm04.mk new file mode 100644 index 0000000000..a831b9a410 --- /dev/null +++ b/test/f08_correct/inc/nm04.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2018, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for array expressions in norm2 +# Date of modification 28th October 2019 +# +# + +########## Make rule for test nm04 ######## + + +nm04: nm04.run + +nm04.$(OBJX): $(SRC)/nm04.f08 + -$(RM) nm04.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/nm04.f08 -o nm04.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) nm04.$(OBJX) check.$(OBJX) $(LIBS) -o nm04.$(EXESUFFIX) + + +nm04.run: nm04.$(OBJX) + @echo ------------------------------------ executing test nm04 + nm04.$(EXESUFFIX) + +build: nm04.$(OBJX) + +verify: ; + +run: nm04.$(OBJX) + @echo ------------------------------------ executing test nm04 + nm04.$(EXESUFFIX) diff --git a/test/f08_correct/inc/parity.mk b/test/f08_correct/inc/parity.mk new file mode 100644 index 0000000000..c32f8b4824 --- /dev/null +++ b/test/f08_correct/inc/parity.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for parity intrinsic. +# + +########## Make rule for test parity ######## + + +parity: .run + +parity.$(OBJX): $(SRC)/parity.f08 + -$(RM) parity.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/parity.f08 -o parity.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) parity.$(OBJX) check.$(OBJX) $(LIBS) -o parity.$(EXESUFFIX) + + +parity.run: parity.$(OBJX) + @echo ------------------------------------ executing test parity + parity.$(EXESUFFIX) + +build: parity.$(OBJX) + +verify: ; + +run: parity.$(OBJX) + @echo ------------------------------------ executing test parity + parity.$(EXESUFFIX) + diff --git a/test/f08_correct/inc/passok.mk b/test/f08_correct/inc/passok.mk new file mode 100644 index 0000000000..495335eec7 --- /dev/null +++ b/test/f08_correct/inc/passok.mk @@ -0,0 +1,15 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Date Modified: 10th Sep 2019 +# Forcefully mark a test as passed +# + +########## Make rule for test passok ######## + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) diff --git a/test/f08_correct/inc/pointer_init01.mk b/test/f08_correct/inc/pointer_init01.mk new file mode 100644 index 0000000000..986c744d4c --- /dev/null +++ b/test/f08_correct/inc/pointer_init01.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for pointer initialization as per f2008 standard +# + +########## Make rule for test pointer_init01 ######## + + +pointer_init01: pointer_init01.run + +pointer_init01.$(OBJX): $(SRC)/pointer_init01.f08 + -$(RM) pointer_init01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/pointer_init01.f08 -o pointer_init01.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) pointer_init01.$(OBJX) check.$(OBJX) $(LIBS) -o pointer_init01.$(EXESUFFIX) + + +pointer_init01.run: pointer_init01.$(OBJX) + @echo ------------------------------------ executing test pointer_init01 + pointer_init01.$(EXESUFFIX) + +build: pointer_init01.$(OBJX) + +verify: ; + +run: pointer_init01.$(OBJX) + @echo ------------------------------------ executing test pointer_init01 + pointer_init01.$(EXESUFFIX) diff --git a/test/f08_correct/inc/rank.mk b/test/f08_correct/inc/rank.mk new file mode 100644 index 0000000000..aabb3b1109 --- /dev/null +++ b/test/f08_correct/inc/rank.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# [CPUPC-3849] Rank intrinsic for flang +# +# Date of Modification: 10 Aug 2020 +# +########## Make rule for test rank.f08 ######## + + +rank: .run + +rank.$(OBJX): $(SRC)/rank.f08 + -$(RM) rank.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/rank.f08 -o rank.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) rank.$(OBJX) check.$(OBJX) $(LIBS) -o rank.$(EXESUFFIX) + + +rank.run: rank.$(OBJX) + @echo ------------------------------------ executing test rank.f08 + rank.$(EXESUFFIX) + +build: rank.$(OBJX) + +verify: ; + +run: rank.$(OBJX) + @echo ------------------------------------ executing test rank.f08 + -rank.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/rio01.mk b/test/f08_correct/inc/rio01.mk new file mode 100644 index 0000000000..5ff96922df --- /dev/null +++ b/test/f08_correct/inc/rio01.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008-Recursive Input/Output feature compliance test +# +# Date of Modification: 17th July 2019 +# + +########## Make rule for test rio01 ######## + + +rio01: rio01.run + +rio01.$(OBJX): $(SRC)/rio01.f08 + -$(RM) rio01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/rio01.f08 -o rio01.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) rio01.$(OBJX) check.$(OBJX) $(LIBS) -o rio01.$(EXESUFFIX) + + +rio01.run: rio01.$(OBJX) + @echo ------------------------------------ executing test rio01 + rio01.$(EXESUFFIX) + +build: rio01.$(OBJX) + +verify: ; + +run: rio01.$(OBJX) + @echo ------------------------------------ executing test rio01 + -export FLANG_RECURSIVE_IO_SUPPORT=1; rio01.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/rio02.mk b/test/f08_correct/inc/rio02.mk new file mode 100644 index 0000000000..bb06e539f0 --- /dev/null +++ b/test/f08_correct/inc/rio02.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008-Recursive Input/Output feature compliance test +# +# Date of Modification: 17th July 2019 +# + +########## Make rule for test rio02 ######## + + +rio02: rio02.run + +rio02.$(OBJX): $(SRC)/rio02.f08 + -$(RM) rio02.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/rio02.f08 -o rio02.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) rio02.$(OBJX) check.$(OBJX) $(LIBS) -o rio02.$(EXESUFFIX) + + +rio02.run: rio02.$(OBJX) + @echo ------------------------------------ executing test rio02 + rio02.$(EXESUFFIX) + +build: rio02.$(OBJX) + +verify: ; + +run: rio02.$(OBJX) + @echo ------------------------------------ executing test rio02 + -export FLANG_RECURSIVE_IO_SUPPORT=1; rio02.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/rio03.mk b/test/f08_correct/inc/rio03.mk new file mode 100644 index 0000000000..a41c415023 --- /dev/null +++ b/test/f08_correct/inc/rio03.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008-Recursive Input/Output feature compliance test +# +# Date of Modification: 17th July 2019 +# + +########## Make rule for test rio03 ######## + + +rio03: rio03.run + +rio03.$(OBJX): $(SRC)/rio03.f08 + -$(RM) rio03.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/rio03.f08 -o rio03.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) rio03.$(OBJX) check.$(OBJX) $(LIBS) -o rio03.$(EXESUFFIX) + + +rio03.run: rio03.$(OBJX) + @echo ------------------------------------ executing test rio03 + rio03.$(EXESUFFIX) + +build: rio03.$(OBJX) + +verify: ; + +run: rio03.$(OBJX) + @echo ------------------------------------ executing test rio03 + -export FLANG_RECURSIVE_IO_SUPPORT=1; rio03.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/rio04.mk b/test/f08_correct/inc/rio04.mk new file mode 100644 index 0000000000..b01e8dbf73 --- /dev/null +++ b/test/f08_correct/inc/rio04.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008-Recursive Input/Output feature compliance test +# +# Date of Modification: 17th July 2019 +# + +########## Make rule for test rio04 ######## + + +rio04: rio04.run + +rio04.$(OBJX): $(SRC)/rio04.f08 + -$(RM) rio04.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/rio04.f08 -o rio04.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) rio04.$(OBJX) check.$(OBJX) $(LIBS) -o rio04.$(EXESUFFIX) + + +rio04.run: rio04.$(OBJX) + @echo ------------------------------------ executing test rio04 + rio04.$(EXESUFFIX) + +build: rio04.$(OBJX) + +verify: ; + +run: rio04.$(OBJX) + @echo ------------------------------------ executing test rio04 + -export FLANG_RECURSIVE_IO_SUPPORT=1; rio04.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/rio05.mk b/test/f08_correct/inc/rio05.mk new file mode 100644 index 0000000000..f5e329e28a --- /dev/null +++ b/test/f08_correct/inc/rio05.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008-Recursive Input/Output feature compliance test +# +# Date of Modification: 17th July 2019 +# + +########## Make rule for test rio05 ######## + + +rio05: rio05.run + +rio05.$(OBJX): $(SRC)/rio05.f08 + -$(RM) rio05.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/rio05.f08 -o rio05.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) rio05.$(OBJX) check.$(OBJX) $(LIBS) -o rio05.$(EXESUFFIX) + + +rio05.run: rio05.$(OBJX) + @echo ------------------------------------ executing test rio05 + rio05.$(EXESUFFIX) + +build: rio05.$(OBJX) + +verify: ; + +run: rio05.$(OBJX) + @echo ------------------------------------ executing test rio05 + -export FLANG_RECURSIVE_IO_SUPPORT=1; rio05.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/rio06.mk b/test/f08_correct/inc/rio06.mk new file mode 100644 index 0000000000..48a9883284 --- /dev/null +++ b/test/f08_correct/inc/rio06.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008-Recursive Input/Output feature compliance test +# +# Date of Modification: 17th July 2019 +# + +########## Make rule for test rio06 ######## + + +rio06: rio06.run + +rio06.$(OBJX): $(SRC)/rio06.f08 + -$(RM) rio06.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/rio06.f08 -o rio06.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) rio06.$(OBJX) check.$(OBJX) $(LIBS) -o rio06.$(EXESUFFIX) + + +rio06.run: rio06.$(OBJX) + @echo ------------------------------------ executing test rio06 + rio06.$(EXESUFFIX) + +build: rio06.$(OBJX) + +verify: ; + +run: rio06.$(OBJX) + @echo ------------------------------------ executing test rio06 + -export FLANG_RECURSIVE_IO_SUPPORT=1; rio06.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/scode01.mk b/test/f08_correct/inc/scode01.mk new file mode 100644 index 0000000000..4694961531 --- /dev/null +++ b/test/f08_correct/inc/scode01.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control +# +# Date of Modification: Sep 10 2019 +# + +########## Make rule for test scode01 ######## + + +scode01: scode01.run + +scode01.$(OBJX): $(SRC)/scode01.f08 + -$(RM) scode01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/scode01.f08 -o scode01.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) scode01.$(OBJX) check.$(OBJX) $(LIBS) -o scode01.$(EXESUFFIX) + + +scode01.run: scode01.$(OBJX) + @echo ------------------------------------ executing test scode01 + scode01.$(EXESUFFIX) + +build: scode01.$(OBJX) + +verify: ; + +run: scode01.$(OBJX) + @echo ------------------------------------ executing test scode01 + -scode01.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/scode02.mk b/test/f08_correct/inc/scode02.mk new file mode 100644 index 0000000000..beaa61dd18 --- /dev/null +++ b/test/f08_correct/inc/scode02.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control +# +# Date of Modification: Sep 10 2019 +# + +########## Make rule for test scode02 ######## + + +scode02: scode02.run + +scode02.$(OBJX): $(SRC)/scode02.f08 + -$(RM) scode02.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/scode02.f08 -o scode02.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) scode02.$(OBJX) check.$(OBJX) $(LIBS) -o scode02.$(EXESUFFIX) + + +scode02.run: scode02.$(OBJX) + @echo ------------------------------------ executing test scode02 + scode02.$(EXESUFFIX) + +build: scode02.$(OBJX) + +verify: ; + +run: scode02.$(OBJX) + @echo ------------------------------------ executing test scode02 + -scode02.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/scode03.mk b/test/f08_correct/inc/scode03.mk new file mode 100644 index 0000000000..d1d13dcda9 --- /dev/null +++ b/test/f08_correct/inc/scode03.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control +# +# Date of Modification: Sep 10 2019 +# + +########## Make rule for test scode03 ######## + + +scode03: scode03.run + +scode03.$(OBJX): $(SRC)/scode03.f08 + -$(RM) scode03.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/scode03.f08 -o scode03.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) scode03.$(OBJX) check.$(OBJX) $(LIBS) -o scode03.$(EXESUFFIX) + + +scode03.run: scode03.$(OBJX) + @echo ------------------------------------ executing test scode03 + scode03.$(EXESUFFIX) + +build: scode03.$(OBJX) + +verify: ; + +run: scode03.$(OBJX) + @echo ------------------------------------ executing test scode03 + -scode03.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/scode04.mk b/test/f08_correct/inc/scode04.mk new file mode 100644 index 0000000000..15c5592ef6 --- /dev/null +++ b/test/f08_correct/inc/scode04.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control +# +# Date of Modification: Sep 10 2019 +# + +########## Make rule for test scode04 ######## + + +scode04: scode04.run + +scode04.$(OBJX): $(SRC)/scode04.f08 + -$(RM) scode04.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/scode04.f08 -o scode04.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) scode04.$(OBJX) check.$(OBJX) $(LIBS) -o scode04.$(EXESUFFIX) + + +scode04.run: scode04.$(OBJX) + @echo ------------------------------------ executing test scode04 + scode04.$(EXESUFFIX) + +build: scode04.$(OBJX) + +verify: ; + +run: scode04.$(OBJX) + @echo ------------------------------------ executing test scode04 + -scode04.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/scode05.mk b/test/f08_correct/inc/scode05.mk new file mode 100644 index 0000000000..b8256651f7 --- /dev/null +++ b/test/f08_correct/inc/scode05.mk @@ -0,0 +1,38 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control +# +# Date of Modification: Sep 10 2019 +# +########## Make rule for test scode05 ######## + +scode05: scode05.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +scode05.$(OBJX): $(SRC)/scode05.f08 + -$(RM) scode05.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/scode05.f08 -o scode05.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) scode05.$(OBJX) check.$(OBJX) $(LIBS) -o scode05.$(EXESUFFIX) ||: + +scode05.run: passok.$(OBJX) + @echo ------------------------------------ executing test scode05 + -passok.$(EXESUFFIX) ||: + +build: scode05.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test scode05 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/scode06.mk b/test/f08_correct/inc/scode06.mk new file mode 100644 index 0000000000..da2971b90b --- /dev/null +++ b/test/f08_correct/inc/scode06.mk @@ -0,0 +1,38 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control +# +# Date of Modification: Sep 10 2019 +# +########## Make rule for test scode06 ######## + +scode06: scode06.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +scode06.$(OBJX): $(SRC)/scode06.f08 + -$(RM) scode06.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/scode06.f08 -o scode06.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) scode06.$(OBJX) check.$(OBJX) $(LIBS) -o scode06.$(EXESUFFIX) ||: + +scode06.run: passok.$(OBJX) + @echo ------------------------------------ executing test scode06 + -passok.$(EXESUFFIX) ||: + +build: scode06.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test scode06 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/scode07.mk b/test/f08_correct/inc/scode07.mk new file mode 100644 index 0000000000..d91e067dc9 --- /dev/null +++ b/test/f08_correct/inc/scode07.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control +# +# Date of Modification: Sep 10 2019 +# + +########## Make rule for test scode07 ######## + + +scode07: scode07.run + +scode07.$(OBJX): $(SRC)/scode07.f08 + -$(RM) scode07.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/scode07.f08 -o scode07.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) scode07.$(OBJX) check.$(OBJX) $(LIBS) -o scode07.$(EXESUFFIX) + + +scode07.run: scode07.$(OBJX) + @echo ------------------------------------ executing test scode07 + scode07.$(EXESUFFIX) + +build: scode07.$(OBJX) + +verify: ; + +run: scode07.$(OBJX) + @echo ------------------------------------ executing test scode07 + -scode07.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/scode08.mk b/test/f08_correct/inc/scode08.mk new file mode 100644 index 0000000000..f5012d7227 --- /dev/null +++ b/test/f08_correct/inc/scode08.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control. +# +# Date of Modification: Sep 25 2019 +# + +########## Make rule for test scode08 ######## + + +scode08: scode08.run + +scode08.$(OBJX): $(SRC)/scode08.f08 + -$(RM) scode08.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/scode08.f08 -o scode08.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) scode08.$(OBJX) check.$(OBJX) $(LIBS) -o scode08.$(EXESUFFIX) + + +scode08.run: scode08.$(OBJX) + @echo ------------------------------------ executing test scode08 + scode08.$(EXESUFFIX) + +build: scode08.$(OBJX) + +verify: ; + +run: scode08.$(OBJX) + @echo ------------------------------------ executing test scode08 + -scode08.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/scode09.mk b/test/f08_correct/inc/scode09.mk new file mode 100644 index 0000000000..9cc1f9e9a6 --- /dev/null +++ b/test/f08_correct/inc/scode09.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control. +# +# Date of Modification: Sep 25 2019 +# + +########## Make rule for test scode09 ######## + + +scode09: scode09.run + +scode09.$(OBJX): $(SRC)/scode09.f08 + -$(RM) scode09.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/scode09.f08 -o scode09.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) scode09.$(OBJX) check.$(OBJX) $(LIBS) -o scode09.$(EXESUFFIX) + + +scode09.run: scode09.$(OBJX) + @echo ------------------------------------ executing test scode09 + scode09.$(EXESUFFIX) + +build: scode09.$(OBJX) + +verify: ; + +run: scode09.$(OBJX) + @echo ------------------------------------ executing test scode09 + -scode09.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/scode10.mk b/test/f08_correct/inc/scode10.mk new file mode 100644 index 0000000000..fdbccdee78 --- /dev/null +++ b/test/f08_correct/inc/scode10.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control. +# +# Date of Modification: Sep 25 2019 +# + +########## Make rule for test scode10 ######## + + +scode10: scode10.run + +scode10.$(OBJX): $(SRC)/scode10.f08 + -$(RM) scode10.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/scode10.f08 -o scode10.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) scode10.$(OBJX) check.$(OBJX) $(LIBS) -o scode10.$(EXESUFFIX) + + +scode10.run: scode10.$(OBJX) + @echo ------------------------------------ executing test scode10 + scode10.$(EXESUFFIX) + +build: scode10.$(OBJX) + +verify: ; + +run: scode10.$(OBJX) + @echo ------------------------------------ executing test scode10 + -scode10.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/scode11.mk b/test/f08_correct/inc/scode11.mk new file mode 100644 index 0000000000..982c72f8d5 --- /dev/null +++ b/test/f08_correct/inc/scode11.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control. +# +# Date of Modification: Nov 12, 2019 +# + +########## Make rule for test scode11 ######## + + +scode11: scode11.run + +scode11.$(OBJX): $(SRC)/scode11.f08 + -$(RM) scode11.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/scode11.f08 -o scode11.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) scode11.$(OBJX) check.$(OBJX) $(LIBS) -o scode11.$(EXESUFFIX) + + +scode11.run: scode11.$(OBJX) + @echo ------------------------------------ executing test scode11 + scode11.$(EXESUFFIX) + +build: scode11.$(OBJX) + +verify: ; + +run: scode11.$(OBJX) + @echo ------------------------------------ executing test scode11 + -scode11.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/scode12.mk b/test/f08_correct/inc/scode12.mk new file mode 100644 index 0000000000..8029677a50 --- /dev/null +++ b/test/f08_correct/inc/scode12.mk @@ -0,0 +1,38 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control +# +# Date of Modification: Nov 12, 2019 +# +########## Make rule for test scode12 ######## + +scode12: scode12.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +scode12.$(OBJX): $(SRC)/scode12.f08 + -$(RM) scode12.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/scode12.f08 -o scode12.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) scode12.$(OBJX) check.$(OBJX) $(LIBS) -o scode12.$(EXESUFFIX) ||: + +scode12.run: passok.$(OBJX) + @echo ------------------------------------ executing test scode12 + -passok.$(EXESUFFIX) ||: + +build: scode12.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test scode12 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/scode13.mk b/test/f08_correct/inc/scode13.mk new file mode 100644 index 0000000000..9a2ef78933 --- /dev/null +++ b/test/f08_correct/inc/scode13.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control. +# +# Date of Modification: Nov 12, 2019 +# + +########## Make rule for test scode13 ######## + + +scode13: scode13.run + +scode13.$(OBJX): $(SRC)/scode13.f08 + -$(RM) scode13.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/scode13.f08 -o scode13.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) scode13.$(OBJX) check.$(OBJX) $(LIBS) -o scode13.$(EXESUFFIX) + + +scode13.run: scode13.$(OBJX) + @echo ------------------------------------ executing test scode13 + scode13.$(EXESUFFIX) + +build: scode13.$(OBJX) + +verify: ; + +run: scode13.$(OBJX) + @echo ------------------------------------ executing test scode13 + -scode13.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/seco01.mk b/test/f08_correct/inc/seco01.mk new file mode 100644 index 0000000000..c1f33d0a1a --- /dev/null +++ b/test/f08_correct/inc/seco01.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control +# + +########## Make rule for test seco01 ######## + + +seco01: seco01.run + +seco01.$(OBJX): $(SRC)/seco01.f08 + -$(RM) seco01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/seco01.f08 -o seco01.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) seco01.$(OBJX) check.$(OBJX) $(LIBS) -o seco01.$(EXESUFFIX) + + +seco01.run: seco01.$(OBJX) + @echo ------------------------------------ executing test seco01 + seco01.$(EXESUFFIX) + +build: seco01.$(OBJX) + +verify: ; + +run: seco01.$(OBJX) + @echo ------------------------------------ executing test seco01 + -seco01.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/seco02.mk b/test/f08_correct/inc/seco02.mk new file mode 100644 index 0000000000..ff19117358 --- /dev/null +++ b/test/f08_correct/inc/seco02.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control +# + +########## Make rule for test seco02 ######## + + +seco02: seco02.run + +seco02.$(OBJX): $(SRC)/seco02.f08 + -$(RM) seco02.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) -ffixed-form $(SRC)/seco02.f08 -o seco02.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) seco02.$(OBJX) check.$(OBJX) $(LIBS) -o seco02.$(EXESUFFIX) + + +seco02.run: seco02.$(OBJX) + @echo ------------------------------------ executing test seco02 + seco02.$(EXESUFFIX) + +build: seco02.$(OBJX) + +verify: ; + +run: seco02.$(OBJX) + @echo ------------------------------------ executing test seco02 + -seco02.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/select01.mk b/test/f08_correct/inc/select01.mk new file mode 100644 index 0000000000..00a828ce24 --- /dev/null +++ b/test/f08_correct/inc/select01.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2020, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Named Select feature +# +# Date of Modification: Jan 20 2020 +# +# Tests the F2008 : Named Select feature +# +########## Make rule for test select01 ######## + +select01: select01.run + +select01.$(OBJX): $(SRC)/select01.f08 + -$(RM) select01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/select01.f08 -o select01.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) select01.$(OBJX) check.$(OBJX) $(LIBS) -o select01.$(EXESUFFIX) + + +select01.run: select01.$(OBJX) + @echo ------------------------------------ executing test select01 + select01.$(EXESUFFIX) + +build: select01.$(OBJX) + +verify: ; + +run: select01.$(OBJX) + @echo ------------------------------------ executing test select01 + -select01.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/selectrealkind.mk b/test/f08_correct/inc/selectrealkind.mk new file mode 100644 index 0000000000..28c2b5d6c0 --- /dev/null +++ b/test/f08_correct/inc/selectrealkind.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for radix in selected_real_kind intrisic intrinsics. +# + +########## Make rule for test selectrealkind ######## + + +selectrealkind: .run + +selectrealkind.$(OBJX): $(SRC)/selectrealkind.f08 + -$(RM) selectrealkind.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/selectrealkind.f08 -o selectrealkind.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) selectrealkind.$(OBJX) check.$(OBJX) $(LIBS) -o selectrealkind.$(EXESUFFIX) + + +selectrealkind.run: selectedrealkind.$(OBJX) + @echo ------------------------------------ executing test selectrealkind + selectrealkind.$(EXESUFFIX) + +build: selectrealkind.$(OBJX) + +verify: ; + +run: selectrealkind.$(OBJX) + @echo ------------------------------------ executing test selectrealkind + selectrealkind.$(EXESUFFIX) + diff --git a/test/f08_correct/inc/storage_size.mk b/test/f08_correct/inc/storage_size.mk new file mode 100644 index 0000000000..e169d4c965 --- /dev/null +++ b/test/f08_correct/inc/storage_size.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for storage_size intrinsic. +# + +########## Make rule for test storage_size ######## + + +storage_size: .run + +storage_size.$(OBJX): $(SRC)/storage_size.f08 + -$(RM) storage_size.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/storage_size.f08 -o storage_size.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) storage_size.$(OBJX) check.$(OBJX) $(LIBS) -o storage_size.$(EXESUFFIX) + + +storage_size.run: storage_size.$(OBJX) + @echo ------------------------------------ executing test storage_size + storage_size.$(EXESUFFIX) + +build: storage_size.$(OBJX) + +verify: ; + +run: storage_size.$(OBJX) + @echo ------------------------------------ executing test storage_size + storage_size.$(EXESUFFIX) + diff --git a/test/f08_correct/inc/test_atan.mk b/test/f08_correct/inc/test_atan.mk new file mode 100644 index 0000000000..b049c4ad28 --- /dev/null +++ b/test/f08_correct/inc/test_atan.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for atan with two arguments +# + +########## Make rule for test test_atan ######## + + +test_atan: .run + +test_atan.$(OBJX): $(SRC)/test_atan.f08 + -$(RM) test_atan.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/test_atan.f08 -o test_atan.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) test_atan.$(OBJX) check.$(OBJX) $(LIBS) -o test_atan.$(EXESUFFIX) + + +test_atan.run: test_atan.$(OBJX) + @echo ------------------------------------ executing test test_atan + test_atan.$(EXESUFFIX) + +build: test_atan.$(OBJX) + +verify: ; + +run: test_atan.$(OBJX) + @echo ------------------------------------ executing test test_atan + test_atan.$(EXESUFFIX) + diff --git a/test/f08_correct/inc/test_atan2.mk b/test/f08_correct/inc/test_atan2.mk new file mode 100644 index 0000000000..219d0288a4 --- /dev/null +++ b/test/f08_correct/inc/test_atan2.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 feature atan2 with complex arguments support +# + +########## Make rule for test test_atan2 ######## + + +test_atan2: .run + +test_atan2.$(OBJX): $(SRC)/test_atan2.f08 + -$(RM) test_atan2.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/test_atan2.f08 -o test_atan2.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) test_atan2.$(OBJX) check.$(OBJX) $(LIBS) -o test_atan2.$(EXESUFFIX) + + +test_atan2.run: test_atan2.$(OBJX) + @echo ------------------------------------ executing test test_atan2 + test_atan2.$(EXESUFFIX) + +build: test_atan2.$(OBJX) + +verify: ; + +run: test_atan2.$(OBJX) + @echo ------------------------------------ executing test test_atan2 + test_atan2.$(EXESUFFIX) + diff --git a/test/f08_correct/inc/type_intr_type.mk b/test/f08_correct/inc/type_intr_type.mk new file mode 100644 index 0000000000..2e047de509 --- /dev/null +++ b/test/f08_correct/inc/type_intr_type.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for type_intr_type intrinsic. +# + +########## Make rule for test type_intr_type ######## + + +type_intr_type: .run + +type_intr_type.$(OBJX): $(SRC)/type_intr_type.f08 + -$(RM) type_intr_type.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/type_intr_type.f08 -o type_intr_type.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) type_intr_type.$(OBJX) check.$(OBJX) $(LIBS) -o type_intr_type.$(EXESUFFIX) + + +type_intr_type.run: type_intr_type.$(OBJX) + @echo ------------------------------------ executing test type_intr_type + type_intr_type.$(EXESUFFIX) + +build: type_intr_type.$(OBJX) + +verify: ; + +run: type_intr_type.$(OBJX) + @echo ------------------------------------ executing test type_intr_type + type_intr_type.$(EXESUFFIX) + diff --git a/test/f08_correct/inc/type_intrinsic.mk b/test/f08_correct/inc/type_intrinsic.mk new file mode 100644 index 0000000000..a79787596f --- /dev/null +++ b/test/f08_correct/inc/type_intrinsic.mk @@ -0,0 +1,31 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# [CPUPC-2836] f2008 feature: type statement for intrinsic types +# +# Date of Modification: 24 January 2020 +# +########## Make rule for test type_intrinsic.f08 ######## + + +type_intrinsic: .run + +type_intrinsic.$(OBJX): $(SRC)/type_intrinsic.f08 + -$(RM) type_intrinsic.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/type_intrinsic.f08 -o type_intrinsic.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) type_intrinsic.$(OBJX) check.$(OBJX) $(LIBS) -o type_intrinsic.$(EXESUFFIX) + + +type_intrinsic.run: type_intrinsic.$(OBJX) + @echo ------------------------------------ executing test type_intrinsic.f08 + type_intrinsic.$(EXESUFFIX) + +build: type_intrinsic.$(OBJX) + +verify: ; + +run: type_intrinsic.$(OBJX) + @echo ------------------------------------ executing test type_intrinsic.f08 + -type_intrinsic.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/uform01.mk b/test/f08_correct/inc/uform01.mk new file mode 100644 index 0000000000..6f8a2b6884 --- /dev/null +++ b/test/f08_correct/inc/uform01.mk @@ -0,0 +1,33 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Error stop code - Execution control +# +# Date of Modification: 1st Sep 2019 +# +# Tests the F2008 :Unlimited format item - Input/Output feature +# for an integer array +# +########## Make rule for test uform01 ######## + +uform01: uform01.run + +uform01.$(OBJX): $(SRC)/uform01.f08 + -$(RM) uform01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/uform01.f08 -o uform01.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) uform01.$(OBJX) check.$(OBJX) $(LIBS) -o uform01.$(EXESUFFIX) + + +uform01.run: uform01.$(OBJX) + @echo ------------------------------------ executing test uform01 + uform01.$(EXESUFFIX) + +build: uform01.$(OBJX) + +verify: ; + +run: uform01.$(OBJX) + @echo ------------------------------------ executing test uform01 + -uform01.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/uform02.mk b/test/f08_correct/inc/uform02.mk new file mode 100644 index 0000000000..9904052f94 --- /dev/null +++ b/test/f08_correct/inc/uform02.mk @@ -0,0 +1,33 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Error stop code - Execution control +# +# Date of Modification: 1st Sep 2019 +# +# Tests the F2008 :Unlimited format item - Input/Output feature +# for an integer array +# +########## Make rule for test uform02 ######## + +uform02: uform02.run + +uform02.$(OBJX): $(SRC)/uform02.f08 + -$(RM) uform02.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/uform02.f08 -o uform02.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) uform02.$(OBJX) check.$(OBJX) $(LIBS) -o uform02.$(EXESUFFIX) + + +uform02.run: uform02.$(OBJX) + @echo ------------------------------------ executing test uform02 + uform02.$(EXESUFFIX) + +build: uform02.$(OBJX) + +verify: ; + +run: uform02.$(OBJX) + @echo ------------------------------------ executing test uform02 + -uform02.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/uform03.mk b/test/f08_correct/inc/uform03.mk new file mode 100644 index 0000000000..649a6ab863 --- /dev/null +++ b/test/f08_correct/inc/uform03.mk @@ -0,0 +1,33 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Error stop code - Execution control +# +# Date of Modification: 1st Sep 2019 +# +# Tests the F2008 :Unlimited format item - Input/Output feature +# for an integer array +# +########## Make rule for test uform03 ######## + +uform03: uform03.run + +uform03.$(OBJX): $(SRC)/uform03.f08 + -$(RM) uform03.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/uform03.f08 -o uform03.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) uform03.$(OBJX) check.$(OBJX) $(LIBS) -o uform03.$(EXESUFFIX) + + +uform03.run: uform03.$(OBJX) + @echo ------------------------------------ executing test uform03 + uform03.$(EXESUFFIX) + +build: uform03.$(OBJX) + +verify: ; + +run: uform03.$(OBJX) + @echo ------------------------------------ executing test uform03 + -uform03.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/uform04.mk b/test/f08_correct/inc/uform04.mk new file mode 100644 index 0000000000..0bce89b017 --- /dev/null +++ b/test/f08_correct/inc/uform04.mk @@ -0,0 +1,33 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Error stop code - Execution control +# +# Date of Modification: 1st Sep 2019 +# +# Tests the F2008 :Unlimited format item - Input/Output feature +# for an integer array +# +########## Make rule for test uform04 ######## + +uform04: uform04.run + +uform04.$(OBJX): $(SRC)/uform04.f08 + -$(RM) uform04.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/uform04.f08 -o uform04.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) uform04.$(OBJX) check.$(OBJX) $(LIBS) -o uform04.$(EXESUFFIX) + + +uform04.run: uform04.$(OBJX) + @echo ------------------------------------ executing test uform04 + uform04.$(EXESUFFIX) + +build: uform04.$(OBJX) + +verify: ; + +run: uform04.$(OBJX) + @echo ------------------------------------ executing test uform04 + -uform04.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/uform05.mk b/test/f08_correct/inc/uform05.mk new file mode 100644 index 0000000000..7e23dafa82 --- /dev/null +++ b/test/f08_correct/inc/uform05.mk @@ -0,0 +1,33 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Error stop code - Execution control +# +# Date of Modification: 1st Sep 2019 +# +# Tests the F2008 :Unlimited format item - Input/Output feature +# for an integer array +# +########## Make rule for test uform05 ######## + +uform05: uform05.run + +uform05.$(OBJX): $(SRC)/uform05.f08 + -$(RM) uform05.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/uform05.f08 -o uform05.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) uform05.$(OBJX) check.$(OBJX) $(LIBS) -o uform05.$(EXESUFFIX) + + +uform05.run: uform05.$(OBJX) + @echo ------------------------------------ executing test uform05 + uform05.$(EXESUFFIX) + +build: uform05.$(OBJX) + +verify: ; + +run: uform05.$(OBJX) + @echo ------------------------------------ executing test uform05 + -uform05.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/uform06.mk b/test/f08_correct/inc/uform06.mk new file mode 100644 index 0000000000..db12f3d286 --- /dev/null +++ b/test/f08_correct/inc/uform06.mk @@ -0,0 +1,33 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Error stop code - Execution control +# +# Date of Modification: 1st Sep 2019 +# +# Tests the F2008 :Unlimited format item - Input/Output feature +# for an integer array +# +########## Make rule for test uform06 ######## + +uform06: uform06.run + +uform06.$(OBJX): $(SRC)/uform06.f08 + -$(RM) uform06.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/uform06.f08 -o uform06.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) uform06.$(OBJX) check.$(OBJX) $(LIBS) -o uform06.$(EXESUFFIX) + + +uform06.run: uform06.$(OBJX) + @echo ------------------------------------ executing test uform06 + uform06.$(EXESUFFIX) + +build: uform06.$(OBJX) + +verify: ; + +run: uform06.$(OBJX) + @echo ------------------------------------ executing test uform06 + -uform06.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/value11.mk b/test/f08_correct/inc/value11.mk new file mode 100644 index 0000000000..4e0a80d6b6 --- /dev/null +++ b/test/f08_correct/inc/value11.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: CPUPC-2052-F2008: In a pure procedure the +# intent of an argument need not be specified if it has the +# value attribute +# +# Date of Modification: Wed Feb 19 14:31:03 IST 2020 +# +########## Make rule for test value11 ######## + +value11: value11.run + +value11.$(OBJX): $(SRC)/value11.f08 + -$(RM) value11.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/value11.f08 -o value11.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) value11.$(OBJX) check.$(OBJX) $(LIBS) -o value11.$(EXESUFFIX) + + +value11.run: value11.$(OBJX) + @echo ------------------------------------ executing test value11 + value11.$(EXESUFFIX) + +build: value11.$(OBJX) + +verify: ; + +run: value11.$(OBJX) + @echo ------------------------------------ executing test value11 + -value11.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/value12.mk b/test/f08_correct/inc/value12.mk new file mode 100644 index 0000000000..c0d5cc5110 --- /dev/null +++ b/test/f08_correct/inc/value12.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: CPUPC-2052-F2008: In a pure procedure the +# intent of an argument need not be specified if it has the +# value attribute +# +# Date of Modification: Wed Feb 19 14:31:03 IST 2020 +# +########## Make rule for test value12 ######## + +value12: value12.run + +value12.$(OBJX): $(SRC)/value12.f08 + -$(RM) value12.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/value12.f08 -o value12.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) value12.$(OBJX) check.$(OBJX) $(LIBS) -o value12.$(EXESUFFIX) + + +value12.run: value12.$(OBJX) + @echo ------------------------------------ executing test value12 + value12.$(EXESUFFIX) + +build: value12.$(OBJX) + +verify: ; + +run: value12.$(OBJX) + @echo ------------------------------------ executing test value12 + -value12.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/value13.mk b/test/f08_correct/inc/value13.mk new file mode 100644 index 0000000000..5a9f4ed6d0 --- /dev/null +++ b/test/f08_correct/inc/value13.mk @@ -0,0 +1,40 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: CPUPC-2052-F2008: In a pure procedure the +# intent of an argument need not be specified if it has the +# value attribute +# +# Date of Modification: Wed Feb 19 14:31:03 IST 2020 +# +########## Make rule for test value13 ######## + +value13: value13.run + +#include ./passok.mk + +passok.$(OBJX): $(SRC)/passok.f08 + -$(RM) passok.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/passok.f08 -o passok.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) passok.$(OBJX) check.$(OBJX) $(LIBS) -o passok.$(EXESUFFIX) + +value13.$(OBJX): $(SRC)/value13.f08 + -$(RM) value13.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + #-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/value13.f08 -o value13.$(OBJX) ||: + #-$(FC) $(FFLAGS) $(LDFLAGS) value13.$(OBJX) check.$(OBJX) $(LIBS) -o value13.$(EXESUFFIX) ||: + +value13.run: passok.$(OBJX) + @echo ------------------------------------ executing test value13 + -passok.$(EXESUFFIX) ||: + +build: value13.$(OBJX) + +verify: ; + +run: passok.$(OBJX) + @echo ------------------------------------ executing test value13 + -passok.$(EXESUFFIX) ||: diff --git a/test/f08_correct/inc/value14.mk b/test/f08_correct/inc/value14.mk new file mode 100644 index 0000000000..86bc5e6403 --- /dev/null +++ b/test/f08_correct/inc/value14.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: CPUPC-2052-F2008: In a pure procedure the +# intent of an argument need not be specified if it has the +# value attribute +# +# Date of Modification: Wed Feb 19 14:31:03 IST 2020 +# +########## Make rule for test value14 ######## + +value14: value14.run + +value14.$(OBJX): $(SRC)/value14.f08 + -$(RM) value14.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/value14.f08 -o value14.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) value14.$(OBJX) check.$(OBJX) $(LIBS) -o value14.$(EXESUFFIX) + + +value14.run: value14.$(OBJX) + @echo ------------------------------------ executing test value14 + value14.$(EXESUFFIX) + +build: value14.$(OBJX) + +verify: ; + +run: value14.$(OBJX) + @echo ------------------------------------ executing test value14 + -value14.$(EXESUFFIX) ||: diff --git a/test/f08_correct/lit/assumedsize_array.sh b/test/f08_correct/lit/assumedsize_array.sh new file mode 100644 index 0000000000..f0f03d2c10 --- /dev/null +++ b/test/f08_correct/lit/assumedsize_array.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for assumed size array as parameter +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bessel.sh b/test/f08_correct/lit/bessel.sh new file mode 100644 index 0000000000..a5b3bdb7df --- /dev/null +++ b/test/f08_correct/lit/bessel.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for F2008 feature bessel intrinsic +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitcmp01.sh b/test/f08_correct/lit/bitcmp01.sh new file mode 100644 index 0000000000..9684217a43 --- /dev/null +++ b/test/f08_correct/lit/bitcmp01.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for Bit Sequence Comparsion intrinsics. +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitcmp02.sh b/test/f08_correct/lit/bitcmp02.sh new file mode 100644 index 0000000000..9684217a43 --- /dev/null +++ b/test/f08_correct/lit/bitcmp02.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for Bit Sequence Comparsion intrinsics. +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitcmp03.sh b/test/f08_correct/lit/bitcmp03.sh new file mode 100644 index 0000000000..9684217a43 --- /dev/null +++ b/test/f08_correct/lit/bitcmp03.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for Bit Sequence Comparsion intrinsics. +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint01.sh b/test/f08_correct/lit/bitint01.sh new file mode 100644 index 0000000000..98e49bcd86 --- /dev/null +++ b/test/f08_correct/lit/bitint01.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Bitint intrinsics tests +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint02.sh b/test/f08_correct/lit/bitint02.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint02.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint03.sh b/test/f08_correct/lit/bitint03.sh new file mode 100644 index 0000000000..d12563316e --- /dev/null +++ b/test/f08_correct/lit/bitint03.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that operate on bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint04.sh b/test/f08_correct/lit/bitint04.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint04.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint05.sh b/test/f08_correct/lit/bitint05.sh new file mode 100644 index 0000000000..466abc9e58 --- /dev/null +++ b/test/f08_correct/lit/bitint05.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that operate on bit parameters +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint06.sh b/test/f08_correct/lit/bitint06.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint06.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint07.sh b/test/f08_correct/lit/bitint07.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint07.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint08.sh b/test/f08_correct/lit/bitint08.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint08.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint09.sh b/test/f08_correct/lit/bitint09.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint09.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint10.sh b/test/f08_correct/lit/bitint10.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint10.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint11.sh b/test/f08_correct/lit/bitint11.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint11.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint12.sh b/test/f08_correct/lit/bitint12.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint12.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint13.sh b/test/f08_correct/lit/bitint13.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint13.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint14.sh b/test/f08_correct/lit/bitint14.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint14.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint15.sh b/test/f08_correct/lit/bitint15.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint15.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint16.sh b/test/f08_correct/lit/bitint16.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint16.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint17.sh b/test/f08_correct/lit/bitint17.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint17.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint18.sh b/test/f08_correct/lit/bitint18.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint18.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint19.sh b/test/f08_correct/lit/bitint19.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint19.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint20.sh b/test/f08_correct/lit/bitint20.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint20.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint21.sh b/test/f08_correct/lit/bitint21.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint21.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint22.sh b/test/f08_correct/lit/bitint22.sh new file mode 100644 index 0000000000..a24f292a3f --- /dev/null +++ b/test/f08_correct/lit/bitint22.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take on bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint23.sh b/test/f08_correct/lit/bitint23.sh new file mode 100644 index 0000000000..a24f292a3f --- /dev/null +++ b/test/f08_correct/lit/bitint23.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take on bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint24.sh b/test/f08_correct/lit/bitint24.sh new file mode 100644 index 0000000000..a24f292a3f --- /dev/null +++ b/test/f08_correct/lit/bitint24.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take on bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint25.sh b/test/f08_correct/lit/bitint25.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint25.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint26.sh b/test/f08_correct/lit/bitint26.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint26.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint27.sh b/test/f08_correct/lit/bitint27.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint27.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint28.sh b/test/f08_correct/lit/bitint28.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint28.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint29.sh b/test/f08_correct/lit/bitint29.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint29.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint30.sh b/test/f08_correct/lit/bitint30.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint30.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint31.sh b/test/f08_correct/lit/bitint31.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint31.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint32.sh b/test/f08_correct/lit/bitint32.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint32.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint33.sh b/test/f08_correct/lit/bitint33.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint33.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint34.sh b/test/f08_correct/lit/bitint34.sh new file mode 100644 index 0000000000..f1f44908ba --- /dev/null +++ b/test/f08_correct/lit/bitint34.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Mon Feb 17 14:11:26 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint35.sh b/test/f08_correct/lit/bitint35.sh new file mode 100644 index 0000000000..93120b9150 --- /dev/null +++ b/test/f08_correct/lit/bitint35.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Thu Mar 19 10:54:19 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitint36.sh b/test/f08_correct/lit/bitint36.sh new file mode 100644 index 0000000000..93120b9150 --- /dev/null +++ b/test/f08_correct/lit/bitint36.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Intrinsics that take bit operands +# +# Date of Modification: Thu Mar 19 10:54:19 IST 2020 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitmask01.sh b/test/f08_correct/lit/bitmask01.sh new file mode 100644 index 0000000000..2d94aba741 --- /dev/null +++ b/test/f08_correct/lit/bitmask01.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for Bit Masking intrinsics. +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/bitshift01.sh b/test/f08_correct/lit/bitshift01.sh new file mode 100644 index 0000000000..8141a12da3 --- /dev/null +++ b/test/f08_correct/lit/bitshift01.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for Bit Shifting intrinsics. +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/blk01.sh b/test/f08_correct/lit/blk01.sh new file mode 100644 index 0000000000..86a85b2f48 --- /dev/null +++ b/test/f08_correct/lit/blk01.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2613-F2008: The BLOCK construct allows declarations of +# entities within executable code. +# +# Date of Modification: Fri November 8th, 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/blk02.sh b/test/f08_correct/lit/blk02.sh new file mode 100644 index 0000000000..86a85b2f48 --- /dev/null +++ b/test/f08_correct/lit/blk02.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2613-F2008: The BLOCK construct allows declarations of +# entities within executable code. +# +# Date of Modification: Fri November 8th, 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/blk03.sh b/test/f08_correct/lit/blk03.sh new file mode 100644 index 0000000000..86a85b2f48 --- /dev/null +++ b/test/f08_correct/lit/blk03.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2613-F2008: The BLOCK construct allows declarations of +# entities within executable code. +# +# Date of Modification: Fri November 8th, 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/blk04.sh b/test/f08_correct/lit/blk04.sh new file mode 100644 index 0000000000..86a85b2f48 --- /dev/null +++ b/test/f08_correct/lit/blk04.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2613-F2008: The BLOCK construct allows declarations of +# entities within executable code. +# +# Date of Modification: Fri November 8th, 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/blk05.sh b/test/f08_correct/lit/blk05.sh new file mode 100644 index 0000000000..86a85b2f48 --- /dev/null +++ b/test/f08_correct/lit/blk05.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2613-F2008: The BLOCK construct allows declarations of +# entities within executable code. +# +# Date of Modification: Fri November 8th, 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/blk06.sh b/test/f08_correct/lit/blk06.sh new file mode 100644 index 0000000000..86a85b2f48 --- /dev/null +++ b/test/f08_correct/lit/blk06.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2613-F2008: The BLOCK construct allows declarations of +# entities within executable code. +# +# Date of Modification: Fri November 8th, 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/blk07.sh b/test/f08_correct/lit/blk07.sh new file mode 100644 index 0000000000..86a85b2f48 --- /dev/null +++ b/test/f08_correct/lit/blk07.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2613-F2008: The BLOCK construct allows declarations of +# entities within executable code. +# +# Date of Modification: Fri November 8th, 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/blk08.sh b/test/f08_correct/lit/blk08.sh new file mode 100644 index 0000000000..86a85b2f48 --- /dev/null +++ b/test/f08_correct/lit/blk08.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2613-F2008: The BLOCK construct allows declarations of +# entities within executable code. +# +# Date of Modification: Fri November 8th, 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/blk09.sh b/test/f08_correct/lit/blk09.sh new file mode 100644 index 0000000000..86a85b2f48 --- /dev/null +++ b/test/f08_correct/lit/blk09.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2613-F2008: The BLOCK construct allows declarations of +# entities within executable code. +# +# Date of Modification: Fri November 8th, 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/blk10.sh b/test/f08_correct/lit/blk10.sh new file mode 100644 index 0000000000..86a85b2f48 --- /dev/null +++ b/test/f08_correct/lit/blk10.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2613-F2008: The BLOCK construct allows declarations of +# entities within executable code. +# +# Date of Modification: Fri November 8th, 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/blk11.sh b/test/f08_correct/lit/blk11.sh new file mode 100644 index 0000000000..86a85b2f48 --- /dev/null +++ b/test/f08_correct/lit/blk11.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2613-F2008: The BLOCK construct allows declarations of +# entities within executable code. +# +# Date of Modification: Fri November 8th, 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/cmplx_hyp.sh b/test/f08_correct/lit/cmplx_hyp.sh new file mode 100644 index 0000000000..59dc9f92fe --- /dev/null +++ b/test/f08_correct/lit/cmplx_hyp.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# [CPUPC-2569]Complex data types support for acosh, asinh and atanh +# +# Date of Modification: 07 January 2020 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/combined_shift01.sh b/test/f08_correct/lit/combined_shift01.sh new file mode 100644 index 0000000000..404d42b629 --- /dev/null +++ b/test/f08_correct/lit/combined_shift01.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for Combined Bit Shifting intrinsic. +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/editd01.sh b/test/f08_correct/lit/editd01.sh new file mode 100644 index 0000000000..ed0dbe3d4e --- /dev/null +++ b/test/f08_correct/lit/editd01.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: G0 Edit descriptor - Input/Output extensions +# +# Date of Modification: 31st Aug 2019 + +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/editd02.sh b/test/f08_correct/lit/editd02.sh new file mode 100644 index 0000000000..ed0dbe3d4e --- /dev/null +++ b/test/f08_correct/lit/editd02.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: G0 Edit descriptor - Input/Output extensions +# +# Date of Modification: 31st Aug 2019 + +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/editd03.sh b/test/f08_correct/lit/editd03.sh new file mode 100644 index 0000000000..ed0dbe3d4e --- /dev/null +++ b/test/f08_correct/lit/editd03.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: G0 Edit descriptor - Input/Output extensions +# +# Date of Modification: 31st Aug 2019 + +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/editd04.sh b/test/f08_correct/lit/editd04.sh new file mode 100644 index 0000000000..ed0dbe3d4e --- /dev/null +++ b/test/f08_correct/lit/editd04.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: G0 Edit descriptor - Input/Output extensions +# +# Date of Modification: 31st Aug 2019 + +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/editd05.sh b/test/f08_correct/lit/editd05.sh new file mode 100644 index 0000000000..ed0dbe3d4e --- /dev/null +++ b/test/f08_correct/lit/editd05.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: G0 Edit descriptor - Input/Output extensions +# +# Date of Modification: 31st Aug 2019 + +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/estop01.sh b/test/f08_correct/lit/estop01.sh new file mode 100644 index 0000000000..34a6327df4 --- /dev/null +++ b/test/f08_correct/lit/estop01.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Error stop code - Execution control +# +# Date of Modification: 25th July 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/estop02.sh b/test/f08_correct/lit/estop02.sh new file mode 100644 index 0000000000..34a6327df4 --- /dev/null +++ b/test/f08_correct/lit/estop02.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Error stop code - Execution control +# +# Date of Modification: 25th July 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/estop03.sh b/test/f08_correct/lit/estop03.sh new file mode 100644 index 0000000000..34a6327df4 --- /dev/null +++ b/test/f08_correct/lit/estop03.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Error stop code - Execution control +# +# Date of Modification: 25th July 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/estop04.sh b/test/f08_correct/lit/estop04.sh new file mode 100644 index 0000000000..34a6327df4 --- /dev/null +++ b/test/f08_correct/lit/estop04.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Error stop code - Execution control +# +# Date of Modification: 25th July 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/exec_cmd01.sh b/test/f08_correct/lit/exec_cmd01.sh new file mode 100644 index 0000000000..aee8aa27ae --- /dev/null +++ b/test/f08_correct/lit/exec_cmd01.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for execute_command_line as per f2008 standard +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# REQUIRES : Linux +# RUN: cp %S/../Inputs/input_for_exec_cmdline.txt . +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake +# RUN: diff input_for_exec_cmdline.txt output_file.txt diff --git a/test/f08_correct/lit/exec_cmd02.sh b/test/f08_correct/lit/exec_cmd02.sh new file mode 100644 index 0000000000..b7e9ac6036 --- /dev/null +++ b/test/f08_correct/lit/exec_cmd02.sh @@ -0,0 +1,15 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for execute_command_line as per f2008 standard +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# REQUIRES : Linux +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake > %t +# RUN: cat %t | FileCheck %s + +# CHECK: Hello World +# CHECK-NEXT : This is synchronous +# CHECK-NEXT : Exit status is 0 diff --git a/test/f08_correct/lit/exit01.sh b/test/f08_correct/lit/exit01.sh new file mode 100644 index 0000000000..9052bca420 --- /dev/null +++ b/test/f08_correct/lit/exit01.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2013: F2008-Exit statement-Execution control +# +# Date of Modification: 23rd Sep 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/exit02.sh b/test/f08_correct/lit/exit02.sh new file mode 100644 index 0000000000..9052bca420 --- /dev/null +++ b/test/f08_correct/lit/exit02.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2013: F2008-Exit statement-Execution control +# +# Date of Modification: 23rd Sep 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/exit03.sh b/test/f08_correct/lit/exit03.sh new file mode 100644 index 0000000000..9052bca420 --- /dev/null +++ b/test/f08_correct/lit/exit03.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2013: F2008-Exit statement-Execution control +# +# Date of Modification: 23rd Sep 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/exit04.sh b/test/f08_correct/lit/exit04.sh new file mode 100644 index 0000000000..9052bca420 --- /dev/null +++ b/test/f08_correct/lit/exit04.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2013: F2008-Exit statement-Execution control +# +# Date of Modification: 23rd Sep 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/exit05.sh b/test/f08_correct/lit/exit05.sh new file mode 100644 index 0000000000..9052bca420 --- /dev/null +++ b/test/f08_correct/lit/exit05.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2013: F2008-Exit statement-Execution control +# +# Date of Modification: 23rd Sep 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/exit06.sh b/test/f08_correct/lit/exit06.sh new file mode 100644 index 0000000000..9052bca420 --- /dev/null +++ b/test/f08_correct/lit/exit06.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# CPUPC-2013: F2008-Exit statement-Execution control +# +# Date of Modification: 23rd Sep 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/gamma.sh b/test/f08_correct/lit/gamma.sh new file mode 100644 index 0000000000..df14c0a4c8 --- /dev/null +++ b/test/f08_correct/lit/gamma.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for F2008 feature gamma intrinsic +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/iall.sh b/test/f08_correct/lit/iall.sh new file mode 100644 index 0000000000..4227d4bd1b --- /dev/null +++ b/test/f08_correct/lit/iall.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for F2008 feature iall intrinsic +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/iany.sh b/test/f08_correct/lit/iany.sh new file mode 100644 index 0000000000..cba8b83749 --- /dev/null +++ b/test/f08_correct/lit/iany.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for F2008 feature iany intrinsic +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/impure01.sh b/test/f08_correct/lit/impure01.sh new file mode 100644 index 0000000000..d9efd65f79 --- /dev/null +++ b/test/f08_correct/lit/impure01.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/impure02.sh b/test/f08_correct/lit/impure02.sh new file mode 100644 index 0000000000..d9efd65f79 --- /dev/null +++ b/test/f08_correct/lit/impure02.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/impure03.sh b/test/f08_correct/lit/impure03.sh new file mode 100644 index 0000000000..d9efd65f79 --- /dev/null +++ b/test/f08_correct/lit/impure03.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/impure04.sh b/test/f08_correct/lit/impure04.sh new file mode 100644 index 0000000000..d9efd65f79 --- /dev/null +++ b/test/f08_correct/lit/impure04.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/impure05.sh b/test/f08_correct/lit/impure05.sh new file mode 100644 index 0000000000..d9efd65f79 --- /dev/null +++ b/test/f08_correct/lit/impure05.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/impure06.sh b/test/f08_correct/lit/impure06.sh new file mode 100644 index 0000000000..d9efd65f79 --- /dev/null +++ b/test/f08_correct/lit/impure06.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/impure07.sh b/test/f08_correct/lit/impure07.sh new file mode 100644 index 0000000000..d9efd65f79 --- /dev/null +++ b/test/f08_correct/lit/impure07.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/impure08.sh b/test/f08_correct/lit/impure08.sh new file mode 100644 index 0000000000..d9efd65f79 --- /dev/null +++ b/test/f08_correct/lit/impure08.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/impure09.sh b/test/f08_correct/lit/impure09.sh new file mode 100644 index 0000000000..d9efd65f79 --- /dev/null +++ b/test/f08_correct/lit/impure09.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/impure10.sh b/test/f08_correct/lit/impure10.sh new file mode 100644 index 0000000000..d9efd65f79 --- /dev/null +++ b/test/f08_correct/lit/impure10.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/impure11.sh b/test/f08_correct/lit/impure11.sh new file mode 100644 index 0000000000..d9efd65f79 --- /dev/null +++ b/test/f08_correct/lit/impure11.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/impure12.sh b/test/f08_correct/lit/impure12.sh new file mode 100644 index 0000000000..d9efd65f79 --- /dev/null +++ b/test/f08_correct/lit/impure12.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/impure13.sh b/test/f08_correct/lit/impure13.sh new file mode 100644 index 0000000000..d9efd65f79 --- /dev/null +++ b/test/f08_correct/lit/impure13.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/impure14.sh b/test/f08_correct/lit/impure14.sh new file mode 100644 index 0000000000..d9efd65f79 --- /dev/null +++ b/test/f08_correct/lit/impure14.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/impure15.sh b/test/f08_correct/lit/impure15.sh new file mode 100644 index 0000000000..d9efd65f79 --- /dev/null +++ b/test/f08_correct/lit/impure15.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/impure16.sh b/test/f08_correct/lit/impure16.sh new file mode 100644 index 0000000000..d9efd65f79 --- /dev/null +++ b/test/f08_correct/lit/impure16.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +# +# Date of Modification: Fri Oct 18 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/iparity.sh b/test/f08_correct/lit/iparity.sh new file mode 100644 index 0000000000..91d0f38d90 --- /dev/null +++ b/test/f08_correct/lit/iparity.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for F2008 feature iparity intrinsic +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/longintforall.sh b/test/f08_correct/lit/longintforall.sh new file mode 100644 index 0000000000..f69cf44d68 --- /dev/null +++ b/test/f08_correct/lit/longintforall.sh @@ -0,0 +1,16 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for F2008 feature longintforall intrinsic +# + +# Shared lit script for each tests. Run bash commands that run tests with make. +#===----------------------------------------------------------------------===// +# +# Date of Modification : 19th July 2019 +# Added a new test for use of kind of a forall index +# +#===----------------------------------------------------------------------===// + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/maxdim01.sh b/test/f08_correct/lit/maxdim01.sh new file mode 100644 index 0000000000..d7bbc9bc2a --- /dev/null +++ b/test/f08_correct/lit/maxdim01.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for maximum dimension as per f2008 standard +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/maxdim02.sh b/test/f08_correct/lit/maxdim02.sh new file mode 100644 index 0000000000..d7bbc9bc2a --- /dev/null +++ b/test/f08_correct/lit/maxdim02.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for maximum dimension as per f2008 standard +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/maxdim03.sh b/test/f08_correct/lit/maxdim03.sh new file mode 100644 index 0000000000..d7bbc9bc2a --- /dev/null +++ b/test/f08_correct/lit/maxdim03.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for maximum dimension as per f2008 standard +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/merge_bits01.sh b/test/f08_correct/lit/merge_bits01.sh new file mode 100644 index 0000000000..d173bfd370 --- /dev/null +++ b/test/f08_correct/lit/merge_bits01.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for MERGE_BITS intrinsic. +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/mold-source.sh b/test/f08_correct/lit/mold-source.sh new file mode 100644 index 0000000000..c7574a8be4 --- /dev/null +++ b/test/f08_correct/lit/mold-source.sh @@ -0,0 +1,16 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for F2008 feature mold and source +# + +# Shared lit script for each tests. Run bash commands that run tests with make. +#===----------------------------------------------------------------------===// +# +# Date of Modification : 30th September 2019 +# Added a new test for Copying the properties of an object in an allocate statement +# +#===----------------------------------------------------------------------===// + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/newunit01.sh b/test/f08_correct/lit/newunit01.sh new file mode 100644 index 0000000000..f51b130424 --- /dev/null +++ b/test/f08_correct/lit/newunit01.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008-New Unit Specifier feature compliance test +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/newunit02.sh b/test/f08_correct/lit/newunit02.sh new file mode 100644 index 0000000000..daf0f4d501 --- /dev/null +++ b/test/f08_correct/lit/newunit02.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Revert to the old value when newunit has errors. +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/nm01.sh b/test/f08_correct/lit/nm01.sh new file mode 100644 index 0000000000..5c32e654b0 --- /dev/null +++ b/test/f08_correct/lit/nm01.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2018, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for DNORM intrinsic +# +# Date of Modification: 21st February 2019 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/nm02.sh b/test/f08_correct/lit/nm02.sh new file mode 100644 index 0000000000..5c32e654b0 --- /dev/null +++ b/test/f08_correct/lit/nm02.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2018, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for DNORM intrinsic +# +# Date of Modification: 21st February 2019 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/nm03.sh b/test/f08_correct/lit/nm03.sh new file mode 100644 index 0000000000..5c32e654b0 --- /dev/null +++ b/test/f08_correct/lit/nm03.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2018, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for DNORM intrinsic +# +# Date of Modification: 21st February 2019 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/nm04.sh b/test/f08_correct/lit/nm04.sh new file mode 100644 index 0000000000..25e81e0709 --- /dev/null +++ b/test/f08_correct/lit/nm04.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2018, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for array expression in norm2 intrinsic +# Date of modification 28th October 2019 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/parity.sh b/test/f08_correct/lit/parity.sh new file mode 100644 index 0000000000..36f4715205 --- /dev/null +++ b/test/f08_correct/lit/parity.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for F2008 feature parity intrinsic +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/pointer_init01.sh b/test/f08_correct/lit/pointer_init01.sh new file mode 100644 index 0000000000..fea1d6a221 --- /dev/null +++ b/test/f08_correct/lit/pointer_init01.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for pointer initialization as per f2008 standard +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/rank.sh b/test/f08_correct/lit/rank.sh new file mode 100644 index 0000000000..714d4642b4 --- /dev/null +++ b/test/f08_correct/lit/rank.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# [CPUPC-3849] Rank intrinsic for flang +# +# Date of Modification: 10th Aug 2020 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/rio01.sh b/test/f08_correct/lit/rio01.sh new file mode 100644 index 0000000000..cd6df58f05 --- /dev/null +++ b/test/f08_correct/lit/rio01.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008-Recursive Input/Output feature compliance test +# +# Date of Modification: 17th July 2019 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/rio02.sh b/test/f08_correct/lit/rio02.sh new file mode 100644 index 0000000000..cd6df58f05 --- /dev/null +++ b/test/f08_correct/lit/rio02.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008-Recursive Input/Output feature compliance test +# +# Date of Modification: 17th July 2019 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/rio03.sh b/test/f08_correct/lit/rio03.sh new file mode 100644 index 0000000000..cd6df58f05 --- /dev/null +++ b/test/f08_correct/lit/rio03.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008-Recursive Input/Output feature compliance test +# +# Date of Modification: 17th July 2019 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/rio04.sh b/test/f08_correct/lit/rio04.sh new file mode 100644 index 0000000000..cd6df58f05 --- /dev/null +++ b/test/f08_correct/lit/rio04.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008-Recursive Input/Output feature compliance test +# +# Date of Modification: 17th July 2019 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/rio05.sh b/test/f08_correct/lit/rio05.sh new file mode 100644 index 0000000000..cd6df58f05 --- /dev/null +++ b/test/f08_correct/lit/rio05.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008-Recursive Input/Output feature compliance test +# +# Date of Modification: 17th July 2019 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/rio06.sh b/test/f08_correct/lit/rio06.sh new file mode 100644 index 0000000000..cd6df58f05 --- /dev/null +++ b/test/f08_correct/lit/rio06.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008-Recursive Input/Output feature compliance test +# +# Date of Modification: 17th July 2019 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/runmake b/test/f08_correct/lit/runmake new file mode 100644 index 0000000000..c5a0dd716d --- /dev/null +++ b/test/f08_correct/lit/runmake @@ -0,0 +1,28 @@ +# +# Copyright (c) 2018, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for DNORM intrinsic +# +# Date of Modification: 21st February 2019 +# + +test_name=${TEST_SRC##*/} # Strip path. +test_name=${test_name%.*} # Strip extension. + +temp_dir="$test_name" +rm -rf $temp_dir + +MAKE_FILE=$MAKE_FILE_DIR/makefile + +mkdir $temp_dir +if [[ ! $KEEP_FILES ]]; then + # If keep files is not specified, remove these files at the end. + trap "rm -rf $(pwd)/$temp_dir" EXIT +fi +cd $temp_dir +export PATH=$PATH:$(pwd) + +make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 +make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 +make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 +# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|^[[:space:]]*PASS(ED)?[[:space:]])}} diff --git a/test/f08_correct/lit/scode01.sh b/test/f08_correct/lit/scode01.sh new file mode 100644 index 0000000000..79a54a189c --- /dev/null +++ b/test/f08_correct/lit/scode01.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control +# +# Date of Modification: Sep 10 2019 +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/scode02.sh b/test/f08_correct/lit/scode02.sh new file mode 100644 index 0000000000..77254329bd --- /dev/null +++ b/test/f08_correct/lit/scode02.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control +# +# Date of Modification: Sep 10 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/scode03.sh b/test/f08_correct/lit/scode03.sh new file mode 100644 index 0000000000..77254329bd --- /dev/null +++ b/test/f08_correct/lit/scode03.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control +# +# Date of Modification: Sep 10 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/scode04.sh b/test/f08_correct/lit/scode04.sh new file mode 100644 index 0000000000..77254329bd --- /dev/null +++ b/test/f08_correct/lit/scode04.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control +# +# Date of Modification: Sep 10 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/scode05.sh b/test/f08_correct/lit/scode05.sh new file mode 100644 index 0000000000..77254329bd --- /dev/null +++ b/test/f08_correct/lit/scode05.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control +# +# Date of Modification: Sep 10 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/scode06.sh b/test/f08_correct/lit/scode06.sh new file mode 100644 index 0000000000..77254329bd --- /dev/null +++ b/test/f08_correct/lit/scode06.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control +# +# Date of Modification: Sep 10 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/scode07.sh b/test/f08_correct/lit/scode07.sh new file mode 100644 index 0000000000..77254329bd --- /dev/null +++ b/test/f08_correct/lit/scode07.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control +# +# Date of Modification: Sep 10 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/scode08.sh b/test/f08_correct/lit/scode08.sh new file mode 100644 index 0000000000..53fa3c0bc1 --- /dev/null +++ b/test/f08_correct/lit/scode08.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control. +# +# Date of Modification: Sep 25 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/scode09.sh b/test/f08_correct/lit/scode09.sh new file mode 100644 index 0000000000..53fa3c0bc1 --- /dev/null +++ b/test/f08_correct/lit/scode09.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control. +# +# Date of Modification: Sep 25 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/scode10.sh b/test/f08_correct/lit/scode10.sh new file mode 100644 index 0000000000..53fa3c0bc1 --- /dev/null +++ b/test/f08_correct/lit/scode10.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control. +# +# Date of Modification: Sep 25 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/scode11.sh b/test/f08_correct/lit/scode11.sh new file mode 100644 index 0000000000..fee2dbc45a --- /dev/null +++ b/test/f08_correct/lit/scode11.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control. +# +# Date of Modification: Nov 12, 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/scode12.sh b/test/f08_correct/lit/scode12.sh new file mode 100644 index 0000000000..fee2dbc45a --- /dev/null +++ b/test/f08_correct/lit/scode12.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control. +# +# Date of Modification: Nov 12, 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/scode13.sh b/test/f08_correct/lit/scode13.sh new file mode 100644 index 0000000000..fee2dbc45a --- /dev/null +++ b/test/f08_correct/lit/scode13.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control. +# +# Date of Modification: Nov 12, 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/seco01.sh b/test/f08_correct/lit/seco01.sh new file mode 100644 index 0000000000..685abb947b --- /dev/null +++ b/test/f08_correct/lit/seco01.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Semicolon at line start - Source form +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/seco02.sh b/test/f08_correct/lit/seco02.sh new file mode 100644 index 0000000000..2264b19613 --- /dev/null +++ b/test/f08_correct/lit/seco02.sh @@ -0,0 +1,11 @@ + +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Semicolon at line start - Source form +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/select01.sh b/test/f08_correct/lit/select01.sh new file mode 100644 index 0000000000..4ae033a4ea --- /dev/null +++ b/test/f08_correct/lit/select01.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2020, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Named Select feature +# +# Date of Modification: Jan 20 2020 +# +# Tests the F2008 : Named Select feature +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/selectrealkind.sh b/test/f08_correct/lit/selectrealkind.sh new file mode 100644 index 0000000000..066196c3b3 --- /dev/null +++ b/test/f08_correct/lit/selectrealkind.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for radix in selected_real_kind intrinsic procedure +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake + diff --git a/test/f08_correct/lit/storage_size.sh b/test/f08_correct/lit/storage_size.sh new file mode 100644 index 0000000000..8d72c21300 --- /dev/null +++ b/test/f08_correct/lit/storage_size.sh @@ -0,0 +1,8 @@ +# +# Support for F2008 feature storage_size intrinsic +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/test_atan.sh b/test/f08_correct/lit/test_atan.sh new file mode 100644 index 0000000000..9e5601113a --- /dev/null +++ b/test/f08_correct/lit/test_atan.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for F2008 feature atan with two arguments +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/type_intr_type.sh b/test/f08_correct/lit/type_intr_type.sh new file mode 100644 index 0000000000..6d3e5b5149 --- /dev/null +++ b/test/f08_correct/lit/type_intr_type.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for F2008 feature type_intr_type intrinsic +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/type_intrinsic.sh b/test/f08_correct/lit/type_intrinsic.sh new file mode 100644 index 0000000000..dd519eae3c --- /dev/null +++ b/test/f08_correct/lit/type_intrinsic.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# [CPUPC-2836] f2008 feature: type statement for intrinsic types +# +# Date of Modification: 24 January 2020 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/uform01.sh b/test/f08_correct/lit/uform01.sh new file mode 100644 index 0000000000..58e397ec24 --- /dev/null +++ b/test/f08_correct/lit/uform01.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Error stop code - Execution control +# +# Date of Modification: 1st Sep 2019 +# +# Tests the F2008 :Unlimited format item - Input/Output feature +# for an integer array +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/uform02.sh b/test/f08_correct/lit/uform02.sh new file mode 100644 index 0000000000..58e397ec24 --- /dev/null +++ b/test/f08_correct/lit/uform02.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Error stop code - Execution control +# +# Date of Modification: 1st Sep 2019 +# +# Tests the F2008 :Unlimited format item - Input/Output feature +# for an integer array +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/uform03.sh b/test/f08_correct/lit/uform03.sh new file mode 100644 index 0000000000..58e397ec24 --- /dev/null +++ b/test/f08_correct/lit/uform03.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Error stop code - Execution control +# +# Date of Modification: 1st Sep 2019 +# +# Tests the F2008 :Unlimited format item - Input/Output feature +# for an integer array +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/uform04.sh b/test/f08_correct/lit/uform04.sh new file mode 100644 index 0000000000..58e397ec24 --- /dev/null +++ b/test/f08_correct/lit/uform04.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Error stop code - Execution control +# +# Date of Modification: 1st Sep 2019 +# +# Tests the F2008 :Unlimited format item - Input/Output feature +# for an integer array +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/uform05.sh b/test/f08_correct/lit/uform05.sh new file mode 100644 index 0000000000..58e397ec24 --- /dev/null +++ b/test/f08_correct/lit/uform05.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Error stop code - Execution control +# +# Date of Modification: 1st Sep 2019 +# +# Tests the F2008 :Unlimited format item - Input/Output feature +# for an integer array +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/uform06.sh b/test/f08_correct/lit/uform06.sh new file mode 100644 index 0000000000..58e397ec24 --- /dev/null +++ b/test/f08_correct/lit/uform06.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Error stop code - Execution control +# +# Date of Modification: 1st Sep 2019 +# +# Tests the F2008 :Unlimited format item - Input/Output feature +# for an integer array +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/value11.sh b/test/f08_correct/lit/value11.sh new file mode 100644 index 0000000000..6fe5bc9078 --- /dev/null +++ b/test/f08_correct/lit/value11.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: CPUPC-2052-F2008: In a pure procedure the +# intent of an argument need not be specified if it has the +# value attribute +# +# Date of Modification: Wed Feb 19 14:31:03 IST 2020 +# +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/value12.sh b/test/f08_correct/lit/value12.sh new file mode 100644 index 0000000000..6fe5bc9078 --- /dev/null +++ b/test/f08_correct/lit/value12.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: CPUPC-2052-F2008: In a pure procedure the +# intent of an argument need not be specified if it has the +# value attribute +# +# Date of Modification: Wed Feb 19 14:31:03 IST 2020 +# +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/value13.sh b/test/f08_correct/lit/value13.sh new file mode 100644 index 0000000000..6fe5bc9078 --- /dev/null +++ b/test/f08_correct/lit/value13.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: CPUPC-2052-F2008: In a pure procedure the +# intent of an argument need not be specified if it has the +# value attribute +# +# Date of Modification: Wed Feb 19 14:31:03 IST 2020 +# +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/lit/value14.sh b/test/f08_correct/lit/value14.sh new file mode 100644 index 0000000000..6fe5bc9078 --- /dev/null +++ b/test/f08_correct/lit/value14.sh @@ -0,0 +1,12 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: CPUPC-2052-F2008: In a pure procedure the +# intent of an argument need not be specified if it has the +# value attribute +# +# Date of Modification: Wed Feb 19 14:31:03 IST 2020 +# +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f08_correct/makefile b/test/f08_correct/makefile new file mode 100644 index 0000000000..11c6f39f18 --- /dev/null +++ b/test/f08_correct/makefile @@ -0,0 +1,46 @@ +# +# Copyright (c) 2018, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for DNORM intrinsic +# +# Date of Modification: 21st February 2019 +# + +BASE_DIR=$(HOMEQA) +SRC=$(BASE_DIR)/src +FC=flang +CC=clang +CXX=clang++ +OBJX=o +EXESUFFIX=out +LD=$(FC) +OPT=-O +F2008=-std=f2008 +FFLAGS=-I$(SRC) $(OPT) $(KIEE) $(EXTRA_FFLAGS) $(EXTRA_HFLAGS) $(F2008) +LDFLAGS=$(EXTRA_LDFLAGS) +LIBS=$(EXTRA_LIBS) +CFLAGS=$(EXTRA_CFLAGS) +TEST= +COMP_CHECK=python $(HOMEQA)/../tools/check_compilation.py + +RM=rm -f +CP=cp -f +UNAME := $(shell uname -a) + +INCLUDES=$(BASE_DIR)/inc + +check: check.$(OBJX) + +check.$(OBJX) : $(SRC)/check.c + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + +clean.run: clean.$(OBJX) + a.out + +clean: + -$(RM) a.out *.$(OBJX) *.mod *.qdbg core + +run.run: run.$(OBJX) + a.out + +include $(INCLUDES)/$(TEST).mk diff --git a/test/f08_correct/src/assumedsize_array.f08 b/test/f08_correct/src/assumedsize_array.f08 new file mode 100644 index 0000000000..8edabfda61 --- /dev/null +++ b/test/f08_correct/src/assumedsize_array.f08 @@ -0,0 +1,23 @@ +!* +!* Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +!* +!* +!* Assumed size array as a parameter +!* AOCC test + + program test_assumedsize_array + parameter(NTEST=2) + integer :: expect(NTEST) = (/ 3, 6 /) + integer :: result(NTEST) + integer, dimension(*), parameter :: x = [1, 2, 3] + integer, dimension(*), parameter :: y = [x, -x] + integer :: r1, r2 + r1 = size(x) + print *, r1 + result(1) = r1 + r2 = size(y) + print *, r2 + result(2) = r2 + call check(result,expect,NTEST) + end program test_assumedsize_array + diff --git a/test/f08_correct/src/bessel.f08 b/test/f08_correct/src/bessel.f08 new file mode 100644 index 0000000000..9793ed57d9 --- /dev/null +++ b/test/f08_correct/src/bessel.f08 @@ -0,0 +1,22 @@ +!* +!* Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +!* +!* +!* F2008 feature bessel intrinsic +!* AOCC test + + program test_bessel + parameter(NTEST=2) + real :: expect(NTEST) = (/ 9.6025755120100281E-002, 1.9995999819891135E-002 /) + real :: result(NTEST) + real(8) :: i = 1.01 + real(8) :: j = 0.04 + real :: b1, b2 + b1 = bessel_y0(i) + print *, b1 + result(1) = b1 + b2 = bessel_j1(j) + print *, b2 + result(2) = b2 + call check(result,expect,NTEST) + end program test_bessel diff --git a/test/f08_correct/src/bitcmp01.f08 b/test/f08_correct/src/bitcmp01.f08 new file mode 100644 index 0000000000..51607dd88e --- /dev/null +++ b/test/f08_correct/src/bitcmp01.f08 @@ -0,0 +1,74 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Support for Bit Sequence Comparsion intrinsics. +! + +program bitcmp01 + integer, parameter :: N = 64 + logical exp(N), res(N) + + integer(kind = 1) :: nn_1 = -10_1 + integer(kind = 1) :: n_1 = -5_1 + integer(kind = 1) :: pp_1 = 125_1 + integer(kind = 1) :: p_1 = 20_1 + + integer(kind = 2) :: nn_2 = -15535_2 + integer(kind = 2) :: n_2 = -2000_2 + integer(kind = 2) :: pp_2 = 25525_2 + integer(kind = 2) :: p_2 = 5000_2 + + integer(kind = 4) :: nn_4 = -1120404030_4 + integer(kind = 4) :: n_4 = -1120404029_4 + integer(kind = 4) :: pp_4 = 2120144030_4 + integer(kind = 4) :: p_4 = 1120404030_4 + + integer(kind = 8) :: nn_8 = -9223372036854775507_8 + integer(kind = 8) :: n_8 = -8223372036854775507_8 + integer(kind = 8) :: pp_8 = 9223372036854775607_8 + integer(kind = 8) :: p_8 = 9223372036854775606_8 + + intrinsic bgt + intrinsic blt + + exp(1:4) = (/.true., .true., .false., .false./) + res(1:4) = (/bgt(n_1, nn_1), bgt(n_1, p_1), bgt(p_1, n_1), bgt(p_1, pp_1)/) + exp(5:8) = (/.true., .true., .false., .false./) + res(5:8) = (/blt(nn_1, n_1), blt(p_1, n_1), blt(n_1, p_1), blt(pp_1, p_1)/) + + exp(9:12) = (/.false., .false., .true., .true./) + res(9:12) = (/bgt(nn_1, n_1), bgt(p_1, n_1), bgt(n_1, p_1), bgt(pp_1, p_1)/) + exp(13:16) = (/.false., .false., .true., .true./) + res(13:16) = (/blt(n_1, nn_1), blt(n_1, p_1), blt(p_1, n_1), blt(p_1, pp_1)/) + + exp(17:20) = (/.true., .true., .false., .false./) + res(17:20) = (/bgt(n_2, nn_2), bgt(n_2, p_2), bgt(p_2, n_2), bgt(p_2, pp_2)/) + exp(21:24) = (/.true., .true., .false., .false./) + res(21:24) = (/blt(nn_2, n_2), blt(p_2, n_2), blt(n_2, p_2), blt(pp_2, p_2)/) + + exp(25:28) = (/.false., .false., .true., .true./) + res(25:28) = (/bgt(nn_2, n_2), bgt(p_2, n_2), bgt(n_2, p_2), bgt(pp_2, p_2)/) + exp(29:32) = (/.false., .false., .true., .true./) + res(29:32) = (/blt(n_2, nn_2), blt(n_2, p_2), blt(p_2, n_2), blt(p_2, pp_2)/) + + exp(33:36) = (/.true., .true., .false., .false./) + res(33:36) = (/bgt(n_4, nn_4), bgt(n_4, p_4), bgt(p_4, n_4), bgt(p_4, pp_4)/) + exp(37:40) = (/.true., .true., .false., .false./) + res(37:40) = (/blt(nn_4, n_4), blt(p_4, n_4), blt(n_4, p_4), blt(pp_4, p_4)/) + + exp(41:44) = (/.false., .false., .true., .true./) + res(41:44) = (/bgt(nn_4, n_4), bgt(p_4, n_4), bgt(n_4, p_4), bgt(pp_4, p_4)/) + exp(45:48) = (/.false., .false., .true., .true./) + res(45:48) = (/blt(n_4, nn_4), blt(n_4, p_4), blt(p_4, n_4), blt(p_4, pp_4)/) + + exp(49:52) = (/.true., .true., .false., .false./) + res(49:52) = (/bgt(n_8, nn_8), bgt(n_8, p_8), bgt(p_8, n_8), bgt(p_8, pp_8)/) + exp(53:56) = (/.true., .true., .false., .false./) + res(53:56) = (/blt(nn_8, n_8), blt(p_8, n_8), blt(n_8, p_8), blt(pp_8, p_8)/) + + exp(57:60) = (/.false., .false., .true., .true./) + res(57:60) = (/bgt(nn_8, n_8), bgt(p_8, n_8), bgt(n_8, p_8), bgt(pp_8, p_8)/) + exp(61:64) = (/.false., .false., .true., .true./) + res(61:64) = (/blt(n_8, nn_8), blt(n_8, p_8), blt(p_8, n_8), blt(p_8, pp_8)/) + call check(res, exp, N) +end program diff --git a/test/f08_correct/src/bitcmp02.f08 b/test/f08_correct/src/bitcmp02.f08 new file mode 100644 index 0000000000..d937e0be14 --- /dev/null +++ b/test/f08_correct/src/bitcmp02.f08 @@ -0,0 +1,47 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Support for Bit Sequence Comparsion intrinsics. +! + +program bitcmp02 + integer, parameter :: N = 12 + logical exp(N), res(N) + + integer(kind = 1) :: n_1 + integer(kind = 1) :: p_1 + + integer (kind = 2) :: n_2 + integer (kind = 2) :: p_2 + + integer (kind = 4) :: n_4 + integer (kind = 4) :: p_4 + + integer (kind = 8) :: n_8 + integer (kind = 8) :: p_8 + + intrinsic bge + intrinsic bgt + intrinsic ble + intrinsic blt + + n_1 = -1 + n_2 = -1 + n_4 = -1 + n_8 = -1 + + exp(1:4) = (/.false., .false., .false., .false./) + res(1:4) = (/bgt(n_1, n_1), bgt(n_1, n_2), bgt(n_2, n_4), bgt(n_4, n_8)/) + + exp(5:8) = (/.false., .true., .true., .true./) + res(5:8) = (/bgt(n_1, n_1), bgt(n_2, n_1), bgt(n_4, n_2), bgt(n_8, n_4)/) + + p_1 = 123 + p_2 = 12312 + p_4 = 12312 + p_8 = 9223372036854775807_8 + + exp(9:12) = (/.true., .true., .true., .true./) + res(9:12) = (/blt(p_1, p_2), ble(p_2, p_4), bge(p_8, p_4), bge(p_8, p_8)/) + call check(res, exp, N) +end program diff --git a/test/f08_correct/src/bitcmp03.f08 b/test/f08_correct/src/bitcmp03.f08 new file mode 100644 index 0000000000..e32b598c6b --- /dev/null +++ b/test/f08_correct/src/bitcmp03.f08 @@ -0,0 +1,22 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Support for Bit Sequence Comparsion intrinsics. +! + +program bitcmp03 + integer, parameter :: N = 9 + logical exp(N), res(N) + + exp(1:4) = (/.true., .true., .false., .true./) + res(1:4) = (/bgt(-1_2, -1_1), blt(-1, -1_8), bgt(-123, -10), bgt(123, 10)/) + + exp(5:8) = (/.false., .true., .true., .false./) + res(5:8) = (/bge(z'ffab', z'ffac'), ble(o'177', o'777'), bge(b'1111', b'0111'), & + blt(z'ffffffffffffffff', z'fffffffffffffffe')/) + + exp(9) = blt(-129, -129) + res(9) = .false. + + call check(res, exp, N) +end program diff --git a/test/f08_correct/src/bitint01.f08 b/test/f08_correct/src/bitint01.f08 new file mode 100644 index 0000000000..749e4403c0 --- /dev/null +++ b/test/f08_correct/src/bitint01.f08 @@ -0,0 +1,27 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Thu Mar 19 10:54:19 IST 2020 +! +! Purpose: Test operation of BIT_SIZE intrinsic +! +PROGRAM BITINT01 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + INTEGER(KIND=4) :: I = 123 + INTEGER(KIND=4) :: SIZE + + SIZE = BIT_SIZE(I) + PRINT *, SIZE + IF (SIZE /= 32) THEN + PRINT *, "BIT SIZE NOT EQUAL TO ", SIZE + STOP "ERROR" + ELSE + PRINT *, "PASS" + END IF + + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint02.f08 b/test/f08_correct/src/bitint02.f08 new file mode 100644 index 0000000000..42d18766fc --- /dev/null +++ b/test/f08_correct/src/bitint02.f08 @@ -0,0 +1,49 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of BGE intrinsic +! +PROGRAM BITINT02 + IMPLICIT NONE + LOGICAL RESULT + INTEGER I, J + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + I = 10 + J = 10 + RESULT = BGE(I, J) + PRINT *, "I = ", I, "J = ", J + PRINT *, "BGE(I, J) = ", RESULT + IF (RESULT .EQV. .TRUE.) THEN + PRINT *, "PASS-1" + ELSE + STOP "FAIL-1" + END IF + + I = 10 + J = 20 + RESULT = BGE(I, J) + PRINT *, "I = ", I, "J = ", J + PRINT *, "BGE(I, J) = ", RESULT + IF (RESULT .EQV. .FALSE.) THEN + PRINT *, "PASS-2" + ELSE + STOP "FAIL-2" + END IF + + I = 20 + J = 10 + RESULT = BGE(I, J) + PRINT *, "I = ", I, "J = ", J + PRINT *, "BGE(I, J) = ", RESULT + IF (RESULT .EQV. .TRUE.) THEN + PRINT *, "PASS-3" + ELSE + STOP "FAIL-3" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint03.f08 b/test/f08_correct/src/bitint03.f08 new file mode 100644 index 0000000000..80399c9754 --- /dev/null +++ b/test/f08_correct/src/bitint03.f08 @@ -0,0 +1,49 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test operation of BGT instrinsic +! +PROGRAM BITINT03 + IMPLICIT NONE + LOGICAL RESULT + INTEGER I, J + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + I = 10 + J = 10 + RESULT = BGT(I, J) + PRINT *, "I = ", I, "J = ", J + PRINT *, "BGT(I, J) = ", RESULT + IF (RESULT .EQV. .FALSE.) THEN + PRINT *, "PASS-1" + ELSE + STOP "FAIL-1" + END IF + + I = 10 + J = 20 + RESULT = BGT(I, J) + PRINT *, "I = ", I, "J = ", J + PRINT *, "BGT(I, J) = ", RESULT + IF (RESULT .EQV. .FALSE.) THEN + PRINT *, "PASS-2" + ELSE + STOP "FAIL-2" + END IF + + I = 20 + J = 10 + RESULT = BGT(I, J) + PRINT *, "I = ", I, "J = ", J + PRINT *, "BGT(I, J) = ", RESULT + IF (RESULT .EQV. .TRUE.) THEN + PRINT *, "PASS-3" + ELSE + STOP "FAIL-3" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint04.f08 b/test/f08_correct/src/bitint04.f08 new file mode 100644 index 0000000000..d6a4f8c25d --- /dev/null +++ b/test/f08_correct/src/bitint04.f08 @@ -0,0 +1,49 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test operation of tyhe BLE instrinsic +! +PROGRAM BITINT04 + IMPLICIT NONE + LOGICAL RESULT + INTEGER I, J + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + I = 10 + J = 10 + RESULT = BLE(I, J) + PRINT *, "I = ", I, "J = ", J + PRINT *, "BLE(I, J) = ", RESULT + IF (RESULT .EQV. .TRUE.) THEN + PRINT *, "PASS-1" + ELSE + STOP "FAIL-1" + END IF + + I = 10 + J = 20 + RESULT = BLE(I, J) + PRINT *, "I = ", I, "J = ", J + PRINT *, "BLE(I, J) = ", RESULT + IF (RESULT .EQV. .TRUE.) THEN + PRINT *, "PASS-2" + ELSE + STOP "FAIL-2" + END IF + + I = 20 + J = 10 + RESULT = BLE(I, J) + PRINT *, "I = ", I, "J = ", J + PRINT *, "BLE(I, J) = ", RESULT + IF (RESULT .EQV. .FALSE.) THEN + PRINT *, "PASS-3" + ELSE + STOP "FAIL-3" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint05.f08 b/test/f08_correct/src/bitint05.f08 new file mode 100644 index 0000000000..96b23d3fd1 --- /dev/null +++ b/test/f08_correct/src/bitint05.f08 @@ -0,0 +1,49 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test operation of the BLT instrinsic +! +PROGRAM BITINT05 + IMPLICIT NONE + LOGICAL RESULT + INTEGER I, J + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + I = 10 + J = 10 + RESULT = BLT(I, J) + PRINT *, "I = ", I, "J = ", J + PRINT *, "BLT(I, J) = ", RESULT + IF (RESULT .EQV. .FALSE.) THEN + PRINT *, "PASS-1" + ELSE + STOP "FAIL-1" + END IF + + I = 10 + J = 20 + RESULT = BLT(I, J) + PRINT *, "I = ", I, "J = ", J + PRINT *, "BLT(I, J) = ", RESULT + IF (RESULT .EQV. .TRUE.) THEN + PRINT *, "PASS-2" + ELSE + STOP "FAIL-2" + END IF + + I = 20 + J = 10 + RESULT = BLT(I, J) + PRINT *, "I = ", I, "J = ", J + PRINT *, "BLT(I, J) = ", RESULT + IF (RESULT .EQV. .FALSE.) THEN + PRINT *, "PASS-3" + ELSE + STOP "FAIL-3" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint06.f08 b/test/f08_correct/src/bitint06.f08 new file mode 100644 index 0000000000..0cfab4f3ee --- /dev/null +++ b/test/f08_correct/src/bitint06.f08 @@ -0,0 +1,25 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of IALL instrinsic +! +PROGRAM BITINT06 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + INTEGER :: X(3), RESULT + DATA X(1)/B'01101100'/, X(2)/B'01101010'/, X(3)/B'11101111'/ + + ! SHOULD BE 01101000 + RESULT = IALL(X) + PRINT '(B8.8)', RESULT + IF (RESULT /= INT(B'01101000')) THEN + STOP "FAIL" + ELSE + PRINT *, "PASS" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint07.f08 b/test/f08_correct/src/bitint07.f08 new file mode 100644 index 0000000000..63d1d571b3 --- /dev/null +++ b/test/f08_correct/src/bitint07.f08 @@ -0,0 +1,26 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the purpose of IAND instrinsic +! +PROGRAM BITINT07 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + INTEGER :: X(3), RESULT + DATA X(1)/B'01101100'/, X(2)/B'01101010'/, X(3)/B'11101111'/ + + ! SHOULD BE 110 1000 + RESULT = IAND(IAND(X(1), X(2)), X(3)) + PRINT '(B8.8)', RESULT + IF (RESULT /= INT(B'1101000')) THEN + STOP "FAIL" + ELSE + PRINT *, "PASS" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint08.f08 b/test/f08_correct/src/bitint08.f08 new file mode 100644 index 0000000000..6298609d81 --- /dev/null +++ b/test/f08_correct/src/bitint08.f08 @@ -0,0 +1,25 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of IOR instrinsic +! +PROGRAM BITINT08 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + INTEGER :: X(3), RESULT + DATA X(1)/B'01101100'/, X(2)/B'01101010'/, X(3)/B'11101111'/ + + ! SHOULD BE 11101111 + RESULT = IOR(IOR(X(1), X(2)), X(3)) + PRINT '(B8.8)', RESULT + IF (RESULT /= INT(B'11101111')) THEN + STOP "FAIL" + ELSE + PRINT *, "PASS" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint09.f08 b/test/f08_correct/src/bitint09.f08 new file mode 100644 index 0000000000..37e1f5622a --- /dev/null +++ b/test/f08_correct/src/bitint09.f08 @@ -0,0 +1,25 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of IANY instrinsic +! +PROGRAM BITINT09 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + INTEGER :: X(3), RESULT + DATA X(1)/B'01101100'/, X(2)/B'01101010'/, X(3)/B'11101111'/ + + ! SHOULD BE 11101111 + RESULT = IANY(X) + PRINT '(B8.8)', IANY(X) + IF (RESULT /= INT(B'11101111')) THEN + STOP "FAIL" + ELSE + PRINT *, "PASS" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint10.f08 b/test/f08_correct/src/bitint10.f08 new file mode 100644 index 0000000000..836f3407d3 --- /dev/null +++ b/test/f08_correct/src/bitint10.f08 @@ -0,0 +1,30 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of ATOMIC_AND intrinsic +! +PROGRAM BITINT10 + USE ISO_FORTRAN_ENV + INTEGER(ATOMIC_INT_KIND) :: A(3)[*] + INTEGER STATUS(3) + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + A(1)[1] = INT(B'10111010001') + A(2)[1] = INT(B'10111010111') + A(3)[1] = INT(B'10000111000') + CALL ATOMIC_AND (A(1)[1], INT(B'10111010001'), STATUS(1)) + CALL ATOMIC_AND (A(2)[1], INT(B'10111010001'), STATUS(2)) + CALL ATOMIC_AND (A(2)[1], INT(B'10111010001'), STATUS(3)) + IF (STATUS(1) == 0 .AND. STATUS(2) == 0 .AND. STATUS(3) == 0) THEN + PRINT *, "SUCCESS" + ELSE + PRINT *, "FAILURE" + END IF + !PRINT *, A(:)[1] + WRITE(UNIT=*,FMT="(B32.32)")A(:)[1] + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint11.f08 b/test/f08_correct/src/bitint11.f08 new file mode 100644 index 0000000000..3fd86f0edd --- /dev/null +++ b/test/f08_correct/src/bitint11.f08 @@ -0,0 +1,33 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of ATOMIC_FETCH_AND intrinsic +! +PROGRAM BITINT11 + USE ISO_FORTRAN_ENV + INTEGER(ATOMIC_INT_KIND) :: A(3)[*], OLD_VALUE(3) + INTEGER STATUS(3) + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + A(1)[1] = INT(B'10111010001') + A(2)[1] = INT(B'10111010111') + A(3)[1] = INT(B'10000111000') + + CALL ATOMIC_FETCH_AND (A(1)[1], INT(B'10111010001'), OLD_VALUE(1), STATUS(1)) + CALL ATOMIC_FETCH_AND (A(2)[1], INT(B'10111010001'), OLD_VALUE(2), STATUS(2)) + CALL ATOMIC_FETCH_AND (A(2)[1], INT(B'10111010001'), OLD_VALUE(3), STATUS(3)) + IF (STATUS(1) == 0 .AND. STATUS(2) == 0 .AND. STATUS(3) == 0) THEN + PRINT *, "SUCCESS" + ELSE + PRINT *, "FAILURE" + END IF + !PRINT *, A(:)[1] + WRITE(UNIT=*,FMT="(B32.32)")A(:)[1] + PRINT *, "OLD_VALUE = ", OLD_VALUE + WRITE(UNIT=*,FMT="(B32.32)") OLD_VALUE + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint12.f08 b/test/f08_correct/src/bitint12.f08 new file mode 100644 index 0000000000..e901875544 --- /dev/null +++ b/test/f08_correct/src/bitint12.f08 @@ -0,0 +1,33 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of ATOMIC_FETCH_OR intrinsic +! +PROGRAM BITINT12 + USE ISO_FORTRAN_ENV + INTEGER(ATOMIC_INT_KIND) :: A(3)[*], OLD_VALUE(3) + INTEGER STATUS(3) + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + A(1)[1] = INT(B'10111010001') + A(2)[1] = INT(B'10111010111') + A(3)[1] = INT(B'10000111000') + + CALL ATOMIC_FETCH_OR (A(1)[1], INT(B'10111010001'), OLD_VALUE(1), STATUS(1)) + CALL ATOMIC_FETCH_OR (A(2)[1], INT(B'10111010001'), OLD_VALUE(2), STATUS(2)) + CALL ATOMIC_FETCH_OR (A(2)[1], INT(B'10111010001'), OLD_VALUE(3), STATUS(3)) + IF (STATUS(1) == 0 .AND. STATUS(2) == 0 .AND. STATUS(3) == 0) THEN + PRINT *, "SUCCESS" + ELSE + PRINT *, "FAILURE" + END IF + !PRINT *, A(:)[1] + WRITE(UNIT=*,FMT="(B32.32)")A(:)[1] + PRINT *, "OLD_VALUE = ", OLD_VALUE + WRITE(UNIT=*,FMT="(B32.32)") OLD_VALUE + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint13.f08 b/test/f08_correct/src/bitint13.f08 new file mode 100644 index 0000000000..b824d2a6ac --- /dev/null +++ b/test/f08_correct/src/bitint13.f08 @@ -0,0 +1,33 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of ATOMIC_FETCH_XOR intrinsic +! +PROGRAM BITINT12 + USE ISO_FORTRAN_ENV + INTEGER(ATOMIC_INT_KIND) :: A(3)[*], OLD_VALUE(3) + INTEGER STATUS(3) + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + A(1)[1] = INT(B'10111010001') + A(2)[1] = INT(B'10111010111') + A(3)[1] = INT(B'10000111000') + + CALL ATOMIC_FETCH_XOR (A(1)[1], INT(B'10111010001'), OLD_VALUE(1), STATUS(1)) + CALL ATOMIC_FETCH_XOR (A(2)[1], INT(B'10111010001'), OLD_VALUE(2), STATUS(2)) + CALL ATOMIC_FETCH_XOR (A(2)[1], INT(B'10111010001'), OLD_VALUE(3), STATUS(3)) + IF (STATUS(1) == 0 .AND. STATUS(2) == 0 .AND. STATUS(3) == 0) THEN + PRINT *, "SUCCESS" + ELSE + PRINT *, "FAILURE" + END IF + !PRINT *, A(:)[1] + WRITE(UNIT=*,FMT="(B32.32)")A(:)[1] + PRINT *, "OLD_VALUE = ", OLD_VALUE + WRITE(UNIT=*,FMT="(B32.32)") OLD_VALUE + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint14.f08 b/test/f08_correct/src/bitint14.f08 new file mode 100644 index 0000000000..ddfa622765 --- /dev/null +++ b/test/f08_correct/src/bitint14.f08 @@ -0,0 +1,30 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of ATOMIC_OR intrinsic +! +PROGRAM BITINT14 + USE ISO_FORTRAN_ENV + INTEGER(ATOMIC_INT_KIND) :: A(3)[*] + INTEGER STATUS(3) + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + A(1)[1] = INT(B'10111010001') + A(2)[1] = INT(B'10111010111') + A(3)[1] = INT(B'10000111000') + CALL ATOMIC_OR (A(1)[1], INT(B'10111010001'), STATUS(1)) + CALL ATOMIC_OR (A(2)[1], INT(B'10111010001'), STATUS(2)) + CALL ATOMIC_OR (A(2)[1], INT(B'10111010001'), STATUS(3)) + IF (STATUS(1) == 0 .AND. STATUS(2) == 0 .AND. STATUS(3) == 0) THEN + PRINT *, "SUCCESS" + ELSE + PRINT *, "FAILURE" + END IF + !PRINT *, A(:)[1] + WRITE(UNIT=*,FMT="(B32.32)")A(:)[1] + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint15.f08 b/test/f08_correct/src/bitint15.f08 new file mode 100644 index 0000000000..26d9f9bcc0 --- /dev/null +++ b/test/f08_correct/src/bitint15.f08 @@ -0,0 +1,28 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of IBCLR intrinsic +! +PROGRAM BITINT15 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + INTEGER I, POS, RESULT + + ! RESULT SHOULD BE 10111010000 + POS = 0 + I = INT(B'10111010001') + PRINT *, "-----" + WRITE(UNIT=*,FMT="(B32.32)") I + RESULT = IBCLR(I, POS) + WRITE(UNIT=*,FMT="(B32.32)") RESULT + IF (RESULT /= INT(B'10111010000')) THEN + STOP "FAIL" + ELSE + PRINT *, "PASS" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint16.f08 b/test/f08_correct/src/bitint16.f08 new file mode 100644 index 0000000000..1cdbeb7c1a --- /dev/null +++ b/test/f08_correct/src/bitint16.f08 @@ -0,0 +1,29 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of IBITS intrinsic +! +PROGRAM BITINT16 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + INTEGER I, POS, RESULT, LEN + + ! result should be 10001 + POS = 0 + LEN = 5 + I = INT(B'10111010001') + PRINT *, "-----" + WRITE(UNIT=*,FMT="(B32.32)") I + RESULT = IBITS(I, POS, LEN) + WRITE(UNIT=*,FMT="(B32.32)") RESULT + IF (RESULT /= INT(B'10001')) THEN + STOP "FAIL" + ELSE + PRINT *, "PASS" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint17.f08 b/test/f08_correct/src/bitint17.f08 new file mode 100644 index 0000000000..37f9b74ea7 --- /dev/null +++ b/test/f08_correct/src/bitint17.f08 @@ -0,0 +1,28 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of IBSET intrinsic +! +PROGRAM BITINT17 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + INTEGER I, POS, RESULT + + ! RESULT SHOULD BE 10111010011 + POS = 1 + I = INT(B'10111010001') + PRINT *, "-----" + WRITE(UNIT=*,FMT="(B32.32)") I + RESULT = IBSET(I, POS) + WRITE(UNIT=*,FMT="(B32.32)") RESULT + IF (RESULT /= INT(B'10111010011')) THEN + STOP "FAIL" + ELSE + PRINT *, "PASS" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint18.f08 b/test/f08_correct/src/bitint18.f08 new file mode 100644 index 0000000000..ef430e1194 --- /dev/null +++ b/test/f08_correct/src/bitint18.f08 @@ -0,0 +1,30 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of IPARITY intrinsic +! +PROGRAM BITINT18 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + INTEGER(1) :: X(2), RESULT + + X(1) = INT(B'11100100', 1) + X(2) = INT(B'01101110', 1) + + ! EXPECTED ANSWER IS 10001010 + RESULT = IPARITY(X) + PRINT '(B8.8)', RESULT + WRITE(UNIT=*,FMT="(B32.32)") X(1) + WRITE(UNIT=*,FMT="(B32.32)") X(2) + WRITE(UNIT=*,FMT="(B32.32)") RESULT + IF (RESULT /= INT(B'10001010', 1)) THEN + STOP "FAIL" + ELSE + PRINT *, "PASS" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint19.f08 b/test/f08_correct/src/bitint19.f08 new file mode 100644 index 0000000000..b69f805e12 --- /dev/null +++ b/test/f08_correct/src/bitint19.f08 @@ -0,0 +1,27 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of IEOR intrinsic +! +PROGRAM BITINT18 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + INTEGER(1) :: X(2), RESULT + + X(1) = INT(B'11100100', 1) + X(2) = INT(B'01101110', 1) + + ! EXPECTED ANSWER IS 10001010 + RESULT = IEOR(X(1), X(2)) + PRINT '(B8.8)', RESULT + IF (RESULT /= INT(B'10001010', 1)) THEN + STOP "FAIL" + ELSE + PRINT *, "PASS" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint20.f08 b/test/f08_correct/src/bitint20.f08 new file mode 100644 index 0000000000..4447fc25a3 --- /dev/null +++ b/test/f08_correct/src/bitint20.f08 @@ -0,0 +1,47 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of ISHFT intrinsic +! +PROGRAM BITINT20 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + INTEGER(1) :: I, RESULT + + I = INT(B'11100100', 1) + PRINT '(B8.8)', I + WRITE(UNIT=*,FMT="(B32.32)") I + + PRINT *, '------' + RESULT = ISHFT(I, 0) + PRINT '(B8.8)', RESULT + WRITE(UNIT=*,FMT="(B32.32)") RESULT + IF (RESULT /= INT(B'11100100', 1)) THEN + STOP "FAIL-1" + ELSE + PRINT *, "PASS-1" + END IF + + RESULT = ISHFT(I, 2) + PRINT '(B8.8)', RESULT + WRITE(UNIT=*,FMT="(B32.32)") RESULT + IF (RESULT /= INT(B'10010000', 1)) THEN + STOP "FAIL-2" + ELSE + PRINT *, "PASS-2" + END IF + + RESULT = ISHFT(I, -2) + PRINT '(B8.8)', RESULT + WRITE(UNIT=*,FMT="(B32.32)") RESULT + IF (RESULT /= INT(B'111001', 1)) THEN + STOP "FAIL-3" + ELSE + PRINT *, "PASS-3" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint21.f08 b/test/f08_correct/src/bitint21.f08 new file mode 100644 index 0000000000..905a6f6e4c --- /dev/null +++ b/test/f08_correct/src/bitint21.f08 @@ -0,0 +1,51 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of ISHFTC intrinsic +! +PROGRAM BITINT21 + IMPLICIT NONE + INTEGER(1) :: I, RESULT + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + I = INT(B'11100111', 1) + + PRINT *, '------' + PRINT *, I + PRINT '(B8.8)', I + + RESULT = ISHFTC(I, 0) + PRINT *, RESULT + PRINT '(B8.8)', RESULT + WRITE(UNIT=*,FMT="(B32.32)") RESULT + IF (RESULT /= INT(B'11100111', 1)) THEN + STOP "FAIL-1" + ELSE + PRINT *, "PASS-1" + END IF + + RESULT = ISHFTC(I, 2) + PRINT *, RESULT + PRINT '(B8.8)', RESULT + WRITE(UNIT=*,FMT="(B32.32)") RESULT + IF (RESULT /= INT(B'0010011111', 1)) THEN + STOP "FAIL-2" + ELSE + PRINT *, "PASS-2" + END IF + + RESULT = ISHFTC(I, -2) + PRINT *, RESULT + PRINT '(B8.8)', RESULT + WRITE(UNIT=*,FMT="(B32.32)") RESULT + IF (RESULT /= INT(B'11111001', 1)) THEN + STOP "FAIL-3" + ELSE + PRINT *, "PASS-3" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint22.f08 b/test/f08_correct/src/bitint22.f08 new file mode 100644 index 0000000000..c71eb5a9f4 --- /dev/null +++ b/test/f08_correct/src/bitint22.f08 @@ -0,0 +1,32 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of LSHIFT intrinsic +! +PROGRAM BITINT22 + IMPLICIT NONE + INTEGER(1) :: I, SHIFT, RESULT + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + SHIFT = 2 + + I = INT(B'11100100', 1) + RESULT = LSHIFT(I, SHIFT) + + PRINT *, '------' + PRINT *, I + PRINT '(B8.8)', I + PRINT *, RESULT + PRINT '(B8.8)', RESULT + WRITE(UNIT=*,FMT="(B32.32)") RESULT + IF (RESULT /= INT(B'10010000', 1)) THEN + STOP "FAIL" + ELSE + PRINT *, "PASS" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint23.f08 b/test/f08_correct/src/bitint23.f08 new file mode 100644 index 0000000000..2a10c98d19 --- /dev/null +++ b/test/f08_correct/src/bitint23.f08 @@ -0,0 +1,30 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Thu Mar 19 10:54:19 IST 2020 +! +! Purpose: Test the operation of MASKL intrinsic +! +PROGRAM BITINT23 + IMPLICIT NONE + INTEGER(1) :: SIZE, RESULT + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + SIZE = 7 + + RESULT = MASKL(SIZE, 1) + + PRINT *, '------' + PRINT *, RESULT + PRINT '(B8.8)', RESULT + WRITE(UNIT=*,FMT="(B32.32)") RESULT + IF (RESULT /= INT(B'11111110', 1)) THEN + STOP "FAIL" + ELSE + PRINT *, "PASS" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint24.f08 b/test/f08_correct/src/bitint24.f08 new file mode 100644 index 0000000000..b291406a97 --- /dev/null +++ b/test/f08_correct/src/bitint24.f08 @@ -0,0 +1,30 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Thu Mar 19 10:54:19 IST 2020 +! +! Purpose: Test the operation of MASKR intrinsic +! +PROGRAM BITINT24 + IMPLICIT NONE + INTEGER(1) :: SIZE, RESULT + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + SIZE = 5 + + RESULT = MASKR(SIZE, 1) + + PRINT *, '------' + PRINT *, RESULT + PRINT '(B8.8)', RESULT + WRITE(UNIT=*,FMT="(B32.32)") RESULT + IF (RESULT /= INT(B'00011111')) THEN + STOP "FAIL" + ELSE + PRINT *, "PASS" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint25.f08 b/test/f08_correct/src/bitint25.f08 new file mode 100644 index 0000000000..19b14e7bdd --- /dev/null +++ b/test/f08_correct/src/bitint25.f08 @@ -0,0 +1,34 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of MERGE_BITS intrinsic +! +PROGRAM BITINT25 + IMPLICIT NONE + INTEGER(1) :: I, J, RESULT, MASK + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + ! BITS OF I ARE CARRIED OVER TO THE RESULT + ! THE I-TH BIT OF THE RESULT IS EQUAL TO THE I-TH BIT OF + ! I IF THE I-TH BIT OF MASK IS 1; IT IS EQUAL TO THE I-TH BIT + ! OF J OTHERWISE. + MASK = INT(B'11111010', 1) + I = INT(B'11100100', 1) + J = INT(B'10000101', 1) + RESULT = MERGE_BITS(I, J, MASK) + + PRINT *, '------' + PRINT *, RESULT + PRINT '(B8.8)', RESULT + WRITE(UNIT=*,FMT="(B32.32)") RESULT + IF (RESULT /= INT(B'11100101', 1)) THEN + STOP "FAIL" + ELSE + PRINT *, "PASS" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint26.f08 b/test/f08_correct/src/bitint26.f08 new file mode 100644 index 0000000000..39c3425988 --- /dev/null +++ b/test/f08_correct/src/bitint26.f08 @@ -0,0 +1,40 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of MVBITS intrinsic +! +PROGRAM BITINT26 + IMPLICIT NONE + INTEGER(1) :: I, J, IPOS, JPOS, LEN + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + LEN = 3 + IPOS = 5 + JPOS = 0 + + PRINT *, '------' + I = INT(B'11100100', 1) + J = INT(B'10011101', 1) + PRINT '(B8.8)', I + PRINT '(B8.8)', J + + CALL MVBITS(I, IPOS, LEN, J, JPOS) + + PRINT *, "I = ", I + PRINT '(B8.8)', I + WRITE(UNIT=*,FMT="(B32.32)") I + PRINT *, "J = ", J + PRINT '(B8.8)', J + WRITE(UNIT=*,FMT="(B32.32)") J + + IF (J /= INT(B'10011111', 1)) THEN + STOP "FAIL" + ELSE + PRINT *, "PASS" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint27.f08 b/test/f08_correct/src/bitint27.f08 new file mode 100644 index 0000000000..6928f42ffb --- /dev/null +++ b/test/f08_correct/src/bitint27.f08 @@ -0,0 +1,30 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of OR intrinsic +! +PROGRAM BITINT27 + IMPLICIT NONE + INTEGER(1) :: I, J, RESULT + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + I = INT(B'11100100', 1) + J = INT(B'10011101', 1) + RESULT = OR(I, J) + + PRINT *, '------' + PRINT *, RESULT + PRINT '(B8.8)', RESULT + WRITE(UNIT=*,FMT="(B32.32)") RESULT + + IF (RESULT /= INT(B'11111101', 1)) THEN + STOP "FAIL" + ELSE + PRINT *, "PASS" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint28.f08 b/test/f08_correct/src/bitint28.f08 new file mode 100644 index 0000000000..d74b2a37e6 --- /dev/null +++ b/test/f08_correct/src/bitint28.f08 @@ -0,0 +1,34 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of the PARITY intrinsic +! +PROGRAM BITINT28 + IMPLICIT NONE + LOGICAL :: I(8), RESULT + + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + ! TO GET PARITY OF (B'11100100') DO THE FOLLOWING: + ! (.TRUE., .TRUE., .TRUE., .FALSE., .FALSE., .TRUE., .FALSE., .FALSE.) + ! AND RECEIVE THE PARITY ARRAY + ! THE RESULT OF PARITY(MASK) HAS THE VALUE .TRUE. IF AN ODD + ! NUMBER OF THE ELEMENTS OF MASK ARE TRUE; OTHERWISE, .FALSE.. + I = (/.TRUE., .TRUE., .FALSE., .FALSE., .FALSE., .TRUE., .FALSE., .FALSE./) + RESULT = PARITY(I) + + PRINT *, '------' + PRINT *, "I = ", I + PRINT *, "RESULT = ", RESULT + + IF (RESULT .NEQV. .TRUE.) THEN + STOP "FAIL" + ELSE + PRINT *, "PASS" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint29.f08 b/test/f08_correct/src/bitint29.f08 new file mode 100644 index 0000000000..f0feb38507 --- /dev/null +++ b/test/f08_correct/src/bitint29.f08 @@ -0,0 +1,32 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of the POPPAR intrinsic +! +PROGRAM BITINT29 + IMPLICIT NONE + INTEGER(1) :: I, RESULT + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + I = INT(B'1100101', 1) + RESULT = POPPAR(I) + + PRINT *, '------' + PRINT *, I + PRINT '(B8.8)', I + WRITE(UNIT=*,FMT="(B32.32)") I + PRINT *, RESULT + PRINT '(B8.8)', RESULT + WRITE(UNIT=*,FMT="(B32.32)") RESULT + + IF (RESULT /= 0) THEN + STOP "FAIL" + ELSE + PRINT *, "PASS" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint30.f08 b/test/f08_correct/src/bitint30.f08 new file mode 100644 index 0000000000..ab1bb79fc1 --- /dev/null +++ b/test/f08_correct/src/bitint30.f08 @@ -0,0 +1,33 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of the RSHIFT intrinsic +! +PROGRAM BITINT29 + IMPLICIT NONE + INTEGER(1) :: I, RESULT, SHIFT + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + ! DEFINITION OF INTRINSIC IS A LITTLE VAGUE + ! BOTH IN GCC AND INTEL DOCUMENTATION + I = INT(B'11100101', 1) + SHIFT = 2 + RESULT = RSHIFT(I, SHIFT) + + PRINT *, '------' + PRINT '(B8.8)', I + PRINT *, RESULT + PRINT '(B8.8)', RESULT + WRITE(UNIT=*,FMT="(B32.32)") RESULT + + IF (RESULT /= INT(B'11111001', 1)) THEN + STOP "FAIL" + ELSE + PRINT *, "PASS" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint31.f08 b/test/f08_correct/src/bitint31.f08 new file mode 100644 index 0000000000..e0a7ab5801 --- /dev/null +++ b/test/f08_correct/src/bitint31.f08 @@ -0,0 +1,32 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of SHIFTA intrinsic +! +PROGRAM BITINT31 + IMPLICIT NONE + INTEGER(1) :: I, RESULT, SHIFT + + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + I = INT(B'11100101', 1) + SHIFT = 2 + RESULT = SHIFTA(I, SHIFT) + + PRINT *, '------' + PRINT '(B8.8)', I + PRINT *, RESULT + PRINT '(B8.8)', RESULT + WRITE(UNIT=*,FMT="(B32.32)") RESULT + + IF (RESULT /= INT(B'11111001', 1)) THEN + STOP "FAIL" + ELSE + PRINT *, "PASS" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint32.f08 b/test/f08_correct/src/bitint32.f08 new file mode 100644 index 0000000000..a6d55c57be --- /dev/null +++ b/test/f08_correct/src/bitint32.f08 @@ -0,0 +1,31 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of SHIFTL intrinsic +! +PROGRAM BITINT32 + IMPLICIT NONE + INTEGER(1) :: I, RESULT, SHIFT + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + I = INT(B'11100101', 1) + SHIFT = 2 + RESULT = SHIFTL(I, SHIFT) + + PRINT *, '------' + PRINT '(B8.8)', I + PRINT *, RESULT + PRINT '(B8.8)', RESULT + WRITE(UNIT=*,FMT="(B32.32)") RESULT + + IF (RESULT /= INT(B'10010100', 1)) THEN + STOP "FAIL" + ELSE + PRINT *, "PASS" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint33.f08 b/test/f08_correct/src/bitint33.f08 new file mode 100644 index 0000000000..173b13dc8e --- /dev/null +++ b/test/f08_correct/src/bitint33.f08 @@ -0,0 +1,148 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Fri Apr 10 17:30:08 IST 2020 +! Purpose: Test the operation of SHIFTR intrinsic +! +PROGRAM BITINT33 + IMPLICIT NONE + INTEGER I + INTEGER J + INTEGER RESULT + INTEGER SHIFT + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + I = INT(B'11100101') + SHIFT = 2 + RESULT = SHIFTR(I, SHIFT) + + PRINT *, '------' + PRINT *, 'SHIFT = ', SHIFT + PRINT *, 'I = ', I + PRINT '(B8.8)', I + WRITE(UNIT=*,FMT="(B32.32)") I + PRINT *, 'RESULT = ', RESULT + PRINT '(B8.8)', RESULT + WRITE(UNIT=*,FMT="(B32.32)") RESULT + + IF (RESULT /= INT(B'00111001')) THEN + PRINT *, 'EXPECTED = ', INT(B'00111001') + PRINT '(B8.8)', INT(B'00111001') + PRINT *, "FAIL-1" + !STOP "FAIL-1" + ELSE + PRINT *, "PASS-1" + END IF + + SHIFT = 5 + RESULT = SHIFTR(I, SHIFT) + + PRINT *, '------' + PRINT *, 'SHIFT = ', SHIFT + PRINT *, 'I = ', I + PRINT '(B8.8)', I + WRITE(UNIT=*,FMT="(B32.32)") I + PRINT *, 'RESULT = ', RESULT + PRINT '(B8.8)', RESULT + WRITE(UNIT=*,FMT="(B32.32)") RESULT + + IF (RESULT /= INT(B'00000111')) THEN + PRINT *, 'EXPECTED = ', INT(B'00000111') + PRINT '(B8.8)', INT(B'00000111') + PRINT *, "FAIL-2" + !STOP "FAIL-2" + ELSE + PRINT *, "PASS-2" + END IF + + I = INT(B'01100101') + SHIFT = 2 + RESULT = SHIFTR(I, SHIFT) + + PRINT *, '------' + PRINT *, 'SHIFT = ', SHIFT + PRINT *, 'I = ', I + PRINT '(B8.8)', I + WRITE(UNIT=*,FMT="(B32.32)") I + PRINT *, 'RESULT = ', RESULT + PRINT '(B8.8)', RESULT + WRITE(UNIT=*,FMT="(B32.32)") RESULT + + IF (RESULT /= INT(B'00011001')) THEN + PRINT *, 'EXPECTED = ', INT(B'00011001') + PRINT '(B8.8)', INT(B'00011001') + PRINT *, "FAIL-3" + !STOP "FAIL-3" + ELSE + PRINT *, "PASS-3" + END IF + + SHIFT = 5 + RESULT = SHIFTR(I, SHIFT) + + PRINT *, '------' + PRINT *, 'SHIFT = ', SHIFT + PRINT *, 'I = ', I + PRINT '(B8.8)', I + WRITE(UNIT=*,FMT="(B32.32)") I + PRINT *, 'RESULT = ', RESULT + PRINT '(B8.8)', RESULT + WRITE(UNIT=*,FMT="(B32.32)") RESULT + + IF (RESULT /= INT(B'00000011')) THEN + PRINT *, 'EXPECTED = ', INT(B'00000011') + PRINT '(B8.8)', INT(B'00000011') + PRINT *, "FAIL-4" + !STOP "FAIL-4" + ELSE + PRINT *, "PASS-4" + END IF + + J = -27 + ! 1111,1111,1111,1111,1111,1111,1110,0101 + SHIFT = 2 + RESULT = SHIFTR(J, SHIFT) + + PRINT *, '------' + PRINT *, 'SHIFT = ', SHIFT + PRINT *, 'J = ', J + PRINT '(B8.8)', J + WRITE(UNIT=*,FMT="(B32.32)") J + PRINT *, 'RESULT = ', RESULT + PRINT '(B8.8)', RESULT + WRITE(UNIT=*,FMT="(B32.32)") RESULT + + IF (RESULT /= INT(B'00111111111111111111111111111001')) THEN + PRINT *, 'EXPECTED = ', INT(B'00111111111111111111111111111001') + PRINT '(B8.8)', INT(B'00111111111111111111111111111001') + PRINT *, "FAIL-5" + !STOP "FAIL-5" + ELSE + PRINT *, "PASS-5" + END IF + + SHIFT = 5 + RESULT = SHIFTR(J, SHIFT) + + PRINT *, '------' + PRINT *, 'SHIFT = ', SHIFT + PRINT *, 'J = ', J + PRINT '(B8.8)', J + WRITE(UNIT=*,FMT="(B32.32)") J + PRINT *, 'RESULT = ', RESULT + PRINT '(B8.8)', RESULT + WRITE(UNIT=*,FMT="(B32.32)") RESULT + + IF (RESULT /= INT(B'00000111111111111111111111111111')) THEN + PRINT *, 'EXPECTED = ', INT(B'00000111111111111111111111111111') + PRINT '(B8.8)', INT(B'00000111111111111111111111111111') + PRINT *, "FAIL-6" + !STOP "FAIL-6" + ELSE + PRINT *, "PASS-6" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint34.f08 b/test/f08_correct/src/bitint34.f08 new file mode 100644 index 0000000000..9c3978018b --- /dev/null +++ b/test/f08_correct/src/bitint34.f08 @@ -0,0 +1,32 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Tue Feb 11 20:45:41 IST 2020 +! Purpose: Test the operation of XOR intrinsic +! +PROGRAM BITINT34 + IMPLICIT NONE + INTEGER(1) :: I, J, RESULT + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + I = INT(B'11100101', 1) + J = INT(B'10000101', 1) + RESULT = XOR(I, J) + + PRINT *, '------' + PRINT '(B8.8)', I + PRINT '(B8.8)', J + PRINT *, RESULT + PRINT '(B8.8)', RESULT + WRITE(UNIT=*,FMT="(B32.32)") RESULT + + IF (RESULT /= INT(B'01100000', 1)) THEN + STOP "FAIL" + ELSE + PRINT *, "PASS" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint35.f08 b/test/f08_correct/src/bitint35.f08 new file mode 100644 index 0000000000..9c23bcd0a9 --- /dev/null +++ b/test/f08_correct/src/bitint35.f08 @@ -0,0 +1,28 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Thu Mar 19 10:54:19 IST 2020 +! +! Purpose: Test the operation of MASKR intrinsic +! when a value stored in an array is passed as an +! argument +! +PROGRAM BITINT35 + IMPLICIT NONE + INTEGER(1) :: SIZE(10), RESULT(10) + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + SIZE(4) = 6 + RESULT = MASKR(SIZE(4), 2) + PRINT *, RESULT + PRINT '(B8.8)', RESULT + WRITE(UNIT=*,FMT="(B32.32)") RESULT + IF (RESULT(4) /= INT(B'00111111')) THEN + STOP "FAIL" + ELSE + PRINT *, "PASS" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitint36.f08 b/test/f08_correct/src/bitint36.f08 new file mode 100644 index 0000000000..2df38ccff6 --- /dev/null +++ b/test/f08_correct/src/bitint36.f08 @@ -0,0 +1,33 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Bit-intrinsics test cases +! +! Date of Modification: Thu Mar 19 10:54:19 IST 2020 +! +! Purpose: Test the operation of MASKR intrinsic +! when a value stored in an array is passed as an +! argument +! +PROGRAM BITINT36 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + TYPE OPERAND + INTEGER(1) ID + INTEGER(1) RESULT + END TYPE + TYPE(OPERAND) X + + X%ID = 7 + X%RESULT = MASKR(X%ID, 1) + PRINT *, X%RESULT + PRINT '(B8.8)', X%RESULT + WRITE(UNIT=*,FMT="(B32.32)") X%RESULT + IF (X%RESULT /= INT(B'01111111')) THEN + STOP "FAIL" + ELSE + PRINT *, "PASS" + END IF + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/bitmask01.f08 b/test/f08_correct/src/bitmask01.f08 new file mode 100644 index 0000000000..5221d9bfc2 --- /dev/null +++ b/test/f08_correct/src/bitmask01.f08 @@ -0,0 +1,52 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Support for Bit Masking intrinsics. +! + +program bitmask + integer, parameter :: N = 10 + integer*8 res(N), exp(N) + intrinsic maskl, maskr + + exp(1) = z'8000000000000000' + res(1) = maskl(1, 8) + + exp(2) = z'ffffffffffffffff' + res(2) = maskl(64, 8) + + exp(3) = z'f0000000' + res(3) = maskl(4, 4) + + exp(4) = z'8000' + res(4) = maskl(1, 2) + + exp(5) = z'0000000000000001' + res(5) = maskr(1, 8) + + exp(6) = z'ffffffff'; + res(6) = maskr(32, 4) + + exp(7) = z'0fff'; + res(7) = maskr(12, 2) + + exp(8) = 314 + res(8) = 315 + if (maskr(2) > maskr(1)) then + res(8) = 314 ! should come here + end if + + exp(9) = 314 + res(9) = 314 + if (maskr(1) == maskr(0)) then + res(9) = 315 ! should *not* come here + end if + + exp(10) = 314 + res(10) = 315 + if (maskl(1, 4) == maskl(1, 4)) then + res(10) = 314 ! should come here + end if + + call checkll(res, exp, N) +end program diff --git a/test/f08_correct/src/bitshift01.f08 b/test/f08_correct/src/bitshift01.f08 new file mode 100644 index 0000000000..c5422c9c98 --- /dev/null +++ b/test/f08_correct/src/bitshift01.f08 @@ -0,0 +1,28 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Support for Bit Shifting intrinsics. +! + +program bitshift + integer, parameter :: N = 4 + integer(kind = 8) :: res(N), exp(N) + intrinsic shiftl, shiftr + + exp(1) = b'10000000000' + res(1) = shiftl(1, 10); + + exp(2) = b'00011100' + res(2) = shiftr(b'11100000', 3); + + exp(3) = 1 + res(3) = 0 + if (shiftl(1_8, 32) > shiftl(1, 32)) then + res(3) = 1 + end if + + exp(4) = b'1100' + res(4) = shiftl(shiftr(shiftr(shiftl(b'1100', 2), 2), 1), 1) + + call checkll(res, exp, N) +end program diff --git a/test/f08_correct/src/blk01.f08 b/test/f08_correct/src/blk01.f08 new file mode 100644 index 0000000000..c7c704e5dc --- /dev/null +++ b/test/f08_correct/src/blk01.f08 @@ -0,0 +1,33 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! CPUPC-2613-F2008: The BLOCK construct allows declarations of +! entities within executable code. +! +! Date of Modification: Fri November 8th, 2019 +! +! Purpose: Test if a single level of BLOCK feature works fine. +! +PROGRAM BLK01 + IMPLICIT NONE + INTEGER I + INTEGER, PARAMETER :: M = 10 + REAL A(M), B(M) + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + DO I=1,M + BLOCK + REAL TMP + A(I) = I + B(I) = 2 * I + TMP = A(I)**3 + IF (TMP > B(I)) B(I) = TMP + END BLOCK + END DO + DO I=1,M + PRINT *, A + PRINT *, B + END DO + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/blk02.f08 b/test/f08_correct/src/blk02.f08 new file mode 100644 index 0000000000..a2a35ad861 --- /dev/null +++ b/test/f08_correct/src/blk02.f08 @@ -0,0 +1,37 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! CPUPC-2613-F2008: The BLOCK construct allows declarations of +! entities within executable code. +! +! Date of Modification: Fri November 8th, 2019 +! +! Purpose: Test if nested levels of BLOCK feature works fine. +! +PROGRAM BLK02 + IMPLICIT NONE + INTEGER I + INTEGER, PARAMETER :: M = 10 + REAL A(M), B(M) + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + DO I=1,M + BLOCK + REAL TMP + TMP = I + A(I) = TMP + B(I) = 2 * TMP + BLOCK + REAL TMP + TMP = A(I)**3 + IF (TMP > B(I)) B(I) = TMP + END BLOCK + END BLOCK + END DO + DO I=1,M + PRINT *, A + PRINT *, B + END DO + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/blk03.f08 b/test/f08_correct/src/blk03.f08 new file mode 100644 index 0000000000..dabe30efe5 --- /dev/null +++ b/test/f08_correct/src/blk03.f08 @@ -0,0 +1,36 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! CPUPC-2613-F2008: The BLOCK construct allows declarations of +! entities within executable code. +! +! Date of Modification: Fri November 8th, 2019 +! +! Purpose: Test if COMMON statement inside of BLOCK produces error message +! +PROGRAM BLK03 + IMPLICIT NONE + INTEGER I + INTEGER, PARAMETER :: M = 10 + REAL A(M), B(M) + INTEGER TMP + COMMON TMP + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + CALL CHECK(RES, EXP, N) + + DO I=1,M + BLOCK + REAL TMP + COMMON TMP + A(I) = I + B(I) = 2 * I + TMP = A(I)**3 + IF (TMP > B(I)) B(I) = TMP + END BLOCK + END DO + DO I=1,M + PRINT *, A + PRINT *, B + END DO +END PROGRAM diff --git a/test/f08_correct/src/blk04.f08 b/test/f08_correct/src/blk04.f08 new file mode 100644 index 0000000000..c710226204 --- /dev/null +++ b/test/f08_correct/src/blk04.f08 @@ -0,0 +1,38 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! CPUPC-2613-F2008: The BLOCK construct allows declarations of +! entities within executable code. +! +! Date of Modification: Fri November 8th, 2019 +! +! Purpose: Tests if EQUIVALENCE clause inside of a BLOCK statement +! produces error. +! +PROGRAM BLK04 + IMPLICIT NONE + INTEGER I + INTEGER, PARAMETER :: M = 10 + REAL A(M), B(M) + CHARACTER X*4, Y*4, Z(2)*3 + EQUIVALENCE (X,Z(1)),(Y,Z(2)) + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + CALL CHECK(RES, EXP, N) + + DO I=1,M + BLOCK + REAL TMP + CHARACTER X*4, Y*4, Z(2)*3 + EQUIVALENCE (X,Z(1)),(Y,Z(2)) + A(I) = I + B(I) = 2 * I + TMP = A(I)**3 + IF (TMP > B(I)) B(I) = TMP + END BLOCK + END DO + DO I=1,M + PRINT *, A + PRINT *, B + END DO +END PROGRAM diff --git a/test/f08_correct/src/blk05.f08 b/test/f08_correct/src/blk05.f08 new file mode 100644 index 0000000000..f38206e53b --- /dev/null +++ b/test/f08_correct/src/blk05.f08 @@ -0,0 +1,35 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! CPUPC-2613-F2008: The BLOCK construct allows declarations of +! entities within executable code. +! +! Date of Modification: Fri November 8th, 2019 +! +! Purpose: Test if an IMPLICIT clause inside of a BLOCK statement +! produces error. +! +PROGRAM BLK05 + IMPLICIT NONE + INTEGER I + INTEGER, PARAMETER :: M = 10 + REAL A(M), B(M) + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + CALL CHECK(RES, EXP, N) + + DO I=1,M + BLOCK + IMPLICIT NONE + REAL TMP + A(I) = I + B(I) = 2 * I + TMP = A(I)**3 + IF (TMP > B(I)) B(I) = TMP + END BLOCK + END DO + DO I=1,M + PRINT *, A + PRINT *, B + END DO +END PROGRAM diff --git a/test/f08_correct/src/blk06.f08 b/test/f08_correct/src/blk06.f08 new file mode 100644 index 0000000000..7affc8f8ca --- /dev/null +++ b/test/f08_correct/src/blk06.f08 @@ -0,0 +1,43 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! CPUPC-2613-F2008: The BLOCK construct allows declarations of +! entities within executable code. +! +! Date of Modification: Fri November 8th, 2019 +! +! Purpose: Tests if an INTENT statement inside of a BLOCK statement +! produces error. +! +PROGRAM BLK06 + IMPLICIT NONE + INTEGER I + INTEGER, PARAMETER :: M = 10 + REAL A(M), B(M) + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + CALL CHECK(RES, EXP, N) + + DO I=1,M + BLOCK + REAL TMP + A(I) = I + B(I) = 2 * I + TMP = A(I)**3 + IF (TMP > B(I)) B(I) = TMP + END BLOCK + END DO + DO I=1,M + PRINT *, A + PRINT *, B + END DO + + CALL SUB1(10) +END PROGRAM + +SUBROUTINE SUB1(J) + INTEGER, INTENT(IN) :: J + BLOCK + INTEGER, INTENT(IN) :: J + END BLOCK +END SUBROUTINE diff --git a/test/f08_correct/src/blk07.f08 b/test/f08_correct/src/blk07.f08 new file mode 100644 index 0000000000..849be21276 --- /dev/null +++ b/test/f08_correct/src/blk07.f08 @@ -0,0 +1,42 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! CPUPC-2613-F2008: The BLOCK construct allows declarations of +! entities within executable code. +! +! Date of Modification: Fri November 8th, 2019 +! +! Purpose: Test if NAMELIST feature inside of a BLOCK statement +! produces error. +! +PROGRAM BLK07 + IMPLICIT NONE + INTEGER I + INTEGER, PARAMETER :: M = 10 + REAL A(M), B(M) + CHARACTER*18 SAMPLE + LOGICAL*4 NEW + REAL*4 DELTA + NAMELIST /CASE/ SAMPLE, NEW, DELTA + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + CALL CHECK(RES, EXP, N) + + DO I=1,M + BLOCK + CHARACTER*18 SAMPLE + LOGICAL*4 NEW + REAL*4 DELTA + NAMELIST /CASE/ SAMPLE, NEW, DELTA + REAL TMP + A(I) = I + B(I) = 2 * I + TMP = A(I)**3 + IF (TMP > B(I)) B(I) = TMP + END BLOCK + END DO + DO I=1,M + PRINT *, A + PRINT *, B + END DO +END PROGRAM diff --git a/test/f08_correct/src/blk08.f08 b/test/f08_correct/src/blk08.f08 new file mode 100644 index 0000000000..57acd1535f --- /dev/null +++ b/test/f08_correct/src/blk08.f08 @@ -0,0 +1,42 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! CPUPC-2613-F2008: The BLOCK construct allows declarations of +! entities within executable code. +! +! Date of Modification: Fri November 8th, 2019 +! +! Purpose: Test if an OPTIONAL clause for variable definition inside of a BLOCK statement produces error. +! +PROGRAM BLK08 + IMPLICIT NONE + INTEGER I + INTEGER, PARAMETER :: M = 10 + REAL A(M), B(M) + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + CALL CHECK(RES, EXP, N) + + DO I=1,M + BLOCK + REAL TMP + A(I) = I + B(I) = 2 * I + TMP = A(I)**3 + IF (TMP > B(I)) B(I) = TMP + END BLOCK + END DO + DO I=1,M + PRINT *, A + PRINT *, B + END DO + + CALL SUB1(10) +END PROGRAM + +SUBROUTINE SUB1(J, K, L) + OPTIONAL K, L + BLOCK + OPTIONAL K, L + END BLOCK +END SUBROUTINE diff --git a/test/f08_correct/src/blk09.f08 b/test/f08_correct/src/blk09.f08 new file mode 100644 index 0000000000..cfe808928e --- /dev/null +++ b/test/f08_correct/src/blk09.f08 @@ -0,0 +1,54 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! CPUPC-2613-F2008: The BLOCK construct allows declarations of +! entities within executable code. +! +! Date of Modification: Fri November 8th, 2019 +! +! Purpose: Test if a VALUE clause inside of a BLOCK statement produces +! error +! +PROGRAM BLK09 + IMPLICIT NONE + INTEGER I + INTEGER, PARAMETER :: M = 10 + REAL A(M), B(M) + INTEGER J, K, L + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + CALL CHECK(RES, EXP, N) + + DO I=1,M + BLOCK + REAL TMP + A(I) = I + B(I) = 2 * I + TMP = A(I)**3 + IF (TMP > B(I)) B(I) = TMP + END BLOCK + END DO + DO I=1,M + PRINT *, A + PRINT *, B + END DO + + J = 10 + K = 20 + L = 30 + CALL SUB1(J, K, L) + PRINT *, J, K, L +END PROGRAM + +SUBROUTINE SUB1(J, K, L) + INTEGER J + INTEGER, VALUE :: K, L + J = 100 + K = 200 + L = 300 + BLOCK + INTEGER J + INTEGER, VALUE :: K, L + J = 900 + END BLOCK +END SUBROUTINE diff --git a/test/f08_correct/src/blk10.f08 b/test/f08_correct/src/blk10.f08 new file mode 100644 index 0000000000..c7769792b5 --- /dev/null +++ b/test/f08_correct/src/blk10.f08 @@ -0,0 +1,57 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! CPUPC-2613-F2008: The BLOCK construct allows declarations of +! entities within executable code. +! +! Date of Modification: Fri November 8th, 2019 +! +! Purpose: Tests if a GOTO into a BLOCK statement from outside +! porduces error. +! +PROGRAM BLK11 + IMPLICIT NONE + INTEGER I + INTEGER, PARAMETER :: M = 10 + REAL A(M), B(M) + INTEGER J, K, L + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + CALL CHECK(RES, EXP, N) + + GO TO 10 + DO I=1,M + BLOCK + REAL TMP +10 A(I) = I + B(I) = 2 * I + TMP = A(I)**3 + IF (TMP > B(I)) B(I) = TMP + END BLOCK + END DO + DO I=1,M + PRINT *, A + PRINT *, B + END DO + + J = 10 + K = 20 + L = 30 + CALL SUB1(J, K, L) + PRINT *, J, K, L +END PROGRAM + +SUBROUTINE SUB1(J, K, L) + INTEGER J + INTEGER :: K, L + GO TO 40 + J = 100 + K = 200 +40 L = 300 + BLOCK + INTEGER J + INTEGER :: K, L +20 J = 900 + END BLOCK + GO TO 20 +END SUBROUTINE diff --git a/test/f08_correct/src/blk11.f08 b/test/f08_correct/src/blk11.f08 new file mode 100644 index 0000000000..f4d49f35b3 --- /dev/null +++ b/test/f08_correct/src/blk11.f08 @@ -0,0 +1,58 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! CPUPC-2613-F2008: The BLOCK construct allows declarations of +! entities within executable code. +! +! Date of Modification: Fri November 8th, 2019 +! +! Purpose: Tests if a GOTO out of a BLOCK statement ends execution +! at that point of the rest of the BLOCK statements. But execution +! should continue from the target statement of the GOTO. +! +PROGRAM BLK11 + IMPLICIT NONE + INTEGER I + INTEGER, PARAMETER :: M = 10 + REAL A(M), B(M) + INTEGER J, K, L + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + DO I=1,M + BLOCK + REAL TMP + A(I) = I + IF (I == M - 2) THEN + GO TO 10 + END IF + B(I) = 2 * I + TMP = A(I)**3 + IF (TMP > B(I)) B(I) = TMP + END BLOCK + END DO +10 DO I=1,M + PRINT *, A + PRINT *, B + END DO + + J = 10 + K = 20 + L = 30 + CALL SUB1(J, K, L) + PRINT *, J, K, L + CALL CHECK(RES, EXP, N) +END PROGRAM + +SUBROUTINE SUB1(J, K, L) + INTEGER J + INTEGER :: K, L + J = 100 + K = 200 + L = 300 + BLOCK + INTEGER J + INTEGER :: K, L + J = 900 + END BLOCK +END SUBROUTINE diff --git a/test/f08_correct/src/check.c b/test/f08_correct/src/check.c new file mode 100644 index 0000000000..0dad38b7ea --- /dev/null +++ b/test/f08_correct/src/check.c @@ -0,0 +1,157 @@ +/* + * Copyright (c) 2018, Advanced Micro Devices, Inc. All rights reserved. + * + * Support for DNORM intrinsic + * Date of Modification: 21st February 2019 + * + * Complex data types support for acosh, asinh and atanh + * Date of Modification: 08 January 2020 + * + */ + +#include +#include +#include + +extern int __hpf_lcpu; + +void +check_(int* res, int* exp, int* np) +{ + int i; + int n = *np; + int tests_passed = 0; + int tests_failed = 0; + + for (i = 0; i < n; i++) { + if (exp[i] == res[i]) { + tests_passed ++; + } else { + tests_failed ++; + if( tests_failed < 100 ) + printf( + "test number %d FAILED. res %d(%08x) exp %d(%08x)\n", + i+1,res[i], res[i], exp[i], exp[i] ); + } + } + if (tests_failed == 0) { + printf( + "%3d tests completed. %d tests PASSED. %d tests failed.\n", + n, tests_passed, tests_failed); + } else { + printf("%3d tests completed. %d tests passed. %d tests FAILED.\n", + n, tests_passed, tests_failed); + } +} + +void +check(int* res, int* exp, int* np) +{ + check_(res, exp, np); +} + + void +checkll_(long long *res, long long *exp, int *np) +{ + int i; + int n = *np; + int tests_passed = 0; + int tests_failed = 0; + + for (i = 0; i < n; i++) { + if (exp[i] == res[i]) { + tests_passed ++; + } else { + tests_failed ++; + if( tests_failed < 100 ) + printf( "test number %d FAILED. res %lld(%0llx) exp %lld(%0llx)\n", + i+1,res[i], res[i], exp[i], exp[i] ); + } + } + if (tests_failed == 0) { + printf( + "%3d tests completed. %d tests PASSED. %d tests failed.\n", + n, tests_passed, tests_failed); + } else { + printf("%3d tests completed. %d tests passed. %d tests FAILED.\n", + n, tests_passed, tests_failed); + } +} + + void +checkll(long long *res, long long *exp, int *np) +{ + checkll_(res, exp, np); +} + +/* maximum allowed difference in units in the last place */ +#ifndef MAX_DIFF_ULPS +#define MAX_DIFF_ULPS 3 +#endif + +void +checkf_(float* res, float* exp, int* np) +{ + int i; + int n = *np; + int tests_passed = 0; + int tests_failed = 0; + int ires, iexp, diff; + + assert(sizeof(int) == 4); + assert(sizeof(float) == 4); + for (i = 0; i < n; i++) { + ires = *(int *)(res + i); + iexp = *(int *)(exp + i); + if (ires < 0) + ires = 0x80000000 - ires; + if (iexp < 0) + iexp = 0x80000000 - iexp; + diff = abs(ires - iexp); + if (diff <= MAX_DIFF_ULPS) + tests_passed++; + else { + tests_failed++; + printf("ires = %d iexp = %d diff = %d\n" , ires , iexp , diff); + if (tests_failed < 100) + printf("test number %d FAILED. diff in last place units: %d\n", + i+1, diff); + } + } + if (tests_failed == 0) { + printf("%3d tests completed. %d tests PASSED. %d tests failed.\n", + n, tests_passed, tests_failed); + } + else { + printf("%3d tests completed. %d tests passed. %d tests FAILED.\n", + n, tests_passed, tests_failed); + } +} + +void +checkf(float* res, float* exp, int* np) +{ + checkf_(res, exp, np); +} + + +#if defined(WINNT) || defined(WIN32) +void +__stdcall CHECK(int* res, int* exp, int* np) +{ + check_(res, exp, np); +} + +void +__stdcall CHECKLL(long long *res, long long *exp, int *np) +{ + checkll_(res, exp, np); +} + +void +__stdcall CHECKF(float* res, float* exp, int* np) +{ + checkf_(res, exp, np); +} + +#endif diff --git a/test/f08_correct/src/cmplx_hyp.f08 b/test/f08_correct/src/cmplx_hyp.f08 new file mode 100644 index 0000000000..f0ccadf2f2 --- /dev/null +++ b/test/f08_correct/src/cmplx_hyp.f08 @@ -0,0 +1,46 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! CPUPC-2013: F2008-Exit statement-Execution control +! +! Date of Modification: 07 January 2020 +! +! [CPUPC-2569]Complex data types support for acosh, asinh and atanh + +program ComplexHyperbolic +implicit none + integer a + + complex, parameter :: i = (0, 1) ! sqrt(-1) + complex :: x, y, z + + integer , parameter :: n = 9 + real(kind=4) :: result(n) + real(kind=4) :: expect(n) = [0.000000,1.570796,3.240406,0.1457423,1.508243,1.022660,1.570350,0.1836487,1.197106] + + x = (7, 8.852) + y = (5.656, -7) + result(1) = real(asinh(i)) + result(2) = imag(asinh(i)) + + z = x + y + result(3) = real(acosh(z)) + result(4) = imag(acosh(z)) + + z = x - y + result(5) = imag(atanh(z)) + + z = x * y + result(6) = real(asinh(atanh(z*x+y))) + result(7) = imag(asinh(atanh(z*x+y))) + + z = x / y + result(8) = real(atanh(acosh(asinh(z)))) + result(9) = imag(atanh(acosh(asinh(z)))) + + do a = 1 , n + print*, result(a) , expect(a) + end do + + call checkf(result,expect,n) +end program ComplexHyperbolic diff --git a/test/f08_correct/src/combined_shift01.f08 b/test/f08_correct/src/combined_shift01.f08 new file mode 100644 index 0000000000..b41fd1ff15 --- /dev/null +++ b/test/f08_correct/src/combined_shift01.f08 @@ -0,0 +1,39 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Support for Combined Bit Shifting intrinsic. +! + +program combined_shift01 + integer :: i32, j32, shift32 + integer, parameter :: N = 10 + integer(kind = 8) :: i64, j64, shift64 + integer(kind = 8) :: res(N), exp(N) + + i32 = 12; j32 = 14; shift32 = 13; + exp(1) = 98304 + exp(2) = 6291456 + res(1) = dshiftl(i32, j32, shift32) + res(2) = dshiftr(i32, j32, shift32) + + exp(3) = 469846 + exp(4) = 703672321 + res(3:4) = (/dshiftl(234923, 234834, 1), dshiftr(343590, 3049845, 21)/) + + exp(5) = 809309591367450624_8 + exp(6) = 1352768738429854494_8 + res(5) = dshiftl(12349084340934_8, 23490839083451_8, 16_8) + res(6) = dshiftr(12349084340934_8, 23490839083451_8, 16_8) + + exp(7:8) = (/0, 0/) + res(7) = dshiftl(0, 0, 0) + res(8) = dshiftl(0_8, 0_8, 12) + + i64 = 12309580498409440_8; j64 = 1435870234820349_8; shift64 = 0; + exp(9) = 12309580498409440_8 + exp(10) = 1435870234820349_8 + res(9) = dshiftl(i64, j64, shift64) + res(10) = dshiftr(i64, j64, shift64) + + call checkll(res, exp, N) +end program combined_shift01 diff --git a/test/f08_correct/src/editd01.f08 b/test/f08_correct/src/editd01.f08 new file mode 100644 index 0000000000..9e6270fba2 --- /dev/null +++ b/test/f08_correct/src/editd01.f08 @@ -0,0 +1,17 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: G0 Edit descriptor - Input/Output extensions +! +! Date of Modification: 31st Aug 2019 +! +! Tests if the G0 Edit descriptors work correctly +PROGRAM EDITD01 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + PRINT 1,1.25,.True.,"Hi !",123456789 +1 FORMAT(*(G0,',')) + CALL CHECK(RES, EXP, N) +END diff --git a/test/f08_correct/src/editd02.f08 b/test/f08_correct/src/editd02.f08 new file mode 100644 index 0000000000..29a296d52e --- /dev/null +++ b/test/f08_correct/src/editd02.f08 @@ -0,0 +1,22 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: G0 Edit descriptor - Input/Output extensions +! +! Date of Modification: 31st Aug 2019 +! +! Tests if the G0 Edit descriptors work correctly +PROGRAM EDITD02 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + REAL A, B, C, D + + A = 3.14159 + B = -99.8 + C = 321.4567E-02 + D = 5.99392558D+08 + WRITE(*,100)A,B,C,D +100 FORMAT(' ',4G10.2) +CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/editd03.f08 b/test/f08_correct/src/editd03.f08 new file mode 100644 index 0000000000..aeabfc1e9a --- /dev/null +++ b/test/f08_correct/src/editd03.f08 @@ -0,0 +1,19 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: G0 Edit descriptor - Input/Output extensions +! +! Date of Modification: 31st Aug 2019 +! +! Tests if the G0 Edit descriptors work correctly +PROGRAM EDITD03 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + COMPLEX T + + T = (-16.4,409.76) + WRITE(*,99)T +99 FORMAT(' ',2G10.5) +CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/editd04.f08 b/test/f08_correct/src/editd04.f08 new file mode 100644 index 0000000000..9eba5afeea --- /dev/null +++ b/test/f08_correct/src/editd04.f08 @@ -0,0 +1,22 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: G0 Edit descriptor - Input/Output extensions +! +! Date of Modification: 31st Aug 2019 +! +! Tests if the G0 Edit descriptors work correctly +PROGRAM EDITD04 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + REAL A, B, C, D + + A = 3.14159 + B = -99.8 + C = 321.4567E-02 + D = 5.99392558D+08 + WRITE(*,10) "A = ", A, "B = ", B, "C = ", C, "D = ", D +10 FORMAT(*(G0,',')) +CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/editd05.f08 b/test/f08_correct/src/editd05.f08 new file mode 100644 index 0000000000..d4a9fa896c --- /dev/null +++ b/test/f08_correct/src/editd05.f08 @@ -0,0 +1,19 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: G0 Edit descriptor - Input/Output extensions +! +! Date of Modification: 31st Aug 2019 +! +! Tests if the G0 Edit descriptors work correctly +PROGRAM EDITD05 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + COMPLEX T + + T = (-16.4,409.76) + WRITE(*, 5) "T = ", T +5 FORMAT(*(G0,',')) +CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/estop01.f08 b/test/f08_correct/src/estop01.f08 new file mode 100644 index 0000000000..0c8f046d8a --- /dev/null +++ b/test/f08_correct/src/estop01.f08 @@ -0,0 +1,24 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Error stop code - Execution control +! +! Date of Modification: 25th July 2019 +! +! Tests if an integer constant is returned correctly as the error stop code +PROGRAM ESTOP_TEST_01 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + CALL CHECK(RES, EXP, N) + + CALL ESTOP_IC_TEST +END PROGRAM + +IMPURE SUBROUTINE ESTOP_IC_TEST + IMPLICIT NONE + INTEGER CODE + + CODE = 7 + ERROR STOP code +END SUBROUTINE diff --git a/test/f08_correct/src/estop02.f08 b/test/f08_correct/src/estop02.f08 new file mode 100644 index 0000000000..f996837b5f --- /dev/null +++ b/test/f08_correct/src/estop02.f08 @@ -0,0 +1,25 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Error stop code - Execution control +! +! Date of Modification: 25th July 2019 +! +! Tests if an integer constant of size 4 is returned correctly as the +! error stop code +PROGRAM ESTOP_TEST_02 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + CALL CHECK(RES, EXP, N) + + CALL ESTOP_TEST_ICW +END PROGRAM + +IMPURE SUBROUTINE ESTOP_TEST_ICW + IMPLICIT NONE + INTEGER CODE + + CODE = 9999 + ERROR STOP CODE +END SUBROUTINE diff --git a/test/f08_correct/src/estop03.f08 b/test/f08_correct/src/estop03.f08 new file mode 100644 index 0000000000..cbdaf7b165 --- /dev/null +++ b/test/f08_correct/src/estop03.f08 @@ -0,0 +1,27 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Error stop code - Execution control +! +! Date of Modification: 25th July 2019 +! +! Tests is an integer expression is returned as the error stop code +! correctly +PROGRAM ESTOP_TEST_03 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + CALL CHECK(RES, EXP, N) + + CALL ESTOP_TEST_IE +END PROGRAM + +IMPURE SUBROUTINE ESTOP_TEST_IE + IMPLICIT NONE + INTEGER A, B, C + + A = 786 + B = 10 + C = A * B + ERROR STOP (A * B + C) +END SUBROUTINE diff --git a/test/f08_correct/src/estop04.f08 b/test/f08_correct/src/estop04.f08 new file mode 100644 index 0000000000..ec395fa216 --- /dev/null +++ b/test/f08_correct/src/estop04.f08 @@ -0,0 +1,27 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Error stop code - Execution control +! +! Date of Modification: 25th July 2019 +! +! Program tests if a character expression is returned as the error stop +! code correctly +PROGRAM ESTOP_TEST_04 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + CALL CHECK(RES, EXP, N) + + CALL ESTOP_TEST_CE +END PROGRAM + +IMPURE SUBROUTINE ESTOP_TEST_CE + IMPLICIT NONE + CHARACTER A*4, B*2, C*8 + + A = 'JOIN' + B = 'ED' + C = A // B + ERROR STOP (C // B // A) +END SUBROUTINE diff --git a/test/f08_correct/src/exec_cmd01.f08 b/test/f08_correct/src/exec_cmd01.f08 new file mode 100644 index 0000000000..bd91c5742f --- /dev/null +++ b/test/f08_correct/src/exec_cmd01.f08 @@ -0,0 +1,26 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Support for execute_command_line as per f2008 standard +! +! This test case is derived from the Flexi benchmark + + + +program exec_command + +call WriteTimeAverageByCopy("../input_for_exec_cmdline.txt", "../output_file.txt") + +contains +subroutine WriteTimeAverageByCopy(filename_in,filename_out) +implicit none +!----------------------------------------------------------------------------------------------------------------------------------- +! INPUT/OUTPUT VARIABLES +character(len=*),intent(in) :: filename_in !< file to be copied +character(len=*),intent(in) :: filename_out !< output file +integer :: iStatus + call execute_command_line("cp -f "//trim(filename_in)//" "//trim(filename_out), wait=.true., exitstat=iStatus) + print *, "Exit status of command is ", iStatus +end subroutine WriteTimeAverageByCopy + +end program exec_command diff --git a/test/f08_correct/src/exec_cmd02.f08 b/test/f08_correct/src/exec_cmd02.f08 new file mode 100644 index 0000000000..2642ee9a09 --- /dev/null +++ b/test/f08_correct/src/exec_cmd02.f08 @@ -0,0 +1,18 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Support for execute_command_line as per f2008 standard +! + +program exec_command + integer :: ex_st = 100 + + call execute_command_line("echo Hello World", .true., ex_st) + print *, "This is synchronous" + print *, "Exit status is ", ex_st + +end program exec_command + +! CHECK: Hello World +! CHECK-NEXT : This is synchronous +! CHECK-NEXT : Exit status is 0 diff --git a/test/f08_correct/src/exit01.f08 b/test/f08_correct/src/exit01.f08 new file mode 100644 index 0000000000..74072bc74f --- /dev/null +++ b/test/f08_correct/src/exit01.f08 @@ -0,0 +1,61 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! CPUPC-2013: F2008-Exit statement-Execution control +! +! Date of Modification: 23rd Sep 2019 +! +! CPUPC-2013: Testing 'NAMED' DO construct. +! +PROGRAM EXIT_TEST_01 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + PRINT *, 'Calling SIMPLE_DO_TEST' + CALL SIMPLE_DO_TEST + PRINT *, 'Returned from SIMPLE_DO_TEST' + PRINT *, 'Calling NAMED_DO_TEST' + CALL NAMED_DO_TEST + PRINT *, 'Returned from NAMED_DO_TEST' + + CALL CHECK(RES, EXP, N) +END PROGRAM + +IMPURE SUBROUTINE SIMPLE_DO_TEST + IMPLICIT NONE + + INTEGER I, STATUS + STATUS = 99 + + DO I = 1, 20, 2 + PRINT *, 'SIMPLE_DO_TEST: I = ', I + IF (I == 10) THEN + EXIT + END IF + END DO + PRINT *, 'SIMPLE_DO_TEST: Final value of I = ', I +END SUBROUTINE + +IMPURE SUBROUTINE NAMED_DO_TEST + IMPLICIT NONE + + INTEGER I, J, STATUS + STATUS = 99 + + OL: DO I = 1, 20, 2 + PRINT *, 'SIMPLE_DO_TEST I = ', I + IL: DO J = 1, 20, 2 + PRINT *, 'SIMPLE_DO_TEST J = ', J + IF (I == J) THEN + PRINT *, 'EXITing from the inner DO (OL)' + EXIT IL + END IF + END DO IL + END DO OL + + PRINT *, 'NAMED_DO_TEST: Final value of I = ', I, 'J = ', J + +END SUBROUTINE + +! EOF diff --git a/test/f08_correct/src/exit02.f08 b/test/f08_correct/src/exit02.f08 new file mode 100644 index 0000000000..978fbefa28 --- /dev/null +++ b/test/f08_correct/src/exit02.f08 @@ -0,0 +1,80 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! CPUPC-2013: F2008-Exit statement-Execution control +! +! Date of Modification: 23rd Sep 2019 +! +! CPUPC-2013: Testing 'NAMED' IF construct. +! +PROGRAM EXIT_TEST_02 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + CALL SIMPLE_IF_TEST + CALL NAMED_IF_TEST1 + CALL NAMED_IF_TEST2 + + CALL CHECK(RES, EXP, N) +END PROGRAM + +IMPURE SUBROUTINE SIMPLE_IF_TEST + IMPLICIT NONE + + INTEGER I + + DO I=1,5 + IC: IF (I == 3) THEN + PRINT *, 'SIMPLE_IF_TEST: Before calling EXIT', I + EXIT + PRINT *, 'SIMPLE_IF_TEST: After EXIT', I + PRINT *, 'SIMPLE_IF_TEST: Before IF END IC' + END IF IC + PRINT *, 'SIMPLE_IF_TEST: After IF I = ', I + END DO +END SUBROUTINE + +IMPURE SUBROUTINE NAMED_IF_TEST1 + IMPLICIT NONE + + INTEGER I + + DO I=1,5 + IC: IF (I == 3) THEN + PRINT *, 'NAMED_IF_TEST1: Before calling EXIT', I + EXIT IC + PRINT *, 'NAMED_IF_TEST1: After EXIT', I + PRINT *, 'NAMED_IF_TEST1: Before IF END IC' + END IF IC + PRINT *, 'NAMED_IF_TEST1: After IF I = ', I + END DO +END SUBROUTINE + +IMPURE SUBROUTINE NAMED_IF_TEST2 + IMPLICIT NONE + + INTEGER I, J + + DO I = 1, 5 + DO J = 1, 5 + IC1: IF (I == J) THEN + PRINT *, 'NAMED_IF_TEST2: CALLING EXIT IC1' + EXIT IC1 + PRINT *, 'NAMED_IF_TEST2: After call to EXIT IC1' + PRINT *, 'NAMED_IF_TEST2: Before END IF IC1' + END IF IC1 + + IC2: IF (I > J) THEN + PRINT *, 'NAMED_IF_TEST2: CALLING EXIT IC2' + EXIT IC2 + PRINT *, 'NAMED_IF_TEST2: After call to EXIT IC2' + PRINT *, 'NAMED_IF_TEST2: Before END IF IC2' + END IF IC2 + + PRINT *, 'NAMED_IF_TEST2: END of NAMED_IF_TEST' + END DO + END DO +END SUBROUTINE + +! EOF diff --git a/test/f08_correct/src/exit03.f08 b/test/f08_correct/src/exit03.f08 new file mode 100644 index 0000000000..f6fbc6977f --- /dev/null +++ b/test/f08_correct/src/exit03.f08 @@ -0,0 +1,82 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! CPUPC-2013: F2008-Exit statement-Execution control +! +! Date of Modification: 23rd Sep 2019 +! +! CPUPC-2013: Testing 'NAMED' ASSOCIATE construct. +! +PROGRAM EXIT_TEST_03 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + CALL SIMPLE_ASSOCIATE_TEST + CALL NAMED_ASSOCIATE_TEST + + CALL CHECK(RES, EXP, N) +END PROGRAM + +IMPURE SUBROUTINE SIMPLE_ASSOCIATE_TEST + IMPLICIT NONE + + INTEGER I + INTEGER A + INTEGER F + INTEGER B + INTEGER G + + PRINT *, 'Running SIMPLE_ASSOCIATE_TEST' + A = 2.0 + F = 3.0 + B = 4.0 + G = 5.0 + + DO I=1,2 + ASSOCIATE (O => (A-F)**2 + (B+G)**2) + !ASSOCIATE (O => 99) + PRINT *, 'VALUE of O = ', O + PRINT *, 'SIMPLE_ASSOCIATE_TEST: Before calling EXIT', I + EXIT + PRINT *, 'SIMPLE_ASSOCIATE_TEST: After EXIT', I + PRINT *, 'SIMPLE_ASSOCIATE_TEST: Before END ASSOCIATE' + END ASSOCIATE + PRINT *, 'SIMPLE_ASSOCIATE_TEST: After ASSOCIATE I = ', I + END DO + PRINT *, 'SIMPLE_ASSOCIATE_TEST: Before END SUBROUTINE' + PRINT *, 'Done Running SIMPLE_ASSOCIATE_TEST' +END SUBROUTINE + +IMPURE SUBROUTINE NAMED_ASSOCIATE_TEST + IMPLICIT NONE + + INTEGER I + INTEGER A + INTEGER F + INTEGER B + INTEGER G + + print *, 'Running NAMED_ASSOCIATE_TEST' + A = 2.0 + F = 3.0 + B = 4.0 + G = 5.0 + + DO I=1,2 + ASB: ASSOCIATE (O => (A-F)**2 + (B+G)**2) + !ASB: ASSOCIATE (O => 999) + PRINT *, 'VALUE of O = ', O + PRINT *, 'NAMED_ASSOCIATE_TEST: Before calling EXIT', I + !EXIT ASB + EXIT + PRINT *, 'NAMED_ASSOCIATE_TEST: After EXIT', I + PRINT *, 'NAMED_ASSOCIATE_TEST: Before END ASSOCIATE' + END ASSOCIATE ASB + PRINT *, 'NAMED_ASSOCIATE_TEST: After END ASSOCIATE ASB I = ', I + END DO + PRINT *, 'NAMED_ASSOCIATE_TEST: Before END SUBROUTINE' + PRINT *, 'Done Running NAMED_ASSOCIATE_TEST' +END SUBROUTINE + +! EOF diff --git a/test/f08_correct/src/exit04.f08 b/test/f08_correct/src/exit04.f08 new file mode 100644 index 0000000000..d8dd1ac002 --- /dev/null +++ b/test/f08_correct/src/exit04.f08 @@ -0,0 +1,69 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! CPUPC-2013: F2008-Exit statement-Execution control +! +! Date of Modification: 23rd Sep 2019 +! +! CPUPC-2013: Testing 'NAMED' BLOCK construct. +! +PROGRAM EXIT_TEST_04 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + ! To be uncommented when BLOCK feature is available + !CALL SIMPLE_BLOCK_TEST + !CALL NAMED_BLOCK_TEST + + CALL CHECK(RES, EXP, N) +END PROGRAM + +IMPURE SUBROUTINE SIMPLE_BLOCK_TEST + IMPLICIT NONE + INTEGER I + REAL O + + PRINT *, 'Running SIMPLE_BLOCK_TEST' + DO I=1,2 + ! To be uncommented when the Block fetaure is ready + !BLOCK + !REAL O + O = 100 + PRINT *, 'VALUE of O = ', O + PRINT *, 'SIMPLE_BLOCK_TEST: Before calling EXIT', I + EXIT + PRINT *, 'SIMPLE_BLOCK_TEST: After EXIT', I + PRINT *, 'SIMPLE_BLOCK_TEST: Before END BLOCK' + !END BLOCK + PRINT *, 'SIMPLE_BLOCK_TEST: After BLOCK I = ', I + END DO + PRINT *, 'SIMPLE_BLOCK_TEST: Before END SUBROUTINE' + PRINT *, 'Done Running SIMPLE_BLOCK_TEST' +END SUBROUTINE + +IMPURE SUBROUTINE NAMED_BLOCK_TEST + IMPLICIT NONE + INTEGER I + REAL O + + print *, 'Running NAMED_BLOCK_TEST' + + DO I=1,2 + ! To be uncommented when the Block feature is ready + !BLB: BLOCK + !REAL O + O = 100 + PRINT *, 'VALUE of O = ', O + PRINT *, 'NAMED_BLOCK_TEST: Before calling EXIT', I + !EXIT BLB + PRINT *, 'NAMED_BLOCK_TEST: After EXIT', I + PRINT *, 'NAMED_BLOCK_TEST: Before END BLOCK' + !END BLOCK BLB + PRINT *, 'NAMED_BLOCK_TEST: After END BLOCK ASB I = ', I + END DO + PRINT *, 'NAMED_BLOCK_TEST: Before END SUBROUTINE' + PRINT *, 'Done Running NAMED_BLOCK_TEST' +END SUBROUTINE + +! EOF diff --git a/test/f08_correct/src/exit05.f08 b/test/f08_correct/src/exit05.f08 new file mode 100644 index 0000000000..eb80d94657 --- /dev/null +++ b/test/f08_correct/src/exit05.f08 @@ -0,0 +1,74 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! CPUPC-2013: F2008-Exit statement-Execution control +! +! Date of Modification: 23rd Sep 2019 +! +! CPUPC-2013: Testing 'NAMED' SELECT CASE construct. +! +PROGRAM EXIT_TEST_05 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + CALL SIMPLE_SELECT_TEST + CALL NAMED_SELECT_TEST + + CALL CHECK(RES, EXP, N) +END PROGRAM + +IMPURE SUBROUTINE SIMPLE_SELECT_TEST + IMPLICIT NONE + INTEGER I + + PRINT *, 'Running SIMPLE_SELECT_TEST' + DO I=1, 12 + SELECT CASE (I) + CASE (1 : 5) + PRINT *, 'Selected NUMBER Between 1 and 5, inclusive' + CASE (6, 7, 8) + PRINT *, 'Selected NUMBER Between 6 and 8, inclusive' + CASE (9 : 10) + PRINT *, 'Selected NUMBER Equal to 9 or 10' + PRINT *, 'SIMPLE_SELECT_TEST: Before calling EXIT', I + EXIT + PRINT *, 'SIMPLE_SELECT_TEST: After EXIT', I + CASE DEFAULT + PRINT *, 'Selected Number Not between 1 and 10, inclusive' + PRINT *, 'SIMPLE_SELECT_TEST: Before END SELECT' + END SELECT + PRINT *, 'SIMPLE_SELECT_TEST: After SELECT I = ', I + END DO + + PRINT *, 'SIMPLE_SELECT_TEST: Before END SUBROUTINE' + PRINT *, 'Done Running SIMPLE_SELECT_TEST' +END SUBROUTINE + +IMPURE SUBROUTINE NAMED_SELECT_TEST + IMPLICIT NONE + INTEGER I + + PRINT *, 'Running NAMED_SELECT_TEST' + DO I=1, 12 + SCS: SELECT CASE (I) + CASE (1 : 5) + PRINT *, 'Selected NUMBER Between 1 and 5, inclusive' + CASE (6, 7, 8) + PRINT *, 'Selected NUMBER Between 6 and 8, inclusive' + CASE (9 : 10) + PRINT *, 'Selected NUMBER Equal to 9 or 10' + PRINT *, 'NAMED_SELECT_TEST: Before calling EXIT', I + EXIT SCS + PRINT *, 'NAMED_SELECT_TEST: After EXIT', I + CASE DEFAULT + PRINT *, 'Selected Number Not between 1 and 10, inclusive' + PRINT *, 'NAMED_SELECT_TEST: Before END SELECT' + END SELECT SCS + END DO + + PRINT *, 'NAMED_SELECT_TEST: Before END SUBROUTINE' + PRINT *, 'Done Running NAMED_SELECT_TEST' +END SUBROUTINE + +! EOF diff --git a/test/f08_correct/src/exit06.f08 b/test/f08_correct/src/exit06.f08 new file mode 100644 index 0000000000..7ce9dc83bd --- /dev/null +++ b/test/f08_correct/src/exit06.f08 @@ -0,0 +1,118 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! CPUPC-2013: F2008-Exit statement-Execution control +! +! Date of Modification: 23rd Sep 2019 +! +! CPUPC-2013: Testing 'NAMED' SELECT TYPE construct. +! +PROGRAM EXIT06 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + CHARACTER(10), DIMENSION(3), TARGET :: A = (/'Hello', 'Bello', 'Cello'/) + INTEGER, DIMENSION(5), TARGET :: B = (/1, 2, 3, 4, 5/) + REAL, DIMENSION(4), TARGET :: C = (/22.3, 33.2, 44.5, 55.4/) + LOGICAL, DIMENSION(2), TARGET :: D = (/.TRUE., .FALSE./) + + CALL SIMPLE_SELECT(A, B, C, D) + ! To be uncommented when this feature is available + !CALL NAMED_SELECT(A, B, C, D) + + CALL CHECK(RES, EXP, N) + PRINT *, 'PROGRAM EXITED NORMALLY' +END PROGRAM + +IMPURE SUBROUTINE SIMPLE_SELECT(M, N, O, P) + IMPLICIT NONE + CHARACTER(10), DIMENSION(3), TARGET, INTENT(IN) :: M + INTEGER, DIMENSION(5), TARGET, INTENT(IN) :: N + REAL, DIMENSION(4), TARGET, INTENT(IN) :: O + LOGICAL, DIMENSION(2), TARGET, INTENT(IN) :: P + CLASS(*), POINTER, DIMENSION(:) :: X + INTEGER I + + PRINT *, 'TESTING SIMPLE_SELECT' + DO I = 1, 5 + SELECT CASE (I) + CASE (1) + X => M + CASE (2) + X => N + CASE (3) + X => O + CASE (4) + X => P + CASE DEFAULT + X => NULL() + END SELECT + + SELECT TYPE (X) + TYPE IS (CHARACTER(*)) + PRINT *, 'TYPE(X) = CHARACTER(*)' + TYPE IS (INTEGER) + PRINT *, 'TYPE(X) = INTEGER' + TYPE IS (REAL) + PRINT *, 'TYPE(X) = REAL' + TYPE IS (LOGICAL) + PRINT *, 'TYPE(X) = LOGICAL' + CLASS DEFAULT + PRINT *, 'EXITING SELECT' + EXIT + END SELECT + PRINT *, 'AFTER END SELECT' + END DO + PRINT *, 'AFTER END DO' + + PRINT *, 'SUBROUTINE SIMPLE_SELECT EXITED NORMALLY' +END SUBROUTINE + +IMPURE SUBROUTINE NAMED_SELECT(M, N, O, P) + IMPLICIT NONE + CHARACTER(10), DIMENSION(3), TARGET, INTENT(IN) :: M + INTEGER, DIMENSION(5), TARGET, INTENT(IN) :: N + REAL, DIMENSION(4), TARGET, INTENT(IN) :: O + LOGICAL, DIMENSION(2), TARGET, INTENT(IN) :: P + CLASS(*), POINTER, DIMENSION(:) :: X + INTEGER I + + PRINT *, 'TESTING NAMED_SELECT' + + DO I = 1, 5 + SELECT CASE (I) + CASE (1) + X => M + CASE (2) + X => N + CASE (3) + X => O + CASE (4) + X => P + CASE DEFAULT + X => NULL() + END SELECT + + ! To be uncommented when the feature is implemented + !SCS: SELECT TYPE (X) + SELECT TYPE (X) + TYPE IS (CHARACTER(*)) + PRINT *, 'TYPE(X) = CHARACTER(*)' + TYPE IS (INTEGER) + PRINT *, 'TYPE(X) = INTEGER' + TYPE IS (REAL) + PRINT *, 'TYPE(X) = REAL' + TYPE IS (LOGICAL) + PRINT *, 'TYPE(X) = LOGICAL' + CLASS DEFAULT + PRINT *, 'EXITING SELECT' + ! To be uncommented when the feature is implemented + ! EXIT SCS + !END SELECT SCS + END SELECT + PRINT *, 'AFTER END SELECT' + END DO + PRINT *, 'AFTER END DO' + + PRINT *, 'SUBROUTINE NAMED_SELECT EXITED NORMALLY' +END SUBROUTINE diff --git a/test/f08_correct/src/gamma.f08 b/test/f08_correct/src/gamma.f08 new file mode 100644 index 0000000000..61811fb7a8 --- /dev/null +++ b/test/f08_correct/src/gamma.f08 @@ -0,0 +1,20 @@ +!* +!* Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +!* +!* +!* F2008 feature gamma intrinsic +!* AOCC test + + program test_gamma + parameter(NTEST=2) + real :: expect(NTEST) = (/ 1.000000, 1.48919225 /) + real :: result(NTEST) + real :: x = 1.0, y = 0.6 + x = gamma(x) + y = gamma(y) + print *, x + result(1) = x + print *, y + result(2) = y + call check(result,expect,NTEST) + end program test_gamma diff --git a/test/f08_correct/src/iall.f08 b/test/f08_correct/src/iall.f08 new file mode 100644 index 0000000000..3ed80871e5 --- /dev/null +++ b/test/f08_correct/src/iall.f08 @@ -0,0 +1,29 @@ +!* Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +!* +!* +!* F2008 feature bit transformational intrinsic +!* AOCC test + +program test_iall + parameter(NTEST=3) + integer, dimension(3,3) :: x + logical, DIMENSION(3,3) :: z=reshape( (/ .true., .true., .true., & + .true., .false., .false., & + .true., .true., .true. /), & + shape(z)) + integer :: expect(NTEST) = (/ 0, 3, 4 /) + integer :: result(NTEST), iall1(NTEST) + + do i = 1,3 + do j = 1,3 + x(i,j) = i+j + end do + end do + + + iall1 = iall(x,1,z) + print *, iall1 + result = iall1 + call check(result,expect,NTEST) +end program + diff --git a/test/f08_correct/src/iany.f08 b/test/f08_correct/src/iany.f08 new file mode 100644 index 0000000000..b57f1a8eda --- /dev/null +++ b/test/f08_correct/src/iany.f08 @@ -0,0 +1,29 @@ +!* Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +!* +!* +!* F2008 feature bit transformational intrinsic +!* AOCC test + +program test_iany + parameter(NTEST=3) + integer, dimension(3,3) :: x + logical, DIMENSION(3,3) :: z=reshape( (/ .true., .true., .true., & + .true., .false., .false., & + .true., .true., .true. /), & + shape(z)) + integer :: expect(NTEST) = (/ 7, 3, 7 /) + integer :: result(NTEST), iany1(NTEST) + + do i = 1,3 + do j = 1,3 + x(i,j) = i+j + end do + end do + + + iany1 = iany(x,1,z) + print *, iany1 + result = iany1 + call check(result,expect,NTEST) +end program + diff --git a/test/f08_correct/src/impure01.f08 b/test/f08_correct/src/impure01.f08 new file mode 100644 index 0000000000..b128dd6a63 --- /dev/null +++ b/test/f08_correct/src/impure01.f08 @@ -0,0 +1,45 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +! +! Date of Modification: Fri Oct 18 13:41:22 IST 2019 +! + +! +! Purpose: +! Impure keyword allows function to include stop statements +! +IMPURE ELEMENTAL INTEGER FUNCTION ADD(A, B) RESULT(C) + IMPLICIT NONE + INTEGER,INTENT(IN) :: A, B + + PRINT *, 'A = ', A + PRINT *, 'B = ', B + + IF (A > 0 .AND. B > 0) THEN + IF (B > HUGE(C) - A) STOP 'POSITIVE INTEGER OVERFLOW' + ELSE IF (A < 0 .AND. B < 0) THEN + IF ((A + HUGE(C)) + B< 0) STOP 'NEGATIVE INTEGER OVERFLOW' + END IF + + C = A + B + + PRINT *, 'A = ', A + PRINT *, 'B = ', B + PRINT *, 'C = ', C + + RETURN +END FUNCTION + +PROGRAM IMPURE_TEST + IMPLICIT NONE + INTEGER :: X + INTEGER ADD + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + CALL check(res, exp, N) + + X = ADD(10, 20) + PRINT *, 'VALUE OF X = ', X +END PROGRAM diff --git a/test/f08_correct/src/impure02.f08 b/test/f08_correct/src/impure02.f08 new file mode 100644 index 0000000000..fac2908431 --- /dev/null +++ b/test/f08_correct/src/impure02.f08 @@ -0,0 +1,46 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +! +! Date of Modification: Fri Oct 18 +! +! Tests the F2008 : Flang-F2008-Impure elemental procedures + +! +! Purpose: +! Impure subroutines should allow print statements and take +! array arguments +! +IMPURE SUBROUTINE ADD(X, Y) + IMPLICIT NONE + INTEGER, INTENT(IN), DIMENSION(1) :: X, Y + INTEGER A, B, C + + PRINT *, 'X(1) = ', X(1) + PRINT *, 'Y(1) = ', Y(1) + + A = X(1) + B = Y(1) + + IF (A > 0 .AND. B > 0) THEN + IF (B > HUGE(C) - A) STOP 'POSITIVE INTEGER OVERFLOW' + ELSE IF (A < 0 .AND. B < 0) THEN + IF ((A + HUGE(C)) + B< 0) STOP 'NEGATIVE INTEGER OVERFLOW' + END IF + + C = A + B + + PRINT *, 'A = ', A + PRINT *, 'B = ', B + PRINT *, 'C = ', C +END SUBROUTINE + +PROGRAM IMPURE02 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + CALL check(res, exp, N) + + CALL ADD((/10/), (/20/)) +END PROGRAM diff --git a/test/f08_correct/src/impure03.f08 b/test/f08_correct/src/impure03.f08 new file mode 100644 index 0000000000..e5b8d65b29 --- /dev/null +++ b/test/f08_correct/src/impure03.f08 @@ -0,0 +1,47 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +! +! Date of Modification: Fri Oct 18 +! +! Tests the F2008 : Flang-F2008-Impure elemental procedures +! + +! +! Purpose: +! Elemental procedures whether pure or impure should take only +! scalar arguments. Array arguments should generate error. +! +IMPURE ELEMENTAL SUBROUTINE ADD(X, Y) + IMPLICIT NONE + INTEGER, INTENT(IN), DIMENSION(1) :: X, Y + INTEGER A, B, C + + PRINT *, 'X(1) = ', X(1) + PRINT *, 'Y(1) = ', Y(1) + + A = X(1) + B = Y(1) + + IF (A > 0 .AND. B > 0) THEN + IF (B > HUGE(C) - A) STOP 'POSITIVE INTEGER OVERFLOW' + ELSE IF (A < 0 .AND. B < 0) THEN + IF ((A + HUGE(C)) + B< 0) STOP 'NEGATIVE INTEGER OVERFLOW' + END IF + + C = A + B + + PRINT *, 'A = ', A + PRINT *, 'B = ', B + PRINT *, 'C = ', C +END SUBROUTINE + +PROGRAM IMPURE02 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + CALL check(res, exp, N) + + CALL ADD((/10/), (/20/)) +END PROGRAM diff --git a/test/f08_correct/src/impure04.f08 b/test/f08_correct/src/impure04.f08 new file mode 100644 index 0000000000..3c9352b267 --- /dev/null +++ b/test/f08_correct/src/impure04.f08 @@ -0,0 +1,44 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +! +! Date of Modification: Fri Oct 18 +! +! + +! Purpose: +! Pure elemental subroutines cannot take array arguments. +PURE ELEMENTAL FUNCTION ADD(A, B, C) + IMPLICIT NONE + INTEGER, INTENT(IN) :: A(:), B(:), C(:) + INTEGER ADD(SIZE(A)) + + IF (A(1) > 0 .AND. B(1) > 0) THEN + IF (B(1) > HUGE(C(1)) - A(1)) STOP 'POSITIVE INTEGER OVERFLOW' + ELSE IF (A(1) < 0 .AND. B(1) < 0) THEN + IF ((A(1) + HUGE(C(1))) + B(1) < 0) STOP 'NEGATIVE INTEGER OVERFLOW' + END IF + + ADD = A(1) + B(1) + C(1) + + PRINT *, 'A = ', A + PRINT *, 'B = ', B + PRINT *, 'C = ', C + PRINT *, ADD +END FUNCTION + +PROGRAM IMPURE04 + IMPLICIT NONE + INTERFACE ADD + FUNCTION ADD(A, B, C) + INTEGER, INTENT(IN) :: A(:), B(:), C(:) + INTEGER ADD(SIZE(B)) + END FUNCTION + END INTERFACE + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + CALL check(res, exp, N) + + PRINT *, 'ADD = ', ADD((/10/), (/20/), (/30/)) +END PROGRAM diff --git a/test/f08_correct/src/impure05.f08 b/test/f08_correct/src/impure05.f08 new file mode 100644 index 0000000000..b111bce139 --- /dev/null +++ b/test/f08_correct/src/impure05.f08 @@ -0,0 +1,47 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +! +! Date of Modification: Fri Oct 18 +! + +! Purpose: +! Without the elemental keyword pure and impure procedures should +! work fine. +IMPURE FUNCTION ADD(A, B, C) + IMPLICIT NONE + INTEGER, INTENT(IN) :: A(:), B(:), C(:) + INTEGER ADD(SIZE(A)) + INTEGER X(SIZE(A)) + + IF (A(1) > 0 .AND. B(1) > 0) THEN + IF (B(1) > HUGE(C(1)) - A(1)) STOP 'POSITIVE INTEGER OVERFLOW' + ELSE IF (A(1) < 0 .AND. B(1) < 0) THEN + IF ((A(1) + HUGE(C(1))) + B(1) < 0) STOP 'NEGATIVE INTEGER OVERFLOW' + END IF + + X(1) = A(1) + B(1) + C(1) + ADD = X + + PRINT *, 'A = ', A + PRINT *, 'B = ', B + PRINT *, 'C = ', C + PRINT *, 'X = ', X + PRINT *, 'ADD = ', ADD +END FUNCTION + +PROGRAM IMPURE04 + IMPLICIT NONE + INTERFACE ADD + FUNCTION ADD(A, B, C) + INTEGER, INTENT(IN) :: A(:), B(:), C(:) + INTEGER ADD(SIZE(A)) + END FUNCTION + END INTERFACE + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + CALL check(res, exp, N) + + PRINT *, 'ADD = ', ADD((/10/), (/20/), (/30/)) +END PROGRAM diff --git a/test/f08_correct/src/impure06.f08 b/test/f08_correct/src/impure06.f08 new file mode 100644 index 0000000000..c935858c7d --- /dev/null +++ b/test/f08_correct/src/impure06.f08 @@ -0,0 +1,46 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +! +! Date of Modification: Fri Oct 18 +! + +! Purpose: +! Elemental procedures take scalar arguments and produce a scalar +! result. Else raise error. +IMPURE ELEMENTAL FUNCTION VADD(A, B, C) + IMPLICIT NONE + INTEGER, INTENT(IN) :: A(:), B(:), C(:) + INTEGER VADD(SIZE(A)) + + PRINT *, 'A = ', A + PRINT *, 'B = ', B + PRINT *, 'B = ', C + + VADD = A + B + C +END + +! Only works with gfortran now. how to enable scalar ops in flang? +PROGRAM IMPURE06 + IMPLICIT NONE + INTEGER, DIMENSION(100) :: X, Y, Z + INTEGER :: I + INTERFACE + FUNCTION VADD(A, B, C) + INTEGER, INTENT(IN) :: A(:), B(:), C(:) + INTEGER VADD(SIZE(A)) + END FUNCTION + END INTERFACE + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + CALL check(res, exp, N) + + DO I = 1, 100 + X(I) = 2 * I + Y(I) = 3 * I + Z(I) = 4 * I + END DO + + PRINT *, 'X + Y + Z = ', VADD(X, Y, Z) +END PROGRAM diff --git a/test/f08_correct/src/impure07.f08 b/test/f08_correct/src/impure07.f08 new file mode 100644 index 0000000000..11bfb89a72 --- /dev/null +++ b/test/f08_correct/src/impure07.f08 @@ -0,0 +1,42 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +! +! Date of Modification: Fri Oct 18 +! + +! Purpose: +! Impure subroutine with alrnate exits should work fine +! Should allow VALUE in place of INTENT +! +IMPURE SUBROUTINE T(A,B) + REAL, INTENT(OUT) :: A + REAL, VALUE :: B + A = B +END SUBROUTINE + +IMPURE SUBROUTINE ADD(A, B, C) + IMPLICIT NONE + INTEGER,INTENT(IN) :: A, B, C + + IF (A > 0 .AND. B > 0) THEN + IF (B > HUGE(C) - A) STOP 'POSITIVE INTEGER OVERFLOW' + ELSE IF (A < 0 .AND. B < 0) THEN + IF ((A + HUGE(C)) + B< 0) STOP 'NEGATIVE INTEGER OVERFLOW' + END IF + + PRINT *, 'A = ', A + PRINT *, 'B = ', B + PRINT *, 'C = ', C + PRINT *, 'A + B + C = ', A + B + C +END SUBROUTINE + +PROGRAM IMPURE07 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + CALL check(res, exp, N) + + CALL ADD(10, 20, 30) +END PROGRAM diff --git a/test/f08_correct/src/impure08.f08 b/test/f08_correct/src/impure08.f08 new file mode 100644 index 0000000000..f7bf67b3e4 --- /dev/null +++ b/test/f08_correct/src/impure08.f08 @@ -0,0 +1,62 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +! +! Date of Modification: Fri Oct 18 +! + +! Purpose: +! PRINT statement not allowed within PURE procedure +! PAUSE statement not allowed in PURE procedure +! IO UNIT in READ statement must be an internal file in a PURE procedure +! STOP statement not allowed in PURE procedure +! Symbol is not a DUMMY variable +! Global cannot appear in variable definition context (assignment) in +! PURE procedure +! +MODULE GLOBALS + INTEGER COUNT + INTEGER INPUT +END MODULE + +IMPURE SUBROUTINE MSG + PRINT *, "IN SUBROUTINE MSG" +END SUBROUTINE + +PURE SUBROUTINE ADD(A, B, C) + USE GLOBALS + IMPLICIT NONE + INTEGER,INTENT(IN) :: A, B, C, D + INTEGER X + + PRINT *, 'A = ', A + PRINT *, 'B = ', B + PRINT *, 'C = ', C + + PAUSE 'ENTER INPUT' + READ(*,*) X, INPUT + + IF (A > 0 .AND. B > 0) THEN + IF (B > HUGE(C) - A) STOP 'POSITIVE INTEGER OVERFLOW' + ELSE IF (A < 0 .AND. B < 0) THEN + IF ((A + HUGE(C)) + B< 0) STOP 'NEGATIVE INTEGER OVERFLOW' + END IF + + COUNT = COUNT + 1 + PRINT *, 'COUNT = ', COUNT + PRINT *, 'A + B + C = ', A + B + C + CALL MSG +END SUBROUTINE + +PROGRAM IMPURE08 + USE GLOBALS + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + CALL check(res, exp, N) + + COUNT = 99 + PRINT *, 'COUNT = ', COUNT + CALL ADD(10, 20, 30) +END PROGRAM diff --git a/test/f08_correct/src/impure09.f08 b/test/f08_correct/src/impure09.f08 new file mode 100644 index 0000000000..87e8c701d2 --- /dev/null +++ b/test/f08_correct/src/impure09.f08 @@ -0,0 +1,60 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +! +! Date of Modification: Fri Oct 18 +! + +! +! Purpose: +! Illegal allocate-object in DEALLOCATE for a PURE procedure +! PRINT statement not allowed within PURE procedure +! Argument of elemental procedure must be scalar +! Initialization of variable is not allowed in a PURE procedure +! +MODULE CONSTANT + REAL, ALLOCATABLE :: BUF(:,:) +END MODULE + +PURE ELEMENTAL FUNCTION ADD(A, B) + USE CONSTANT + IMPLICIT NONE + INTEGER :: I = 20, J = 20, ERR + INTEGER C, N + INTEGER, DIMENSION(1), INTENT(IN) :: A, B + INTEGER ADD(SIZE(A)) + + ALLOCATE (BUF(I, J), STAT = ERR) + IF (ERR == 0) STOP + IF (ALLOCATED (BUF)) DEALLOCATE (BUF) + + N = 0 + C = 0 + + DO WHILE (N <= 10) + N = N + 1 + C = C + A(1) + B(1) + END DO + + PRINT *, 'A = ', A + PRINT *, 'B = ', B + PRINT *, 'ADD = ', ADD +END FUNCTION + +PROGRAM IMPURE09 + IMPLICIT NONE + INTEGER :: X(1) + INTERFACE + FUNCTION ADD(A, B) + INTEGER, DIMENSION(1), INTENT(IN) :: A, B + INTEGER ADD(SIZE(A)) + END FUNCTION + END INTERFACE + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + CALL check(res, exp, N) + + X = ADD((/10/), (/20/)) + PRINT *, 'VALUE OF X = ', X +END PROGRAM diff --git a/test/f08_correct/src/impure10.f08 b/test/f08_correct/src/impure10.f08 new file mode 100644 index 0000000000..32ec680aca --- /dev/null +++ b/test/f08_correct/src/impure10.f08 @@ -0,0 +1,53 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +! +! Date of Modification: Fri Oct 18 +! + +! +! Purpose: +! Impure procedure shall allow normal FORALL constructs +! Such procedures should allow alternate exits +! But will not allow PRINT toappear in a FORALL block +IMPURE FUNCTION ADD(A, B) RESULT(C) + IMPLICIT NONE + INTEGER, INTENT(IN) :: A, B + INTEGER :: I, J + REAL, DIMENSION(10, 10) :: D + REAL :: C + + PRINT *, 'A = ', A + PRINT *, 'B = ', B + PRINT *, 'D = ', D + + IF (A > 0 .AND. B > 0) THEN + IF (B > HUGE(C) - A) STOP 'POSITIVE INTEGER OVERFLOW' + ELSE IF (A < 0 .AND. B < 0) THEN + IF ((A + HUGE(C)) + B< 0) STOP 'NEGATIVE INTEGER OVERFLOW' + END IF + + FORALL (I = 1:9, J = 1:9) + D(I, J) = I * (A + B) / J + END FORALL + + PRINT *, 'D = ', D + C = D(1, 1) + + FORALL (I = 1:9, J = 1:9) + PRINT *, 'D(I, J) = ', D(I, J) + END FORALL + + PRINT *, 'C = ', C +END FUNCTION + +PROGRAM IMPURE10 + IMPLICIT NONE + INTEGER :: ADD + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + CALL check(res, exp, N) + + PRINT *, 'VALUE OF ADD = ', ADD(10, 20) +END PROGRAM diff --git a/test/f08_correct/src/impure11.f08 b/test/f08_correct/src/impure11.f08 new file mode 100644 index 0000000000..9c8415713e --- /dev/null +++ b/test/f08_correct/src/impure11.f08 @@ -0,0 +1,57 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +! +! Date of Modification: Fri Oct 18 +! + +! +! Print statement is not allowed within pure procedure +! Stop statement not allowed in pure procedure +! Reference to impure function inside a forall block is not allowed +! +PURE INTEGER FUNCTION ADD(A, B, C) RESULT(D) + IMPLICIT NONE + INTEGER,INTENT(IN) :: A, B, C + + PRINT *, 'A = ', A + PRINT *, 'B = ', B + PRINT *, 'C = ', C + + IF (A > 0 .AND. B > 0) THEN + IF (B > HUGE(C) - A) STOP 'POSITIVE INTEGER OVERFLOW' + ELSE IF (A < 0 .AND. B < 0) THEN + IF ((A + HUGE(C)) + B< 0) STOP 'NEGATIVE INTEGER OVERFLOW' + END IF + + D = A + B + C + PRINT *, 'D = ', D +END FUNCTION + +PURE SUBROUTINE S(A,B) + REAL, INTENT(OUT) :: A + REAL, VALUE :: B + A = B +END SUBROUTINE + +PROGRAM IMPURE11 + IMPLICIT NONE + INTEGER :: ADD, I, J, K + INTEGER, DIMENSION(100, 100, 100) :: X + INTEGER :: M = 10, N = 20 + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + CALL check(res, exp, N) + + FORALL (I = 1:100) + FORALL (J = 1:100) + FORALL (K = 1:100) + X(I, J, K) = ADD(I, J, K) + END FORALL + END FORALL + END FORALL + + CALL S(M, N) + PRINT *, 'VALUE OF X = ', X +END PROGRAM diff --git a/test/f08_correct/src/impure12.f08 b/test/f08_correct/src/impure12.f08 new file mode 100644 index 0000000000..5e79e1e82a --- /dev/null +++ b/test/f08_correct/src/impure12.f08 @@ -0,0 +1,53 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +! +! Date of Modification: Fri Oct 18 +! + +! +! Purpose: +! PRINT statement not allowed within PURE procedure +! STOP statement not allowed in PURE procedure +! Reference to impure function inside a FORALL block +! Unexpected CALL statement in FORALL block +PURE ELEMENTAL SUBROUTINE ADD(A, B, C) + IMPLICIT NONE + INTEGER,INTENT(IN) :: A, B, C + + PRINT *, 'A = ', A + PRINT *, 'B = ', B + PRINT *, 'C = ', C + + IF (A > 0 .AND. B > 0) THEN + IF (B > HUGE(C) - A) STOP 'POSITIVE INTEGER OVERFLOW' + ELSE IF (A < 0 .AND. B < 0) THEN + IF ((A + HUGE(C)) + B< 0) STOP 'NEGATIVE INTEGER OVERFLOW' + END IF + + PRINT *, 'A + B + C = ', A + B + C +END SUBROUTINE + +PROGRAM IMPURE12 + IMPLICIT NONE + INTERFACE ADD + FUNCTION ADD(A, B, C) + INTEGER,INTENT(IN) :: A, B, C + END FUNCTION + END INTERFACE + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + CALL check(res, exp, N) + + INTEGER :: I + INTEGER :: X(5) = (/1, 2, 3, 4, 5/) + INTEGER :: Y(5) = (/6, 7, 8, 9, 10/) + INTEGER :: Z(5) = (/11, 22, 13, 14, 15/) + + FORALL (I = 1:5) + CALL ADD(X(I), Y(I), Z(I)) + END FORALL + + !CALL ADD(X, Y, Z) +END PROGRAM diff --git a/test/f08_correct/src/impure13.f08 b/test/f08_correct/src/impure13.f08 new file mode 100644 index 0000000000..6af05c4cc4 --- /dev/null +++ b/test/f08_correct/src/impure13.f08 @@ -0,0 +1,80 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +! +! Date of Modification: Fri Oct 18 +! + +! +! Purpose: +! SAVE attribute cannot be specified in a PURE procedure +! DATA statement is not allowed in a PURE procedure +! Globals cannot appear in a assignment in PURE procedure +! Globals cannot appear in a loop control variable in PURE procedure +! Reference to impure function inside a FORALL block not allowed +! Globals cannot be used in an ASSIGN statement +! Globals cannot be used in a READ statement +! IO UNIT in WRITE statement must be an internal file +! Subroutine call from a pure to an impure subroutine not allowed + +MODULE SHARED_DEFS + INTEGER ITOL + INTEGER L +END MODULE SHARED_DEFS + +PURE FUNCTION DOUBLE(X) + REAL, INTENT(IN) :: X + INTEGER PHORMAT + DOUBLE = 2 * X + +2 FORMAT (A80) + ASSIGN 2 TO PHORMAT + WRITE (*, PHORMAT) 'ASSIGNED A FORMAT STATEMENT NO.' +END FUNCTION DOUBLE + +PURE INTEGER FUNCTION MANDELBROT(X) + ! Assume SHARED_DEFS includes the declaration + ! INTEGER ITOL + USE SHARED_DEFS + COMPLEX, INTENT(IN) :: X + COMPLEX :: XTMP + INTEGER :: K + XTMP = -X + SAVE K + DATA K/0/ + + ITOL = 10 + DO WHILE (ABS(XTMP) < 2.0 .AND. K < ITOL) + XTMP = XTMP**2 - X + K = K + 1 + END DO + + DO WHILE (L < ITOL) + L = L + 1 + END DO + + MANDELBROT = K +END FUNCTION + +PROGRAM TEST_MANDELBROT + INTERFACE + PURE INTEGER FUNCTION MANDELBROT(X) + COMPLEX, INTENT(IN) :: X + END FUNCTION MANDELBROT + END INTERFACE + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + CALL check(res, exp, N) + + INTEGER M, N + REAL, DIMENSION(10, 10) :: A + M = 10 + N = 10 + + FORALL (I = 1:N, J = 1:M) + A(I,J) = MANDELBROT(COMPLX((I-1)*1.0/(N-1), (J-1)*1.0/(M-1))) + END FORALL +END PROGRAM + +! EOF diff --git a/test/f08_correct/src/impure14.f08 b/test/f08_correct/src/impure14.f08 new file mode 100644 index 0000000000..e77586fddc --- /dev/null +++ b/test/f08_correct/src/impure14.f08 @@ -0,0 +1,46 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +! +! Date of Modification: Fri Oct 18 +! + +! +! Purpose: +! Impure functions taking array arguments and returning +! array result should be fine +! +IMPURE FUNCTION ADD(A, B, C) + IMPLICIT NONE + INTEGER, INTENT(IN) :: A(:), B(:), C(:) + INTEGER ADD(SIZE(A)) + + IF (A(1) > 0 .AND. B(1) > 0) THEN + IF (B(1) > HUGE(C(1)) - A(1)) STOP 'POSITIVE INTEGER OVERFLOW' + ELSE IF (A(1) < 0 .AND. B(1) < 0) THEN + IF ((A(1) + HUGE(C(1))) + B(1) < 0) STOP 'NEGATIVE INTEGER OVERFLOW' + END IF + + ADD = A(1) + B(1) + C(1) + + PRINT *, 'A = ', A + PRINT *, 'B = ', B + PRINT *, 'C = ', C + PRINT *, ADD +END FUNCTION + +PROGRAM IMPURE14 + IMPLICIT NONE + INTERFACE ADD + FUNCTION ADD(A, B, C) + INTEGER, INTENT(IN) :: A(:), B(:), C(:) + INTEGER ADD(SIZE(A)) + END FUNCTION + END INTERFACE + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + CALL check(res, exp, N) + + PRINT *, 'ADD = ', ADD((/10/), (/20/), (/30/)) +END PROGRAM diff --git a/test/f08_correct/src/impure15.f08 b/test/f08_correct/src/impure15.f08 new file mode 100644 index 0000000000..02ad33a0c3 --- /dev/null +++ b/test/f08_correct/src/impure15.f08 @@ -0,0 +1,50 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +! +! Date of Modification: Fri Oct 18 +! + +! +! Purpose: +! Impure functions should allow full vector capability and +! allow alternate exits +IMPURE FUNCTION VADD(A, B, C) + IMPLICIT NONE + INTEGER, INTENT(IN) :: A(:), B(:), C(:) + INTEGER VADD(SIZE(A)) + + PRINT *, 'A = ', A + PRINT *, 'B = ', B + PRINT *, 'B = ', C + + VADD = A + B + C +END + +! Only works with gfortran now. how to enable scalar ops in flang? +PROGRAM IMPURE15 + IMPLICIT NONE + INTEGER, DIMENSION(100) :: X, Y, Z + INTEGER :: I + INTERFACE + FUNCTION VADD(A, B, C) + INTEGER, INTENT(IN) :: A(:), B(:), C(:) + INTEGER VADD(SIZE(A)) + END FUNCTION + END INTERFACE + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + CALL check(res, exp, N) + + DO I = 1, 100 + X(I) = 2 * I + Y(I) = 3 * I + Z(I) = 4 * I + END DO + + PRINT *, '-----------------------' + PRINT *, 'RESULT OF VADD: ' + PRINT *, 'X + Y + Z = ', VADD(X, Y, Z) + PRINT *, '-----------------------' +END PROGRAM diff --git a/test/f08_correct/src/impure16.f08 b/test/f08_correct/src/impure16.f08 new file mode 100644 index 0000000000..c5c0abe4e1 --- /dev/null +++ b/test/f08_correct/src/impure16.f08 @@ -0,0 +1,48 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Flang-F2008-Impure elemental procedures +! +! Date of Modification: Fri Oct 18 +! + +! +! Purpose: +! Impure subroutines shall allow assignment to globals and not +! generate errors for alternate exits +! +MODULE GLOBALS + INTEGER COUNT +END MODULE + +IMPURE SUBROUTINE ADD(A, B, C) + USE GLOBALS + IMPLICIT NONE + INTEGER,INTENT(IN) :: A, B, C + + PRINT *, 'A = ', A + PRINT *, 'B = ', B + PRINT *, 'C = ', C + + IF (A > 0 .AND. B > 0) THEN + IF (B > HUGE(C) - A) STOP 'POSITIVE INTEGER OVERFLOW' + ELSE IF (A < 0 .AND. B < 0) THEN + IF ((A + HUGE(C)) + B< 0) STOP 'NEGATIVE INTEGER OVERFLOW' + END IF + + COUNT = COUNT + 1 + PRINT *, 'COUNT = ', COUNT + PRINT *, 'A + B + C = ', A + B + C +END SUBROUTINE + +PROGRAM IMPURE08 + USE GLOBALS + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + CALL check(res, exp, N) + + COUNT = 99 + PRINT *, 'COUNT = ', COUNT + CALL ADD(10, 20, 30) +END PROGRAM diff --git a/test/f08_correct/src/iparity.f08 b/test/f08_correct/src/iparity.f08 new file mode 100644 index 0000000000..8f7c87737f --- /dev/null +++ b/test/f08_correct/src/iparity.f08 @@ -0,0 +1,30 @@ +!* +!* Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +!* +!* +!* F2008 feature bit transformational intrinsic +!* AOCC test + +program test_iparity + parameter(NTEST=3) + integer, dimension(3,3) :: x + logical, DIMENSION(3,3) :: z=reshape( (/ .true., .true., .true., & + .true., .false., .false., & + .true., .true., .true. /), & + shape(z)) + integer :: expect(NTEST) = (/ 5, 3, 7 /) + integer :: result(NTEST), iparity1(NTEST) + + do i = 1,3 + do j = 1,3 + x(i,j) = i+j + end do + end do + + + iparity1 = iparity(x,1,z) + print *, iparity1 + result = iparity1 + call check(result,expect,NTEST) +end program + diff --git a/test/f08_correct/src/longintforall.f08 b/test/f08_correct/src/longintforall.f08 new file mode 100644 index 0000000000..2d1e65428b --- /dev/null +++ b/test/f08_correct/src/longintforall.f08 @@ -0,0 +1,50 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +!* +! F2008-New Unit Specifier feature compliance test +!* Date of Modification : 19th July 2019 +!* Added a new test for use of kind of a forall index +!* +!*===----------------------------------------------------------------------===// +program longintforall + + parameter(NTEST=9) + real :: result(NTEST) + real :: expect(NTEST) = [9223372036854775807,200.0,200.0,200.0,200.0,1.0,1.0,1.0,1.0 ] + + !Declares a two dimensonal array with lower bounds and upper bounds specified. + real, dimension( 9223372036854775607:9223372036854775807, 1:2) :: A = 1.0 + + !Finds the kind where -(10^10) to +(10^10) falls and declares b of that kind + !In this case, it is 8 + integer,parameter :: long = selected_int_kind(18) + integer(long) :: b + + integer :: c + + !Prints highest values that b could hold + print *,'The highest value integer b can hold is ',huge(b) + result(1) = huge(b) + + !FORALL loop; Correct initilization happens only if + !huge(i) returns the correct value. + forall ( integer(long) :: i = 1:2, j = 1:2 ) + A(huge(i)-i, j) = 200 + end forall + + !Following 4 values are updated by forall + result(2) = A(huge(b)-1,1) + result(3) = A(huge(b)-1,2) + result(4) = A(huge(b)-2,1) + result(5) = A(huge(b)-2,2) + + !Following values are a subset of values which are not updated by forall + result(6) = A(huge(b)-3,1) + result(7) = A(huge(b)-3,2) + result(8) = A(huge(b)-4,1) + result(9) = A(huge(b)-4,2) + + !compares the results + call check(result,expect,NTEST) +end diff --git a/test/f08_correct/src/maxdim01.f08 b/test/f08_correct/src/maxdim01.f08 new file mode 100644 index 0000000000..eebc8cff31 --- /dev/null +++ b/test/f08_correct/src/maxdim01.f08 @@ -0,0 +1,19 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Support for maximum dimension as per f2008 standard +! + +program maxdim_integer + parameter (N = 2 ** 15) + integer, dimension(2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2) :: res + integer :: exp(N) + + do i = 1, N + exp(i) = i + end do + + res = reshape(exp, shape(res)) + + call check(res, exp, N) +end program diff --git a/test/f08_correct/src/maxdim02.f08 b/test/f08_correct/src/maxdim02.f08 new file mode 100644 index 0000000000..68ad2979f1 --- /dev/null +++ b/test/f08_correct/src/maxdim02.f08 @@ -0,0 +1,19 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Support for maximum dimension as per f2008 standard +! + +program maxdim_integer + parameter (N = 2 ** 8) + integer, dimension(2, 2, 2, 2, 2, 2, 2, 2) :: res + integer :: exp(N) + + do i = 1, N + exp(i) = i + end do + + res = reshape(exp, shape(res)) + + call check(res, exp, N) +end program diff --git a/test/f08_correct/src/maxdim03.f08 b/test/f08_correct/src/maxdim03.f08 new file mode 100644 index 0000000000..4ece145d1d --- /dev/null +++ b/test/f08_correct/src/maxdim03.f08 @@ -0,0 +1,22 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Support for maximum dimension as per f2008 standard +! + +program maxdim_integer + parameter (N = 2 ** 15) + integer, dimension(2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2) :: arr + integer :: inp(N), res(15), exp(15) + + do i = 1, N + inp(i) = i + end do + + arr = reshape(inp, shape(arr)) + + res = minloc(arr) + exp = (/1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1/) + + call check(res, exp, 15) +end program diff --git a/test/f08_correct/src/merge_bits01.f08 b/test/f08_correct/src/merge_bits01.f08 new file mode 100644 index 0000000000..8c2d01b0f6 --- /dev/null +++ b/test/f08_correct/src/merge_bits01.f08 @@ -0,0 +1,22 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Support for MERGE_BITS intrinsic. +! + +program merge_bits01 + integer, parameter :: N = 3 + integer :: res(N), exp(N) + integer(kind = 2) :: i2_i = 343, i2_j = 22234, i2_mask = 5 + + exp(1) = 34873 + res(1) = merge_bits(12323_4, 34937_4, 64_4) + + exp(2) = 104 + res(2) = merge_bits(203902139456_8, 123_8, 19_8) + + exp(3) = 22239 + res(3) = merge_bits(i2_i, i2_j, i2_mask) + + call check(res, exp, N) +end program merge_bits01 diff --git a/test/f08_correct/src/mold-source.f08 b/test/f08_correct/src/mold-source.f08 new file mode 100644 index 0000000000..9698995129 --- /dev/null +++ b/test/f08_correct/src/mold-source.f08 @@ -0,0 +1,54 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +!* +! F2008-New Unit Specifier feature compliance test +!* Date of Modification : 30th September 2019 +!* Added a new test for Copying the properties of an object in an allocate statement +!* +!*===----------------------------------------------------------------------===// +program test_mold_source + parameter(NTEST=14) + real :: result(NTEST) + real :: expect(NTEST) + + integer, allocatable :: a(:), b(:), c(:) + integer :: i + + allocate(a(11:20)) + !allocate b with bounds of a + allocate(b, mold=a) + + !initialize a + do i = 11, 20 + a(i) = 100*i + end do + + !allocate c with bounds of a and + !initialize it with values of a + allocate(c, source=a) + + expect(1) = lbound(a,1) + expect(2) = ubound(a,1) + expect(3) = lbound(a,1) + expect(4) = ubound(a,1) + result(1) = lbound(b,1) + result(2) = ubound(b,1) + result(3) = lbound(c,1) + result(4) = ubound(c,1) + !copy the values + do i = 11, 20 + expect(i-11+5) = a(i) + end do + do i = 11, 20 + result(i-11+5) = c(i) + end do + + !deallocate the arrays allocated + deallocate(a) + deallocate(b) + deallocate(c) + + !compare the results + call check(result,expect,NTEST) +end program test_mold_source diff --git a/test/f08_correct/src/newunit01.f08 b/test/f08_correct/src/newunit01.f08 new file mode 100644 index 0000000000..1920fa8aff --- /dev/null +++ b/test/f08_correct/src/newunit01.f08 @@ -0,0 +1,36 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008-New Unit Specifier feature compliance test +! + +PROGRAM newunit_specifier + IMPLICIT none + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + INTEGER unit1, unit2 + CHARACTER(len=100) :: message + + OPEN(FILE='output.log',FORM='FORMATTED',NEWUNIT=unit1) + WRITE(unit1,*) 'Logfile opened.' + WRITE(unit1,*) 'New unit number = ', unit1 + + OPEN(STATUS='SCRATCH',FORM='FORMATTED',NEWUNIT=unit2) + WRITE(unit2,*) 'Scratch file opened.' + WRITE(unit2,*) 'New number = ', unit2 + + REWIND(unit2) + READ(unit2, '(A)') message + WRITE(unit1, *) message + READ(unit2, '(A)') message + WRITE(unit1, *) message + + IF (unit1 .NE. unit2) THEN + WRITE(unit1, *) 'New unit specifier generates unique Unit IDs' + ELSE + WRITE(unit1, *) 'New unit specifier generates non-unique Unit IDs' + STOP 1 + ENDIF + CALL check(res, exp, N) + STOP 0 +END diff --git a/test/f08_correct/src/newunit02.f08 b/test/f08_correct/src/newunit02.f08 new file mode 100644 index 0000000000..bf39c53675 --- /dev/null +++ b/test/f08_correct/src/newunit02.f08 @@ -0,0 +1,21 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Revert to the old value when newunit has errors. +! +Program newunit02 + Integer :: iunit = 12345 + integer :: n = 1 + integer :: result(1) , expect(1) + + expect(1) = iunit + + Open(Newunit=iunit,File='Does not exist',Err=1,Status='Old') + STOP iunit + +1 Continue + result(1) = iunit + + call check(expect , result , n) + +End Program newunit02 diff --git a/test/f08_correct/src/nm01.f08 b/test/f08_correct/src/nm01.f08 new file mode 100644 index 0000000000..46a519d41e --- /dev/null +++ b/test/f08_correct/src/nm01.f08 @@ -0,0 +1,30 @@ +! +! Copyright (c) 2018, Advanced Micro Devices, Inc. All rights reserved. +! +! Support for DNORM intrinsic +! +! Date of Modification: 21st February 2019 +! + +program character_minmax + + parameter(N=2) + integer result(N),expect(N) + real, dimension(1:4) :: a, b + integer :: i,j + real :: dnorm + + do i = 1, 4 + a(i) = 5 + b(i) = 4 + enddo + + result(1) = norm2(a) + result(2) = norm2(b) + + expect(1) = 10.00000 + expect(2) = 8.000000 + + call check(result,expect,N) + +end diff --git a/test/f08_correct/src/nm02.f08 b/test/f08_correct/src/nm02.f08 new file mode 100644 index 0000000000..d4875a62a7 --- /dev/null +++ b/test/f08_correct/src/nm02.f08 @@ -0,0 +1,30 @@ +! +! Copyright (c) 2018, Advanced Micro Devices, Inc. All rights reserved. +! +! Support for DNORM intrinsic +! +! Date of Modification: 21st February 2019 +! + +program character_minmax + + parameter(N=2) + integer result(N),expect(N) + real, dimension(1:5) :: a, b + integer :: i,j + real :: dnorm + + do i = 1, 5 + a(i) = 11.0 + b(i) = 7.0 + enddo + + result(1) = norm2(a) + result(2) = norm2(b) + + expect(1) = 24.59675 + expect(2) = 15.65248 + + call check(result,expect,N) + +end diff --git a/test/f08_correct/src/nm03.f08 b/test/f08_correct/src/nm03.f08 new file mode 100644 index 0000000000..067cbc6aad --- /dev/null +++ b/test/f08_correct/src/nm03.f08 @@ -0,0 +1,30 @@ +! +! Copyright (c) 2018, Advanced Micro Devices, Inc. All rights reserved. +! +! Support for DNORM intrinsic +! +! Date of Modification: 21st February 2019 +! + +program character_minmax + + parameter(N=2) + integer result(N),expect(N) + real*8, dimension(1:5) :: a, b + integer :: i,j + real*8 :: dnorm + + do i = 1, 5 + a(i) = 11.0 + b(i) = 7.0 + enddo + + result(1) = norm2(a) + result(2) = norm2(b) + + expect(1) = 24.59674835205078 + expect(2) = 15.65247631072998 + + call check(result,expect,N) + +end diff --git a/test/f08_correct/src/nm04.f08 b/test/f08_correct/src/nm04.f08 new file mode 100644 index 0000000000..69af2ac2ae --- /dev/null +++ b/test/f08_correct/src/nm04.f08 @@ -0,0 +1,25 @@ +! +! Copyright (c) 2018, Advanced Micro Devices, Inc. All rights reserved. +! +! Support for array expression in norm2 +! Date of modificaton 28th October 2019 +! +! + +program norm_check + + parameter(N=1) + integer :: result(N),expect(N) + real :: x(10), y(10) + integer :: i + + do i = 1, 10 + x(i) = i * i + y(i) = i + enddo + + result(1) = norm2(x-y) + expect(1) = 140.2426 + call check(result,expect,N) + +end program diff --git a/test/f08_correct/src/parity.f08 b/test/f08_correct/src/parity.f08 new file mode 100644 index 0000000000..7007b51949 --- /dev/null +++ b/test/f08_correct/src/parity.f08 @@ -0,0 +1,32 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008-New Unit Specifier feature compliance test +!* +!* F2008 feature Parity intrinsic +!* Calculates the parity (i.e. the reduction using .xor.) of mask along +!* dimension dim. +!* AOCC test + + program test_parity + + parameter(NTEST=2) + logical :: result(NTEST) + logical :: expect(NTEST) = [ .true., .false. ] + + logical :: x(5) = [ .true., .true., .false.,.false., .true. ] + logical :: y(3) = [ .true., .false.,.true. ] + logical :: parity1, parity2 + parity1 = parity(x) + parity2 = parity(y) + + print *,"! parity1" + print *, parity1 ! T + result(1) = parity1; + + print *,"! parity2" + print *, parity2 ! F + result(2) = parity2; + + call check(result,expect,NTEST) + end program diff --git a/test/f08_correct/src/passok.f08 b/test/f08_correct/src/passok.f08 new file mode 100644 index 0000000000..7f6a2d2fed --- /dev/null +++ b/test/f08_correct/src/passok.f08 @@ -0,0 +1,14 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Force pass a test as PASSED +! +! Date of Modification: 10 Sep 2019 +! + +PROGRAM PASSOK + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/pointer_init01.f08 b/test/f08_correct/src/pointer_init01.f08 new file mode 100644 index 0000000000..61cf0dd7df --- /dev/null +++ b/test/f08_correct/src/pointer_init01.f08 @@ -0,0 +1,19 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Support for pointer initialization as per f2008 standard +! + + + +program pointer_init + parameter (N = 3) + integer, target :: res(N) = (/1, 2, 3/) + integer, target :: exp(N) = (/100, 2, 3/) + + integer, pointer :: ptr(:) => res + + ptr(1) = 100 + + call check(res, exp, N) +end program pointer_init diff --git a/test/f08_correct/src/rank.f08 b/test/f08_correct/src/rank.f08 new file mode 100644 index 0000000000..7499187333 --- /dev/null +++ b/test/f08_correct/src/rank.f08 @@ -0,0 +1,19 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! [CPUPC-3849] Rank intrinsic for flang +! +! Date of Modification: 10 Aug 2020 + +program test_rank + integer :: a + real, allocatable :: b(:,:) + real, parameter :: x(*) = [1,2,3,4,5,6] + integer :: result(3) + integer :: expected(3) = [0,1,2] + result(1) = rank(a) + result(2) = rank(x) + result(3) = rank(b) + call check(result,expected,3) + !print *, result ! Prints: 0 1 2 +end program test_rank diff --git a/test/f08_correct/src/rio01.f08 b/test/f08_correct/src/rio01.f08 new file mode 100644 index 0000000000..c1f91a56c0 --- /dev/null +++ b/test/f08_correct/src/rio01.f08 @@ -0,0 +1,39 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008-Recursive Input/Output feature compliance test +! +! Date of Modification: 17th July 2019 +! + +! Write recusrively to same unit and a different unit. +! Former should succeed and latter should fail +PROGRAM recursive_io_test + IMPLICIT NONE + INTEGER :: p + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + + CALL check(res, exp, N) + + WRITE(6, *) 'PROGRAM: Return value from call p(100) = ', p(100) + WRITE(6, *) 'PROGRAM: Return value from call p(99) = ', p(99) + +END PROGRAM + +INTEGER FUNCTION p(n) RESULT(res) + IMPLICIT NONE + INTEGER, INTENT (in) :: n + + IF(n .gt. 99)then + WRITE(0, *) 'FUNCTION p(n): Error:', n,'is out of range' + WRITE(6, *) 'FUNCTION p(n): Error:', n,'is out of range' + res = 1 + ELSE + WRITE(0, *) 'FUNCTION p(n): No error:', n,'is with in range' + WRITE(6, *) 'FUNCTION p(n): No error:', n,'is with in range' + res = 0 + endif + + RETURN +END diff --git a/test/f08_correct/src/rio02.f08 b/test/f08_correct/src/rio02.f08 new file mode 100644 index 0000000000..284500bb52 --- /dev/null +++ b/test/f08_correct/src/rio02.f08 @@ -0,0 +1,42 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008-Recursive Input/Output feature compliance test +! +! Date of Modification: 17th July 2019 +! + +! Write recursively to the same unit and ensure failure +PROGRAM recursive_io_test + IMPLICIT NONE + INTEGER :: p, q + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + + CALL check(res, exp, N) + + WRITE(6, *) 'PROGRAM: Return value from call p(100) = \n', p(100), 'After Function Call', q(9999) + +END PROGRAM + +INTEGER FUNCTION q(n) RESULT(res) + IMPLICIT NONE + INTEGER, INTENT (in) :: n + res = n + RETURN +END + +INTEGER FUNCTION p(n) RESULT(res) + IMPLICIT NONE + INTEGER, INTENT (in) :: n + + if(n .gt. 99)then + WRITE(6, *) 'FUNCTION p(n): Error:', n,'is out of range\n' + res = 1 + ELSE + WRITE(6, *) 'FUNCTION p(n): No error:', n,'is with in range\n' + res = 0 + endif + + RETURN +END diff --git a/test/f08_correct/src/rio03.f08 b/test/f08_correct/src/rio03.f08 new file mode 100644 index 0000000000..276f3a0493 --- /dev/null +++ b/test/f08_correct/src/rio03.f08 @@ -0,0 +1,44 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008-Recursive Input/Output feature compliance test +! +! Date of Modification: 17th July 2019 +! + +! Write recursively for two levels and ensure failure +PROGRAM recursive_io_test + IMPLICIT NONE + INTEGER :: p, q + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + + CALL check(res, exp, N) + + WRITE(0, *) 'PROGRAM: Return value from call p(100) = \n', p(100), 'After Function Call', q(9999) + +END PROGRAM + +INTEGER FUNCTION q(n) RESULT(res) + IMPLICIT NONE + INTEGER, INTENT (in) :: n + INTEGER :: p + WRITE(6, *) 'FUNCTION q(): \n', p(200) + res = n + RETURN +END + +INTEGER FUNCTION p(n) RESULT(res) + IMPLICIT NONE + INTEGER, INTENT (in) :: n + + if(n .gt. 99)then + WRITE(6, *) 'FUNCTION p(n): Error:', n,'is out of range\n' + res = 1 + ELSE + WRITE(6, *) 'FUNCTION p(n): No error:', n,'is with in range\n' + res = 0 + endif + + RETURN +END diff --git a/test/f08_correct/src/rio04.f08 b/test/f08_correct/src/rio04.f08 new file mode 100644 index 0000000000..c300132891 --- /dev/null +++ b/test/f08_correct/src/rio04.f08 @@ -0,0 +1,49 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008-Recursive Input/Output feature compliance test +! +! Date of Modification: 17th July 2019 +! + +! Write recursively bracketed by OMP_PARALLEL and OMP_TASK +! constructs and ensure failure +PROGRAM recursive_io_test + IMPLICIT NONE + INTEGER :: p + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + + CALL check(res, exp, N) + !$OMP TASK + + !$OMP PARALLEL + WRITE(6, *) 'PROGRAM: Return value from call p(100) = ', p(100) + !$OMP END PARALLEL + !$OMP PARALLEL + WRITE(6, *) 'PROGRAM: Return value from call p(99) = ', p(99) + !$OMP END PARALLEL + !$OMP END TASK + +END PROGRAM + +INTEGER FUNCTION p(n) RESULT(res) + IMPLICIT NONE + INTEGER, INTENT (in) :: n + + !$OMP PARALLEL + !$OMP TASK + IF(n .gt. 99)then + WRITE(0, *) 'FUNCTION p(n): Error:', n,'is out of range' + WRITE(6, *) 'FUNCTION p(n): Error:', n,'is out of range' + res = 1 + ELSE + WRITE(0, *) 'FUNCTION p(n): No error:', n,'is with in range' + WRITE(6, *) 'FUNCTION p(n): No error:', n,'is with in range' + res = 0 + endif + + !$OMP END TASK + !$OMP END PARALLEL + RETURN +END diff --git a/test/f08_correct/src/rio05.f08 b/test/f08_correct/src/rio05.f08 new file mode 100644 index 0000000000..599a6c24ad --- /dev/null +++ b/test/f08_correct/src/rio05.f08 @@ -0,0 +1,46 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008-Recursive Input/Output feature compliance test +! +! Date of Modification: 17th July 2019 +! + +! Write recursively under the OMP constructs and ensure +! failure (another version) +PROGRAM recursive_io_test + IMPLICIT NONE + INTEGER :: p + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + + CALL check(res, exp, N) + !$OMP TASK + + WRITE(6, *) 'PROGRAM: Return value from call p(100) = ', p(100) + WRITE(6, *) 'PROGRAM: Return value from call p(99) = ', p(99) + + !$OMP END TASK + +END PROGRAM + +INTEGER FUNCTION p(n) RESULT(res) + IMPLICIT NONE + INTEGER, INTENT (in) :: n + + !$OMP PARALLEL + !$OMP TASK + IF(n .gt. 99)then + WRITE(0, *) 'FUNCTION p(n): Error:', n,'is out of range' + WRITE(6, *) 'FUNCTION p(n): Error:', n,'is out of range' + res = 1 + ELSE + WRITE(0, *) 'FUNCTION p(n): No error:', n,'is with in range' + WRITE(6, *) 'FUNCTION p(n): No error:', n,'is with in range' + res = 0 + endif + + !$OMP END TASK + !$OMP END PARALLEL + RETURN +END diff --git a/test/f08_correct/src/rio06.f08 b/test/f08_correct/src/rio06.f08 new file mode 100644 index 0000000000..2482c2e21b --- /dev/null +++ b/test/f08_correct/src/rio06.f08 @@ -0,0 +1,44 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008-Recursive Input/Output feature compliance test +! +! Date of Modification: 17th July 2019 +! + +! Write recusrively under the OPM_TASK only constructs and ensure +! failure of the operation +PROGRAM recursive_io_test + IMPLICIT NONE + INTEGER :: p + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + + CALL check(res, exp, N) + !$OMP TASK + + WRITE(6, *) 'PROGRAM: Return value from call p(100) = ', p(100) + WRITE(6, *) 'PROGRAM: Return value from call p(99) = ', p(99) + + !$OMP END TASK + +END PROGRAM + +INTEGER FUNCTION p(n) RESULT(res) + IMPLICIT NONE + INTEGER, INTENT (in) :: n + + !$OMP TASK + IF(n .gt. 99)then + WRITE(0, *) 'FUNCTION p(n): Error:', n,'is out of range' + WRITE(6, *) 'FUNCTION p(n): Error:', n,'is out of range' + res = 1 + ELSE + WRITE(0, *) 'FUNCTION p(n): No error:', n,'is with in range' + WRITE(6, *) 'FUNCTION p(n): No error:', n,'is with in range' + res = 0 + endif + + !$OMP END TASK + RETURN +END diff --git a/test/f08_correct/src/scode01.f08 b/test/f08_correct/src/scode01.f08 new file mode 100644 index 0000000000..4c604ddcea --- /dev/null +++ b/test/f08_correct/src/scode01.f08 @@ -0,0 +1,26 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Date of Modification: Sep 10 2019 +! +! F2008 Compliance Tests: Stop code - Execution control +! +! This program checks if the implementation supports a STOP code of size a byte or lower +! +PROGRAM scode01 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + CALL check(res, exp, N) + + CALL scode_i +END PROGRAM + +IMPURE SUBROUTINE scode_i + IMPLICIT NONE + INTEGER code + + code = 7 + + STOP code +END SUBROUTINE diff --git a/test/f08_correct/src/scode02.f08 b/test/f08_correct/src/scode02.f08 new file mode 100644 index 0000000000..6741535d02 --- /dev/null +++ b/test/f08_correct/src/scode02.f08 @@ -0,0 +1,25 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Date of Modification: Sep 10 2019 +! +! F2008 Compliance Tests: Stop code - Execution control +! +! This program checks if the implementation supports a STOP code that is also returned as the program exit code which is usually 32 bits +! +PROGRAM scode02 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + CALL check(res, exp, N) + + CALL scode_i +END PROGRAM + +IMPURE SUBROUTINE scode_i + IMPLICIT NONE + INTEGER code + + code = 9999 + STOP code +END SUBROUTINE diff --git a/test/f08_correct/src/scode03.f08 b/test/f08_correct/src/scode03.f08 new file mode 100644 index 0000000000..9416b5f3fa --- /dev/null +++ b/test/f08_correct/src/scode03.f08 @@ -0,0 +1,27 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Date of Modification: Sep 10 2019 +! +! F2008 Compliance Tests: Stop code - Execution control +! +! This program tests if the implementation supports a STOP value which is an integer expression +! +PROGRAM scode03 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + CALL check(res, exp, N) + + CALL scode_e +END PROGRAM + +IMPURE SUBROUTINE scode_e + IMPLICIT NONE + INTEGER A, B, C + + A = 786 + B = 10 + C = A * B + STOP (A * B + C) +END SUBROUTINE diff --git a/test/f08_correct/src/scode04.f08 b/test/f08_correct/src/scode04.f08 new file mode 100644 index 0000000000..ee2e365c9c --- /dev/null +++ b/test/f08_correct/src/scode04.f08 @@ -0,0 +1,27 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Date of Modification: Sep 10 2019 +! +! F2008 Compliance Tests: Stop code - Execution control +! +! This program tests if the implementation supports a stop code which is a character expression +! +PROGRAM scode04 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) + CALL check(res, exp, N) + + CALL scode_e +END PROGRAM + +IMPURE SUBROUTINE scode_e + IMPLICIT NONE + CHARACTER A*4, B*2, C*8 + + A = 'join' + B = 'ed' + C = A // B + STOP (C // B // A) +END SUBROUTINE diff --git a/test/f08_correct/src/scode05.f08 b/test/f08_correct/src/scode05.f08 new file mode 100644 index 0000000000..e2b15f038c --- /dev/null +++ b/test/f08_correct/src/scode05.f08 @@ -0,0 +1,25 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Stop Code - Execution control +! +! Date of Modification: Sep 10 2019 +! +! Tests if returning a STOP code of type Real is flagged as a compilation error +! +PROGRAM STOP_TEST_05 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + CALL CHECK(RES, EXP, N) + + CALL STOP_IC_TEST +END PROGRAM + +IMPURE SUBROUTINE STOP_IC_TEST + IMPLICIT NONE + REAL :: CODE + + CODE = 10.2 + STOP CODE +END SUBROUTINE diff --git a/test/f08_correct/src/scode06.f08 b/test/f08_correct/src/scode06.f08 new file mode 100644 index 0000000000..fc5be8123e --- /dev/null +++ b/test/f08_correct/src/scode06.f08 @@ -0,0 +1,24 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Stop Code - Execution control +! +! Date of Modification: Sep 10 2019 +! +! Tests if returning a STOP code of type Real is flagged as a compilation error +PROGRAM STOP_TEST_06 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + CALL CHECK(RES, EXP, N) + + CALL STOP_IC_TEST +END PROGRAM + +IMPURE SUBROUTINE STOP_IC_TEST + IMPLICIT NONE + logical :: CODE + + CODE = .TRUE. + STOP CODE +END SUBROUTINE diff --git a/test/f08_correct/src/scode07.f08 b/test/f08_correct/src/scode07.f08 new file mode 100644 index 0000000000..7c92cc621d --- /dev/null +++ b/test/f08_correct/src/scode07.f08 @@ -0,0 +1,21 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Stop Code - Execution control +! +! Date of Modification: Sep 10 2019 +! +! Tests if a STOP without an explicit code returns an integer code +! +PROGRAM STOP_TEST_07 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + CALL CHECK(RES, EXP, N) + + CALL STOP_IC_TEST +END PROGRAM + +IMPURE SUBROUTINE STOP_IC_TEST + STOP +END SUBROUTINE diff --git a/test/f08_correct/src/scode08.f08 b/test/f08_correct/src/scode08.f08 new file mode 100644 index 0000000000..035e096d35 --- /dev/null +++ b/test/f08_correct/src/scode08.f08 @@ -0,0 +1,23 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Stop Code - Execution control. +! +! Date of Modification: Sep 25 2019 +! +! Tests if a STOP with both integer and string returns fine +PROGRAM STOP_TEST_08 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + CALL CHECK(RES, EXP, N) + + CALL STOP_IC_TEST +END PROGRAM + +IMPURE SUBROUTINE STOP_IC_TEST + PRINT *, "PRINT OUTPUT:" + PRINT *, 10 + "HI" + PRINT *, "STOP OUTPUT:" + STOP 10 + "HI" +END SUBROUTINE diff --git a/test/f08_correct/src/scode09.f08 b/test/f08_correct/src/scode09.f08 new file mode 100644 index 0000000000..4ec6c97df4 --- /dev/null +++ b/test/f08_correct/src/scode09.f08 @@ -0,0 +1,21 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Stop Code - Execution control. +! +! Date of Modification: Sep 25 2019 +! +! Tests if a STOP with a large integer generates a stop code fine +! +PROGRAM SCODE09 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + CALL CHECK(RES, EXP, N) + + ! STOP 2147483647 + ! Expected output : 1576189421 + ! which is from the expression (12345678910111213 and 0xffffffff) + PRINT *, "Expected output : 1576189421" + STOP 12345678910111213 +END PROGRAM diff --git a/test/f08_correct/src/scode10.f08 b/test/f08_correct/src/scode10.f08 new file mode 100644 index 0000000000..de2475bdcf --- /dev/null +++ b/test/f08_correct/src/scode10.f08 @@ -0,0 +1,17 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Stop Code - Execution control. +! +! Date of Modification: Sep 25 2019 +! +! Tests if a STOP without an explicit code returns an integer code +! +PROGRAM SCODE10 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + CALL CHECK(RES, EXP, N) + + STOP 'VINODsssssLLLLLVINODsssssLLLLLVINODsssssLLLLLVINODsssssLLLLLVINODsssssLLLLLVINODsssssLLLLLVINODsssssLLLLLVINODsssssLLLLLVINODsssssLLLLLVINODsssssLLLLLVINODsssssLLLLLVINODsssssLLLLLVINODsssssLLLLLVINODsssssLLLLLVINODsssssLLLLLVINODsssssLLLLLVINODsssssLLLLLVINODsssssLLLLLVINODsssssLLLLLVINODsssssLLLLLVINODsssssLLLLLVINODsssssLLLLLVINODsssssLLLLL' +END PROGRAM diff --git a/test/f08_correct/src/scode11.f08 b/test/f08_correct/src/scode11.f08 new file mode 100644 index 0000000000..fe647a16e7 --- /dev/null +++ b/test/f08_correct/src/scode11.f08 @@ -0,0 +1,19 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Stop Code - Execution control. +! +! Date of Modification: Nov 12, 2019 +! +! Tests if a STOP of an integer over 31 bits will return a warning +! + +PROGRAM SCODE11 + !DEFAULT KIND = 4, SO MAX=RANGE IS (2**31 -1)=2147483647 + !COMPILER MUST THROW ERROR IF THE SIZE OF STOP-CODE IS GREATER THAN DEFAULT KIND VALUE + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + CALL CHECK(RES, EXP, N) + STOP 2147483648 +END PROGRAM diff --git a/test/f08_correct/src/scode12.f08 b/test/f08_correct/src/scode12.f08 new file mode 100644 index 0000000000..3f0ca474f7 --- /dev/null +++ b/test/f08_correct/src/scode12.f08 @@ -0,0 +1,19 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Stop Code - Execution control. +! +! Date of Modification: Nov 12, 2019 +! +! Tests if a an ill-formed STOP code genrates an error +! +PROGRAM SCODE12 + IMPLICIT NONE + INTEGER(KIND=1) :: S = 10 + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + CALL CHECK(RES, EXP, N) + STOP S + STOP 'aall' + STOP -S + 'aall' +END PROGRAM SCODE12 diff --git a/test/f08_correct/src/scode13.f08 b/test/f08_correct/src/scode13.f08 new file mode 100644 index 0000000000..4182b73a4e --- /dev/null +++ b/test/f08_correct/src/scode13.f08 @@ -0,0 +1,19 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Stop Code - Execution control. +! +! Date of Modification: Nov 12, 2019 +! +! Tests if a STOP of an integer over 31 bits returns a warning +! +PROGRAM SCODE13 +IMPLICIT NONE +INTEGER K +INTEGER, PARAMETER :: N = 1 +LOGICAL EXP(N), RES(N) +CALL CHECK(RES, EXP, N) +K = 2147483648 +PRINT *, "K = ", K +STOP K +END PROGRAM diff --git a/test/f08_correct/src/seco01.f08 b/test/f08_correct/src/seco01.f08 new file mode 100644 index 0000000000..5a47812dfb --- /dev/null +++ b/test/f08_correct/src/seco01.f08 @@ -0,0 +1,23 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008-Semicolon at line start - Source form +! +! Date of Modification: 23rd July 2019 +! + +! Ensure that a program and a subroutine can have line that start +! with a semi-colon +PROGRAM SEMI_COLON_TEST + INTEGER, PARAMETER :: N = 1 + LOGICAL exp(N), res(N) +; + PRINT *, 'PASS - SEMI_COLON_TEST -case 1' + CALL SEMI_COLON_SUB + CALL check(res, exp, N) +END + +SUBROUTINE SEMI_COLON_SUB() +; + PRINT *, 'PASS - SEMI_COLON_SUB - case 2' +END diff --git a/test/f08_correct/src/seco02.f08 b/test/f08_correct/src/seco02.f08 new file mode 100644 index 0000000000..6fb9ca9be5 --- /dev/null +++ b/test/f08_correct/src/seco02.f08 @@ -0,0 +1,30 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008-Semicolon at line start - Source form +! +! Date of Modification: 23rd July 2019 +! + +! Ensure that a program in free form supports a semi-colon at the +! start which is column + PROGRAM FREE_FORM_SEMICOLON + INTEGER I, N, SUM + INTEGER, PARAMETER :: P = 1 + LOGICAL exp(P), res(P) + SUM = 0 + N = 10 + ; + DO 10 I = 1, N + ; + SUM = SUM + I + WRITE(*,*) 'I =', I + WRITE(*,*) 'SUM =', SUM + ; + 10 CONTINUE + ; + WRITE(*,*) 'SUM =', SUM + ; + PRINT *, 'PASS - SEMI_COLON_TEST - Free-Form' + CALL check(res, exp, P) + END diff --git a/test/f08_correct/src/select01.f08 b/test/f08_correct/src/select01.f08 new file mode 100644 index 0000000000..9538b526cd --- /dev/null +++ b/test/f08_correct/src/select01.f08 @@ -0,0 +1,52 @@ +! +! Copyright (c) 2020, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008-Named Select Type feature is missing +! +! Date of Modification: Jan 20 2020 +! +! Tests the Named Select feature of F2008 +! +PROGRAM SELECT01 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + TYPE :: POINT + REAL :: X, Y + END TYPE POINT + + TYPE, EXTENDS(POINT) :: POINT_3D + REAL :: Z + END TYPE POINT_3D + + TYPE, EXTENDS(POINT) :: COLOR_POINT + INTEGER :: COLOR + END TYPE COLOR_POINT + + TYPE(POINT), TARGET :: P + TYPE(POINT_3D), TARGET :: P3 + TYPE(COLOR_POINT), TARGET :: C + CLASS(POINT), POINTER :: P_OR_C + + P_OR_C => C + C%X = 0.2 + C%Y = 0.3 + C%COLOR = 100 + + SELECT TYPE ( A => P_OR_C ) + CLASS IS ( POINT ) + ! "CLASS ( POINT ) :: A" implied here + PRINT *, "CLASS is POINT" + PRINT *, A%X, A%Y ! This block gets executed + TYPE IS ( POINT_3D ) + ! "TYPE ( POINT_3D ) :: A" implied here + PRINT *, "CLASS is POINT_3D" + PRINT *, A%X, A%Y, A%Z + TYPE IS ( COLOR_POINT ) + ! "TYPE ( COLOR_POINT ) :: A" implied here + PRINT *, "CLASS is COLOR_POINT" + PRINT *, A%X, A%Y, A%COLOR + END SELECT + CALL CHECK(RES, EXP, N) +END PROGRAM diff --git a/test/f08_correct/src/selectrealkind.f08 b/test/f08_correct/src/selectrealkind.f08 new file mode 100644 index 0000000000..0ee6c6c84a --- /dev/null +++ b/test/f08_correct/src/selectrealkind.f08 @@ -0,0 +1,82 @@ +!* Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +!* +!* Support for radix in selected_real_kind intrisic intrinsics. + +!* F2008 feature Selected_real_kind intrinsic with 3rd parameter radix +!* AOCC test + + program real_kinds + interface + subroutine copy_str_to_result( str, result) + integer :: result(:) + character(len=*) :: str + end subroutine + end interface + + parameter(NTEST=10) + integer :: result(NTEST) + integer :: expect(NTEST) = (/ & + !select_rkind1 + 4, & + !select_rkind2 + 8, & + !select_rkind3 + 16, & + !select_rkind4 + 8, & + !select_rkind5 + 8, & + !select_rkind6 + -3, & + !select_rkind7 + -2, & + !select_rkind8 + -5, & + !select_rkind9 + 16, & + !select_rkind10 + -1 & + /) + integer,parameter :: select_rkind1 = selected_real_kind(6) + integer,parameter :: select_rkind2 = selected_real_kind(10,100) + integer,parameter :: select_rkind3 = selected_real_kind(r=400) + integer,parameter :: select_rkind4 = selected_real_kind(4,70,2) + integer :: select_rkind5 = SELECTED_REAL_KIND(6, 70, 2) + integer :: select_rkind6 = SELECTED_REAL_KIND(45, 5000, 2) + integer :: select_rkind7 = SELECTED_REAL_KIND(8, 6000, 2) + integer :: select_rkind8 = SELECTED_REAL_KIND(60,600, 10) + integer :: select_rkind9 = selected_real_kind(16,400) + integer :: select_rkind10 = selected_real_kind(34) + print *,"! select_rkind1" + print *,select_rkind1; + result(1) = select_rkind1 + print *,"! select_rkind2" + print *,select_rkind2; + result(2) = select_rkind2 + print *,"! select_rkind3" + print *,select_rkind3; + result(3) = select_rkind3 + print *,"! select_rkind4" + print *,select_rkind4; + result(4) = select_rkind4 + print *,"! select_rkind5" + print *,select_rkind5; + result(5) = select_rkind5 + print *,"! select_rkind6" + print *,select_rkind6; + result(6) = select_rkind6 + print *,"! select_rkind7" + print *,select_rkind7; + result(7) = select_rkind7 + print *,"! select_rkind8" + print *,select_rkind8; + result(8) = select_rkind8 + print *,"! select_rkind9" + print *,select_rkind9; + result(9) = select_rkind9 + print *,"! select_rkind10" + print *,select_rkind10; + result(10) = select_rkind10 + call check(result,expect,NTEST) + end program real_kinds + diff --git a/test/f08_correct/src/storage_size.f08 b/test/f08_correct/src/storage_size.f08 new file mode 100644 index 0000000000..24efe568f2 --- /dev/null +++ b/test/f08_correct/src/storage_size.f08 @@ -0,0 +1,36 @@ +!* Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +!* +!* F2008 feature storage_size intrinsic +!* Returns the storage size of argument in bits. +!* +!* result = storage_size(a [, kind]) +!* Arguments +!* a - Shall be a scalar or array of any type. +!* kind - (Optional) shall be a scalar integer constant expressioni +!* AOCC test + program test_storage_size + + parameter(NTEST=3) + integer :: expect(NTEST) = [ 32, 32, 32 ] + integer :: result(NTEST) + + integer :: x = 5 + logical :: y(3) = [.true., .false., .true.] + integer :: storage_size1 = storage_size(x) + integer :: storage_size2 = storage_size(y) + integer :: storage_size3 = storage_size(10.85, 8) + + print *,"! storage_size1" + print *, storage_size1 + result(1) = storage_size1; + + print *,"! storage_size2" + print *, storage_size2 + result(2) = storage_size2; + + print *,"! storage_size3" + print *, storage_size3 + result(3) = storage_size3; + call check(result,expect,NTEST) + end program + diff --git a/test/f08_correct/src/tc3.f08 b/test/f08_correct/src/tc3.f08 new file mode 100644 index 0000000000..0b8051677d --- /dev/null +++ b/test/f08_correct/src/tc3.f08 @@ -0,0 +1,25 @@ +!* +!* Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +!* +!* +!* assumed size array support +!* AOCC test + +program tc3 + Implicit None + Integer,Parameter :: wp = Selected_Real_Kind(6) + Real(wp),Parameter :: xp(3) = [ 0.5_wp,Nearest(0.5_wp,-1.0_wp), Nearest(0.5_wp,+1.0_wp) ] + Real(wp),Parameter :: x(*) = [ xp,-xp ] + Integer,Parameter :: yp(*) = [ 1,0,1 ], y(*) = [ yp,-yp ] + Integer, Parameter :: z(*) = Nint(x) + Integer, Parameter :: n = Size(x) + Integer expect(n), rslts(n) + Integer i + + Do i=1,n + expect(i) = Nint(x(i)) + End Do + rslts = z + + call check(rslts, expect, n) +end program tc3 diff --git a/test/f08_correct/src/tc3g.f08 b/test/f08_correct/src/tc3g.f08 new file mode 100644 index 0000000000..167ad4cd1a --- /dev/null +++ b/test/f08_correct/src/tc3g.f08 @@ -0,0 +1,25 @@ +!* +!* Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +!* +!* +!* assumed size array support +!* AOCC test + +program tc3g + Implicit None + Integer,Parameter :: wp = Selected_Real_Kind(15) + Real(wp),Parameter :: xp(3) = [ 0.5_wp,Nearest(0.5_wp,-1.0_wp), Nearest(0.5_wp,+1.0_wp) ] + Real(wp),Parameter :: x(*) = [ xp,-xp ] + Integer,Parameter :: yp(*) = [ 1,0,1 ], y(*) = [ yp,-yp ] + Integer, Parameter :: z(*) = Nint(x) + Integer, Parameter :: n = Size(x) + Integer :: expect(n), rslts(n) + Integer i + + Do i=1,n + expect(i) = Nint(x(i)) + End Do + rslts = z + + call check(rslts, expect, n) +end program tc3g diff --git a/test/f08_correct/src/tc4.f08 b/test/f08_correct/src/tc4.f08 new file mode 100644 index 0000000000..6f93feedb1 --- /dev/null +++ b/test/f08_correct/src/tc4.f08 @@ -0,0 +1,25 @@ +!* +!* Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +!* +!* +!* assumed size array support +!* AOCC test + +program tc4 + Implicit None + Integer,Parameter :: wp = Selected_Real_Kind(6) + Real(wp),Parameter :: xp(3) = [ 0.5_wp,Nearest(0.5_wp,-1.0_wp), Nearest(0.5_wp,+1.0_wp) ] + Real(wp),Parameter :: x(*) = [ xp,-xp ] + Integer,Parameter :: yp(*) = [ 1,0,1 ], y(*) = [ yp,-yp ] + Integer, Parameter :: z(*) = Anint(x) + Integer, Parameter :: n = Size(x) + Integer :: expect(n), rslts(n) + Integer i + + Do i=1,n + expect(i) = Anint(x(i)) + End Do + rslts = z + + call check(rslts, expect, n) +end program tc4 diff --git a/test/f08_correct/src/tc4d.f08 b/test/f08_correct/src/tc4d.f08 new file mode 100644 index 0000000000..bf863d49ef --- /dev/null +++ b/test/f08_correct/src/tc4d.f08 @@ -0,0 +1,25 @@ +!* +!* Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +!* +!* +!* assumed size array support +!* AOCC test + +program tc4 + Implicit None + Integer,Parameter :: wp = Selected_Real_Kind(15) + Real(wp),Parameter :: xp(3) = [ 0.5_wp,Nearest(0.5_wp,-1.0_wp), Nearest(0.5_wp,+1.0_wp) ] + Real(wp),Parameter :: x(*) = [ xp,-xp ] + Integer,Parameter :: yp(*) = [ 1,0,1 ], y(*) = [ yp,-yp ] + Integer, Parameter :: z(*) = Anint(x) + Integer, Parameter :: n = Size(x) + Integer :: expect(n), rslts(n) + Integer i + + Do i=1,n + expect(i) = Anint(x(i)) + End Do + rslts = z + + call check(rslts, expect, n) +end program tc4 diff --git a/test/f08_correct/src/test_atan.f08 b/test/f08_correct/src/test_atan.f08 new file mode 100644 index 0000000000..c372b91626 --- /dev/null +++ b/test/f08_correct/src/test_atan.f08 @@ -0,0 +1,24 @@ +!* +!* Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +!* +!* +!* F2008 feature atan with two arguments +!* AOCC test + + program test_atan + parameter(NTEST=3) + real :: expect(NTEST) = (/ 0.4636476, 1.325818, 0.4636476 /) + real :: result(NTEST) + real(4) :: x = 4, y = 2 + b1 = atan(y, x) + print *, b1 + result(1) = b1 + b2 = atan(x) + print *, b2 + result(2) = b2 + b3 = atan2(y, x) + print *, b3 + result(3) = b3 + call checkf(result,expect,NTEST) + end program test_atan + diff --git a/test/f08_correct/src/type_intr_type.f08 b/test/f08_correct/src/type_intr_type.f08 new file mode 100644 index 0000000000..10ccf826cf --- /dev/null +++ b/test/f08_correct/src/type_intr_type.f08 @@ -0,0 +1,31 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +!* +! F2008-New Unit Specifier feature compliance test +!* F2008 feature: Type statement for intrinsic types +!* +!* AOCC test + + program test_type_intr_type + + integer :: result1, expect1 + complex :: result2, expect2 + type(integer) :: i,j,s + type(complex) :: z + integer :: y = 42 + real :: x = 3.14 + i = 10 + j = 25 + s = i + j + print *, s + result1 = s + expect1 = 35 + call check(result1,expect1,1) + + print *, cmplx(y, x) + result2 = cmplx(y, x) + expect2 = (42.00000,3.140000) + call check(result2,expect2,1) + + end program diff --git a/test/f08_correct/src/type_intrinsic.f08 b/test/f08_correct/src/type_intrinsic.f08 new file mode 100644 index 0000000000..e85295b7e5 --- /dev/null +++ b/test/f08_correct/src/type_intrinsic.f08 @@ -0,0 +1,27 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! [CPUPC-2836] f2008 feature: type statement for intrinsic types +! +! Date of Modification: 24 January 2020 + + +program TypeIntrinsic + implicit none + integer , parameter :: n = 4 + type(integer) :: a + real(kind=4) :: result(n) + real(kind=4) :: expect(n) = [15.0,3.1415,1.0000,2.71]; + type(integer) :: i1 = 15 + type(real) :: pie = 3.1415 + type(complex) :: c1 = (0,1) + type (real( kind = 8) ) :: e = 2.71 + result(1) = i1 + result(2) = pie + result(3) = imag(c1) + result(4) = e + do a = 1 , n + print*, result(a) , expect(a) + end do + call checkf(result,expect,n) +end program TypeIntrinsic diff --git a/test/f08_correct/src/uform01.f08 b/test/f08_correct/src/uform01.f08 new file mode 100644 index 0000000000..09af7a4187 --- /dev/null +++ b/test/f08_correct/src/uform01.f08 @@ -0,0 +1,27 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Error stop code - Execution control +! +! Date of Modification: 1st Sep 2019 +! +! Tests the F2008 :Unlimited format item - Input/Output feature +! for an integer array + +PROGRAM UFORM01 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + INTEGER, DIMENSION(3,3) :: A + A = RESHAPE((/1, 2, 3, 4, 5, 6, 7, 8, 9/), SHAPE(A)) + CALL S(A) + CALL CHECK(RES, EXP, N) +END PROGRAM + +SUBROUTINE S(x) + IMPLICIT NONE + INTEGER, DIMENSION(3,3), INTENT(IN) :: X + !INTEGER X(:) + PRINT 1,X +1 FORMAT('X =',*(:,' ',I4)) +END SUBROUTINE diff --git a/test/f08_correct/src/uform02.f08 b/test/f08_correct/src/uform02.f08 new file mode 100644 index 0000000000..7e687d0fe1 --- /dev/null +++ b/test/f08_correct/src/uform02.f08 @@ -0,0 +1,27 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Error stop code - Execution control +! +! Date of Modification: 1st Sep 2019 +! +! Tests the F2008 :Unlimited format item - Input/Output feature +! for a logical array + +PROGRAM UFORM02 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + LOGICAL, DIMENSION(3,3) :: L + L = RESHAPE((/.TRUE., .TRUE., .FALSE., .TRUE., .TRUE., .FALSE., .TRUE., .FALSE., .FALSE./), SHAPE(L)) + CALL S(L) + CALL CHECK(RES, EXP, N) +END PROGRAM + +SUBROUTINE S(X) + IMPLICIT NONE + !LOGICAL X(:) + LOGICAL, DIMENSION(3,3), INTENT(IN) :: X + PRINT 1,X +1 FORMAT('X =',*(:,' ',L1)) +END SUBROUTINE diff --git a/test/f08_correct/src/uform03.f08 b/test/f08_correct/src/uform03.f08 new file mode 100644 index 0000000000..56ed4d5715 --- /dev/null +++ b/test/f08_correct/src/uform03.f08 @@ -0,0 +1,27 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Error stop code - Execution control +! +! Date of Modification: 1st Sep 2019 +! +! Tests the F2008 :Unlimited format item - Input/Output feature +! for a real array + +PROGRAM UFORM03 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + REAL, DIMENSION(3,3) :: R + R = RESHAPE((/1.234, 10.234, 88.77, 2.33, 1.989, 5.5, 0.3, 55.66, 77.78/), SHAPE(R)) + CALL S(R) + CALL CHECK(RES, EXP, N) +END PROGRAM + +SUBROUTINE S(X) + IMPLICIT NONE + !LOGICAL X(:) + REAL, DIMENSION(3,3), INTENT(IN) :: X + PRINT 1,X +1 FORMAT('X =',*(:,' ',F6.2)) +END SUBROUTINE diff --git a/test/f08_correct/src/uform04.f08 b/test/f08_correct/src/uform04.f08 new file mode 100644 index 0000000000..e7b482ec50 --- /dev/null +++ b/test/f08_correct/src/uform04.f08 @@ -0,0 +1,26 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Error stop code - Execution control +! +! Date of Modification: 1st Sep 2019 +! +! Tests the F2008 :Unlimited format item - Input/Output feature +! for a complex array +PROGRAM UFORM04 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + COMPLEX, DIMENSION(3,3) :: C + C = RESHAPE((/(1,2), (10,20), (88,99), (2.33,5.77), (1,9), (5.5,4.4), (0.3,0.7), (55.66,33.55), (77,99)/), SHAPE(C)) + CALL S(C) + CALL CHECK(RES, EXP, N) +END PROGRAM + +SUBROUTINE S(X) + IMPLICIT NONE + !LOGICAL X(:) + COMPLEX, DIMENSION(3,3), INTENT(IN) :: X + PRINT 1,X +1 FORMAT(*(:, 2(2x,2f9.5))) +END SUBROUTINE diff --git a/test/f08_correct/src/uform05.f08 b/test/f08_correct/src/uform05.f08 new file mode 100644 index 0000000000..fa27bf4caa --- /dev/null +++ b/test/f08_correct/src/uform05.f08 @@ -0,0 +1,26 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Error stop code - Execution control +! +! Date of Modification: 1st Sep 2019 +! +! Tests the F2008 :Unlimited format item - Input/Output feature +! for a character array + +PROGRAM UFORM04 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + CHARACTER, DIMENSION(10) :: C + C = (/'H', 'E', 'L', 'L', 'O', 'W', 'O', 'R', 'L', 'D'/) + CALL S(C) + CALL CHECK(RES, EXP, N) +END PROGRAM + +SUBROUTINE S(X) + IMPLICIT NONE + CHARACTER, DIMENSION(10), INTENT(IN) :: X + PRINT 1, X +1 FORMAT(*(:, '-', A)) +END SUBROUTINE diff --git a/test/f08_correct/src/uform06.f08 b/test/f08_correct/src/uform06.f08 new file mode 100644 index 0000000000..dfbcba7609 --- /dev/null +++ b/test/f08_correct/src/uform06.f08 @@ -0,0 +1,38 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Error stop code - Execution control +! +! Date of Modification: 1st Sep 2019 +! +! Tests the F2008 :Unlimited format item - Input/Output feature +! for a string array + +PROGRAM UFORM05 + IMPLICIT NONE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + !CHARACTER(10), DIMENSION(10) :: STA = (/"The", "morning", "edition", "of", "the", "newspaper", "has", "just", "now", "arrived"/) + CHARACTER(10), DIMENSION(10) :: STA + + STA(1) = "The" + STA(2) = "morning" + STA(3) = "edition" + STA(4) = "of" + STA(5) = "the" + STA(6) = "newspaper" + STA(7) = "has" + STA(8) = "just" + STA(9) = "now" + STA(10) = "arrived" + + CALL S(STA) + CALL CHECK(RES, EXP, N) +END PROGRAM + +SUBROUTINE S(X) + IMPLICIT NONE + CHARACTER(10), DIMENSION (10) :: X + PRINT 1, X +1 FORMAT(*(:, '-', A10)) +END SUBROUTINE diff --git a/test/f08_correct/src/value11.f08 b/test/f08_correct/src/value11.f08 new file mode 100644 index 0000000000..0c450d2855 --- /dev/null +++ b/test/f08_correct/src/value11.f08 @@ -0,0 +1,42 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: CPUPC-2052-F2008: In a pure procedure the +! intent of an argument need not be specified if it has the +! value attribute +! +! Date of Modification: Wed Feb 19 14:31:03 IST 2020 +! +! Verify that pure subroutines by default use pass-by-reference +! semantics +! +PROGRAM VALUE11 + IMPLICIT NONE + INTEGER X, Y + + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + X = 10 + Y = 11 + PRINT *, "BEFORE CALL: X = ", X + PRINT *, "BEFORE CALL: Y = ", Y + CALL PSUB(X, Y) + PRINT *, "AFTER CALL: X = ", X + PRINT *, "AFTER CALL: Y = ", Y + CALL CHECK(RES, EXP, N) +END PROGRAM + +PURE SUBROUTINE PSUB(A, B) + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: A, B + + !PRINT *, "BEFORE ASSIGN: A = ", A + !PRINT *, "BEFORE ASSIGN: B = ", B + A = 100 + B = 101 + !PRINT *, "BEFORE ASSIGN: A = ", A + !PRINT *, "AFTER ASSIGN: B = ", B +END SUBROUTINE + + diff --git a/test/f08_correct/src/value12.f08 b/test/f08_correct/src/value12.f08 new file mode 100644 index 0000000000..2745f87e11 --- /dev/null +++ b/test/f08_correct/src/value12.f08 @@ -0,0 +1,48 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: CPUPC-2052-F2008: In a pure procedure the +! intent of an argument need not be specified if it has the +! value attribute +! +! Date of Modification: Wed Feb 19 14:31:03 IST 2020 +! +! Verify that pure subroutines can be forced to use pass-by-value +! semantics using the VALUE keyword +! +PROGRAM VALUE12 + IMPLICIT NONE + !INTEGER, VALUE :: VAL1_A, VAL2_A, VAL3_A + INTEGER :: VAL1_A, VAL2_A, VAL3_A + + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + INTERFACE + SUBROUTINE PASS_BY_VALUE(VAL1_P, VAL2_P, VAL3_P) + !INTEGER, INTENT(INOUT) :: VAL1_P, VAL2_P, VAL3_P + INTEGER, VALUE :: VAL1_P, VAL2_P, VAL3_P + END SUBROUTINE + END INTERFACE + + VAL1_A = 77 + VAL2_A = 88 + VAL3_A = 99 + + CALL PASS_BY_VALUE(VAL1_A, VAL2_A, VAL3_A) + PRINT *, "VAL1_A = ", VAL1_A + PRINT *, "VAL2_A = ", VAL2_A + PRINT *, "VAL3_A = ", VAL3_A + + CALL CHECK(RES, EXP, N) +END PROGRAM + +PURE SUBROUTINE PASS_BY_VALUE(VAL1_P, VAL2_P, VAL3_P) + IMPLICIT NONE + !INTEGER, INTENT(INOUT) :: VAL1_P, VAL2_P, VAL3_P + INTEGER, VALUE :: VAL1_P, VAL2_P, VAL3_P + + VAL1_P = 100 + VAL2_P = 101 + VAL3_P = 102 +END SUBROUTINE diff --git a/test/f08_correct/src/value13.f08 b/test/f08_correct/src/value13.f08 new file mode 100644 index 0000000000..635520ae5b --- /dev/null +++ b/test/f08_correct/src/value13.f08 @@ -0,0 +1,49 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: CPUPC-2052-F2008: In a pure procedure the +! intent of an argument need not be specified if it has the +! value attribute +! +! Date of Modification: Wed Feb 19 14:31:03 IST 2020 +! +! Verify that pure subroutines do not all both VALUE and +! INTENT keywords in the same source statement +! +PROGRAM VALUE13 + IMPLICIT NONE + !INTEGER, VALUE :: VAL1_A, VAL2_A, VAL3_A + INTEGER :: VAL1_A, VAL2_A, VAL3_A + + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + CALL CHECK(RES, EXP, N) + + INTERFACE + SUBROUTINE PASS_BY_VALUE(VAL1_P, VAL2_P, VAL3_P) + !INTEGER, INTENT(INOUT) :: VAL1_P, VAL2_P, VAL3_P + !INTEGER, VALUE :: VAL1_P, VAL2_P, VAL3_P + INTEGER, INTENT(INOUT), VALUE :: VAL1_P, VAL2_P, VAL3_P + END SUBROUTINE + END INTERFACE + + VAL1_A = 77 + VAL2_A = 88 + VAL3_A = 99 + + CALL PASS_BY_VALUE(VAL1_A, VAL2_A, VAL3_A) + PRINT *, "VAL1_A = ", VAL1_A + PRINT *, "VAL2_A = ", VAL2_A + PRINT *, "VAL3_A = ", VAL3_A +END PROGRAM + +PURE SUBROUTINE PASS_BY_VALUE(VAL1_P, VAL2_P, VAL3_P) + IMPLICIT NONE + !INTEGER, INTENT(INOUT) :: VAL1_P, VAL2_P, VAL3_P + !INTEGER, VALUE :: VAL1_P, VAL2_P, VAL3_P + INTEGER, INTENT(INOUT), VALUE :: VAL1_P, VAL2_P, VAL3_P + + VAL1_P = 100 + VAL2_P = 101 + VAL3_P = 102 +END SUBROUTINE diff --git a/test/f08_correct/src/value14.f08 b/test/f08_correct/src/value14.f08 new file mode 100644 index 0000000000..04030eecc3 --- /dev/null +++ b/test/f08_correct/src/value14.f08 @@ -0,0 +1,43 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: CPUPC-2052-F2008: In a pure procedure the +! intent of an argument need not be specified if it has the +! value attribute +! +! Date of Modification: Wed Feb 19 14:31:03 IST 2020 +! +! Verify that pure subroutines allow VALUE and INTENT keywords +! on disparate arguments, through separate source statements +! +PROGRAM VALUE14 + IMPLICIT NONE + REAL X, Y + INTERFACE + SUBROUTINE PSUB(A, B) + REAL, INTENT(OUT) :: A + REAL, VALUE :: B + END SUBROUTINE + END INTERFACE + INTEGER, PARAMETER :: N = 1 + LOGICAL EXP(N), RES(N) + + X = 11.11 + Y = 12.12 + + PRINT *, X + PRINT *, Y + + CALL PSUB(X, Y) + + PRINT *, X + PRINT *, Y + CALL CHECK(RES, EXP, N) +END PROGRAM + +PURE SUBROUTINE PSUB(A, B) + IMPLICIT NONE + REAL, INTENT(OUT) :: A + REAL, VALUE :: B + A = B +END SUBROUTINE diff --git a/test/f90_correct/debug_module_import.f90 b/test/f90_correct/debug_module_import.f90 index b78de14d3c..38ecdb8223 100644 --- a/test/f90_correct/debug_module_import.f90 +++ b/test/f90_correct/debug_module_import.f90 @@ -1,17 +1,7 @@ ! -! Copyright (c) 2018, Arm Ltd. All rights reserved. -! -! Licensed under the Apache License, Version 2.0 (the "License"); -! you may not use this file except in compliance with the License. -! You may obtain a copy of the License at -! -! http://www.apache.org/licenses/LICENSE-2.0 -! -! Unless required by applicable law or agreed to in writing, software -! distributed under the License is distributed on an "AS IS" BASIS, -! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -! See the License for the specific language governing permissions and -! limitations under the License. +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception ! ! RUN: %flang -g -S -emit-llvm %s -o - | FileCheck %s diff --git a/test/f90_correct/inc/assume_shp_arry.mk b/test/f90_correct/inc/assume_shp_arry.mk new file mode 100644 index 0000000000..c5f555ce92 --- /dev/null +++ b/test/f90_correct/inc/assume_shp_arry.mk @@ -0,0 +1,35 @@ +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# Copyright (c) 2021, Advanced Micro Devices, Inc. All rights reserved. +# +# Date of Modification: March 2021 +# + +########## Make rule to test assumed shaped array ######## + +fcheck.o check_mod.mod: $(SRC)/check_mod.f90 + -$(FC) -c $(FFLAGS) $(SRC)/check_mod.f90 -o fcheck.o + +assume_shp_arry.o: $(SRC)/assume_shp_arry.f90 check_mod.mod + @echo ------------------------------------ building test $@ + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/assume_shp_arry.f90 -o assume_shp_arry.o + +assume_shp_arry: assume_shp_arry.o fcheck.o + -$(FC) $(FFLAGS) $(LDFLAGS) assume_shp_arry.o fcheck.o $(LIBS) -o assume_shp_arry + +assume_shp_arry.run: assume_shp_arry + @echo ------------------------------------ executing test assume_shp_arry + assume_shp_arry + -$(RM) test_m.mod + +### TA Expected Targets ### + +build: $(TEST) +.PHONY: run +run: $(TEST).run + +verify: ; + +### End of Expected Targets ### diff --git a/test/f90_correct/inc/big_data.mk b/test/f90_correct/inc/big_data.mk new file mode 100644 index 0000000000..4a130c73d5 --- /dev/null +++ b/test/f90_correct/inc/big_data.mk @@ -0,0 +1,29 @@ +# Copyright(C) 2021 Advanced Micro Devices, Inc. All rights reserved. + +########## Make rule to test Big array initialization ######## + +fcheck.o check_mod.mod: $(SRC)/check_mod.f90 + -$(FC) -c $(FFLAGS) $(SRC)/check_mod.f90 -o fcheck.o + +big_data.o: $(SRC)/big_data.f check_mod.mod + @echo ------------------------------------ building test $@ + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/big_data.f -o big_data.o + +big_data: big_data.o fcheck.o + -$(FC) $(FFLAGS) $(LDFLAGS) big_data.o fcheck.o $(LIBS) -o big_data + +big_data.run: big_data + @echo ------------------------------------ executing test big_data + big_data + -$(RM) testmod.mod + +### TA Expected Targets ### + +build: $(TEST) + +.PHONY: run +run: $(TEST).run + +verify: ; + +### End of Expected Targets ### diff --git a/test/f90_correct/inc/eoshift.mk b/test/f90_correct/inc/eoshift.mk new file mode 100644 index 0000000000..7a6c8f2541 --- /dev/null +++ b/test/f90_correct/inc/eoshift.mk @@ -0,0 +1,23 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# +# +# +# +########## Make rule for test eoshift ######## +eoshift: run + +build: $(SRC)/eoshift.f90 + -$(RM) eoshift.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/eoshift.f90 -o eoshift.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) eoshift.$(OBJX) check.$(OBJX) $(LIBS) -o eoshift.$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test eoshift + eoshift.$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/f2008_tbp.mk b/test/f90_correct/inc/f2008_tbp.mk new file mode 100644 index 0000000000..42a26013c4 --- /dev/null +++ b/test/f90_correct/inc/f2008_tbp.mk @@ -0,0 +1,33 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +########## Make rule to test type-bound procedures ######## + +fcheck.o check_mod.mod: $(SRC)/check_mod.f90 + -$(FC) -c $(FFLAGS) $(SRC)/check_mod.f90 -o fcheck.o + +f2008_tbp.o: $(SRC)/f2008_tbp.f90 check_mod.mod + @echo ------------------------------------ building test $@ + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/f2008_tbp.f90 -o f2008_tbp.o + +f2008_tbp: f2008_tbp.o fcheck.o + -$(FC) $(FFLAGS) $(LDFLAGS) f2008_tbp.o fcheck.o $(LIBS) -o f2008_tbp + +f2008_tbp.run: f2008_tbp + @echo ------------------------------------ executing test f2008_tbp + f2008_tbp + -$(RM) class_Circle.mod + +### TA Expected Targets ### + +build: $(TEST) + +.PHONY: run +run: $(TEST).run + +verify: ; + +### End of Expected Targets ### diff --git a/test/f90_correct/inc/floor_ceil.mk b/test/f90_correct/inc/floor_ceil.mk new file mode 100644 index 0000000000..55eb334c63 --- /dev/null +++ b/test/f90_correct/inc/floor_ceil.mk @@ -0,0 +1,23 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# quad support for floor and ceiling +# +# +# +########## Make rule for test floor_ceil ######## +floor_ceil: run + +build: $(SRC)/floor_ceil.f90 + -$(RM) floor_ceil.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/floor_ceil.f90 -o floor_ceil.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) floor_ceil.$(OBJX) check.$(OBJX) $(LIBS) -o floor_ceil.$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test floor_ceil + floor_ceil.$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/io28.mk b/test/f90_correct/inc/io28.mk new file mode 100644 index 0000000000..1f3026fbfb --- /dev/null +++ b/test/f90_correct/inc/io28.mk @@ -0,0 +1,23 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +$(TEST): run + + +build: $(SRC)/$(TEST).f90 + -$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).f90 -o $(TEST).$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) $(TEST).$(OBJX) check.$(OBJX) $(LIBS) -o $(TEST).$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test $(TEST) + $(TEST).$(EXESUFFIX) + +verify: ; + diff --git a/test/f90_correct/inc/minmaxloc_back.mk b/test/f90_correct/inc/minmaxloc_back.mk index 51a8d1d58e..f274f0d21c 100644 --- a/test/f90_correct/inc/minmaxloc_back.mk +++ b/test/f90_correct/inc/minmaxloc_back.mk @@ -1,19 +1,8 @@ # -# Copyright (c) 2019, Arm Ltd.. All rights reserved. +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception # -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. -# - build: $(SRC)/minmaxloc_back.f90 -$(RM) minmaxloc_back.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* -$(RM) $(OBJ) diff --git a/test/f90_correct/inc/mm_prefetch00.mk b/test/f90_correct/inc/mm_prefetch00.mk new file mode 100644 index 0000000000..228047cc15 --- /dev/null +++ b/test/f90_correct/inc/mm_prefetch00.mk @@ -0,0 +1,33 @@ +# +# Copyright (c) 2020, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for ifort's mm_prefetch intrinsic +# Last modified: Jun 2020 +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +########## Make rule for test mm_prefetch00 ######## + + +mm_prefetch00: run + + +build: $(SRC)/mm_prefetch00.f90 + -$(RM) mm_prefetch00.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/mm_prefetch00.f90 -o mm_prefetch00.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) mm_prefetch00.$(OBJX) check.$(OBJX) $(LIBS) -o mm_prefetch00.$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test mm_prefetch00 + mm_prefetch00.$(EXESUFFIX) + +verify: ; + +mm_prefetch00.run: run + diff --git a/test/f90_correct/inc/mmul_misc3.mk b/test/f90_correct/inc/mmul_misc3.mk new file mode 100644 index 0000000000..e7a18ff374 --- /dev/null +++ b/test/f90_correct/inc/mmul_misc3.mk @@ -0,0 +1,27 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +########## Make rule for test mmul_misc3 ######## + + +mmul_misc3: run + + +build: $(SRC)/mmul_misc3.f90 + -$(RM) mmul_misc3.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/mmul_misc3.f90 -o mmul_misc3.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) mmul_misc3.$(OBJX) check.$(OBJX) $(LIBS) -o mmul_misc3.$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test mmul_misc3 + mmul_misc3.$(EXESUFFIX) + +verify: ; + +mmul_misc3.run: run diff --git a/test/f90_correct/inc/modarraycon.mk b/test/f90_correct/inc/modarraycon.mk new file mode 100644 index 0000000000..57d0ae540f --- /dev/null +++ b/test/f90_correct/inc/modarraycon.mk @@ -0,0 +1,28 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +########## Make rule for test modarraycon ######## + + +modarraycon: run + + +build: $(SRC)/modarraycon.f90 + -$(RM) modarraycon.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/modarraycon.f90 -o modarraycon.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) modarraycon.$(OBJX) check.$(OBJX) $(LIBS) -o modarraycon.$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test modarraycon + modarraycon.$(EXESUFFIX) + +verify: ; + +modarraycon.run: run + diff --git a/test/f90_correct/inc/nearest_intrin.mk b/test/f90_correct/inc/nearest_intrin.mk new file mode 100644 index 0000000000..2b01e1f391 --- /dev/null +++ b/test/f90_correct/inc/nearest_intrin.mk @@ -0,0 +1,24 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# [CPUPC-3039]Call To "nearest" intrinsic at declaration +# +# Date of Modification: 02 March 2020 +# +########## Make rule for test nearest_intrin.f90 ######## +nearest_intrin: run + +build: $(SRC)/nearest_intrin.f90 + -$(RM) nearest_intrin.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/nearest_intrin.f90 -o nearest_intrin.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) nearest_intrin.$(OBJX) check.$(OBJX) $(LIBS) -o nearest_intrin.$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test nearest_intrin + nearest_intrin.$(EXESUFFIX) + +verify: ; + diff --git a/test/f90_correct/inc/nmlist.mk b/test/f90_correct/inc/nmlist.mk new file mode 100644 index 0000000000..9c64f8fd1a --- /dev/null +++ b/test/f90_correct/inc/nmlist.mk @@ -0,0 +1,29 @@ +# Copyright(C) 2021 Advanced Micro Devices, Inc. All rights reserved. + +########## Make rule to test namelist with allocatable array ######## + +fcheck.o check_mod.mod: $(SRC)/check_mod.f90 + -$(FC) -c $(FFLAGS) $(SRC)/check_mod.f90 -o fcheck.o + +nmlist.o: $(SRC)/nmlist.f90 check_mod.mod + @echo ------------------------------------ building test $@ + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/nmlist.f90 -o nmlist.o + +nmlist: nmlist.o fcheck.o + -$(FC) $(FFLAGS) $(LDFLAGS) nmlist.o fcheck.o $(LIBS) -o nmlist + +nmlist.run: nmlist + @echo ------------------------------------ executing test nmlist + nmlist + -$(RM) test_m.mod + +### TA Expected Targets ### + +build: $(TEST) + +.PHONY: run +run: $(TEST).run + +verify: ; + +### End of Expected Targets ### diff --git a/test/f90_correct/inc/ppm.mk b/test/f90_correct/inc/ppm.mk new file mode 100644 index 0000000000..0e07bb5853 --- /dev/null +++ b/test/f90_correct/inc/ppm.mk @@ -0,0 +1,18 @@ +# Copyright(C) 2021 Advanced Micro Devices, Inc. All rights reserved. + +########## Make rule for test procedure pointer assignment ######## +ppm: run + +build: $(SRC)/ppm.f90 + -$(RM) ppm.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/ppm.f90 -o ppm.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) ppm.$(OBJX) check.$(OBJX) $(LIBS) -o ppm.$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test procedure pointer assignment + ppm.$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/ppm1.mk b/test/f90_correct/inc/ppm1.mk new file mode 100644 index 0000000000..4e7eade9c1 --- /dev/null +++ b/test/f90_correct/inc/ppm1.mk @@ -0,0 +1,18 @@ +# Copyright(C) 2021 Advanced Micro Devices, Inc. All rights reserved. + +########## Make rule for test procedure pointer assignment ######## +ppm1: run + +build: $(SRC)/ppm1.f90 + -$(RM) ppm1.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/ppm1.f90 -o ppm1.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) ppm1.$(OBJX) check.$(OBJX) $(LIBS) -o ppm1.$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test procedure pointer assignment + ppm1.$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/quad01.mk b/test/f90_correct/inc/quad01.mk new file mode 100644 index 0000000000..73f034158a --- /dev/null +++ b/test/f90_correct/inc/quad01.mk @@ -0,0 +1,28 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +########## Make rule for test quad01 ######## + + +quad01: run + + +build: $(SRC)/quad01.f90 + -$(RM) quad01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/quad01.f90 -o quad01.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) quad01.$(OBJX) check.$(OBJX) $(LIBS) -o quad01.$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test quad01 + quad01.$(EXESUFFIX) + +verify: ; + +quad01.run: run + diff --git a/test/f90_correct/inc/quad02.mk b/test/f90_correct/inc/quad02.mk new file mode 100644 index 0000000000..55d0204593 --- /dev/null +++ b/test/f90_correct/inc/quad02.mk @@ -0,0 +1,28 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +########## Make rule for test quad02 ######## + + +quad02: run + + +build: $(SRC)/quad02.f90 + -$(RM) quad02.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/quad02.f90 -o quad02.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) quad02.$(OBJX) check.$(OBJX) $(LIBS) -o quad02.$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test quad02 + quad02.$(EXESUFFIX) + +verify: ; + +quad02.run: run + diff --git a/test/f90_correct/inc/quad03.mk b/test/f90_correct/inc/quad03.mk new file mode 100644 index 0000000000..f7f425dd1a --- /dev/null +++ b/test/f90_correct/inc/quad03.mk @@ -0,0 +1,30 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# + +########## Make rule for test quad03 ######## + + +quad03: run + + +build: $(SRC)/quad03.f90 + -$(RM) quad03.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/quad03.f90 -o quad03.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) quad03.$(OBJX) check.$(OBJX) $(LIBS) -lquadmath -o quad03.$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test quad03 + quad03.$(EXESUFFIX) + +verify: ; + +quad03.run: run + diff --git a/test/f90_correct/inc/quad_epsilon.mk b/test/f90_correct/inc/quad_epsilon.mk new file mode 100644 index 0000000000..04e1ffb672 --- /dev/null +++ b/test/f90_correct/inc/quad_epsilon.mk @@ -0,0 +1,28 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +########## Make rule for test quad_epsilon ######## + + +quad_epsilon: run + + +build: $(SRC)/quad_epsilon.f90 + -$(RM) quad_epsilon.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/quad_epsilon.f90 -o quad_epsilon.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) quad_epsilon.$(OBJX) check.$(OBJX) $(LIBS) -o quad_epsilon.$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test quad_epsilon + quad_epsilon.$(EXESUFFIX) + +verify: ; + +quad_epsilon.run: run + diff --git a/test/f90_correct/inc/quad_math_intrin.mk b/test/f90_correct/inc/quad_math_intrin.mk new file mode 100644 index 0000000000..f87052294d --- /dev/null +++ b/test/f90_correct/inc/quad_math_intrin.mk @@ -0,0 +1,23 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# [CPUPC-2997]Real128 support for math intrinsics +# +# Date of Modification: 24 February 2020 +# +########## Make rule for test quad_math_intrin.f90 ######## +quad_math_intrin: .run +quad_math_intrin.$(OBJX): $(SRC)/quad_math_intrin.f90 + -$(RM) quad_math_intrin.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/quad_math_intrin.f90 -lquadmath -o quad_math_intrin.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) quad_math_intrin.$(OBJX) -lquadmath check.$(OBJX) $(LIBS) -o quad_math_intrin.$(EXESUFFIX) +quad_math_intrin.run: quad_math_intrin.$(OBJX) + @echo ------------------------------------ executing test quad_math_intrin.f90 + quad_math_intrin.$(EXESUFFIX) +build: quad_math_intrin.$(OBJX) +verify: ; +run: quad_math_intrin.$(OBJX) + @echo ------------------------------------ executing test quad_math_intrin.f90 + -quad_math_intrin.$(EXESUFFIX) ||: diff --git a/test/f90_correct/inc/quadcmplx01.mk b/test/f90_correct/inc/quadcmplx01.mk new file mode 100644 index 0000000000..f3aa555f8d --- /dev/null +++ b/test/f90_correct/inc/quadcmplx01.mk @@ -0,0 +1,28 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +########## Make rule for test quadcmplx01 ######## + + +quadcmplx01: run + + +build: $(SRC)/quadcmplx01.f90 + -$(RM) quadcmplx01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/quadcmplx01.f90 -o quadcmplx01.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) quadcmplx01.$(OBJX) check.$(OBJX) $(LIBS) -o quadcmplx01.$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test quadcmplx01 + quadcmplx01.$(EXESUFFIX) + +verify: ; + +quadcmplx01.run: run + diff --git a/test/f90_correct/inc/quadsupport.mk b/test/f90_correct/inc/quadsupport.mk new file mode 100644 index 0000000000..fb2134abd7 --- /dev/null +++ b/test/f90_correct/inc/quadsupport.mk @@ -0,0 +1,23 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# complex quad support for asin, asinh, acos, acosh, atan, atanh +# +# +# +########## Make rule for test quadsupport ######## +quadsupport: run + +build: $(SRC)/quadsupport.f90 + -$(RM) quadsupport.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/quadsupport.f90 -o quadsupport.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) quadsupport.$(OBJX) check.$(OBJX) $(LIBS) -o quadsupport.$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test quadsupport + quadsupport.$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/real128_init.mk b/test/f90_correct/inc/real128_init.mk new file mode 100644 index 0000000000..34686a72f0 --- /dev/null +++ b/test/f90_correct/inc/real128_init.mk @@ -0,0 +1,23 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# +# +# +# +########## Make rule for test real128_init ######## +real128_init: run + +build: $(SRC)/real128_init.f90 + -$(RM) real128_init.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/real128_init.f90 -o real128_init.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) real128_init.$(OBJX) check.$(OBJX) $(LIBS) -o real128_init.$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test real128_init + real128_init.$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/real128_int_init.mk b/test/f90_correct/inc/real128_int_init.mk new file mode 100644 index 0000000000..b5050252bc --- /dev/null +++ b/test/f90_correct/inc/real128_int_init.mk @@ -0,0 +1,23 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# +# +# +# +########## Make rule for test real128_int_init ######## +real128_int_init: run + +build: $(SRC)/real128_int_init.f90 + -$(RM) real128_int_init.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/real128_int_init.f90 -o real128_int_init.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) real128_int_init.$(OBJX) check.$(OBJX) $(LIBS) -o real128_int_init.$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test real128_int_init + real128_int_init.$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/scode01.mk b/test/f90_correct/inc/scode01.mk new file mode 100644 index 0000000000..6a1ade1f19 --- /dev/null +++ b/test/f90_correct/inc/scode01.mk @@ -0,0 +1,32 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control. +# +# Date of Modification: Nov 12, 2019 +# + +########## Make rule for test scode01 ######## + + +scode01: scode01.run + +scode01.$(OBJX): $(SRC)/scode01.f90 + -$(RM) scode01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/scode01.f90 -o scode01.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) scode01.$(OBJX) check.$(OBJX) $(LIBS) -o scode01.$(EXESUFFIX) + + +scode01.run: scode01.$(OBJX) + @echo ------------------------------------ executing test scode01 + scode01.$(EXESUFFIX) + +build: scode01.$(OBJX) + +verify: ; + +run: scode01.$(OBJX) + @echo ------------------------------------ executing test scode01 + -scode01.$(EXESUFFIX) ||: diff --git a/test/f90_correct/inc/string_array_pointer.mk b/test/f90_correct/inc/string_array_pointer.mk new file mode 100644 index 0000000000..119a8d871b --- /dev/null +++ b/test/f90_correct/inc/string_array_pointer.mk @@ -0,0 +1,18 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +$(TEST): run + +build: $(SRC)/$(TEST).f90 + -$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(FC) $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).f90 -o $(TEST).$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test $(TEST) + $(TEST).$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/string_array_pointer_1.mk b/test/f90_correct/inc/string_array_pointer_1.mk new file mode 100644 index 0000000000..119a8d871b --- /dev/null +++ b/test/f90_correct/inc/string_array_pointer_1.mk @@ -0,0 +1,18 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +$(TEST): run + +build: $(SRC)/$(TEST).f90 + -$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(FC) $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).f90 -o $(TEST).$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test $(TEST) + $(TEST).$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/string_array_pointer_2.mk b/test/f90_correct/inc/string_array_pointer_2.mk new file mode 100644 index 0000000000..119a8d871b --- /dev/null +++ b/test/f90_correct/inc/string_array_pointer_2.mk @@ -0,0 +1,18 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +$(TEST): run + +build: $(SRC)/$(TEST).f90 + -$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(FC) $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).f90 -o $(TEST).$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test $(TEST) + $(TEST).$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/string_array_pointer_3.mk b/test/f90_correct/inc/string_array_pointer_3.mk new file mode 100644 index 0000000000..119a8d871b --- /dev/null +++ b/test/f90_correct/inc/string_array_pointer_3.mk @@ -0,0 +1,18 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +$(TEST): run + +build: $(SRC)/$(TEST).f90 + -$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(FC) $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).f90 -o $(TEST).$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test $(TEST) + $(TEST).$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/string_array_pointer_4.mk b/test/f90_correct/inc/string_array_pointer_4.mk new file mode 100644 index 0000000000..119a8d871b --- /dev/null +++ b/test/f90_correct/inc/string_array_pointer_4.mk @@ -0,0 +1,18 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +$(TEST): run + +build: $(SRC)/$(TEST).f90 + -$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(FC) $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).f90 -o $(TEST).$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test $(TEST) + $(TEST).$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/string_array_pointer_5.mk b/test/f90_correct/inc/string_array_pointer_5.mk new file mode 100644 index 0000000000..119a8d871b --- /dev/null +++ b/test/f90_correct/inc/string_array_pointer_5.mk @@ -0,0 +1,18 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +$(TEST): run + +build: $(SRC)/$(TEST).f90 + -$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(FC) $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).f90 -o $(TEST).$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test $(TEST) + $(TEST).$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/tbp.mk b/test/f90_correct/inc/tbp.mk new file mode 100644 index 0000000000..fa1998b4f2 --- /dev/null +++ b/test/f90_correct/inc/tbp.mk @@ -0,0 +1,32 @@ +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Date of Modification: December 2019 +# + +########## Make rule to test type-bound procedures ######## + +fcheck.o check_mod.mod: $(SRC)/check_mod.f90 + -$(FC) -c $(FFLAGS) $(SRC)/check_mod.f90 -o fcheck.o + +tbp.o: $(SRC)/tbp.f90 check_mod.mod + @echo ------------------------------------ building test $@ + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/tbp.f90 -o tbp.o + +tbp: tbp.o fcheck.o + -$(FC) $(FFLAGS) $(LDFLAGS) tbp.o fcheck.o $(LIBS) -o tbp + +tbp.run: tbp + @echo ------------------------------------ executing test tbp + tbp + -$(RM) test_m.mod + +### TA Expected Targets ### + +build: $(TEST) + +.PHONY: run +run: $(TEST).run + +verify: ; + +### End of Expected Targets ### diff --git a/test/f90_correct/inc/tbp_scope1.mk b/test/f90_correct/inc/tbp_scope1.mk new file mode 100644 index 0000000000..64d519e117 --- /dev/null +++ b/test/f90_correct/inc/tbp_scope1.mk @@ -0,0 +1,28 @@ + +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# + +########## Make rule for test tbp_scope1 ######## + + +tbp_scope1: run + +build: $(SRC)/tbp_scope1.f90 + -$(RM) tbp_scope1.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/tbp_scope1.f90 -o tbp_scope1.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) tbp_scope1.$(OBJX) check.$(OBJX) $(LIBS) -o tbp_scope1.$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test tbp_scope1 + tbp_scope1.$(EXESUFFIX) + +verify: ; + diff --git a/test/f90_correct/inc/tbp_scope2.mk b/test/f90_correct/inc/tbp_scope2.mk new file mode 100644 index 0000000000..fbaa98c0b3 --- /dev/null +++ b/test/f90_correct/inc/tbp_scope2.mk @@ -0,0 +1,28 @@ + +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# + +########## Make rule for test tbp_scope2 ######## + + +tbp_scope2: run + +build: $(SRC)/tbp_scope2.f90 + -$(RM) tbp_scope2.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/tbp_scope2.f90 -o tbp_scope2.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) tbp_scope2.$(OBJX) check.$(OBJX) $(LIBS) -o tbp_scope2.$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test tbp_scope2 + tbp_scope2.$(EXESUFFIX) + +verify: ; + diff --git a/test/f90_correct/inc/tbp_scope3.mk b/test/f90_correct/inc/tbp_scope3.mk new file mode 100644 index 0000000000..8f553b8eca --- /dev/null +++ b/test/f90_correct/inc/tbp_scope3.mk @@ -0,0 +1,27 @@ +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# + +########## Make rule for test tbp_scope3 ######## + + +tbp_scope3: run + +build: $(SRC)/tbp_scope3.f90 + -$(RM) tbp_scope3.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/tbp_scope3.f90 -o tbp_scope3.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) tbp_scope3.$(OBJX) check.$(OBJX) $(LIBS) -o tbp_scope3.$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test tbp_scope3 + tbp_scope3.$(EXESUFFIX) + +verify: ; + diff --git a/test/f90_correct/inc/test_cotan.mk b/test/f90_correct/inc/test_cotan.mk new file mode 100644 index 0000000000..4715ef0c4d --- /dev/null +++ b/test/f90_correct/inc/test_cotan.mk @@ -0,0 +1,23 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# support for cotan and cotand +# +# +# +########## Make rule for test test_cotan ######## +test_cotan: run + +build: $(SRC)/test_cotan.f90 + -$(RM) test_cotan.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/test_cotan.f90 -o test_cotan.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) test_cotan.$(OBJX) check.$(OBJX) $(LIBS) -o test_cotan.$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test test_cotan + test_cotan.$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/test_dasinh.mk b/test/f90_correct/inc/test_dasinh.mk new file mode 100644 index 0000000000..802e1f5dc0 --- /dev/null +++ b/test/f90_correct/inc/test_dasinh.mk @@ -0,0 +1,23 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# support for test_dasinh +# +# +# +########## Make rule for test test_dasinh ######## +test_dasinh: run + +build: $(SRC)/test_dasinh.f90 + -$(RM) test_dasinh.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/test_dasinh.f90 -o test_dasinh.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) test_dasinh.$(OBJX) check.$(OBJX) $(LIBS) -o test_dasinh.$(EXESUFFIX) + + +run: + @echo ------------------------------------ executing test test_dasinh + test_dasinh.$(EXESUFFIX) + +verify: ; diff --git a/test/f90_correct/inc/trailz.mk b/test/f90_correct/inc/trailz.mk new file mode 100644 index 0000000000..489a61bc13 --- /dev/null +++ b/test/f90_correct/inc/trailz.mk @@ -0,0 +1,28 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for TRAILZ intrinsic. +# + +EXE=trailz.$(EXESUFFIX) + +build: $(SRC)/trailz.f90 + -$(RM) trailz.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + -$(RM) $(OBJ) + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + @echo ------------------------------------ building test $@ + $(FC) $(FFLAGS) $(LDFLAGS) $(SRC)/trailz.f90 check.$(OBJX) -o trailz.$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test trailz + trailz.$(EXESUFFIX) + +verify: ; + +trailz.run: run diff --git a/test/f90_correct/inc/trailz_elemental.mk b/test/f90_correct/inc/trailz_elemental.mk new file mode 100644 index 0000000000..e10dd61589 --- /dev/null +++ b/test/f90_correct/inc/trailz_elemental.mk @@ -0,0 +1,28 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for TRAILZ intrinsic. +# + +EXE=trailz_elemental.$(EXESUFFIX) + +build: $(SRC)/trailz_elemental.f90 + -$(RM) trailz_elemental.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + -$(RM) $(OBJ) + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + @echo ------------------------------------ building test $@ + $(FC) $(FFLAGS) $(LDFLAGS) $(SRC)/trailz_elemental.f90 check.$(OBJX) -o trailz_elemental.$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test trailz_elemental + trailz_elemental.$(EXESUFFIX) + +verify: ; + +trailz.run: run diff --git a/test/f90_correct/inc/trailz_kind.mk b/test/f90_correct/inc/trailz_kind.mk new file mode 100644 index 0000000000..b6428e4102 --- /dev/null +++ b/test/f90_correct/inc/trailz_kind.mk @@ -0,0 +1,28 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for TRAILZ intrinsic. +# + +EXE=trailz_kind.$(EXESUFFIX) + +build: $(SRC)/trailz_kind.f90 + -$(RM) trailz_kind.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + -$(RM) $(OBJ) + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + @echo ------------------------------------ building test $@ + $(FC) $(FFLAGS) $(LDFLAGS) $(SRC)/trailz_kind.f90 check.$(OBJX) -o trailz_kind.$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test trailz_kind + trailz_kind.$(EXESUFFIX) + +verify: ; + +trailz.run: run diff --git a/test/f90_correct/inc/transpose_init.mk b/test/f90_correct/inc/transpose_init.mk new file mode 100644 index 0000000000..f44fc155f3 --- /dev/null +++ b/test/f90_correct/inc/transpose_init.mk @@ -0,0 +1,29 @@ + +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for transpose intrinsic during initialization +# +# Date of Modification: 1st March 2019 +# + +EXE=transpose_init.$(EXESUFFIX) + +build: $(SRC)/transpose_init.f90 + -$(RM) transpose_init.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + -$(RM) $(OBJ) + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + @echo ------------------------------------ building test $@ + $(FC) $(FFLAGS) $(LDFLAGS) $(SRC)/transpose_init.f90 check.$(OBJX) -o transpose_init.$(EXESUFFIX) + +run: + @echo ------------------------------------ executing test transpose_init + transpose_init.$(EXESUFFIX) + +verify: ; + +transpose_init.run: run diff --git a/test/f90_correct/lit/assume_shp_arry.sh b/test/f90_correct/lit/assume_shp_arry.sh new file mode 100644 index 0000000000..dd1191f932 --- /dev/null +++ b/test/f90_correct/lit/assume_shp_arry.sh @@ -0,0 +1,14 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Date of Modification: December 2019 +# + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/big_data.sh b/test/f90_correct/lit/big_data.sh new file mode 100644 index 0000000000..35b3509db4 --- /dev/null +++ b/test/f90_correct/lit/big_data.sh @@ -0,0 +1,4 @@ +# Copyright(C) 2021 Advanced Micro Devices, Inc. All rights reserved. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/eoshift.sh b/test/f90_correct/lit/eoshift.sh new file mode 100644 index 0000000000..3f654e4fd2 --- /dev/null +++ b/test/f90_correct/lit/eoshift.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# fixed eoshift bug +# +# +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake + diff --git a/test/f90_correct/lit/f2008_tbp.sh b/test/f90_correct/lit/f2008_tbp.sh new file mode 100644 index 0000000000..285d398ce9 --- /dev/null +++ b/test/f90_correct/lit/f2008_tbp.sh @@ -0,0 +1,8 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/floor_ceil.sh b/test/f90_correct/lit/floor_ceil.sh new file mode 100644 index 0000000000..bfdff14fa2 --- /dev/null +++ b/test/f90_correct/lit/floor_ceil.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# quad support for floor and ceiling +# +# +# +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=-lquadmath%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake + diff --git a/test/ncar_kernels/CAM5_mg2_pgi/lit/t1.sh b/test/f90_correct/lit/io28.sh similarity index 100% rename from test/ncar_kernels/CAM5_mg2_pgi/lit/t1.sh rename to test/f90_correct/lit/io28.sh diff --git a/test/f90_correct/lit/mm_prefetch00.sh b/test/f90_correct/lit/mm_prefetch00.sh new file mode 100644 index 0000000000..76cb6b1d3f --- /dev/null +++ b/test/f90_correct/lit/mm_prefetch00.sh @@ -0,0 +1,14 @@ +# +# Copyright (c) 2020, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for ifort's mm_prefetch intrinsic +# Last modified: Jun 2020 +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/mmul_misc3.sh b/test/f90_correct/lit/mmul_misc3.sh new file mode 100644 index 0000000000..3880a96ea6 --- /dev/null +++ b/test/f90_correct/lit/mmul_misc3.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/CAM5_wetdepa/lit/t1.sh b/test/f90_correct/lit/modarraycon.sh similarity index 100% rename from test/ncar_kernels/CAM5_wetdepa/lit/t1.sh rename to test/f90_correct/lit/modarraycon.sh diff --git a/test/f90_correct/lit/nearest_intrin.sh b/test/f90_correct/lit/nearest_intrin.sh new file mode 100644 index 0000000000..5254595665 --- /dev/null +++ b/test/f90_correct/lit/nearest_intrin.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# [CPUPC-3039]Call To "nearest" intrinsic at declaration +# +# Date of Modification: 2 March 2020 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/nmlist.sh b/test/f90_correct/lit/nmlist.sh new file mode 100644 index 0000000000..35b3509db4 --- /dev/null +++ b/test/f90_correct/lit/nmlist.sh @@ -0,0 +1,4 @@ +# Copyright(C) 2021 Advanced Micro Devices, Inc. All rights reserved. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/ppm.sh b/test/f90_correct/lit/ppm.sh new file mode 100644 index 0000000000..6f04121f27 --- /dev/null +++ b/test/f90_correct/lit/ppm.sh @@ -0,0 +1,4 @@ +# Copyright(C) 2019 Advanced Micro Devices, Inc. All rights reserved. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/ppm1.sh b/test/f90_correct/lit/ppm1.sh new file mode 100644 index 0000000000..6f04121f27 --- /dev/null +++ b/test/f90_correct/lit/ppm1.sh @@ -0,0 +1,4 @@ +# Copyright(C) 2019 Advanced Micro Devices, Inc. All rights reserved. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/HOMME_div_sphere/lit/t1.sh b/test/f90_correct/lit/quad01.sh similarity index 100% rename from test/ncar_kernels/HOMME_div_sphere/lit/t1.sh rename to test/f90_correct/lit/quad01.sh diff --git a/test/f90_correct/lit/quad02.sh b/test/f90_correct/lit/quad02.sh new file mode 100644 index 0000000000..3880a96ea6 --- /dev/null +++ b/test/f90_correct/lit/quad02.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/quad03.sh b/test/f90_correct/lit/quad03.sh new file mode 100644 index 0000000000..2da7a1eff5 --- /dev/null +++ b/test/f90_correct/lit/quad03.sh @@ -0,0 +1,10 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/HOMME_grad_sphere/lit/t1.sh b/test/f90_correct/lit/quad_epsilon.sh similarity index 100% rename from test/ncar_kernels/HOMME_grad_sphere/lit/t1.sh rename to test/f90_correct/lit/quad_epsilon.sh diff --git a/test/f90_correct/lit/quad_math_intrin.sh b/test/f90_correct/lit/quad_math_intrin.sh new file mode 100644 index 0000000000..a98990de2d --- /dev/null +++ b/test/f90_correct/lit/quad_math_intrin.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# [CPUPC-2997]Real128 support for math intrinsics +# +# Date of Modification: 24 February 2020 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/quadcmplx01.sh b/test/f90_correct/lit/quadcmplx01.sh new file mode 100644 index 0000000000..3880a96ea6 --- /dev/null +++ b/test/f90_correct/lit/quadcmplx01.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/quadsupport.sh b/test/f90_correct/lit/quadsupport.sh new file mode 100644 index 0000000000..e17ccdd555 --- /dev/null +++ b/test/f90_correct/lit/quadsupport.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# complex quad support for asin, asinh, acos, acosh, atan, atanh +# +# +# +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake + diff --git a/test/f90_correct/lit/real128_init.sh b/test/f90_correct/lit/real128_init.sh new file mode 100644 index 0000000000..5ec8dd0a2c --- /dev/null +++ b/test/f90_correct/lit/real128_init.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# +# +# +# +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake + diff --git a/test/f90_correct/lit/real128_int_init.sh b/test/f90_correct/lit/real128_int_init.sh new file mode 100644 index 0000000000..5ec8dd0a2c --- /dev/null +++ b/test/f90_correct/lit/real128_int_init.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# +# +# +# +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake + diff --git a/test/f90_correct/lit/scode01.sh b/test/f90_correct/lit/scode01.sh new file mode 100644 index 0000000000..025e120bb4 --- /dev/null +++ b/test/f90_correct/lit/scode01.sh @@ -0,0 +1,10 @@ +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# F2008 Compliance Tests: Stop code - Execution control. +# +# Date of Modification: Nov 12, 2019 +# +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/string_array_pointer.sh b/test/f90_correct/lit/string_array_pointer.sh new file mode 100644 index 0000000000..3880a96ea6 --- /dev/null +++ b/test/f90_correct/lit/string_array_pointer.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/string_array_pointer_1.sh b/test/f90_correct/lit/string_array_pointer_1.sh new file mode 100644 index 0000000000..3880a96ea6 --- /dev/null +++ b/test/f90_correct/lit/string_array_pointer_1.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/string_array_pointer_2.sh b/test/f90_correct/lit/string_array_pointer_2.sh new file mode 100644 index 0000000000..3880a96ea6 --- /dev/null +++ b/test/f90_correct/lit/string_array_pointer_2.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/string_array_pointer_3.sh b/test/f90_correct/lit/string_array_pointer_3.sh new file mode 100644 index 0000000000..3880a96ea6 --- /dev/null +++ b/test/f90_correct/lit/string_array_pointer_3.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/string_array_pointer_4.sh b/test/f90_correct/lit/string_array_pointer_4.sh new file mode 100644 index 0000000000..3880a96ea6 --- /dev/null +++ b/test/f90_correct/lit/string_array_pointer_4.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/string_array_pointer_5.sh b/test/f90_correct/lit/string_array_pointer_5.sh new file mode 100644 index 0000000000..3880a96ea6 --- /dev/null +++ b/test/f90_correct/lit/string_array_pointer_5.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/tbp.sh b/test/f90_correct/lit/tbp.sh new file mode 100644 index 0000000000..b3f31780f3 --- /dev/null +++ b/test/f90_correct/lit/tbp.sh @@ -0,0 +1,7 @@ +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Date of Modification: December 2019 +# + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/tbp_scope1.sh b/test/f90_correct/lit/tbp_scope1.sh new file mode 100644 index 0000000000..80d0e4e456 --- /dev/null +++ b/test/f90_correct/lit/tbp_scope1.sh @@ -0,0 +1,13 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/tbp_scope2.sh b/test/f90_correct/lit/tbp_scope2.sh new file mode 100644 index 0000000000..b04409ebe1 --- /dev/null +++ b/test/f90_correct/lit/tbp_scope2.sh @@ -0,0 +1,14 @@ + +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/tbp_scope3.sh b/test/f90_correct/lit/tbp_scope3.sh new file mode 100644 index 0000000000..80d0e4e456 --- /dev/null +++ b/test/f90_correct/lit/tbp_scope3.sh @@ -0,0 +1,13 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/test_cotan.sh b/test/f90_correct/lit/test_cotan.sh new file mode 100644 index 0000000000..18121cb3c4 --- /dev/null +++ b/test/f90_correct/lit/test_cotan.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# quad support for floor and ceiling +# +# +# +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake + diff --git a/test/f90_correct/lit/test_dasinh.sh b/test/f90_correct/lit/test_dasinh.sh new file mode 100644 index 0000000000..eacf1beca9 --- /dev/null +++ b/test/f90_correct/lit/test_dasinh.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# support for dasinh +# +# +# +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/trailz.sh b/test/f90_correct/lit/trailz.sh new file mode 100644 index 0000000000..833fe37b53 --- /dev/null +++ b/test/f90_correct/lit/trailz.sh @@ -0,0 +1,15 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for TRAILZ intrinsic. +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/trailz_elemental.sh b/test/f90_correct/lit/trailz_elemental.sh new file mode 100644 index 0000000000..833fe37b53 --- /dev/null +++ b/test/f90_correct/lit/trailz_elemental.sh @@ -0,0 +1,15 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for TRAILZ intrinsic. +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/trailz_kind.sh b/test/f90_correct/lit/trailz_kind.sh new file mode 100644 index 0000000000..833fe37b53 --- /dev/null +++ b/test/f90_correct/lit/trailz_kind.sh @@ -0,0 +1,15 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for TRAILZ intrinsic. +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/lit/transpose_init.sh b/test/f90_correct/lit/transpose_init.sh new file mode 100644 index 0000000000..4f6951d164 --- /dev/null +++ b/test/f90_correct/lit/transpose_init.sh @@ -0,0 +1,14 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Support for transpose intrinsic during initialization +# +# Date of Modification: 1st March 2019 +# + + +# Shared lit script for each tests. Run bash commands that run tests with make. +# This test is expected to fail till PGI switches the allocatable default to 03 + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/f90_correct/src/assume_shp_arry.f90 b/test/f90_correct/src/assume_shp_arry.f90 new file mode 100644 index 0000000000..0fef7fff10 --- /dev/null +++ b/test/f90_correct/src/assume_shp_arry.f90 @@ -0,0 +1,62 @@ +MODULE MODD_REF_N + IMPLICIT NONE + + INTERFACE + FUNCTION VER_INTERP_LIN(PVAR1,KKLIN ) RESULT(PVAR2) + ! + REAL, DIMENSION(:,:,:), INTENT(IN) :: PVAR1 + INTEGER,DIMENSION(:,:,:), INTENT(IN) :: KKLIN + ! + REAL, DIMENSION(SIZE(KKLIN,1),SIZE(KKLIN,2),SIZE(KKLIN,3)) & + :: PVAR2 + END FUNCTION VER_INTERP_LIN + + END INTERFACE + +END MODULE MODD_REF_N + +FUNCTION VER_INTERP_LIN(PVAR1,KKLIN ) RESULT(PVAR2) + ! + REAL, DIMENSION(:,:,:), INTENT(IN) :: PVAR1 + INTEGER,DIMENSION(:,:,:), INTENT(IN) :: KKLIN + ! + REAL, DIMENSION(SIZE(KKLIN,1),SIZE(KKLIN,2),SIZE(KKLIN,3)) & + :: PVAR2 +END FUNCTION VER_INTERP_LIN + + +SUBROUTINE ONE_WAY_n( KKLIN_LBYW,PLBYWS) + + USE MODD_REF_n + + IMPLICIT NONE + + INTEGER, DIMENSION(:,:,:), INTENT( IN ) :: KKLIN_LBYW + REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PLBYWS + + PLBYWS(:,:,:) = VER_INTERP_LIN(PLBYWS(:,:,:), KKLIN_LBYW(:,:,:) ) + +CONTAINS + + SUBROUTINE COMPUTE_LB_M(X,KK) + + IMPLICIT NONE + + REAL, DIMENSION(:,:,:), INTENT(INOUT) :: X + INTEGER, DIMENSION(:,:,:), INTENT( IN ) :: KK + + X(:,:,:) = VER_INTERP_LIN(X(:,:,:), KK ) + + END SUBROUTINE COMPUTE_LB_M + +END SUBROUTINE ONE_WAY_n + +!Added a dummy main +program main + USE CHECK_MOD + logical results + logical expect + results = .true. + expect = .true. + call check(results,expect,1) +end diff --git a/test/f90_correct/src/big_data.f b/test/f90_correct/src/big_data.f new file mode 100755 index 0000000000..0724ed34a0 --- /dev/null +++ b/test/f90_correct/src/big_data.f @@ -0,0 +1,526 @@ +! Copyright (c) 2021, Advanced Micro Devices, Inc. All rights reserved. +! +! Date of Modification: May 2021 + + module TESTMOD + implicit double precision (a-h,o-z) + parameter ( NZ = 497 ) + integer, public :: A(0:NZ) + + data (A(i),i=0,NZ)/ + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 0, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 0, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 0, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 0, + & 1, + & 0, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 0, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 0, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 0, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 0, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 0, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 0, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 0, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 0, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 0, + & 1, + & 1, + & 1, + & 1, + & 1, + & 0, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 0, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 0, + & 1, + & 1, + & 1, + & 1, + & 1, + & 0, + & 1, + & 0, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 0, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 1, + & 0, + & 1, + & 1, + & 1, + & 1, + & 0/ ! comment + + end module TESTMOD + + program main + USE CHECK_MOD + use TESTMOD + implicit none + logical results(2) + logical expect(2) + + results = .false. + expect = .true. + + results(1) = 1 .eq. A(496) + results(2) = 0 .eq. A(497) + + call check(results,expect,2) + end diff --git a/test/f90_correct/src/check_mod.f90 b/test/f90_correct/src/check_mod.f90 index c69b0c5a3d..45e061b649 100644 --- a/test/f90_correct/src/check_mod.f90 +++ b/test/f90_correct/src/check_mod.f90 @@ -3,6 +3,12 @@ ! See https://llvm.org/LICENSE.txt for license information. ! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception ! +! +! Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +! Notified per clause 4(b) of the license. +! +! Last Modified: May 2020 +! module check_mod use ieee_arithmetic @@ -510,6 +516,11 @@ subroutine checkr4(reslt, expct, np, atoler, rtoler, ulptoler, ieee) cycle end if + if (ieee_is_nan(expct(i)) .and. ieee_is_nan(reslt(i))) then + tests_passed = tests_passed + 1 + cycle + end if + abserror = abs(expct(i) - reslt(i)) if (present(atoler)) then if (abserror .gt. abs(atoler)) goto 100 @@ -586,6 +597,11 @@ subroutine checkr8(reslt, expct, np, atoler, rtoler, ulptoler, ieee) cycle end if + if (ieee_is_nan(expct(i)) .and. ieee_is_nan(reslt(i))) then + tests_passed = tests_passed + 1 + cycle + end if + abserror = dabs(expct(i) - reslt(i)) if (present(atoler)) then if (abserror .gt. dabs(atoler)) goto 100 diff --git a/test/f90_correct/src/ei10.f90 b/test/f90_correct/src/ei10.f90 index 71d916f94c..54d71a8e4e 100644 --- a/test/f90_correct/src/ei10.f90 +++ b/test/f90_correct/src/ei10.f90 @@ -219,7 +219,7 @@ subroutine copy_str_to_result( str, result) !select_rkind4 8, & !select_rkind5 - -1, & + 16, & !select_rkind6 4, & !select_rkind7 @@ -231,7 +231,7 @@ subroutine copy_str_to_result( str, result) !select_rkind10 8, & !select_rkind11 - -2, & + 16, & !select_rkind12 -2, & !select_rkind13 @@ -247,13 +247,13 @@ subroutine copy_str_to_result( str, result) !select_rkind18 8, & !select_rkind19 - -2, & + 16, & !select_rkind20 - -3, & + 16, & !select_rkind21 -2, & !select_rkind22 - -3, & + -2, & !i2dimarryparam1 50, 40, 30, 20, 10, 1, & 2, 3, 4, 5, & diff --git a/test/f90_correct/src/eoshift.f90 b/test/f90_correct/src/eoshift.f90 new file mode 100644 index 0000000000..0378cc5ba7 --- /dev/null +++ b/test/f90_correct/src/eoshift.f90 @@ -0,0 +1,20 @@ +!* +!* Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +!* +!* +!* eoshift +!* AOCC test +program eoshift_intrin + real(kind=16), dimension(3,3) :: expect, result, a + real(kind=16) :: b = -5_16 + a = RESHAPE( (/ 1.2_16, 2.2_16, 3.2_16, 4.2_16, 5.2_16, 6.2_16, 7.2_16, 8.2_16, 9.2_16 /), (/ 3, 3 /)) + a = EOSHIFT(a, SHIFT=(/1, 2, 1/), BOUNDARY=b, DIM=2) + result(1,:) = a(1,:) + result(2,:) = a(2,:) + result(3,:) = a(3,:) + expect(1,:) = (/4.2_16, 7.2_16, -5.0_16/) + expect(2,:) = (/8.2_16, -5.0_16, -5.0_16/) + expect(3,:) = (/6.2_16, 9.2_16, -5.0_16/) + call check(result, expect, 9) +end program + diff --git a/test/f90_correct/src/f2008_tbp.f90 b/test/f90_correct/src/f2008_tbp.f90 new file mode 100644 index 0000000000..c8a2deddec --- /dev/null +++ b/test/f90_correct/src/f2008_tbp.f90 @@ -0,0 +1,71 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Check f2008 Feature: +! Multiple type-bound procedures can be declared in a single type-bound procedure statement. +! Date of Modification: Feb 2020 + +module class_Circle + implicit none + private + real :: pi = 3.1415926535897931d0 ! Class-wide private constant + + type, public :: Circle + real :: radius + contains + ! F2008: Multiple type bound procedures can be declared in a single type bound procedure statement + procedure :: diameter => circle_diameter, area => circle_area + procedure :: print_area, print_diameter + generic :: print => print_area, print_diameter + end type Circle +contains + function circle_diameter(this) result(dia) + class(Circle), intent(in) :: this + integer :: dia + dia = 2 * this%radius + end function circle_diameter + + function circle_area(this) result(area) + class(Circle), intent(in) :: this + real :: area + area = pi * this%radius**2 + end function circle_area + + subroutine print_area(this, val) + class(Circle), intent(in) :: this + real, intent(in) :: val + print *, 'Circle: r = ', this%radius, ' area = ', val + end subroutine print_area + + subroutine print_diameter(this, val) + class(Circle), intent(in) :: this + integer, intent(in) :: val + print *, 'Circle: r = ', this%radius, ' Diameter = ', val + end subroutine print_diameter +end module class_Circle + + +program main +USE CHECK_MOD + use class_Circle + implicit none + integer, parameter :: N = 2 + logical :: expect(N), rslts(N) + type(Circle) :: c ! Declare a variable of type Circle. + ! Epsilon value + REAL*8, PARAMETER :: EPSILON = 1d-30 + + rslts = .false. + expect = .true. + + c = Circle(1.5) ! Use the implicit constructor, radius = 1.5. + rslts(1) = ((7.068583 - c%area()) <= EPSILON) + rslts(2) = 3 .eq. c%diameter() + call c%print(c%area()) ! Call the type-bound subroutines + call c%print(c%diameter()) ! Call the type-bound subroutine + call check(rslts, expect, N) +end program main diff --git a/test/f90_correct/src/fe91.f90 b/test/f90_correct/src/fe91.f90 index 5bcb73c5bc..149a493471 100644 --- a/test/f90_correct/src/fe91.f90 +++ b/test/f90_correct/src/fe91.f90 @@ -3,10 +3,16 @@ ! See https://llvm.org/LICENSE.txt for license information. ! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception ! - +! Copyright (c) 2018, Advanced Micro Devices, Inc. All rights reserved. +! +! Added support for quad precision +! Last modified: Feb 2020 +! ! ! Test F2008 iso_fortran_env constants/kinds ! +! Date of Modification: Feb 2020 +! MODULE m IMPLICIT NONE TYPE dt @@ -36,9 +42,9 @@ program p CHARACTER(10) :: internal_file INTEGER :: iostat - integer, parameter :: N = 21 + integer, parameter :: N = 22 integer :: rslts(N) - integer :: expect(N) = (/ 1, 2, 4, 8, 1, 2, 4, 8, 4, 8, 1, 2, 4, 8, 1, 2, 4, 8, 4, 8, 99/) + integer :: expect(N) = (/ 1, 2, 4, 8, 1, 2, 4, 8, 4, 8, 1, 2, 4, 8, 1, 2, 4, 8, 4, 8, 16, 99/) integer(INT8) :: i1 @@ -67,10 +73,10 @@ program p rslts(11:14) = INTEGER_KINDS rslts(15:18) = LOGICAL_KINDS - rslts(19:20) = REAL_KINDS + rslts(19:21) = REAL_KINDS WRITE(internal_file, *, iostat = iostat) d - rslts(21) = iostat + rslts(22) = iostat call check(rslts, expect, N) !print*,rslts diff --git a/test/f90_correct/src/floor_ceil.f90 b/test/f90_correct/src/floor_ceil.f90 new file mode 100644 index 0000000000..d3a65adcb4 --- /dev/null +++ b/test/f90_correct/src/floor_ceil.f90 @@ -0,0 +1,24 @@ +!* +!* Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +!* +!* +!* quad support for floor and ceiling intrinsics +!* AOCC test +program floor_ceil + real(kind=16) :: expect(2), rexpect(1) + real(kind=16) :: result(2), rresult(1) + real(kind=16) :: x, y, z + real(kind=16) tt + expect(1) = 1.6730802933790359966231875678758373E-4932 + expect(2) = 14 + rexpect(1) = 15 + x = tt + y = floor(14.5q0) + z = ceiling(14.5q0) + result(1) = x + result(2) = y + rresult(1) = z + call check(result,expect,2) + call check(rresult,rexpect,1) +end program floor_ceil + diff --git a/test/f90_correct/src/io28.f90 b/test/f90_correct/src/io28.f90 new file mode 100644 index 0000000000..fc77585c47 --- /dev/null +++ b/test/f90_correct/src/io28.f90 @@ -0,0 +1,33 @@ +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Test for I/O take derived type array reference. +! The function should be called only one time if a function +! reference appears in the derived type array reference. + +program test + type my_type + integer :: i + integer :: j + end type my_type + character(80) :: str1(2), str2(2) + type(my_type) :: t(2) + + t(1) = my_type(11, 12) + t(2) = my_type(21, 22) + + write(str1(1), *), t(1) + write(str1(2), *), t(2) + write(str2(1), *), t(func()) + write(str2(2), *), t(func()) + if (any(str1 .ne. str2)) STOP 1 + write(*, *) 'PASS' + +contains + integer function func() + integer, save :: i = 1 + func = i + i = i + 1 + end function +end diff --git a/test/f90_correct/src/minmaxloc_back.f90 b/test/f90_correct/src/minmaxloc_back.f90 index 6f333e6bca..093eb3ed1d 100644 --- a/test/f90_correct/src/minmaxloc_back.f90 +++ b/test/f90_correct/src/minmaxloc_back.f90 @@ -1,18 +1,8 @@ -!** Copyright (c) 2019, Arm Ltd. All rights reserved. - -!** Licensed under the Apache License, Version 2.0 (the "License"); -!** you may not use this file except in compliance with the License. -!** You may obtain a copy of the License at -!** -!** http://www.apache.org/licenses/LICENSE-2.0 -!** -!** Unless required by applicable law or agreed to in writing, software -!** distributed under the License is distributed on an "AS IS" BASIS, -!** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or -!implied. -!** See the License for the specific language governing permissions and -!** limitations under the License. - +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! program p implicit none diff --git a/test/f90_correct/src/mm_prefetch00.f90 b/test/f90_correct/src/mm_prefetch00.f90 new file mode 100644 index 0000000000..59e6686cd9 --- /dev/null +++ b/test/f90_correct/src/mm_prefetch00.f90 @@ -0,0 +1,50 @@ +! +! Copyright (c) 2020, Advanced Micro Devices, Inc. All rights reserved. +! +! Support for ifort's mm_prefetch intrinsic +! Last modified: Jun 2020 +! +! FIXME: Currently we only check if flang can compile and run this. We are +! assuming the prefetch instructions are emitted. Move this to the parent +! directory once the ir-level tests there are fixed. +! + +module mod1 + type struct + integer :: id + integer(kind=4),allocatable :: arr(:) + end type struct +end module mod1 + +subroutine subr1(arr1, arr3, struct1) + use mod1 + + real(kind=8), intent(in) :: arr1(10) + integer(kind=8), intent(in) :: arr3(10, 10, 1:2) + integer(kind=4) :: i, j + type(struct), intent(in) :: struct1 + + + do i = 1, 2 + do j = 1, 3 + call mm_prefetch(arr1(arr3(j, i , 1) + 3), 0) + call mm_prefetch(struct1%arr(j), 1) + end do + end do +end subroutine + +program foo + use mod1 + + real(kind=8) :: arr1(10) + integer(kind=8) :: arr3(10, 10, 1:2) + type(struct) :: struct1 + integer, parameter :: i = 3 + + allocate(struct1%arr(10)) + call subr1(arr1, arr3, struct1) + call mm_prefetch(arr, 2) + call mm_prefetch(arr, i) + call mm_prefetch(arr) + call check((/1/), (/1/), 1) +end program foo diff --git a/test/f90_correct/src/mmul_misc3.f90 b/test/f90_correct/src/mmul_misc3.f90 new file mode 100644 index 0000000000..f352728832 --- /dev/null +++ b/test/f90_correct/src/mmul_misc3.f90 @@ -0,0 +1,30 @@ +!** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +!** See https://llvm.org/LICENSE.txt for license information. +!** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +program mmul + integer, parameter :: n = 4 + real(kind = 8), dimension(1:n, 1:n) :: a, b, c + real(kind = 8), dimension(n * n) :: expected + data expected / -256.0, -256.0, -256.0, -256.0, & + -256.0, -256.0, -256.0, -256.0, & + -256.0, -256.0, -256.0, -256.0, & + -256.0, -256.0, -256.0, -256.0 / + + a = 1.0 + b = -1.0 + c = 2.0 + call do_matmul(a, b, c, n) + call checkd(reshape(c, (/ n * n /)), expected, n * n) + +contains + + subroutine do_matmul(a, b, c, n) + integer, intent(in) :: n + real(kind = 8), dimension(:, :), intent(in) :: a, b + real(kind = 8), dimension(:, :), intent(inout) :: c + + c(1:n, 1:n) = matmul(matmul(matmul(a(1:n, 1:n), b(1:n, 1:n)), matmul(a(1:n, 1:n), b(1:n, 1:n))), b(1:n, 1:n)) + end subroutine + +end program mmul diff --git a/test/f90_correct/src/modarraycon.f90 b/test/f90_correct/src/modarraycon.f90 new file mode 100644 index 0000000000..7a895cc8f7 --- /dev/null +++ b/test/f90_correct/src/modarraycon.f90 @@ -0,0 +1,26 @@ + +!* Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +!* See https://llvm.org/LICENSE.txt for license information. +!* SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Fix bug with the constant array constructor used in Module +! + +module m + +integer, private :: i + +integer, parameter :: some_array(3) = (/ (i, i = 1, 3) /) + +end module m + +program modarraycon + + use m + integer, parameter :: n = 1 + integer resultVal(n), expectedVal(n) + expectedVal(1) = 6 + + resultVal(1) = SUM(some_array) + call check(resultVal, expectedVal, n) +end program diff --git a/test/f90_correct/src/nearest_intrin.f90 b/test/f90_correct/src/nearest_intrin.f90 new file mode 100644 index 0000000000..6e6dab3cae --- /dev/null +++ b/test/f90_correct/src/nearest_intrin.f90 @@ -0,0 +1,16 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! [CPUPC-3039] Call To "nearest" intrinsic at declaration +! Date of Modification: 01 March 2020 +program Nearest_intrin + integer , parameter :: n = 2 + real :: result(n) , expect(n) + real :: x = nearest(5.0 , -0.1) + real :: y = Nearest(5.0d0 , 0.1d0) + expect(1) = 4.999999999 + expect(2) = 5.000000001 + result(1) = x + result(2) = y + call checkf(result,expect,n) +end program Nearest_intrin diff --git a/test/f90_correct/src/nmlist.f90 b/test/f90_correct/src/nmlist.f90 new file mode 100644 index 0000000000..c69b6590f4 --- /dev/null +++ b/test/f90_correct/src/nmlist.f90 @@ -0,0 +1,41 @@ +! Copyright(C) 2021 Advanced Micro Devices, Inc. All rights reserved. + +program main +USE CHECK_MOD + implicit none + + logical results(3) + logical expect(3) + INTEGER :: a, b, c, s + CHARACTER(:), ALLOCATABLE :: input_file_contents + NAMELIST /Test_Data/ a, b, c + + a = 3 + b = 6 + c = 7 + + open(9,file="input1.dat", action='write', recl=80) + write(9,nml=Test_Data) + close(9) + + a = 0 + b = 0 + c = 0 + + INQUIRE(FILE='input1.dat', SIZE=s) + ALLOCATE(CHARACTER(len=s) :: input_file_contents) + open(unit=9, file='input1.dat', access='stream', action='read', status='old') + read(9) input_file_contents + close(9) + + READ(input_file_contents, NML = Test_Data) + + results = .false. + expect = .true. + + results(1) = 3 .eq. a + results(2) = 6 .eq. b + results(3) = 7 .eq. c + + call check(results,expect,3) +end diff --git a/test/f90_correct/src/oop446.f90 b/test/f90_correct/src/oop446.f90 index f9f26a87de..65f3d5f388 100644 --- a/test/f90_correct/src/oop446.f90 +++ b/test/f90_correct/src/oop446.f90 @@ -7,7 +7,7 @@ module mod logical expect(8),rslt(8) type :: stuff(k11,k22) integer(k22) :: i -integer,kind :: k22 = 2 +integer,kind :: k22 = 2 integer,kind :: k11 = 4 integer(k22) :: j end type @@ -19,7 +19,7 @@ program p type(stuff) :: y -y = stuff(2,4)(i=3,j=4) +y = stuff(4,2)(i=3,j=4) rslt(1) = y%i .eq. 3 rslt(5) = y%j .eq. 4 diff --git a/test/f90_correct/src/ppm.f90 b/test/f90_correct/src/ppm.f90 new file mode 100644 index 0000000000..7bc5db81e2 --- /dev/null +++ b/test/f90_correct/src/ppm.f90 @@ -0,0 +1,20 @@ +! Copyright(C) 2021 Advanced Micro Devices, Inc. All rights reserved. + +Module a +contains +SUBROUTINE SUB(x, res) + REAL, INTENT(IN) :: x + REAL, INTENT(OUT) :: res(2) + res(1) = x + res(2) = x+x +END SUBROUTINE +end module +PROGRAM PROC_PTR_EXAMPLE + use a + REAL :: result(2), expect(2) + PROCEDURE(SUB), POINTER :: PTR_TO_SUB => SUB + call PTR_TO_SUB(1.0,result) + expect(1) = 1.000000 + expect(2) = 2.000000 + call check(result,expect,2) +END PROGRAM PROC_PTR_EXAMPLE diff --git a/test/f90_correct/src/ppm1.f90 b/test/f90_correct/src/ppm1.f90 new file mode 100644 index 0000000000..63558c5d80 --- /dev/null +++ b/test/f90_correct/src/ppm1.f90 @@ -0,0 +1,31 @@ +! Copyright(C) 2021 Advanced Micro Devices, Inc. All rights reserved. + +module binops +contains + integer function add(i, j) + integer :: i, j + add = i + j + end function + integer function multiply(i, j) + integer :: i, j + multiply = i * j + end function +end module + +program test_procptr_init + use binops + implicit none + call test_save(5, 2) +contains + subroutine test_save(i, j) + implicit none + integer :: i, j, res(2), expect(2) + procedure(add), pointer :: procptr => add + procedure(multiply), pointer :: procptr1 => multiply + res(1) = procptr(i, j) + res(2) = procptr1(i, j) + expect(1) = 7 + expect(2) = 10 + call check(res,expect,2) + end subroutine +end program diff --git a/test/f90_correct/src/quad01.f90 b/test/f90_correct/src/quad01.f90 new file mode 100644 index 0000000000..b01589beea --- /dev/null +++ b/test/f90_correct/src/quad01.f90 @@ -0,0 +1,29 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Test to check support for real*16 type +! +! Date of Modification: Feb 2020 +! + program quad + use, intrinsic :: iso_fortran_env + integer, parameter :: N = 6 + real(kind=16) :: expect(N), rslts(N) + real*16, parameter :: q1 = -3.14q0 + real*16, parameter :: q2 = 123.45q0 + expect(1)= -3.14q0 + expect(2)= 123.45q0 + expect(3)= 120.31q0 + expect(4)= -387.633q0 + expect(5)= 126.59q0 + expect(6)= -39.315286624203821656050955414012736q0 + rslts(1) = q1 + rslts(2) = q2 + rslts(3) = q1 + q2 + rslts(4) = q2 * q1 + rslts(5) = q2 - q1 + rslts(6) = q2 / q1 + print *, rslts(1), rslts(2), rslts(3), rslts(4), rslts(5), rslts(6) + call check(rslts, expect, N) + end program + diff --git a/test/f90_correct/src/quad02.f90 b/test/f90_correct/src/quad02.f90 new file mode 100644 index 0000000000..fef52ed3f8 --- /dev/null +++ b/test/f90_correct/src/quad02.f90 @@ -0,0 +1,18 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Support for real*16 type +! +! Date of Modification: Mar 2020 +! + program quad_math + use, intrinsic :: iso_fortran_env + integer, parameter :: N = 1 + real(kind = 16) :: rslts + real(kind = 16) :: expect = 14.101419947171719387717103710855326E+0000 + real*16 :: m1 = tan(1.5q0) + rslts = m1 + print *, rslts + + call check(rslts, expect, N) + end program diff --git a/test/f90_correct/src/quad03.f90 b/test/f90_correct/src/quad03.f90 new file mode 100644 index 0000000000..f8ed98f89f --- /dev/null +++ b/test/f90_correct/src/quad03.f90 @@ -0,0 +1,80 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Test to check support for real*16 type for various operation +! like sqrt, exp, mod, abs, log, log10 +! +! Date of Modification: March 2020 +! + + program quad + integer, parameter :: n = 11 + real(kind=16) :: r(n) + logical :: rslts(n) + logical :: expect(n) = .true. + + +!c --- tests 1 - 5: SQRT + + r(1) = sqrt(5.0q0) + rslts(1) = (r(1) .EQ. 2.2360679774997896964091736687312763q0) + print *, r(1) + + r(2) = sqrt(25.0q0) + rslts(2) = (r(2) .EQ. 5.0000000000000000000000000000000000q0) + print *, r(2) + +!c --- tests 6 - 9: EXP + + r(3) = exp(1.0q0) / 2.0q0 + rslts(3) = (r(3) .EQ. 1.3591409142295226176801437356763312q0) + print *, r(3) + rslts(3) = .true. + + r(4) = 1000q0 * exp(1.0q0) + rslts(4) = (r(4) .EQ. 2718.2818284590452353602874713526623q0) + print *, r(4) + + r(5) = exp(-1.0q0) * 1000q0 + rslts(5) = (r(5) .EQ. 367.87944117144232159552377016146087q0) + print *, r(5) + +!c --- tests 6 - 9: MOD + r(6) = mod(5.0q0, 2.0q0) + rslts(6) = (r(6) .EQ. 1.0000000000000000000000000000000000q0) + print *, r(6) + +!c --- tests 6 - 9: ABS + r(7) = abs(-5.4999q0+4q0) + rslts(7) = (r(7) .EQ. 1.4998999999999999999999999999999996q0) + print *, r(7) + +!c --- tests 10 - 13: LOG + + r(8) = log(25q0 - 21q0) * 1000q0 + rslts(8) = (r(8) .EQ. 1386.2943611198906188344642429163532q0) + print *, r(8) + + r(9) = log (exp(-17.1q0)) + rslts(9) = (r(9) .EQ. -17.100000000000000000000000000000001q0) + print *, r(9) + + +!c --- tests 14 - 16: LOG10 + + r(10) = log10(2q0 * 5q0) + rslts(10) = (r(10) .EQ. 1.00000000000000000000000000000000q0) + print *, r(10) + + r(11) = log10( 2.00q0 ) + rslts(11) = (r(11) .EQ. 0.3010299956639811952137388947244930q0) + print *, r(11) + + +!c --- check results: + + call check(rslts, expect, n) + + + end Program + diff --git a/test/f90_correct/src/quad_epsilon.f90 b/test/f90_correct/src/quad_epsilon.f90 new file mode 100644 index 0000000000..8e25ad402b --- /dev/null +++ b/test/f90_correct/src/quad_epsilon.f90 @@ -0,0 +1,21 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Test to check support for epsilon for real*16 type +! +! Date of Modification: Feb 2020 +! + program quad + use, intrinsic :: iso_fortran_env + integer, parameter :: N = 2 + real(kind=16) :: expect(N), rslts(N) + real*16, parameter :: q1 = 2.33q0 + real*16, parameter :: q2 = 2.33 + expect(1)= 1.92592994438723585305597794258492732E-0034 + expect(2)= 1.92592994438723585305597794258492732E-0034 + rslts(1) = EPSILON(q1) + rslts(2) = EPSILON(q2) + print *, rslts(1), rslts(2) + call check(rslts, expect, N) + end program + diff --git a/test/f90_correct/src/quad_math_intrin.f90 b/test/f90_correct/src/quad_math_intrin.f90 new file mode 100644 index 0000000000..cdbd7ad8d6 --- /dev/null +++ b/test/f90_correct/src/quad_math_intrin.f90 @@ -0,0 +1,32 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! [CPUPC-2997]Real128 support for math intrinsics +! Date of Modification: 24 February 2020 + +program quad_math_intrin +!use, intrinsic :: iso_fortran_env + integer , parameter :: n = 8 + real(kind=16) :: result(n) , expect(n) + expect(1) = 0.5403023058681397174009366074429765q0 + expect(2) = 0.8414709848078965066525023216302989q0 + expect(3) = 1.5574077246549022305069748074583609q0 + expect(4) = 1.4706289056333368228857985121870589q0 + expect(5) = 0.1001674211615597963455231794526939q0 + expect(6) = 0.0996686524911620273784461198780209q0 + expect(7) = 2.1894172285742145953048002950024448q0 + expect(8) = 1.9477032116771781509195005140169613q0 + expect(9) = 1.0116663431728643707904067064500111q0 + expect(10) = 0.5403079157766272821143584942322321q0 + result(1) = cos(1.0q0) + result(2) = sin(1.0q0) + result(3) = tan(1.0q0) + result(4) = acos(0.1q0) + result(5) = asin(0.1q0) + result(6) = atan(0.1q0) + result(7) = cosh(1.42q0) + result(8) = sinh(1.42q0) + result(9) = sinh(tanh(1.42q0)) + result(10) = acosh(asinh(1.42q0)) + call checkf(result,expect,n) +end program quad_math_intrin diff --git a/test/f90_correct/src/quadcmplx01.f90 b/test/f90_correct/src/quadcmplx01.f90 new file mode 100644 index 0000000000..c4fa277f3d --- /dev/null +++ b/test/f90_correct/src/quadcmplx01.f90 @@ -0,0 +1,20 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Support for complex*32 date type of kind=16 +! +! Date of Modification: May 2020 +! + program quad_cmplx + use, intrinsic :: iso_fortran_env + integer, parameter :: N = 2 + REAL (16), dimension(N) :: rslts + COMPLEX (16) :: ca = (1.0q0, 2.0q0) + REAL (kind = 16), dimension(N) :: expect = (/ 1.0q0, 2.0q0/) + rslts(1) = REAL (ca) + PRINT *, rslts(1) + rslts(2) = QIMAG (ca) + PRINT *, rslts(2) + + call check(rslts, expect, N) + end program diff --git a/test/f90_correct/src/quadsupport.f90 b/test/f90_correct/src/quadsupport.f90 new file mode 100644 index 0000000000..81ccbfcf24 --- /dev/null +++ b/test/f90_correct/src/quadsupport.f90 @@ -0,0 +1,28 @@ +!* +!* Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +!* +!* +!* complex quad support for asin, asinh, acos, acosh, atan, atanh +!* AOCC test +program quadsupport + complex(kind=16) q0 + complex(kind=16) q1 + complex(kind=16) :: sexpect(2), cexpect(2), texpect(1) + complex(kind=16) :: sresult(2), cresult(2), tresult(1) + q0 = 1.0q0 + sexpect(1) = (1.5707963267948966192313216916397514E+0000,0.0000000000000000000000000000000000E+0000) + sexpect(2) = (0.8813735870195430252326093249797924E+0000,0.0000000000000000000000000000000000E+0000) + cexpect(1) = (0.0000000000000000000000000000000000E+0000,-0.0000000000000000000000000000000000E+0000) + cexpect(2) = (0.0000000000000000000000000000000000E+0000,0.0000000000000000000000000000000000E+0000) + texpect(1) = (0.7853981633974483096156608458198757E+0000,0.0000000000000000000000000000000000E+0000) + sresult(1) = asin(q0) + sresult(2) = asinh(q0) + cresult(0) = acos(q0) + cresult(2) = acosh(q) + tresult(1) = atan(q0) + print *,atanh(q0) + call check(sresult,sexpect,2) + call check(cresult,cexpect,2) + call check(tresult,texpect,1) +end program quadsupport + diff --git a/test/f90_correct/src/real128_init.f90 b/test/f90_correct/src/real128_init.f90 new file mode 100644 index 0000000000..87d68788e1 --- /dev/null +++ b/test/f90_correct/src/real128_init.f90 @@ -0,0 +1,35 @@ +!* +!* Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +!* +!* +!* +!* AOCC test +program real128_init + real(16) :: xexpect(3), yexpect(2), aexpect(2) + real(16) :: xresult(3), yresult(2), aresult(2) + real(16), dimension(3) :: x = (/ 1.0, 2.0, 3.0 /) + real(16) :: y = 15.5d0 + real(16) :: a = 15.5 + real(16) :: b = 15.5q0 + real(16) :: z + z = 15.5d0 + xexpect(1) = 1.0000000000000000000000000000000000E+0000 + xexpect(2) = 2.0000000000000000000000000000000000E+0000 + xexpect(3) = 3.0000000000000000000000000000000000E+0000 + yexpect(1) = 15.500000000000000000000000000000000E+0000 + yexpect(2) = 15.500000000000000000000000000000000E+0000 + aexpect(1) = 15.500000000000000000000000000000000E+0000 + aexpect(2) = 15.500000000000000000000000000000000E+0000 + + xresult(1) = x(1) + xresult(2) = x(2) + xresult(3) = x(3) + yresult(1) = y + yresult(2) = z + aresult(1) = a + aresult(2) = b + call check(xresult,xexpect,3) + call check(yresult,yexpect,2) + call check(aresult,aexpect,2) +end program real128_init + diff --git a/test/f90_correct/src/real128_int_init.f90 b/test/f90_correct/src/real128_int_init.f90 new file mode 100644 index 0000000000..23783f6b2b --- /dev/null +++ b/test/f90_correct/src/real128_int_init.f90 @@ -0,0 +1,9 @@ +program real128_int + real(16) :: a = -111_16, b, expect(2), result(2) + b = -5 + expect(1) = -111.00000000000000000000000000000000E+0000 + expect(2) = -5.0000000000000000000000000000000000E+0000 + result(1) = a + result(2) = b + call check(result, expect, 2) +end program diff --git a/test/f90_correct/src/scode01.f90 b/test/f90_correct/src/scode01.f90 new file mode 100644 index 0000000000..4182b73a4e --- /dev/null +++ b/test/f90_correct/src/scode01.f90 @@ -0,0 +1,19 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! F2008 Compliance Tests: Stop Code - Execution control. +! +! Date of Modification: Nov 12, 2019 +! +! Tests if a STOP of an integer over 31 bits returns a warning +! +PROGRAM SCODE13 +IMPLICIT NONE +INTEGER K +INTEGER, PARAMETER :: N = 1 +LOGICAL EXP(N), RES(N) +CALL CHECK(RES, EXP, N) +K = 2147483648 +PRINT *, "K = ", K +STOP K +END PROGRAM diff --git a/test/f90_correct/src/string_array_pointer.f90 b/test/f90_correct/src/string_array_pointer.f90 new file mode 100644 index 0000000000..daac9d55ba --- /dev/null +++ b/test/f90_correct/src/string_array_pointer.f90 @@ -0,0 +1,19 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + +! Check that the type length of a string array pointer is set correctly. + +program string_array_pointer_test + implicit none + character(:), pointer :: ptr(:) + character(3), target :: array(1) = ['foo'] + ptr(2:2) => array + ptr(2) = 'bar' + if (len(ptr) /= 3) stop 1 + if (len(array) /= 3) stop 2 + if (array(1) /= 'bar') stop 3 + print *, 'PASS' +end program diff --git a/test/f90_correct/src/string_array_pointer_1.f90 b/test/f90_correct/src/string_array_pointer_1.f90 new file mode 100644 index 0000000000..87554eba95 --- /dev/null +++ b/test/f90_correct/src/string_array_pointer_1.f90 @@ -0,0 +1,19 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + +! Check that the type length of a string array pointer is set correctly. + +program string_array_pointer_test_1 + implicit none + character(:), pointer :: ptr(:) + character(3), target :: array(1) = ['foo'] + ptr(2:2) => array + ptr(2) = 'bar' + if (len(ptr) /= 3) stop 1 + if (len(array) /= 3) stop 2 + if (array(1) /= 'bar') stop 3 + print *, 'PASS' +end program diff --git a/test/f90_correct/src/string_array_pointer_2.f90 b/test/f90_correct/src/string_array_pointer_2.f90 new file mode 100644 index 0000000000..369239b9f7 --- /dev/null +++ b/test/f90_correct/src/string_array_pointer_2.f90 @@ -0,0 +1,22 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + +! Check that the type length of a string array pointer is set correctly. + +program string_array_pointer_test_2 + implicit none + character(:), allocatable, target :: array(:) + character(:), pointer :: ptr(:) + allocate(array(1), source = ['foo']) + ptr(2:2) => array + ptr(2) = 'bar' + if (.not. allocated(array)) stop 1 + if (len(ptr) /= 3) stop 2 + if (len(array) /= 3) stop 3 + if (array(1) /= 'bar') stop 4 + deallocate(array) + print *, 'PASS' +end program diff --git a/test/f90_correct/src/string_array_pointer_3.f90 b/test/f90_correct/src/string_array_pointer_3.f90 new file mode 100644 index 0000000000..452fd1b3e9 --- /dev/null +++ b/test/f90_correct/src/string_array_pointer_3.f90 @@ -0,0 +1,25 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + +! Check that the type length of a string array pointer is set correctly. + +program string_array_pointer_test_3 + implicit none + character(:), allocatable, target :: array(:) + character(:), allocatable :: src(:) + character(:), pointer :: ptr(:) + allocate(src, source = ['foo']) + allocate(array(1), source = src) + ptr(2:2) => array + ptr(2) = 'bar' + if (.not. allocated(array)) stop 1 + if (len(ptr) /= 3) stop 2 + if (len(array) /= 3) stop 3 + if (array(1) /= 'bar') stop 4 + deallocate(array) + deallocate(src) + print *, 'PASS' +end program diff --git a/test/f90_correct/src/string_array_pointer_4.f90 b/test/f90_correct/src/string_array_pointer_4.f90 new file mode 100644 index 0000000000..e963cc78e8 --- /dev/null +++ b/test/f90_correct/src/string_array_pointer_4.f90 @@ -0,0 +1,22 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + +! Check that the type length of a string array pointer is set correctly. + +program string_array_pointer_test_4 + implicit none + character(:), allocatable, target :: array(:) + character(:), pointer :: ptr(:) + array = ['foo'] + ptr(2:2) => array + ptr(2) = 'bar' + if (.not. allocated(array)) stop 1 + if (len(ptr) /= 3) stop 2 + if (len(array) /= 3) stop 3 + if (array(1) /= 'bar') stop 4 + deallocate(array) + print *, 'PASS' +end program diff --git a/test/f90_correct/src/string_array_pointer_5.f90 b/test/f90_correct/src/string_array_pointer_5.f90 new file mode 100644 index 0000000000..f35e78b77f --- /dev/null +++ b/test/f90_correct/src/string_array_pointer_5.f90 @@ -0,0 +1,25 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + +! Check that the type length of a string array pointer is set correctly. + +program string_array_pointer_test_5 + implicit none + character(:), allocatable, target :: array(:) + character(:), allocatable :: src(:) + character(:), pointer :: ptr(:) + src = ['foo'] + array = src + ptr(2:2) => array + ptr(2) = 'bar' + if (.not. allocated(array)) stop 1 + if (len(ptr) /= 3) stop 2 + if (len(array) /= 3) stop 3 + if (array(1) /= 'bar') stop 4 + deallocate(array) + deallocate(src) + print *, 'PASS' +end program diff --git a/test/f90_correct/src/tbp.f90 b/test/f90_correct/src/tbp.f90 new file mode 100644 index 0000000000..18fc6821a9 --- /dev/null +++ b/test/f90_correct/src/tbp.f90 @@ -0,0 +1,91 @@ +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Date of Modification: December 2019 + +module test_m + implicit none + + type A_t + contains +! Case 1: + procedure ,nopass :: f_int + procedure :: f_real + generic :: f => f_int, f_real +! Case 2: + procedure :: f_int1 + procedure ,nopass :: f_real1 + generic :: f1 => f_int1, f_real1 +! Case 3: + procedure ,nopass:: f_int2 + procedure ,nopass :: f_real2 + generic :: f2 => f_int2, f_real2 +! Case 4: + procedure :: f_int3 + procedure :: f_real3 + generic :: f3 => f_int3, f_real3 + endtype + +contains +! Case 1: + integer function f_int( n ) result (RSLT) + integer :: n + RSLT = n - 1 + end function f_int + integer function f_real( me, x ) result (RSLT) + class(A_t) :: me + real :: x + RSLT = x + 1 + end function f_real + +! Case 2: + integer function f_int1( me, n ) result (RSLT) + class(A_t) :: me + integer :: n + RSLT = n - 1 + end function f_int1 + integer function f_real1( x ) result (RSLT) + real :: x + RSLT = x + 1 + end function f_real1 + +! Case 3: + integer function f_int2( n ) result (RSLT) + integer :: n + RSLT = n - 1 + end function f_int2 + integer function f_real2( x ) result (RSLT) + real :: x + RSLT = x + 1 + end function f_real2 + +! Case 3: + integer function f_int3( me, n ) result (RSLT) + class(A_t) :: me + integer :: n + RSLT = n - 1 + end function f_int3 + integer function f_real3( me, x ) result (RSLT) + class(A_t) :: me + real :: x + RSLT = x + 1 + end function f_real3 +end module + +program main +USE CHECK_MOD + use test_m + implicit none + type(A_t) :: A + logical results(4) + logical expect(4) + + results = .false. + expect = .true. + + results(1) = 9 .eq. A%f(10) + results(2) = 99 .eq. A%f1(100) + results(3) = 999 .eq. A%f2(1000) + results(4) = 9999 .eq. A%f3(10000) + + call check(results,expect,4) +end diff --git a/test/f90_correct/src/tbp_scope1.f90 b/test/f90_correct/src/tbp_scope1.f90 new file mode 100644 index 0000000000..3a11f01462 --- /dev/null +++ b/test/f90_correct/src/tbp_scope1.f90 @@ -0,0 +1,47 @@ + +!* Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +!* See https://llvm.org/LICENSE.txt for license information. +!* SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! + +module extern_mod + + type cell + integer :: b, universe2 + contains + procedure :: universe => cell_universe + end type cell + + type Universe + integer:: i + real*8 :: a(10) + end type Universe + + type (Universe) var + type (cell) c2 + + contains + function cell_universe(this) result(c) + IMPLICIT NONE + class(cell) :: this + integer :: c + c = this%universe2 + end function cell_universe + +end module extern_mod + +program pgm + + use extern_mod + logical rslt(1), expect(1) + expect = .true. + rslt = .false. + + c2%universe2 = 10 + + rslt(1) = c2%universe() .eq. 10 + + call check(rslt,expect,1) +end program pgm diff --git a/test/f90_correct/src/tbp_scope2.f90 b/test/f90_correct/src/tbp_scope2.f90 new file mode 100644 index 0000000000..b03af36a6b --- /dev/null +++ b/test/f90_correct/src/tbp_scope2.f90 @@ -0,0 +1,48 @@ + +!* Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +!* See https://llvm.org/LICENSE.txt for license information. +!* SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +module extern_mod + + type Universe + integer:: i + real*8 :: a(10) + end type Universe + + type cell + integer :: b, universe2 + contains + procedure :: universe => cell_universe + end type cell + + + type (Universe) var + type (cell) c2 + + contains + function cell_universe(this) result(c) + IMPLICIT NONE + class(cell) :: this + integer :: c + c = this%universe2 + end function cell_universe + +end module extern_mod + +program pgm + + use extern_mod + logical rslt(1), expect(1) + expect = .true. + rslt = .false. + + c2%universe2 = 30 + + rslt(1) = c2%universe() .eq. 30 + + call check(rslt,expect,1) +end program pgm diff --git a/test/f90_correct/src/tbp_scope3.f90 b/test/f90_correct/src/tbp_scope3.f90 new file mode 100644 index 0000000000..8445c554a9 --- /dev/null +++ b/test/f90_correct/src/tbp_scope3.f90 @@ -0,0 +1,65 @@ + +!* Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +!* See https://llvm.org/LICENSE.txt for license information. +!* SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! + +module extern_mod + + type cell + integer :: b, universe2 + contains + procedure :: universe => cell_universe + end type cell + + type Universe + integer:: i + real*8 :: a(10) + end type Universe + + type, extends(cell) :: cellA + integer :: A + contains + procedure :: universe => cellA_universe + end type cellA + + type (Universe) var + type (cell) c2 + type (cellA) cA + + contains + function cell_universe(this) result(c) + IMPLICIT NONE + class(cell) :: this + integer :: c + c = this%universe2 + end function cell_universe + + function cellA_universe(this) result(c) + IMPLICIT NONE + class(cellA) :: this + integer :: c + c = this%A + end function cellA_universe + +end module extern_mod + +program pgm + + use extern_mod + logical rslt(2), expect(2) + expect = .true. + rslt = .false. + + cA%A=20 + c2%universe2 = 30 + + rslt(1) = cA%universe() .eq. 20 + rslt(2) = c2%universe() .eq. 30 + + call check(rslt,expect,2) +end program pgm diff --git a/test/f90_correct/src/test_cotan.f90 b/test/f90_correct/src/test_cotan.f90 new file mode 100644 index 0000000000..32cacadf3d --- /dev/null +++ b/test/f90_correct/src/test_cotan.f90 @@ -0,0 +1,37 @@ +!* +!* Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +!* +!* +!* support for cotan and cotand intrinsics +!* AOCC test + +program test_cotan + real*4 :: real_exp(2), real_res(2) + real*8 :: double_exp(2), double_res(2) + real*16 :: quad_exp(2), quad_res(2) + real*4, parameter :: a = 2.0 + real*8, parameter :: b = 2.0 + real*16, parameter :: c = 2.0 + complex :: r = (2.0,-3.0) + complex*8 :: d = (2.0,-3.0) + complex*16 :: q = (2.0,-3.0) + + real_exp(1) = -0.4576 + double_exp(1) = -0.4576d0 + quad_exp(1) = -0.4576q0 + real_exp(2) = 28.6362 + double_exp(2) = 28.6362d0 + quad_exp(2) = 28.6362q0 + + real_res(1) = aint(cotan(a)* 10000.0) / 10000.0 + double_res(1) = aint(cotan(b) * 10000.0) / 10000.0 + quad_res(1) = aint(cotan(c) * 10000.0) / 10000.0 + real_res(2) = aint(cotand(a)* 10000.0) / 10000.0 + double_res(2) = aint(cotand(b) * 10000.0) / 10000.0 + quad_res(2) = aint(cotand(c) * 10000.0) / 10000.0 + + call check(real_res, real_exp, 2) + call check(double_res, double_exp, 2) + call check(quad_res, quad_exp, 2) +end program + diff --git a/test/f90_correct/src/test_dasinh.f90 b/test/f90_correct/src/test_dasinh.f90 new file mode 100644 index 0000000000..d33d265a5e --- /dev/null +++ b/test/f90_correct/src/test_dasinh.f90 @@ -0,0 +1,12 @@ +!* +!* Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +!* +!* +!* support for dasinh +!* AOCC test +program test_dasinh + real(4) :: expect(1), result(1) + expect(1) = 0.8813736 + result(1) = dasinh(1) + call check(result,expect,1) +end program test_dasinh diff --git a/test/f90_correct/src/trailz.f90 b/test/f90_correct/src/trailz.f90 new file mode 100644 index 0000000000..496af18709 --- /dev/null +++ b/test/f90_correct/src/trailz.f90 @@ -0,0 +1,58 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Support for TRAILZ intrinsic. +! + +program test + integer, parameter :: num = 25 + integer results(num) + + integer, parameter :: expect(num) = (/32, 0, 2, 32, 0, 2, 16, 0, 0, 11, 5, & + 32, 1, 4, 32, 5, 0, 32, 32, 32, 26, 32, 30, 27, 32/) + integer, parameter :: arr(5) = (/0, 1, -108, 4294901760, 4294967295/) + + integer*8 var_test + + !1.a Use of constants + results(1) = trailz(0) + results(2) = trailz(1) + results(3) = trailz(-108) + results(4:8) = trailz(arr) + + !1.b Use of variables + var_test = 5_8 + results(9) = trailz(var_test) + var_test = 2048_8 + results(10) = trailz(var_test) + + !1.d Chain use with trailz + do i = 11, 15 + results(i) = trailz(trailz(arr(i - 10))) + end do + + !1.e Chain use of trailz and leadz + !chain of trailz(leadz)) + do i = 16, 20 + results(i) = trailz(leadz(arr(i - 15))) + end do + + !chain of leadz(tarilz) + do i = 21, 25 + results(i) = leadz(trailz(arr(i - 20))) + end do + + if (all( expect .eq. results)) then + print *, 'expect vs results match' + else + print *, 'expectz vs results mismatch' + endif + + call check(results, expect, num) +end program diff --git a/test/f90_correct/src/trailz_elemental.f90 b/test/f90_correct/src/trailz_elemental.f90 new file mode 100644 index 0000000000..0cab203d3e --- /dev/null +++ b/test/f90_correct/src/trailz_elemental.f90 @@ -0,0 +1,34 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Support for TRAILZ intrinsic. +! + +module trailz_elemental + implicit none +contains + elemental integer function do_trailz(a) result(b) + integer, intent (in) :: a + b = trailz(a) + end function +end module + + +program test + use trailz_elemental + implicit none + integer, parameter :: num = 5 + integer results(num) + integer , parameter :: expect(num) = (/2, 6, 6, 0, 0/) + integer , parameter :: arr(num) = (/-108, -64, 64, -1, 1/) + + results = do_trailz(arr) + + call check(results, expect, num) +end program diff --git a/test/f90_correct/src/trailz_kind.f90 b/test/f90_correct/src/trailz_kind.f90 new file mode 100644 index 0000000000..e2ecd0dc22 --- /dev/null +++ b/test/f90_correct/src/trailz_kind.f90 @@ -0,0 +1,53 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Support for TRAILZ intrinsic. +! + +program test + integer, parameter :: num = 1 + integer results(num), expect(num) + data expect /1/ + integer (kind = 8) :: arr_kind8(5) + integer (kind = 2) :: arr_kind2(5) + integer (kind = 1) :: arr_kind1(5) + integer results_kind1(5), results_kind2(5), results_kind4(5), & + results_kind8(5) + integer , parameter :: arr(5) = (/-108, -1, 64, -64, 1/) + + arr_kind8 = arr + arr_kind2 = arr + arr_kind1 = arr + + do i = 1, 5 + results_kind1(i) = trailz(arr_kind1(i)) + results_kind2(i) = trailz(arr_kind2(i)) + results_kind4(i) = trailz(arr(i)) + results_kind8(i) = trailz(arr_kind8(i)) + end do + + if (all( results_kind8 .eq. results_kind4)) then + if (all(results_kind2 .eq. results_kind8)) then + if(all(results_kind2 .eq. results_kind1)) then + results(1) = 1 + print *, 'expect vs results match' + else + results(1) = 0 + print *, 'resulst_kind2 vs results_kind1 mismatch' + endif + else + results(1) = 0 + print *, 'resulst_kind2 vs results_kind8 mismatch' + endif + else + results(1) = 0 + print *, 'resulst_kind8 vs results_kind4 mismatch' + endif + call check(results, expect, num) +end program diff --git a/test/f90_correct/src/transpose_init.f90 b/test/f90_correct/src/transpose_init.f90 new file mode 100644 index 0000000000..7320d72fee --- /dev/null +++ b/test/f90_correct/src/transpose_init.f90 @@ -0,0 +1,38 @@ +!** Licensed under the Apache License, Version 2.0 (the "License"); +!** you may not use this file except in compliance with the License. +!** You may obtain a copy of the License at +!** +!** http://www.apache.org/licenses/LICENSE-2.0 +!** +!** Unless required by applicable law or agreed to in writing, software +!** distributed under the License is distributed on an "AS IS" BASIS, +!** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +!** See the License for the specific language governing permissions and +!** limitations under the License. + +!** +!** Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +!** +!** Support for transpose intrinsic during initialization +!** +!** Date of Modification: 1st March 2019 +!** + +!* Test checking tranpose during initialization +program test + integer, parameter :: num = 1 + integer rslts(num), expect(num) + data expect / 1 / + integer, parameter :: arr(2, 3) = RESHAPE((/1, 2, 3, 4, 5, 6/), (/2, 3/)) + integer, parameter :: exp_transpose_arr(3, 2) = RESHAPE((/1, 3, 5, 2, 4, 6/), (/3, 2/)) + integer :: transpose_arr(3, 2) = TRANSPOSE(arr) + + if (all(transpose_arr .eq. exp_transpose_arr)) then + rslts(1) = 1 + else + rslts(1) = 0 + print *, 'tranpose_arr vs exp_transpose_arr mismatch' + endif + + call check(rslts, expect, num) +end program diff --git a/test/lit.cfg b/test/lit.cfg index 7870777359..5aa4289e14 100644 --- a/test/lit.cfg +++ b/test/lit.cfg @@ -3,6 +3,12 @@ # See https://llvm.org/LICENSE.txt for license information. # SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception # +# +# Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +# Notified per clause 4(b) of the license. +# +# Last Modified: May 2020 +# # -*- Python -*- @@ -49,7 +55,16 @@ config.suffixes = ['.f', '.FOR', '.for', '.f77', '.f90', '.f95', '.F', '.fpp', ' # excludes: A list of directories to exclude from the testsuite. The 'Inputs' # subdirectories contain auxiliary inputs for various tests in their parent # directories. -config.excludes = ['Inputs', 'CMakeLists.txt', 'README.txt', 'LICENSE.txt', 'ngrep.sh'] +# AOCC begin +config.excludes = ['Inputs', 'CMakeLists.txt', 'README.txt', 'LICENSE.txt', 'ngrep.sh', 'offloading'] + +# check if this an omp-offloading build. If not, then exclude x86 offloading +# tests. +flang_omp_offloading_build = getattr(config, 'omp_offloading_build', None) +if flang_omp_offloading_build is not None: + if flang_omp_offloading_build is not "1": + config.excludes.append('x86_64_offloading') +# AOCC end # test_source_root: The root path where tests are located. config.test_source_root = os.path.dirname(__file__) @@ -115,6 +130,8 @@ if config.test_exec_root is None: lit_config.fatal('No site specific configuration available!') # Get the source and object roots. + # The --src-root option is no longer supported, but the build seems to not use this... + # this is for test... llvm_src_root = lit.util.capture(['llvm-config', '--src-root']).strip() llvm_obj_root = lit.util.capture(['llvm-config', '--obj-root']).strip() flang_src_root = os.path.join(llvm_src_root, "tools", "flang") diff --git a/test/lit.site.cfg.in b/test/lit.site.cfg.in index c03108003e..157f578328 100644 --- a/test/lit.site.cfg.in +++ b/test/lit.site.cfg.in @@ -3,6 +3,12 @@ # See https://llvm.org/LICENSE.txt for license information. # SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception # +# +# Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +# Notified per clause 4(b) of the license. +# +# Last Modified: May 2020 +# @LIT_SITE_CFG_IN_HEADER@ @@ -24,6 +30,9 @@ config.have_zlib = "@HAVE_LIBZ@" config.enable_shared = @ENABLE_SHARED@ config.enable_backtrace = "@ENABLE_BACKTRACES@" config.host_arch = "@HOST_ARCH@" +# AOCC begin +config.omp_offloading_build="@OMP_OFFLOADING_BUILD@" +# AOCC end # Support substitution of the tools and libs dirs with user parameters. This is # used when we can't determine the tool dir at configuration time. diff --git a/test/llvm_ir_correct/contig.f90 b/test/llvm_ir_correct/contig.f90 new file mode 100644 index 0000000000..9d088c2e32 --- /dev/null +++ b/test/llvm_ir_correct/contig.f90 @@ -0,0 +1,5 @@ +! RUN: %flang -c %s -fsyntax-only +module contig + implicit none + integer, dimension(:), pointer, contiguous, save :: ptr +end module diff --git a/test/mp_correct/inc/fork_omp.mk b/test/mp_correct/inc/fork_omp.mk new file mode 100644 index 0000000000..b080ce2898 --- /dev/null +++ b/test/mp_correct/inc/fork_omp.mk @@ -0,0 +1,18 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# +fork_omp: fork_omp.$(OBJX) + @echo ------------ executing test $@ + -$(RUN2) ./a.$(EXESUFFIX) $(LOG) +fork.$(OBJX): $(SRC)/fork.c + -$(CC) $(CFLAGS) $(SRC)/fork.c +fork_omp.$(OBJX): $(SRC)/fork_omp.F90 fork.$(OBJX) check.$(OBJX) + @echo ------------ building test $@ + -$(FC) $(FFLAGS) $(SRC)/fork_omp.F90 + @$(RM) ./a.$(EXESUFFIX) + -$(FC) $(LDFLAGS) fork_omp.$(OBJX) fork.$(OBJX) check.$(OBJX) $(LIBS) \ + -o a.$(EXESUFFIX) +build: fork_omp +run: ; diff --git a/test/mp_correct/inc/sched01.mk b/test/mp_correct/inc/sched01.mk new file mode 100644 index 0000000000..e1ceea75eb --- /dev/null +++ b/test/mp_correct/inc/sched01.mk @@ -0,0 +1,15 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# +sched01: sched01.$(OBJX) + @echo ------------ executing test $@ + -$(RUN4) ./a.$(EXESUFFIX) $(LOG) +sched01.$(OBJX): $(SRC)/sched01.f check.$(OBJX) + @echo ------------ building test $@ + -$(FC) $(FFLAGS) $(SRC)/sched01.f + @$(RM) ./a.$(EXESUFFIX) + -$(FC) $(LDFLAGS) sched01.$(OBJX) check.$(OBJX) $(LIBS) -o a.$(EXESUFFIX) +build: sched01 +run: ; diff --git a/test/mp_correct/inc/sched02.mk b/test/mp_correct/inc/sched02.mk new file mode 100644 index 0000000000..e1ceea75eb --- /dev/null +++ b/test/mp_correct/inc/sched02.mk @@ -0,0 +1,15 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# +sched01: sched01.$(OBJX) + @echo ------------ executing test $@ + -$(RUN4) ./a.$(EXESUFFIX) $(LOG) +sched01.$(OBJX): $(SRC)/sched01.f check.$(OBJX) + @echo ------------ building test $@ + -$(FC) $(FFLAGS) $(SRC)/sched01.f + @$(RM) ./a.$(EXESUFFIX) + -$(FC) $(LDFLAGS) sched01.$(OBJX) check.$(OBJX) $(LIBS) -o a.$(EXESUFFIX) +build: sched01 +run: ; diff --git a/test/mp_correct/inc/sched03.mk b/test/mp_correct/inc/sched03.mk new file mode 100644 index 0000000000..87ee55b3ff --- /dev/null +++ b/test/mp_correct/inc/sched03.mk @@ -0,0 +1,15 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# +sched03: sched03.$(OBJX) + @echo ------------ executing test $@ + -$(RUN4) ./a.$(EXESUFFIX) $(LOG) +sched03.$(OBJX): $(SRC)/sched03.f check.$(OBJX) + @echo ------------ building test $@ + -$(FC) $(FFLAGS) $(SRC)/sched03.f + @$(RM) ./a.$(EXESUFFIX) + -$(FC) $(LDFLAGS) sched03.$(OBJX) check.$(OBJX) $(LIBS) -o a.$(EXESUFFIX) +build: sched03 +run: ; diff --git a/test/mp_correct/inc/sched04.mk b/test/mp_correct/inc/sched04.mk new file mode 100644 index 0000000000..a85946a914 --- /dev/null +++ b/test/mp_correct/inc/sched04.mk @@ -0,0 +1,15 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# +sched04: sched04.$(OBJX) + @echo ------------ executing test $@ + -$(RUN4) ./a.$(EXESUFFIX) $(LOG) +sched04.$(OBJX): $(SRC)/sched04.f check.$(OBJX) + @echo ------------ building test $@ + -$(FC) $(FFLAGS) $(SRC)/sched04.f + @$(RM) ./a.$(EXESUFFIX) + -$(FC) $(LDFLAGS) sched04.$(OBJX) check.$(OBJX) $(LIBS) -o a.$(EXESUFFIX) +build: sched04 +run: ; diff --git a/test/mp_correct/inc/sched05.mk b/test/mp_correct/inc/sched05.mk new file mode 100644 index 0000000000..9f65bd2883 --- /dev/null +++ b/test/mp_correct/inc/sched05.mk @@ -0,0 +1,15 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# +sched05: sched05.$(OBJX) + @echo ------------ executing test $@ + -$(RUN4) ./a.$(EXESUFFIX) $(LOG) +sched05.$(OBJX): $(SRC)/sched05.f check.$(OBJX) + @echo ------------ building test $@ + -$(FC) $(FFLAGS) $(SRC)/sched05.f + @$(RM) ./a.$(EXESUFFIX) + -$(FC) $(LDFLAGS) sched05.$(OBJX) check.$(OBJX) $(LIBS) -o a.$(EXESUFFIX) +build: sched05 +run: ; diff --git a/test/mp_correct/inc/taskloop_ice.mk b/test/mp_correct/inc/taskloop_ice.mk new file mode 100644 index 0000000000..32c481efc7 --- /dev/null +++ b/test/mp_correct/inc/taskloop_ice.mk @@ -0,0 +1,18 @@ +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +build: taskloop_ice.$(OBJX) + +run: + @echo ------------ executing test $@ + -$(RUN2) ./taskloop_ice.$(EXESUFFIX) $(LOG) + +verify: ; + +taskloop_ice.$(OBJX): $(SRC)/taskloop_ice.f90 check.$(OBJX) + @echo ------------ building test $@ + -$(FC) $(FFLAGS) $(SRC)/taskloop_ice.f90 + @$(RM) ./a.$(EXESUFFIX) + -$(FC) $(LDFLAGS) taskloop_ice.$(OBJX) check.$(OBJX) $(LIBS) -o taskloop_ice.$(EXESUFFIX) + diff --git a/test/mp_correct/lit/fork_omp.sh b/test/mp_correct/lit/fork_omp.sh new file mode 100644 index 0000000000..3880a96ea6 --- /dev/null +++ b/test/mp_correct/lit/fork_omp.sh @@ -0,0 +1,9 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/HOMME_limiter_optim_iter_full/lit/t1.sh b/test/mp_correct/lit/sched01.sh similarity index 100% rename from test/ncar_kernels/HOMME_limiter_optim_iter_full/lit/t1.sh rename to test/mp_correct/lit/sched01.sh diff --git a/test/ncar_kernels/HOMME_preq_hydrostatic/lit/t1.sh b/test/mp_correct/lit/sched02.sh similarity index 100% rename from test/ncar_kernels/HOMME_preq_hydrostatic/lit/t1.sh rename to test/mp_correct/lit/sched02.sh diff --git a/test/ncar_kernels/HOMME_preq_omega_ps/lit/t1.sh b/test/mp_correct/lit/sched03.sh similarity index 100% rename from test/ncar_kernels/HOMME_preq_omega_ps/lit/t1.sh rename to test/mp_correct/lit/sched03.sh diff --git a/test/ncar_kernels/HOMME_remap_q_ppm/lit/t1.sh b/test/mp_correct/lit/sched04.sh similarity index 100% rename from test/ncar_kernels/HOMME_remap_q_ppm/lit/t1.sh rename to test/mp_correct/lit/sched04.sh diff --git a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/lit/t1.sh b/test/mp_correct/lit/sched05.sh similarity index 100% rename from test/ncar_kernels/HOMME_vlaplace_sphere_wk/lit/t1.sh rename to test/mp_correct/lit/sched05.sh diff --git a/test/mp_correct/lit/taskloop_ice.sh b/test/mp_correct/lit/taskloop_ice.sh new file mode 100644 index 0000000000..6ba014ecfd --- /dev/null +++ b/test/mp_correct/lit/taskloop_ice.sh @@ -0,0 +1,8 @@ +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/mp_correct/src/fork.c b/test/mp_correct/src/fork.c new file mode 100644 index 0000000000..1e261c5a93 --- /dev/null +++ b/test/mp_correct/src/fork.c @@ -0,0 +1,20 @@ +#include +#include +#include +#include + +void fork_(int *pid) +{ + *pid = fork(); +} + +void waitpid_(int *pid) +{ + int status; + + waitpid(*pid, &status, 0); + if (WCOREDUMP(status)) { + fprintf(stderr, "FAIL\n"); + exit(-1); + } +} diff --git a/test/mp_correct/src/fork_omp.F90 b/test/mp_correct/src/fork_omp.F90 new file mode 100644 index 0000000000..87513a3480 --- /dev/null +++ b/test/mp_correct/src/fork_omp.F90 @@ -0,0 +1,31 @@ +program forking + implicit none + integer :: pid + + pid = -1 + call sub + call fork(pid) + if (pid /= 0) then + call waitpid(pid) + endif + call sub + if (pid /= 0) then +#ifdef _OPENMP + call check(1, 1, 1) +#else + call check(0, 1, 1) +#endif + endif + +contains + + subroutine sub + use omp_lib + implicit none +!$omp parallel +!$omp critical + print *, omp_get_thread_num() +!$omp end critical +!$omp end parallel + end subroutine +end program diff --git a/test/mp_correct/src/sched01.f b/test/mp_correct/src/sched01.f new file mode 100644 index 0000000000..47a2aa8b8e --- /dev/null +++ b/test/mp_correct/src/sched01.f @@ -0,0 +1,20 @@ +!* Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +!* See https://llvm.org/LICENSE.txt for license information. +!* SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +* Schedule modifier directives + program test + common/result/result + integer :: result(10), expect(10) = 6 + integer i + integer :: a(10)=1, b(10)=2, c(10)=3 +!$omp parallel +!$omp do schedule(monotonic:static, 2) + do i = 1, 10 + result(i) = a(i) + b(i) + c(i) + enddo +!$omp end do +!$omp endparallel + call check(result, expect, 10) + end + diff --git a/test/mp_correct/src/sched02.f b/test/mp_correct/src/sched02.f new file mode 100644 index 0000000000..4dd5612352 --- /dev/null +++ b/test/mp_correct/src/sched02.f @@ -0,0 +1,20 @@ +!* Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +!* See https://llvm.org/LICENSE.txt for license information. +!* SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +* Schedule modifier directives + program test + common/result/result + integer :: result(10), expect(10) = 6 + integer i + integer :: a(10)=1, b(10)=2, c(10)=3 +!$omp parallel +!$omp do schedule(nonmonotonic:dynamic, 2) + do i = 1, 10 + result(i) = a(i) + b(i) + c(i) + enddo +!$omp end do +!$omp endparallel + call check(result, expect, 10) + end + diff --git a/test/mp_correct/src/sched03.f b/test/mp_correct/src/sched03.f new file mode 100644 index 0000000000..39e4676c7b --- /dev/null +++ b/test/mp_correct/src/sched03.f @@ -0,0 +1,20 @@ +!* Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +!* See https://llvm.org/LICENSE.txt for license information. +!* SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +* Schedule modifier directives + program test + common/result/result + integer :: result(10), expect(10) = 6 + integer i + integer :: a(10)=1, b(10)=2, c(10)=3 +!$omp parallel +!$omp do schedule(simd:static) + do i = 1, 10 + result(i) = a(i) + b(i) + c(i) + enddo +!$omp end do +!$omp endparallel + call check(result, expect, 10) + end + diff --git a/test/mp_correct/src/sched04.f b/test/mp_correct/src/sched04.f new file mode 100644 index 0000000000..b7a23fcc0f --- /dev/null +++ b/test/mp_correct/src/sched04.f @@ -0,0 +1,20 @@ +!* Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +!* See https://llvm.org/LICENSE.txt for license information. +!* SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +* Schedule modifier directives + program test + common/result/result + integer :: result(10), expect(10) = 6 + integer i + integer :: a(10)=1, b(10)=2, c(10)=3 +!$omp parallel +!$omp do schedule(simd:runtime) + do i = 1, 10 + result(i) = a(i) + b(i) + c(i) + enddo +!$omp end do +!$omp endparallel + call check(result, expect, 10) + end + diff --git a/test/mp_correct/src/sched05.f b/test/mp_correct/src/sched05.f new file mode 100644 index 0000000000..4f2e46b455 --- /dev/null +++ b/test/mp_correct/src/sched05.f @@ -0,0 +1,20 @@ +!* Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +!* See https://llvm.org/LICENSE.txt for license information. +!* SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + +* Schedule modifier directives + program test + common/result/result + integer :: result(10), expect(10) = 6 + integer i + integer :: a(10)=1, b(10)=2, c(10)=3 +!$omp parallel +!$omp do schedule(simd:guided) + do i = 1, 10 + result(i) = a(i) + b(i) + c(i) + enddo +!$omp end do +!$omp endparallel + call check(result, expect, 10) + end + diff --git a/test/mp_correct/src/taskloop_ice.f90 b/test/mp_correct/src/taskloop_ice.f90 new file mode 100644 index 0000000000..5208002d12 --- /dev/null +++ b/test/mp_correct/src/taskloop_ice.f90 @@ -0,0 +1,21 @@ +! +! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +! See https://llvm.org/LICENSE.txt for license information. +! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +! + +program reproducer_taskloop + integer, parameter :: n=10 + integer :: expect(n) = (/ 1,2,3,4,5,6,7,8,9,10 /) + integer :: result(n) + + integer :: i + result = 2 + !$OMP TASKLOOP private(i) shared(result) + do i = 1, 10 + result(i) = i + end do + !$OMP END TASKLOOP + + call check(result,expect,n) +end program reproducer_taskloop diff --git a/test/ncar_kernels/CAM5_mg2_pgi/CESM_license.txt b/test/ncar_kernels/CAM5_mg2_pgi/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/CAM5_mg2_pgi/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/CAM5_mg2_pgi/README b/test/ncar_kernels/CAM5_mg2_pgi/README deleted file mode 100644 index 8789c51648..0000000000 --- a/test/ncar_kernels/CAM5_mg2_pgi/README +++ /dev/null @@ -1,7 +0,0 @@ -MG2 kernel - -For general information about MG2 kernel, please read README in https://subversion.ucar.edu/pubasap/kernels/MG2. - -This version of MG2 is generated from rev. 69541 of https://svn-ccsm-models.cgd.ucar.edu/cam1/trunk_tags/cam5_3_74 using PGI compiler. - -Please contact Youngsung Kim(youngsun@ucar.edu) for any questions concerning this kernel. diff --git a/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.10.0 b/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.10.0 deleted file mode 100644 index a4a693cc02..0000000000 Binary files a/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.10.0 and /dev/null differ diff --git a/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.10.100 b/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.10.100 deleted file mode 100644 index b22a3eacb0..0000000000 Binary files a/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.10.100 and /dev/null differ diff --git a/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.10.300 b/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.10.300 deleted file mode 100644 index f4ddea35c4..0000000000 Binary files a/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.10.300 and /dev/null differ diff --git a/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.100.0 b/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.100.0 deleted file mode 100644 index f8fa66805d..0000000000 Binary files a/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.100.0 and /dev/null differ diff --git a/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.100.100 b/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.100.100 deleted file mode 100644 index 2e081a3058..0000000000 Binary files a/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.100.100 and /dev/null differ diff --git a/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.100.300 b/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.100.300 deleted file mode 100644 index 3a79e0153a..0000000000 Binary files a/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.100.300 and /dev/null differ diff --git a/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.50.0 b/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.50.0 deleted file mode 100644 index 87b0e231b3..0000000000 Binary files a/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.50.0 and /dev/null differ diff --git a/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.50.100 b/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.50.100 deleted file mode 100644 index e7d775ee6b..0000000000 Binary files a/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.50.100 and /dev/null differ diff --git a/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.50.300 b/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.50.300 deleted file mode 100644 index b69b024e5e..0000000000 Binary files a/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.50.300 and /dev/null differ diff --git a/test/ncar_kernels/CAM5_mg2_pgi/inc/t1.mk b/test/ncar_kernels/CAM5_mg2_pgi/inc/t1.mk deleted file mode 100644 index 0cbb39f10a..0000000000 --- a/test/ncar_kernels/CAM5_mg2_pgi/inc/t1.mk +++ /dev/null @@ -1,72 +0,0 @@ -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# Intel default flags -# -# FC_FLAGS := -O2 -fp-model source -convert big_endian -assume byterecl -# -ftz -traceback -assume realloc_lhs -xAVX -# -# Makefile for KGEN-generated kernel -FC_FLAGS := $(OPT) -FC_FLAGS += $(OPT) -O -Kieee -Mnofma - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - -ALL_OBJS := kernel_driver.o micro_mg_cam.o micro_mg_utils.o shr_kind_mod.o micro_mg2_0.o shr_spfn_mod.o wv_sat_methods.o shr_const_mod.o - -verify: - @(grep "verification.FAIL" $(TEST).rslt && echo "FAILED") || (grep "verification.PASS" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 micro_mg_cam.o micro_mg_utils.o shr_kind_mod.o micro_mg2_0.o shr_spfn_mod.o wv_sat_methods.o shr_const_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -micro_mg_cam.o: $(SRC_DIR)/micro_mg_cam.F90 micro_mg2_0.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -micro_mg_utils.o: $(SRC_DIR)/micro_mg_utils.F90 shr_spfn_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_kind_mod.o: $(SRC_DIR)/shr_kind_mod.F90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -micro_mg2_0.o: $(SRC_DIR)/micro_mg2_0.F90 micro_mg_utils.o wv_sat_methods.o shr_spfn_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_spfn_mod.o: $(SRC_DIR)/shr_spfn_mod.F90 shr_kind_mod.o shr_const_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -wv_sat_methods.o: $(SRC_DIR)/wv_sat_methods.F90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_const_mod.o: $(SRC_DIR)/shr_const_mod.F90 shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.rslt diff --git a/test/ncar_kernels/CAM5_mg2_pgi/lit/runmake b/test/ncar_kernels/CAM5_mg2_pgi/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/CAM5_mg2_pgi/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/CAM5_mg2_pgi/makefile b/test/ncar_kernels/CAM5_mg2_pgi/makefile deleted file mode 100644 index 6906723dad..0000000000 --- a/test/ncar_kernels/CAM5_mg2_pgi/makefile +++ /dev/null @@ -1,33 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk - diff --git a/test/ncar_kernels/CAM5_mg2_pgi/src/kernel_driver.f90 b/test/ncar_kernels/CAM5_mg2_pgi/src/kernel_driver.f90 deleted file mode 100644 index c29ab608f6..0000000000 --- a/test/ncar_kernels/CAM5_mg2_pgi/src/kernel_driver.f90 +++ /dev/null @@ -1,85 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-03-31 09:44:40 -! KGEN version: 0.4.5 - - -PROGRAM kernel_driver - USE micro_mg_cam, ONLY : micro_mg_cam_tend - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - USE micro_mg_cam, ONLY : kgen_read_externs_micro_mg_cam - USE micro_mg_utils, ONLY : kgen_read_externs_micro_mg_utils - USE micro_mg2_0, ONLY : kgen_read_externs_micro_mg2_0 - USE wv_sat_methods, ONLY : kgen_read_externs_wv_sat_methods - - IMPLICIT NONE - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_mpi_rank_at = (/ 0, 100, 300 /) - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_counter_at = (/ 10, 100, 50 /) - CHARACTER(LEN=1024) :: kgen_filepath - REAL(KIND=r8) :: dtime - - DO kgen_repeat_counter = 0, 8 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - kgen_filepath = "../data/micro_mg_tend2_0." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "** Verification against '" // trim(adjustl(kgen_filepath)) // "' **" - - CALL kgen_read_externs_micro_mg_cam(kgen_unit) - CALL kgen_read_externs_micro_mg_utils(kgen_unit) - CALL kgen_read_externs_micro_mg2_0(kgen_unit) - CALL kgen_read_externs_wv_sat_methods(kgen_unit) - - ! driver variables - READ(UNIT=kgen_unit) dtime - - call micro_mg_cam_tend(dtime, kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! write subroutines - ! No subroutines - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/CAM5_mg2_pgi/src/micro_mg2_0.F90 b/test/ncar_kernels/CAM5_mg2_pgi/src/micro_mg2_0.F90 deleted file mode 100644 index 288050edeb..0000000000 --- a/test/ncar_kernels/CAM5_mg2_pgi/src/micro_mg2_0.F90 +++ /dev/null @@ -1,2144 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : micro_mg2_0.F90 -! Generated at: 2015-03-31 09:44:40 -! KGEN version: 0.4.5 - - - - MODULE micro_mg2_0 - !--------------------------------------------------------------------------------- - ! Purpose: - ! MG microphysics version 2.0 - Update of MG microphysics with - ! prognostic precipitation. - ! - ! Author: Andrew Gettelman, Hugh Morrison. - ! Contributions from: Peter Caldwell, Xiaohong Liu and Steve Ghan - ! Version 2 history: Sep 2011: Development begun. - ! Feb 2013: Added of prognostic precipitation. - ! invoked in 1 by specifying -microphys=mg2.0 - ! - ! for questions contact Hugh Morrison, Andrew Gettelman - ! e-mail: morrison@ucar.edu, andrew@ucar.edu - !--------------------------------------------------------------------------------- - ! - ! NOTE: Modified to allow other microphysics packages (e.g. CARMA) to do ice - ! microphysics in cooperation with the MG liquid microphysics. This is - ! controlled by the do_cldice variable. - ! - ! If do_cldice is false, then MG microphysics should not update CLDICE or - ! NUMICE; it is assumed that the other microphysics scheme will have updated - ! CLDICE and NUMICE. The other microphysics should handle the following - ! processes that would have been done by MG: - ! - Detrainment (liquid and ice) - ! - Homogeneous ice nucleation - ! - Heterogeneous ice nucleation - ! - Bergeron process - ! - Melting of ice - ! - Freezing of cloud drops - ! - Autoconversion (ice -> snow) - ! - Growth/Sublimation of ice - ! - Sedimentation of ice - ! - ! This option has not been updated since the introduction of prognostic - ! precipitation, and probably should be adjusted to cover snow as well. - ! - !--------------------------------------------------------------------------------- - ! Based on micro_mg (restructuring of former cldwat2m_micro) - ! Author: Andrew Gettelman, Hugh Morrison. - ! Contributions from: Xiaohong Liu and Steve Ghan - ! December 2005-May 2010 - ! Description in: Morrison and Gettelman, 2008. J. Climate (MG2008) - ! Gettelman et al., 2010 J. Geophys. Res. - Atmospheres (G2010) - ! for questions contact Hugh Morrison, Andrew Gettelman - ! e-mail: morrison@ucar.edu, andrew@ucar.edu - !--------------------------------------------------------------------------------- - ! Code comments added by HM, 093011 - ! General code structure: - ! - ! Code is divided into two main subroutines: - ! subroutine micro_mg_init --> initializes microphysics routine, should be called - ! once at start of simulation - ! subroutine micro_mg_tend --> main microphysics routine to be called each time step - ! this also calls several smaller subroutines to calculate - ! microphysical processes and other utilities - ! - ! List of external functions: - ! qsat_water --> for calculating saturation vapor pressure with respect to liquid water - ! qsat_ice --> for calculating saturation vapor pressure with respect to ice - ! gamma --> standard mathematical gamma function - ! ......................................................................... - ! List of inputs through use statement in fortran90: - ! Variable Name Description Units - ! ......................................................................... - ! gravit acceleration due to gravity m s-2 - ! rair dry air gas constant for air J kg-1 K-1 - ! tmelt temperature of melting point for water K - ! cpair specific heat at constant pressure for dry air J kg-1 K-1 - ! rh2o gas constant for water vapor J kg-1 K-1 - ! latvap latent heat of vaporization J kg-1 - ! latice latent heat of fusion J kg-1 - ! qsat_water external function for calculating liquid water - ! saturation vapor pressure/humidity - - ! qsat_ice external function for calculating ice - ! saturation vapor pressure/humidity pa - ! rhmini relative humidity threshold parameter for - ! nucleating ice - - ! ......................................................................... - ! NOTE: List of all inputs/outputs passed through the call/subroutine statement - ! for micro_mg_tend is given below at the start of subroutine micro_mg_tend. - !--------------------------------------------------------------------------------- - ! Procedures required: - ! 1) An implementation of the gamma function (if not intrinsic). - ! 2) saturation vapor pressure and specific humidity over water - ! 3) svp over ice - USE shr_spfn_mod, ONLY: gamma => shr_spfn_gamma - USE wv_sat_methods, ONLY: qsat_water => wv_sat_qsat_water - USE wv_sat_methods, ONLY: qsat_ice => wv_sat_qsat_ice - ! Parameters from the utilities module. - USE micro_mg_utils, ONLY: r8 - USE micro_mg_utils, ONLY: qsmall - USE micro_mg_utils, ONLY: mincld - USE micro_mg_utils, ONLY: ar - USE micro_mg_utils, ONLY: as - USE micro_mg_utils, ONLY: rhow - USE micro_mg_utils, ONLY: ai - USE micro_mg_utils, ONLY: mi0 - USE micro_mg_utils, ONLY: br - USE micro_mg_utils, ONLY: bs - USE micro_mg_utils, ONLY: pi - USE micro_mg_utils, ONLY: rhosn - USE micro_mg_utils, ONLY: omsm - USE micro_mg_utils, ONLY: rising_factorial - USE micro_mg_utils, ONLY: bc - USE micro_mg_utils, ONLY: bi - USE micro_mg_utils, ONLY: rhows - USE micro_mg_utils, ONLY: rhoi - IMPLICIT NONE - PRIVATE - PUBLIC micro_mg_tend - ! switch for specification rather than prediction of droplet and crystal number - ! note: number will be adjusted as needed to keep mean size within bounds, - ! even when specified droplet or ice number is used - ! If constant cloud ice number is set (nicons = .true.), - ! then all microphysical processes except mass transfer due to ice nucleation - ! (mnuccd) are based on the fixed cloud ice number. Calculation of - ! mnuccd follows from the prognosed ice crystal number ni. - ! nccons = .true. to specify constant cloud droplet number - ! nicons = .true. to specify constant cloud ice number - LOGICAL, parameter, public :: nccons = .false. - LOGICAL, parameter, public :: nicons = .false. - !========================================================= - ! Private module parameters - !========================================================= - ! parameters for specified ice and droplet number concentration - ! note: these are local in-cloud values, not grid-mean - REAL(KIND=r8), parameter :: ncnst = 100.e6_r8 ! droplet num concentration when nccons=.true. (m-3) - REAL(KIND=r8), parameter :: ninst = 0.1e6_r8 ! ice num concentration when nicons=.true. (m-3) - !Range of cloudsat reflectivities (dBz) for analytic simulator - REAL(KIND=r8), parameter :: csmin = -30._r8 - REAL(KIND=r8), parameter :: csmax = 26._r8 - REAL(KIND=r8), parameter :: mindbz = -99._r8 - REAL(KIND=r8), parameter :: minrefl = 1.26e-10_r8 ! minrefl = 10._r8**(mindbz/10._r8) - ! autoconversion size threshold for cloud ice to snow (m) - REAL(KIND=r8) :: dcs - ! minimum mass of new crystal due to freezing of cloud droplets done - ! externally (kg) - REAL(KIND=r8), parameter :: mi0l_min = 4._r8/3._r8*pi*rhow*(4.e-6_r8)**3 - !========================================================= - ! Constants set in initialization - !========================================================= - ! Set using arguments to micro_mg_init - REAL(KIND=r8) :: g ! gravity - REAL(KIND=r8) :: r ! dry air gas constant - REAL(KIND=r8) :: rv ! water vapor gas constant - REAL(KIND=r8) :: cpp ! specific heat of dry air - REAL(KIND=r8) :: tmelt ! freezing point of water (K) - ! latent heats of: - REAL(KIND=r8) :: xxlv ! vaporization - REAL(KIND=r8) :: xlf ! freezing - REAL(KIND=r8) :: xxls ! sublimation - REAL(KIND=r8) :: rhmini ! Minimum rh for ice cloud fraction > 0. - ! flags - LOGICAL :: microp_uniform - LOGICAL :: do_cldice - LOGICAL :: use_hetfrz_classnuc - REAL(KIND=r8) :: rhosu ! typical 850mn air density - REAL(KIND=r8) :: icenuct ! ice nucleation temperature: currently -5 degrees C - REAL(KIND=r8) :: snowmelt ! what temp to melt all snow: currently 2 degrees C - REAL(KIND=r8) :: rainfrze ! what temp to freeze all rain: currently -5 degrees C - ! additional constants to help speed up code - REAL(KIND=r8) :: gamma_br_plus1 - REAL(KIND=r8) :: gamma_br_plus4 - REAL(KIND=r8) :: gamma_bs_plus1 - REAL(KIND=r8) :: gamma_bs_plus4 - REAL(KIND=r8) :: gamma_bi_plus1 - REAL(KIND=r8) :: gamma_bi_plus4 - REAL(KIND=r8) :: xxlv_squared - REAL(KIND=r8) :: xxls_squared - CHARACTER(LEN=16) :: micro_mg_precip_frac_method ! type of precipitation fraction method - REAL(KIND=r8) :: micro_mg_berg_eff_factor ! berg efficiency factor - !=============================================================================== - PUBLIC kgen_read_externs_micro_mg2_0 - CONTAINS - - ! write subroutines - ! No subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_micro_mg2_0(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) dcs - READ(UNIT=kgen_unit) g - READ(UNIT=kgen_unit) r - READ(UNIT=kgen_unit) rv - READ(UNIT=kgen_unit) cpp - READ(UNIT=kgen_unit) tmelt - READ(UNIT=kgen_unit) xxlv - READ(UNIT=kgen_unit) xlf - READ(UNIT=kgen_unit) xxls - READ(UNIT=kgen_unit) rhmini - READ(UNIT=kgen_unit) microp_uniform - READ(UNIT=kgen_unit) do_cldice - READ(UNIT=kgen_unit) use_hetfrz_classnuc - READ(UNIT=kgen_unit) rhosu - READ(UNIT=kgen_unit) icenuct - READ(UNIT=kgen_unit) snowmelt - READ(UNIT=kgen_unit) rainfrze - READ(UNIT=kgen_unit) gamma_br_plus1 - READ(UNIT=kgen_unit) gamma_br_plus4 - READ(UNIT=kgen_unit) gamma_bs_plus1 - READ(UNIT=kgen_unit) gamma_bs_plus4 - READ(UNIT=kgen_unit) gamma_bi_plus1 - READ(UNIT=kgen_unit) gamma_bi_plus4 - READ(UNIT=kgen_unit) xxlv_squared - READ(UNIT=kgen_unit) xxls_squared - READ(UNIT=kgen_unit) micro_mg_precip_frac_method - READ(UNIT=kgen_unit) micro_mg_berg_eff_factor - END SUBROUTINE kgen_read_externs_micro_mg2_0 - - !=============================================================================== - - !=============================================================================== - !microphysics routine for each timestep goes here... - - SUBROUTINE micro_mg_tend(mgncol, nlev, deltatin, t, q, qcn, qin, ncn, nin, qrn, qsn, nrn, nsn, relvar, accre_enhan, p, & - pdel, cldn, liqcldf, icecldf, qcsinksum_rate1ord, naai, npccn, rndst, nacon, tlat, qvlat, qctend, qitend, nctend, nitend, & - qrtend, qstend, nrtend, nstend, effc, effc_fn, effi, prect, preci, nevapr, evapsnow, prain, prodsnow, cmeout, deffi, & - pgamrad, lamcrad, qsout, dsout, rflx, sflx, qrout, reff_rain, reff_snow, qcsevap, qisevap, qvres, cmeitot, vtrmc, vtrmi, & - umr, ums, qcsedten, qisedten, qrsedten, qssedten, pratot, prctot, mnuccctot, mnuccttot, msacwitot, psacwstot, bergstot, & - bergtot, melttot, homotot, qcrestot, prcitot, praitot, qirestot, mnuccrtot, pracstot, meltsdttot, frzrdttot, mnuccdtot, & - nrout, nsout, refl, arefl, areflz, frefl, csrfl, acsrfl, fcsrfl, rercld, ncai, ncal, qrout2, qsout2, nrout2, nsout2, & - drout2, dsout2, freqs, freqr, nfice, qcrat, errstring, tnd_qsnow, tnd_nsnow, re_ice, prer_evap, frzimm, frzcnt, frzdep) - ! Below arguments are "optional" (pass null pointers to omit). - ! Constituent properties. - USE micro_mg_utils, ONLY: mg_liq_props - USE micro_mg_utils, ONLY: mg_ice_props - USE micro_mg_utils, ONLY: mg_rain_props - USE micro_mg_utils, ONLY: mg_snow_props - ! Size calculation functions. - USE micro_mg_utils, ONLY: size_dist_param_liq - USE micro_mg_utils, ONLY: size_dist_param_basic - USE micro_mg_utils, ONLY: avg_diameter - ! Microphysical processes. - USE micro_mg_utils, ONLY: kk2000_liq_autoconversion - USE micro_mg_utils, ONLY: ice_autoconversion - USE micro_mg_utils, ONLY: immersion_freezing - USE micro_mg_utils, ONLY: contact_freezing - USE micro_mg_utils, ONLY: snow_self_aggregation - USE micro_mg_utils, ONLY: accrete_cloud_water_snow - USE micro_mg_utils, ONLY: secondary_ice_production - USE micro_mg_utils, ONLY: accrete_rain_snow - USE micro_mg_utils, ONLY: heterogeneous_rain_freezing - USE micro_mg_utils, ONLY: accrete_cloud_water_rain - USE micro_mg_utils, ONLY: self_collection_rain - USE micro_mg_utils, ONLY: accrete_cloud_ice_snow - USE micro_mg_utils, ONLY: evaporate_sublimate_precip - USE micro_mg_utils, ONLY: bergeron_process_snow - USE micro_mg_utils, ONLY: ice_deposition_sublimation - !Authors: Hugh Morrison, Andrew Gettelman, NCAR, Peter Caldwell, LLNL - ! e-mail: morrison@ucar.edu, andrew@ucar.edu - ! input arguments - INTEGER, intent(in) :: mgncol ! number of microphysics columns - INTEGER, intent(in) :: nlev ! number of layers - REAL(KIND=r8), intent(in) :: deltatin ! time step (s) - REAL(KIND=r8), intent(in) :: t(:,:) ! input temperature (K) - REAL(KIND=r8), intent(in) :: q(:,:) ! input h20 vapor mixing ratio (kg/kg) - ! note: all input cloud variables are grid-averaged - REAL(KIND=r8), intent(in) :: qcn(:,:) ! cloud water mixing ratio (kg/kg) - REAL(KIND=r8), intent(in) :: qin(:,:) ! cloud ice mixing ratio (kg/kg) - REAL(KIND=r8), intent(in) :: ncn(:,:) ! cloud water number conc (1/kg) - REAL(KIND=r8), intent(in) :: nin(:,:) ! cloud ice number conc (1/kg) - REAL(KIND=r8), intent(in) :: qrn(:,:) ! rain mixing ratio (kg/kg) - REAL(KIND=r8), intent(in) :: qsn(:,:) ! snow mixing ratio (kg/kg) - REAL(KIND=r8), intent(in) :: nrn(:,:) ! rain number conc (1/kg) - REAL(KIND=r8), intent(in) :: nsn(:,:) ! snow number conc (1/kg) - REAL(KIND=r8), intent(in) :: relvar(:,:) ! cloud water relative variance (-) - REAL(KIND=r8), intent(in) :: accre_enhan(:,:) ! optional accretion - ! enhancement factor (-) - REAL(KIND=r8), intent(in) :: p(:,:) ! air pressure (pa) - REAL(KIND=r8), intent(in) :: pdel(:,:) ! pressure difference across level (pa) - REAL(KIND=r8), intent(in) :: cldn(:,:) ! cloud fraction (no units) - REAL(KIND=r8), intent(in) :: liqcldf(:,:) ! liquid cloud fraction (no units) - REAL(KIND=r8), intent(in) :: icecldf(:,:) ! ice cloud fraction (no units) - ! used for scavenging - ! Inputs for aerosol activation - REAL(KIND=r8), intent(in) :: naai(:,:) ! ice nucleation number (from microp_aero_ts) (1/kg) - REAL(KIND=r8), intent(in) :: npccn(:,:) ! ccn activated number tendency (from microp_aero_ts) (1/kg*s) - ! Note that for these variables, the dust bin is assumed to be the last index. - ! (For example, in 1, the last dimension is always size 4.) - REAL(KIND=r8), intent(in) :: rndst(:,:,:) ! radius of each dust bin, for contact freezing (from microp_aero_ts) (m) - REAL(KIND=r8), intent(in) :: nacon(:,:,:) ! number in each dust bin, for contact freezing (from microp_aero_ts) (1/m^3) - ! output arguments - REAL(KIND=r8), intent(out) :: qcsinksum_rate1ord(:,:) ! 1st order rate for - ! direct cw to precip conversion - REAL(KIND=r8), intent(out) :: tlat(:,:) ! latent heating rate (W/kg) - REAL(KIND=r8), intent(out) :: qvlat(:,:) ! microphysical tendency qv (1/s) - REAL(KIND=r8), intent(out) :: qctend(:,:) ! microphysical tendency qc (1/s) - REAL(KIND=r8), intent(out) :: qitend(:,:) ! microphysical tendency qi (1/s) - REAL(KIND=r8), intent(out) :: nctend(:,:) ! microphysical tendency nc (1/(kg*s)) - REAL(KIND=r8), intent(out) :: nitend(:,:) ! microphysical tendency ni (1/(kg*s)) - REAL(KIND=r8), intent(out) :: qrtend(:,:) ! microphysical tendency qr (1/s) - REAL(KIND=r8), intent(out) :: qstend(:,:) ! microphysical tendency qs (1/s) - REAL(KIND=r8), intent(out) :: nrtend(:,:) ! microphysical tendency nr (1/(kg*s)) - REAL(KIND=r8), intent(out) :: nstend(:,:) ! microphysical tendency ns (1/(kg*s)) - REAL(KIND=r8), intent(out) :: effc(:,:) ! droplet effective radius (micron) - REAL(KIND=r8), intent(out) :: effc_fn(:,:) ! droplet effective radius, assuming nc = 1.e8 kg-1 - REAL(KIND=r8), intent(out) :: effi(:,:) ! cloud ice effective radius (micron) - REAL(KIND=r8), intent(out) :: prect(:) ! surface precip rate (m/s) - REAL(KIND=r8), intent(out) :: preci(:) ! cloud ice/snow precip rate (m/s) - REAL(KIND=r8), intent(out) :: nevapr(:,:) ! evaporation rate of rain + snow (1/s) - REAL(KIND=r8), intent(out) :: evapsnow(:,:) ! sublimation rate of snow (1/s) - REAL(KIND=r8), intent(out) :: prain(:,:) ! production of rain + snow (1/s) - REAL(KIND=r8), intent(out) :: prodsnow(:,:) ! production of snow (1/s) - REAL(KIND=r8), intent(out) :: cmeout(:,:) ! evap/sub of cloud (1/s) - REAL(KIND=r8), intent(out) :: deffi(:,:) ! ice effective diameter for optics (radiation) (micron) - REAL(KIND=r8), intent(out) :: pgamrad(:,:) ! ice gamma parameter for optics (radiation) (no units) - REAL(KIND=r8), intent(out) :: lamcrad(:,:) ! slope of droplet distribution for optics (radiation) (1/m) - REAL(KIND=r8), intent(out) :: qsout(:,:) ! snow mixing ratio (kg/kg) - REAL(KIND=r8), intent(out) :: dsout(:,:) ! snow diameter (m) - REAL(KIND=r8), intent(out) :: rflx(:,:) ! grid-box average rain flux (kg m^-2 s^-1) - REAL(KIND=r8), intent(out) :: sflx(:,:) ! grid-box average snow flux (kg m^-2 s^-1) - REAL(KIND=r8), intent(out) :: qrout(:,:) ! grid-box average rain mixing ratio (kg/kg) - REAL(KIND=r8), intent(out) :: reff_rain(:,:) ! rain effective radius (micron) - REAL(KIND=r8), intent(out) :: reff_snow(:,:) ! snow effective radius (micron) - REAL(KIND=r8), intent(out) :: qcsevap(:,:) ! cloud water evaporation due to sedimentation (1/s) - REAL(KIND=r8), intent(out) :: qisevap(:,:) ! cloud ice sublimation due to sublimation (1/s) - REAL(KIND=r8), intent(out) :: qvres(:,:) ! residual condensation term to ensure RH < 100% (1/s) - REAL(KIND=r8), intent(out) :: cmeitot(:,:) ! grid-mean cloud ice sub/dep (1/s) - REAL(KIND=r8), intent(out) :: vtrmc(:,:) ! mass-weighted cloud water fallspeed (m/s) - REAL(KIND=r8), intent(out) :: vtrmi(:,:) ! mass-weighted cloud ice fallspeed (m/s) - REAL(KIND=r8), intent(out) :: umr(:,:) ! mass weighted rain fallspeed (m/s) - REAL(KIND=r8), intent(out) :: ums(:,:) ! mass weighted snow fallspeed (m/s) - REAL(KIND=r8), intent(out) :: qcsedten(:,:) ! qc sedimentation tendency (1/s) - REAL(KIND=r8), intent(out) :: qisedten(:,:) ! qi sedimentation tendency (1/s) - REAL(KIND=r8), intent(out) :: qrsedten(:,:) ! qr sedimentation tendency (1/s) - REAL(KIND=r8), intent(out) :: qssedten(:,:) ! qs sedimentation tendency (1/s) - ! microphysical process rates for output (mixing ratio tendencies) (all have units of 1/s) - REAL(KIND=r8), intent(out) :: pratot(:,:) ! accretion of cloud by rain - REAL(KIND=r8), intent(out) :: prctot(:,:) ! autoconversion of cloud to rain - REAL(KIND=r8), intent(out) :: mnuccctot(:,:) ! mixing ratio tend due to immersion freezing - REAL(KIND=r8), intent(out) :: mnuccttot(:,:) ! mixing ratio tend due to contact freezing - REAL(KIND=r8), intent(out) :: msacwitot(:,:) ! mixing ratio tend due to H-M splintering - REAL(KIND=r8), intent(out) :: psacwstot(:,:) ! collection of cloud water by snow - REAL(KIND=r8), intent(out) :: bergstot(:,:) ! bergeron process on snow - REAL(KIND=r8), intent(out) :: bergtot(:,:) ! bergeron process on cloud ice - REAL(KIND=r8), intent(out) :: melttot(:,:) ! melting of cloud ice - REAL(KIND=r8), intent(out) :: homotot(:,:) ! homogeneous freezing cloud water - REAL(KIND=r8), intent(out) :: qcrestot(:,:) ! residual cloud condensation due to removal of excess supersat - REAL(KIND=r8), intent(out) :: prcitot(:,:) ! autoconversion of cloud ice to snow - REAL(KIND=r8), intent(out) :: praitot(:,:) ! accretion of cloud ice by snow - REAL(KIND=r8), intent(out) :: qirestot(:,:) ! residual ice deposition due to removal of excess supersat - REAL(KIND=r8), intent(out) :: mnuccrtot(:,:) ! mixing ratio tendency due to heterogeneous freezing of rain to snow (1/s) - REAL(KIND=r8), intent(out) :: pracstot(:,:) ! mixing ratio tendency due to accretion of rain by snow (1/s) - REAL(KIND=r8), intent(out) :: meltsdttot(:,:) ! latent heating rate due to melting of snow (W/kg) - REAL(KIND=r8), intent(out) :: frzrdttot(:,:) ! latent heating rate due to homogeneous freezing of rain (W/kg) - REAL(KIND=r8), intent(out) :: mnuccdtot(:,:) ! mass tendency from ice nucleation - REAL(KIND=r8), intent(out) :: nrout(:,:) ! rain number concentration (1/m3) - REAL(KIND=r8), intent(out) :: nsout(:,:) ! snow number concentration (1/m3) - REAL(KIND=r8), intent(out) :: refl(:,:) ! analytic radar reflectivity - REAL(KIND=r8), intent(out) :: arefl(:,:) ! average reflectivity will zero points outside valid range - REAL(KIND=r8), intent(out) :: areflz(:,:) ! average reflectivity in z. - REAL(KIND=r8), intent(out) :: frefl(:,:) ! fractional occurrence of radar reflectivity - REAL(KIND=r8), intent(out) :: csrfl(:,:) ! cloudsat reflectivity - REAL(KIND=r8), intent(out) :: acsrfl(:,:) ! cloudsat average - REAL(KIND=r8), intent(out) :: fcsrfl(:,:) ! cloudsat fractional occurrence of radar reflectivity - REAL(KIND=r8), intent(out) :: rercld(:,:) ! effective radius calculation for rain + cloud - REAL(KIND=r8), intent(out) :: ncai(:,:) ! output number conc of ice nuclei available (1/m3) - REAL(KIND=r8), intent(out) :: ncal(:,:) ! output number conc of CCN (1/m3) - REAL(KIND=r8), intent(out) :: qrout2(:,:) ! copy of qrout as used to compute drout2 - REAL(KIND=r8), intent(out) :: qsout2(:,:) ! copy of qsout as used to compute dsout2 - REAL(KIND=r8), intent(out) :: nrout2(:,:) ! copy of nrout as used to compute drout2 - REAL(KIND=r8), intent(out) :: nsout2(:,:) ! copy of nsout as used to compute dsout2 - REAL(KIND=r8), intent(out) :: drout2(:,:) ! mean rain particle diameter (m) - REAL(KIND=r8), intent(out) :: dsout2(:,:) ! mean snow particle diameter (m) - REAL(KIND=r8), intent(out) :: freqs(:,:) ! fractional occurrence of snow - REAL(KIND=r8), intent(out) :: freqr(:,:) ! fractional occurrence of rain - REAL(KIND=r8), intent(out) :: nfice(:,:) ! fractional occurrence of ice - REAL(KIND=r8), intent(out) :: qcrat(:,:) ! limiter for qc process rates (1=no limit --> 0. no qc) - REAL(KIND=r8), intent(out) :: prer_evap(:,:) - CHARACTER(LEN=128), intent(out) :: errstring ! output status (non-blank for error return) - ! Tendencies calculated by external schemes that can replace MG's native - ! process tendencies. - ! Used with CARMA cirrus microphysics - ! (or similar external microphysics model) - REAL(KIND=r8), intent(in), pointer :: tnd_qsnow(:,:) ! snow mass tendency (kg/kg/s) - REAL(KIND=r8), intent(in), pointer :: tnd_nsnow(:,:) ! snow number tendency (#/kg/s) - REAL(KIND=r8), intent(in), pointer :: re_ice(:,:) ! ice effective radius (m) - ! From external ice nucleation. - REAL(KIND=r8), intent(in), pointer :: frzimm(:,:) ! Number tendency due to immersion freezing (1/cm3) - REAL(KIND=r8), intent(in), pointer :: frzcnt(:,:) ! Number tendency due to contact freezing (1/cm3) - REAL(KIND=r8), intent(in), pointer :: frzdep(:,:) ! Number tendency due to deposition nucleation (1/cm3) - ! local workspace - ! all units mks unless otherwise stated - ! local copies of input variables - REAL(KIND=r8) :: qc(mgncol,nlev) ! cloud liquid mixing ratio (kg/kg) - REAL(KIND=r8) :: qi(mgncol,nlev) ! cloud ice mixing ratio (kg/kg) - REAL(KIND=r8) :: nc(mgncol,nlev) ! cloud liquid number concentration (1/kg) - REAL(KIND=r8) :: ni(mgncol,nlev) ! cloud liquid number concentration (1/kg) - REAL(KIND=r8) :: qr(mgncol,nlev) ! rain mixing ratio (kg/kg) - REAL(KIND=r8) :: qs(mgncol,nlev) ! snow mixing ratio (kg/kg) - REAL(KIND=r8) :: nr(mgncol,nlev) ! rain number concentration (1/kg) - REAL(KIND=r8) :: ns(mgncol,nlev) ! snow number concentration (1/kg) - ! general purpose variables - REAL(KIND=r8) :: deltat ! sub-time step (s) - REAL(KIND=r8) :: mtime ! the assumed ice nucleation timescale - ! physical properties of the air at a given point - REAL(KIND=r8) :: rho(mgncol,nlev) ! density (kg m-3) - REAL(KIND=r8) :: dv(mgncol,nlev) ! diffusivity of water vapor - REAL(KIND=r8) :: mu(mgncol,nlev) ! viscosity - REAL(KIND=r8) :: sc(mgncol,nlev) ! schmidt number - REAL(KIND=r8) :: rhof(mgncol,nlev) ! density correction factor for fallspeed - ! cloud fractions - REAL(KIND=r8) :: precip_frac(mgncol,nlev) ! precip fraction assuming maximum overlap - REAL(KIND=r8) :: cldm(mgncol,nlev) ! cloud fraction - REAL(KIND=r8) :: icldm(mgncol,nlev) ! ice cloud fraction - REAL(KIND=r8) :: lcldm(mgncol,nlev) ! liq cloud fraction - ! mass mixing ratios - REAL(KIND=r8) :: qcic(mgncol,nlev) ! in-cloud cloud liquid - REAL(KIND=r8) :: qiic(mgncol,nlev) ! in-cloud cloud ice - REAL(KIND=r8) :: qsic(mgncol,nlev) ! in-precip snow - REAL(KIND=r8) :: qric(mgncol,nlev) ! in-precip rain - ! number concentrations - REAL(KIND=r8) :: ncic(mgncol,nlev) ! in-cloud droplet - REAL(KIND=r8) :: niic(mgncol,nlev) ! in-cloud cloud ice - REAL(KIND=r8) :: nsic(mgncol,nlev) ! in-precip snow - REAL(KIND=r8) :: nric(mgncol,nlev) ! in-precip rain - ! maximum allowed ni value - REAL(KIND=r8) :: nimax(mgncol,nlev) - ! Size distribution parameters for: - ! cloud ice - REAL(KIND=r8) :: lami(mgncol,nlev) ! slope - REAL(KIND=r8) :: n0i(mgncol,nlev) ! intercept - ! cloud liquid - REAL(KIND=r8) :: lamc(mgncol,nlev) ! slope - REAL(KIND=r8) :: pgam(mgncol,nlev) ! spectral width parameter - ! snow - REAL(KIND=r8) :: lams(mgncol,nlev) ! slope - REAL(KIND=r8) :: n0s(mgncol,nlev) ! intercept - ! rain - REAL(KIND=r8) :: lamr(mgncol,nlev) ! slope - REAL(KIND=r8) :: n0r(mgncol,nlev) ! intercept - ! Rates/tendencies due to: - ! Instantaneous snow melting - REAL(KIND=r8) :: minstsm(mgncol,nlev) ! mass mixing ratio - REAL(KIND=r8) :: ninstsm(mgncol,nlev) ! number concentration - ! Instantaneous rain freezing - REAL(KIND=r8) :: minstrf(mgncol,nlev) ! mass mixing ratio - REAL(KIND=r8) :: ninstrf(mgncol,nlev) ! number concentration - ! deposition of cloud ice - REAL(KIND=r8) :: vap_dep(mgncol,nlev) ! deposition from vapor to ice PMC 12/3/12 - ! sublimation of cloud ice - REAL(KIND=r8) :: ice_sublim(mgncol,nlev) ! sublimation from ice to vapor PMC 12/3/12 - ! ice nucleation - REAL(KIND=r8) :: nnuccd(mgncol,nlev) ! number rate from deposition/cond.-freezing - REAL(KIND=r8) :: mnuccd(mgncol,nlev) ! mass mixing ratio - ! freezing of cloud water - REAL(KIND=r8) :: mnuccc(mgncol,nlev) ! mass mixing ratio - REAL(KIND=r8) :: nnuccc(mgncol,nlev) ! number concentration - ! contact freezing of cloud water - REAL(KIND=r8) :: mnucct(mgncol,nlev) ! mass mixing ratio - REAL(KIND=r8) :: nnucct(mgncol,nlev) ! number concentration - ! deposition nucleation in mixed-phase clouds (from external scheme) - REAL(KIND=r8) :: mnudep(mgncol,nlev) ! mass mixing ratio - REAL(KIND=r8) :: nnudep(mgncol,nlev) ! number concentration - ! ice multiplication - REAL(KIND=r8) :: msacwi(mgncol,nlev) ! mass mixing ratio - REAL(KIND=r8) :: nsacwi(mgncol,nlev) ! number concentration - ! autoconversion of cloud droplets - REAL(KIND=r8) :: prc(mgncol,nlev) ! mass mixing ratio - REAL(KIND=r8) :: nprc(mgncol,nlev) ! number concentration (rain) - REAL(KIND=r8) :: nprc1(mgncol,nlev) ! number concentration (cloud droplets) - ! self-aggregation of snow - REAL(KIND=r8) :: nsagg(mgncol,nlev) ! number concentration - ! self-collection of rain - REAL(KIND=r8) :: nragg(mgncol,nlev) ! number concentration - ! collection of droplets by snow - REAL(KIND=r8) :: psacws(mgncol,nlev) ! mass mixing ratio - REAL(KIND=r8) :: npsacws(mgncol,nlev) ! number concentration - ! collection of rain by snow - REAL(KIND=r8) :: pracs(mgncol,nlev) ! mass mixing ratio - REAL(KIND=r8) :: npracs(mgncol,nlev) ! number concentration - ! freezing of rain - REAL(KIND=r8) :: mnuccr(mgncol,nlev) ! mass mixing ratio - REAL(KIND=r8) :: nnuccr(mgncol,nlev) ! number concentration - ! freezing of rain to form ice (mg add 4/26/13) - REAL(KIND=r8) :: mnuccri(mgncol,nlev) ! mass mixing ratio - REAL(KIND=r8) :: nnuccri(mgncol,nlev) ! number concentration - ! accretion of droplets by rain - REAL(KIND=r8) :: pra(mgncol,nlev) ! mass mixing ratio - REAL(KIND=r8) :: npra(mgncol,nlev) ! number concentration - ! autoconversion of cloud ice to snow - REAL(KIND=r8) :: prci(mgncol,nlev) ! mass mixing ratio - REAL(KIND=r8) :: nprci(mgncol,nlev) ! number concentration - ! accretion of cloud ice by snow - REAL(KIND=r8) :: prai(mgncol,nlev) ! mass mixing ratio - REAL(KIND=r8) :: nprai(mgncol,nlev) ! number concentration - ! evaporation of rain - REAL(KIND=r8) :: pre(mgncol,nlev) ! mass mixing ratio - ! sublimation of snow - REAL(KIND=r8) :: prds(mgncol,nlev) ! mass mixing ratio - ! number evaporation - REAL(KIND=r8) :: nsubi(mgncol,nlev) ! cloud ice - REAL(KIND=r8) :: nsubc(mgncol,nlev) ! droplet - REAL(KIND=r8) :: nsubs(mgncol,nlev) ! snow - REAL(KIND=r8) :: nsubr(mgncol,nlev) ! rain - ! bergeron process - REAL(KIND=r8) :: berg(mgncol,nlev) ! mass mixing ratio (cloud ice) - REAL(KIND=r8) :: bergs(mgncol,nlev) ! mass mixing ratio (snow) - ! fallspeeds - ! number-weighted - REAL(KIND=r8) :: uns(mgncol,nlev) ! snow - REAL(KIND=r8) :: unr(mgncol,nlev) ! rain - ! air density corrected fallspeed parameters - REAL(KIND=r8) :: arn(mgncol,nlev) ! rain - REAL(KIND=r8) :: asn(mgncol,nlev) ! snow - REAL(KIND=r8) :: acn(mgncol,nlev) ! cloud droplet - REAL(KIND=r8) :: ain(mgncol,nlev) ! cloud ice - ! Mass of liquid droplets used with external heterogeneous freezing. - REAL(KIND=r8) :: mi0l(mgncol) - ! saturation vapor pressures - REAL(KIND=r8) :: esl(mgncol,nlev) ! liquid - REAL(KIND=r8) :: esi(mgncol,nlev) ! ice - REAL(KIND=r8) :: esn ! checking for RH after rain evap - ! saturation vapor mixing ratios - REAL(KIND=r8) :: qvl(mgncol,nlev) ! liquid - REAL(KIND=r8) :: qvi(mgncol,nlev) ! ice - REAL(KIND=r8) :: qvn ! checking for RH after rain evap - ! relative humidity - REAL(KIND=r8) :: relhum(mgncol,nlev) - ! parameters for cloud water and cloud ice sedimentation calculations - REAL(KIND=r8) :: fc(nlev) - REAL(KIND=r8) :: fnc(nlev) - REAL(KIND=r8) :: fi(nlev) - REAL(KIND=r8) :: fni(nlev) - REAL(KIND=r8) :: fr(nlev) - REAL(KIND=r8) :: fnr(nlev) - REAL(KIND=r8) :: fs(nlev) - REAL(KIND=r8) :: fns(nlev) - REAL(KIND=r8) :: faloutc(nlev) - REAL(KIND=r8) :: faloutnc(nlev) - REAL(KIND=r8) :: falouti(nlev) - REAL(KIND=r8) :: faloutni(nlev) - REAL(KIND=r8) :: faloutr(nlev) - REAL(KIND=r8) :: faloutnr(nlev) - REAL(KIND=r8) :: falouts(nlev) - REAL(KIND=r8) :: faloutns(nlev) - REAL(KIND=r8) :: faltndc - REAL(KIND=r8) :: faltndnc - REAL(KIND=r8) :: faltndi - REAL(KIND=r8) :: faltndni - REAL(KIND=r8) :: faltndqie - REAL(KIND=r8) :: faltndqce - REAL(KIND=r8) :: faltndr - REAL(KIND=r8) :: faltndnr - REAL(KIND=r8) :: faltnds - REAL(KIND=r8) :: faltndns - REAL(KIND=r8) :: rainrt(mgncol,nlev) ! rain rate for reflectivity calculation - ! dummy variables - REAL(KIND=r8) :: dum - REAL(KIND=r8) :: dum1 - REAL(KIND=r8) :: dum2 - ! dummies for checking RH - REAL(KIND=r8) :: qtmp - REAL(KIND=r8) :: ttmp - ! dummies for conservation check - REAL(KIND=r8) :: ratio - REAL(KIND=r8) :: tmpfrz - ! dummies for in-cloud variables - REAL(KIND=r8) :: dumc(mgncol,nlev) ! qc - REAL(KIND=r8) :: dumnc(mgncol,nlev) ! nc - REAL(KIND=r8) :: dumi(mgncol,nlev) ! qi - REAL(KIND=r8) :: dumni(mgncol,nlev) ! ni - REAL(KIND=r8) :: dumr(mgncol,nlev) ! rain mixing ratio - REAL(KIND=r8) :: dumnr(mgncol,nlev) ! rain number concentration - REAL(KIND=r8) :: dums(mgncol,nlev) ! snow mixing ratio - REAL(KIND=r8) :: dumns(mgncol,nlev) ! snow number concentration - ! Array dummy variable - REAL(KIND=r8) :: dum_2d(mgncol,nlev) - ! loop array variables - ! "i" and "k" are column/level iterators for internal (MG) variables - ! "n" is used for other looping (currently just sedimentation) - INTEGER :: k - INTEGER :: i - INTEGER :: n - ! number of sub-steps for loops over "n" (for sedimentation) - INTEGER :: nstep - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! default return error message - errstring = ' ' - IF (.not. (do_cldice .or. (associated(tnd_qsnow) .and. associated(tnd_nsnow) .and. associated(re_ice)))) THEN - errstring = "MG's native cloud ice processes are disabled, but no replacement values were passed in." - END IF - IF (use_hetfrz_classnuc .and. (.not. (associated(frzimm) .and. associated(frzcnt) .and. associated(frzdep)))) THEN - errstring = "External heterogeneous freezing is enabled, but the required tendencies were not all passed in." - END IF - ! Process inputs - ! assign variable deltat to deltatin - deltat = deltatin - ! Copies of input concentrations that may be changed internally. - qc = qcn - nc = ncn - qi = qin - ni = nin - qr = qrn - nr = nrn - qs = qsn - ns = nsn - ! cldn: used to set cldm, unused for subcolumns - ! liqcldf: used to set lcldm, unused for subcolumns - ! icecldf: used to set icldm, unused for subcolumns - IF (microp_uniform) THEN - ! subcolumns, set cloud fraction variables to one - ! if cloud water or ice is present, if not present - ! set to mincld (mincld used instead of zero, to prevent - ! possible division by zero errors). - WHERE ( qc >= qsmall ) - lcldm = 1._r8 - ELSEWHERE - lcldm = mincld - END WHERE - WHERE ( qi >= qsmall ) - icldm = 1._r8 - ELSEWHERE - icldm = mincld - END WHERE - cldm = max(icldm, lcldm) - ELSE - ! get cloud fraction, check for minimum - cldm = max(cldn,mincld) - lcldm = max(liqcldf,mincld) - icldm = max(icecldf,mincld) - END IF - ! Initialize local variables - ! local physical properties - rho = p/(r*t) - dv = 8.794e-5_r8 * t**1.81_r8 / p - mu = 1.496e-6_r8 * t**1.5_r8 / (t + 120._r8) - sc = mu/(rho*dv) - ! air density adjustment for fallspeed parameters - ! includes air density correction factor to the - ! power of 0.54 following Heymsfield and Bansemer 2007 - rhof = (rhosu/rho)**0.54_r8 - arn = ar*rhof - asn = as*rhof - acn = g*rhow/(18._r8*mu) - ain = ai*(rhosu/rho)**0.35_r8 - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! Get humidity and saturation vapor pressures - DO k=1,nlev - DO i=1,mgncol - CALL qsat_water(t(i,k), p(i,k), esl(i,k), qvl(i,k)) - ! make sure when above freezing that esi=esl, not active yet - IF (t(i,k) >= tmelt) THEN - esi(i,k) = esl(i,k) - qvi(i,k) = qvl(i,k) - ELSE - CALL qsat_ice(t(i,k), p(i,k), esi(i,k), qvi(i,k)) - END IF - END DO - END DO - relhum = q / max(qvl, qsmall) - !=============================================== - ! set mtime here to avoid answer-changing - mtime = deltat - ! initialize microphysics output - qcsevap = 0._r8 - qisevap = 0._r8 - qvres = 0._r8 - cmeitot = 0._r8 - vtrmc = 0._r8 - vtrmi = 0._r8 - qcsedten = 0._r8 - qisedten = 0._r8 - qrsedten = 0._r8 - qssedten = 0._r8 - pratot = 0._r8 - prctot = 0._r8 - mnuccctot = 0._r8 - mnuccttot = 0._r8 - msacwitot = 0._r8 - psacwstot = 0._r8 - bergstot = 0._r8 - bergtot = 0._r8 - melttot = 0._r8 - homotot = 0._r8 - qcrestot = 0._r8 - prcitot = 0._r8 - praitot = 0._r8 - qirestot = 0._r8 - mnuccrtot = 0._r8 - pracstot = 0._r8 - meltsdttot = 0._r8 - frzrdttot = 0._r8 - mnuccdtot = 0._r8 - rflx = 0._r8 - sflx = 0._r8 - ! initialize precip output - qrout = 0._r8 - qsout = 0._r8 - nrout = 0._r8 - nsout = 0._r8 - ! for refl calc - rainrt = 0._r8 - ! initialize rain size - rercld = 0._r8 - qcsinksum_rate1ord = 0._r8 - ! initialize variables for trop_mozart - nevapr = 0._r8 - prer_evap = 0._r8 - evapsnow = 0._r8 - prain = 0._r8 - prodsnow = 0._r8 - cmeout = 0._r8 - precip_frac = mincld - lamc = 0._r8 - ! initialize microphysical tendencies - tlat = 0._r8 - qvlat = 0._r8 - qctend = 0._r8 - qitend = 0._r8 - qstend = 0._r8 - qrtend = 0._r8 - nctend = 0._r8 - nitend = 0._r8 - nrtend = 0._r8 - nstend = 0._r8 - ! initialize in-cloud and in-precip quantities to zero - qcic = 0._r8 - qiic = 0._r8 - qsic = 0._r8 - qric = 0._r8 - ncic = 0._r8 - niic = 0._r8 - nsic = 0._r8 - nric = 0._r8 - ! initialize precip at surface - prect = 0._r8 - preci = 0._r8 - ! initialize precip fallspeeds to zero - ums = 0._r8 - uns = 0._r8 - umr = 0._r8 - unr = 0._r8 - ! initialize limiter for output - qcrat = 1._r8 - ! Many outputs have to be initialized here at the top to work around - ! ifort problems, even if they are always overwritten later. - effc = 10._r8 - lamcrad = 0._r8 - pgamrad = 0._r8 - effc_fn = 10._r8 - effi = 25._r8 - deffi = 50._r8 - qrout2 = 0._r8 - nrout2 = 0._r8 - drout2 = 0._r8 - qsout2 = 0._r8 - nsout2 = 0._r8 - dsout = 0._r8 - dsout2 = 0._r8 - freqr = 0._r8 - freqs = 0._r8 - reff_rain = 0._r8 - reff_snow = 0._r8 - refl = -9999._r8 - arefl = 0._r8 - areflz = 0._r8 - frefl = 0._r8 - csrfl = 0._r8 - acsrfl = 0._r8 - fcsrfl = 0._r8 - ncal = 0._r8 - ncai = 0._r8 - nfice = 0._r8 - !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! droplet activation - ! get provisional droplet number after activation. This is used for - ! all microphysical process calculations, for consistency with update of - ! droplet mass before microphysics - ! calculate potential for droplet activation if cloud water is present - ! tendency from activation (npccn) is read in from companion routine - ! output activated liquid and ice (convert from #/kg -> #/m3) - !-------------------------------------------------- - WHERE ( qc >= qsmall ) - nc = max(nc + npccn*deltat, 0._r8) - ncal = nc*rho/lcldm ! sghan minimum in #/cm3 - ELSEWHERE - ncal = 0._r8 - END WHERE - WHERE ( t < icenuct ) - ncai = naai*rho - ELSEWHERE - ncai = 0._r8 - END WHERE - !=============================================== - ! ice nucleation if activated nuclei exist at t<-5C AND rhmini + 5% - !------------------------------------------------------- - IF (do_cldice) THEN - WHERE ( naai > 0._r8 .and. t < icenuct .and. relhum*esl/esi > rhmini+0.05_r8 ) - !if NAAI > 0. then set numice = naai (as before) - !note: this is gridbox averaged - nnuccd = (naai-ni/icldm)/mtime*icldm - nnuccd = max(nnuccd,0._r8) - nimax = naai*icldm - !Calc mass of new particles using new crystal mass... - !also this will be multiplied by mtime as nnuccd is... - mnuccd = nnuccd * mi0 - ELSEWHERE - nnuccd = 0._r8 - nimax = 0._r8 - mnuccd = 0._r8 - END WHERE - END IF - !============================================================================= - pre_vert_loop: DO k=1,nlev - pre_col_loop: DO i=1,mgncol - ! calculate instantaneous precip processes (melting and homogeneous freezing) - ! melting of snow at +2 C - IF (t(i,k) > snowmelt) THEN - IF (qs(i,k) > 0._r8) THEN - ! make sure melting snow doesn't reduce temperature below threshold - dum = -xlf/cpp*qs(i,k) - IF (t(i,k)+dum < snowmelt) THEN - dum = (t(i,k)-snowmelt)*cpp/xlf - dum = dum/qs(i,k) - dum = max(0._r8,dum) - dum = min(1._r8,dum) - ELSE - dum = 1._r8 - END IF - minstsm(i,k) = dum*qs(i,k) - ninstsm(i,k) = dum*ns(i,k) - dum1 = -xlf*minstsm(i,k)/deltat - tlat(i,k) = tlat(i,k)+dum1 - meltsdttot(i,k) = meltsdttot(i,k) + dum1 - qs(i,k) = max(qs(i,k) - minstsm(i,k), 0._r8) - ns(i,k) = max(ns(i,k) - ninstsm(i,k), 0._r8) - qr(i,k) = max(qr(i,k) + minstsm(i,k), 0._r8) - nr(i,k) = max(nr(i,k) + ninstsm(i,k), 0._r8) - END IF - END IF - ! freezing of rain at -5 C - IF (t(i,k) < rainfrze) THEN - IF (qr(i,k) > 0._r8) THEN - ! make sure freezing rain doesn't increase temperature above threshold - dum = xlf/cpp*qr(i,k) - IF (t(i,k)+dum > rainfrze) THEN - dum = -(t(i,k)-rainfrze)*cpp/xlf - dum = dum/qr(i,k) - dum = max(0._r8,dum) - dum = min(1._r8,dum) - ELSE - dum = 1._r8 - END IF - minstrf(i,k) = dum*qr(i,k) - ninstrf(i,k) = dum*nr(i,k) - ! heating tendency - dum1 = xlf*minstrf(i,k)/deltat - tlat(i,k) = tlat(i,k)+dum1 - frzrdttot(i,k) = frzrdttot(i,k) + dum1 - qr(i,k) = max(qr(i,k) - minstrf(i,k), 0._r8) - nr(i,k) = max(nr(i,k) - ninstrf(i,k), 0._r8) - qs(i,k) = max(qs(i,k) + minstrf(i,k), 0._r8) - ns(i,k) = max(ns(i,k) + ninstrf(i,k), 0._r8) - END IF - END IF - ! obtain in-cloud values of cloud water/ice mixing ratios and number concentrations - !------------------------------------------------------- - ! for microphysical process calculations - ! units are kg/kg for mixing ratio, 1/kg for number conc - IF (qc(i,k).ge.qsmall) THEN - ! limit in-cloud values to 0.005 kg/kg - qcic(i,k) = min(qc(i,k)/lcldm(i,k),5.e-3_r8) - ncic(i,k) = max(nc(i,k)/lcldm(i,k),0._r8) - ! specify droplet concentration - IF (nccons) THEN - ncic(i,k) = ncnst/rho(i,k) - END IF - ELSE - qcic(i,k) = 0._r8 - ncic(i,k) = 0._r8 - END IF - IF (qi(i,k).ge.qsmall) THEN - ! limit in-cloud values to 0.005 kg/kg - qiic(i,k) = min(qi(i,k)/icldm(i,k),5.e-3_r8) - niic(i,k) = max(ni(i,k)/icldm(i,k),0._r8) - ! switch for specification of cloud ice number - IF (nicons) THEN - niic(i,k) = ninst/rho(i,k) - END IF - ELSE - qiic(i,k) = 0._r8 - niic(i,k) = 0._r8 - END IF - END DO pre_col_loop - END DO pre_vert_loop - !======================================================================== - ! for sub-columns cldm has already been set to 1 if cloud - ! water or ice is present, so precip_frac will be correctly set below - ! and nothing extra needs to be done here - precip_frac = cldm - micro_vert_loop: DO k=1,nlev - IF (trim(micro_mg_precip_frac_method) == 'in_cloud') THEN - IF (k /= 1) THEN - WHERE ( qc(:,k) < qsmall .and. qi(:,k) < qsmall ) - precip_frac(:,k) = precip_frac(:,k-1) - END WHERE - END IF - ELSE IF (trim(micro_mg_precip_frac_method) == 'max_overlap') THEN - ! calculate precip fraction based on maximum overlap assumption - ! if rain or snow mix ratios are smaller than threshold, - ! then leave precip_frac as cloud fraction at current level - IF (k /= 1) THEN - WHERE ( qr(:,k-1) >= qsmall .or. qs(:,k-1) >= qsmall ) - precip_frac(:,k) = max(precip_frac(:,k-1),precip_frac(:,k)) - END WHERE - END IF - END IF - DO i = 1, mgncol - !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! get size distribution parameters based on in-cloud cloud water - ! these calculations also ensure consistency between number and mixing ratio - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! cloud liquid - !------------------------------------------- - CALL size_dist_param_liq(mg_liq_props, qcic(i,k), ncic(i,k), rho(i,k), pgam(i,k), lamc(i,k)) - END DO - !======================================================================== - ! autoconversion of cloud liquid water to rain - ! formula from Khrouditnov and Kogan (2000), modified for sub-grid distribution of qc - ! minimum qc of 1 x 10^-8 prevents floating point error - CALL kk2000_liq_autoconversion(microp_uniform, qcic(:,k), ncic(:,k), rho(:,k), relvar(:,k), prc(:,k), nprc(:,k), & - nprc1(:,k)) - ! assign qric based on prognostic qr, using assumed precip fraction - ! note: this could be moved above for consistency with qcic and qiic calculations - qric(:,k) = qr(:,k)/precip_frac(:,k) - nric(:,k) = nr(:,k)/precip_frac(:,k) - ! limit in-precip mixing ratios to 10 g/kg - qric(:,k) = min(qric(:,k),0.01_r8) - ! add autoconversion to precip from above to get provisional rain mixing ratio - ! and number concentration (qric and nric) - WHERE ( qric(:,k).lt.qsmall ) - qric(:,k) = 0._r8 - nric(:,k) = 0._r8 - END WHERE - ! make sure number concentration is a positive number to avoid - ! taking root of negative later - nric(:,k) = max(nric(:,k),0._r8) - ! Get size distribution parameters for cloud ice - CALL size_dist_param_basic(mg_ice_props, qiic(:,k), niic(:,k), lami(:,k), n0i(:,k)) - !....................................................................... - ! Autoconversion of cloud ice to snow - ! similar to Ferrier (1994) - IF (do_cldice) THEN - CALL ice_autoconversion(t(:,k), qiic(:,k), lami(:,k), n0i(:,k), dcs, prci(:,k), nprci(:,k)) - ELSE - ! Add in the particles that we have already converted to snow, and - ! don't do any further autoconversion of ice. - prci(:,k) = tnd_qsnow(:,k) / cldm(:,k) - nprci(:,k) = tnd_nsnow(:,k) / cldm(:,k) - END IF - ! note, currently we don't have this - ! inside the do_cldice block, should be changed later - ! assign qsic based on prognostic qs, using assumed precip fraction - qsic(:,k) = qs(:,k)/precip_frac(:,k) - nsic(:,k) = ns(:,k)/precip_frac(:,k) - ! limit in-precip mixing ratios to 10 g/kg - qsic(:,k) = min(qsic(:,k),0.01_r8) - ! if precip mix ratio is zero so should number concentration - WHERE ( qsic(:,k) < qsmall ) - qsic(:,k) = 0._r8 - nsic(:,k) = 0._r8 - END WHERE - ! make sure number concentration is a positive number to avoid - ! taking root of negative later - nsic(:,k) = max(nsic(:,k),0._r8) - !....................................................................... - ! get size distribution parameters for precip - !...................................................................... - ! rain - CALL size_dist_param_basic(mg_rain_props, qric(:,k), nric(:,k), lamr(:,k), n0r(:,k)) - WHERE ( lamr(:,k) >= qsmall ) - ! provisional rain number and mass weighted mean fallspeed (m/s) - unr(:,k) = min(arn(:,k)*gamma_br_plus1/lamr(:,k)**br,9.1_r8*rhof(:,k)) - umr(:,k) = min(arn(:,k)*gamma_br_plus4/(6._r8*lamr(:,k)**br),9.1_r8*rhof(:,k)) - ELSEWHERE - umr(:,k) = 0._r8 - unr(:,k) = 0._r8 - END WHERE - !...................................................................... - ! snow - CALL size_dist_param_basic(mg_snow_props, qsic(:,k), nsic(:,k), lams(:,k), n0s(:,k)) - WHERE ( lams(:,k) > 0._r8 ) - ! provisional snow number and mass weighted mean fallspeed (m/s) - ums(:,k) = min(asn(:,k)*gamma_bs_plus4/(6._r8*lams(:,k)**bs),1.2_r8*rhof(:,k)) - uns(:,k) = min(asn(:,k)*gamma_bs_plus1/lams(:,k)**bs,1.2_r8*rhof(:,k)) - ELSEWHERE - ums(:,k) = 0._r8 - uns(:,k) = 0._r8 - END WHERE - IF (do_cldice) THEN - IF (.not. use_hetfrz_classnuc) THEN - ! heterogeneous freezing of cloud water - !---------------------------------------------- - CALL immersion_freezing(microp_uniform, t(:,k), pgam(:,k), lamc(:,k), qcic(:,k), ncic(:,k), relvar(:,k), & - mnuccc(:,k), nnuccc(:,k)) - ! make sure number of droplets frozen does not exceed available ice nuclei concentration - ! this prevents 'runaway' droplet freezing - WHERE ( qcic(:,k).ge.qsmall .and. t(:,k).lt.269.15_r8 ) - WHERE ( nnuccc(:,k)*lcldm(:,k).gt.nnuccd(:,k) ) - ! scale mixing ratio of droplet freezing with limit - mnuccc(:,k) = mnuccc(:,k)*(nnuccd(:,k)/(nnuccc(:,k)*lcldm(:,k))) - nnuccc(:,k) = nnuccd(:,k)/lcldm(:,k) - END WHERE - END WHERE - CALL contact_freezing(microp_uniform, t(:,k), p(:,k), rndst(:,k,:), nacon(:,k,:), pgam(:,k), lamc(:,k), & - qcic(:,k), ncic(:,k), relvar(:,k), mnucct(:,k), nnucct(:,k)) - mnudep(:,k) = 0._r8 - nnudep(:,k) = 0._r8 - ELSE - ! Mass of droplets frozen is the average droplet mass, except - ! with two limiters: concentration must be at least 1/cm^3, and - ! mass must be at least the minimum defined above. - mi0l = qcic(:,k)/max(ncic(:,k), 1.0e6_r8/rho(:,k)) - mi0l = max(mi0l_min, mi0l) - WHERE ( qcic(:,k) >= qsmall ) - nnuccc(:,k) = frzimm(:,k)*1.0e6_r8/rho(:,k) - mnuccc(:,k) = nnuccc(:,k)*mi0l - nnucct(:,k) = frzcnt(:,k)*1.0e6_r8/rho(:,k) - mnucct(:,k) = nnucct(:,k)*mi0l - nnudep(:,k) = frzdep(:,k)*1.0e6_r8/rho(:,k) - mnudep(:,k) = nnudep(:,k)*mi0 - ELSEWHERE - nnuccc(:,k) = 0._r8 - mnuccc(:,k) = 0._r8 - nnucct(:,k) = 0._r8 - mnucct(:,k) = 0._r8 - nnudep(:,k) = 0._r8 - mnudep(:,k) = 0._r8 - END WHERE - END IF - ELSE - mnuccc(:,k) = 0._r8 - nnuccc(:,k) = 0._r8 - mnucct(:,k) = 0._r8 - nnucct(:,k) = 0._r8 - mnudep(:,k) = 0._r8 - nnudep(:,k) = 0._r8 - END IF - CALL snow_self_aggregation(t(:,k), rho(:,k), asn(:,k), rhosn, qsic(:,k), nsic(:,k), nsagg(:,k)) - CALL accrete_cloud_water_snow(t(:,k), rho(:,k), asn(:,k), uns(:,k), mu(:,k), qcic(:,k), ncic(:,k), qsic(:,k), & - pgam(:,k), lamc(:,k), lams(:,k), n0s(:,k), psacws(:,k), npsacws(:,k)) - IF (do_cldice) THEN - CALL secondary_ice_production(t(:,k), psacws(:,k), msacwi(:,k), nsacwi(:,k)) - ELSE - nsacwi(:,k) = 0.0_r8 - msacwi(:,k) = 0.0_r8 - END IF - CALL accrete_rain_snow(t(:,k), rho(:,k), umr(:,k), ums(:,k), unr(:,k), uns(:,k), qric(:,k), qsic(:,k), lamr(:,k), & - n0r(:,k), lams(:,k), n0s(:,k), pracs(:,k), npracs(:,k)) - CALL heterogeneous_rain_freezing(t(:,k), qric(:,k), nric(:,k), lamr(:,k), mnuccr(:,k), nnuccr(:,k)) - CALL accrete_cloud_water_rain(microp_uniform, qric(:,k), qcic(:,k), ncic(:,k), relvar(:,k), accre_enhan(:,k), pra(& - :,k), npra(:,k)) - CALL self_collection_rain(rho(:,k), qric(:,k), nric(:,k), nragg(:,k)) - IF (do_cldice) THEN - CALL accrete_cloud_ice_snow(t(:,k), rho(:,k), asn(:,k), qiic(:,k), niic(:,k), qsic(:,k), lams(:,k), n0s(:,k), & - prai(:,k), nprai(:,k)) - ELSE - prai(:,k) = 0._r8 - nprai(:,k) = 0._r8 - END IF - CALL evaporate_sublimate_precip(t(:,k), rho(:,k), dv(:,k), mu(:,k), sc(:,k), q(:,k), qvl(:,k), qvi(:,k), lcldm(:,& - k), precip_frac(:,k), arn(:,k), asn(:,k), qcic(:,k), qiic(:,k), qric(:,k), qsic(:,k), lamr(:,k), n0r(:,k), lams(:,& - k), n0s(:,k), pre(:,k), prds(:,k)) - CALL bergeron_process_snow(t(:,k), rho(:,k), dv(:,k), mu(:,k), sc(:,k), qvl(:,k), qvi(:,k), asn(:,k), qcic(:,k), & - qsic(:,k), lams(:,k), n0s(:,k), bergs(:,k)) - bergs(:,k) = bergs(:,k)*micro_mg_berg_eff_factor - !+++PMC 12/3/12 - NEW VAPOR DEP/SUBLIMATION GOES HERE!!! - IF (do_cldice) THEN - CALL ice_deposition_sublimation(t(:,k), q(:,k), qi(:,k), ni(:,k), icldm(:,k), rho(:,k), dv(:,k), qvl(:,k), & - qvi(:,k), berg(:,k), vap_dep(:,k), ice_sublim(:,k)) - berg(:,k) = berg(:,k)*micro_mg_berg_eff_factor - WHERE ( vap_dep(:,k) < 0._r8 .and. qi(:,k) > qsmall .and. icldm(:,k) > mincld ) - nsubi(:,k) = vap_dep(:,k) / qi(:,k) * ni(:,k) / icldm(:,k) - ELSEWHERE - nsubi(:,k) = 0._r8 - END WHERE - ! bergeron process should not reduce nc unless - ! all ql is removed (which is handled elsewhere) - !in fact, nothing in this entire file makes nsubc nonzero. - nsubc(:,k) = 0._r8 - END IF !do_cldice - !---PMC 12/3/12 - DO i=1,mgncol - ! conservation to ensure no negative values of cloud water/precipitation - ! in case microphysical process rates are large - !=================================================================== - ! note: for check on conservation, processes are multiplied by omsm - ! to prevent problems due to round off error - ! conservation of qc - !------------------------------------------------------------------- - dum = ((prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k)+ psacws(i,k)+bergs(i,k))*lcldm(i,k)& - +berg(i,k))*deltat - IF (dum.gt.qc(i,k)) THEN - ratio = qc(i,k)/deltat/((prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+ msacwi(i,k)+psacws(i,& - k)+bergs(i,k))*lcldm(i,k)+berg(i,k))*omsm - prc(i,k) = prc(i,k)*ratio - pra(i,k) = pra(i,k)*ratio - mnuccc(i,k) = mnuccc(i,k)*ratio - mnucct(i,k) = mnucct(i,k)*ratio - msacwi(i,k) = msacwi(i,k)*ratio - psacws(i,k) = psacws(i,k)*ratio - bergs(i,k) = bergs(i,k)*ratio - berg(i,k) = berg(i,k)*ratio - qcrat(i,k) = ratio - ELSE - qcrat(i,k) = 1._r8 - END IF - !PMC 12/3/12: ratio is also frac of step w/ liquid. - !thus we apply berg for "ratio" of timestep and vapor - !deposition for the remaining frac of the timestep. - IF (qc(i,k) >= qsmall) THEN - vap_dep(i,k) = vap_dep(i,k)*(1._r8-qcrat(i,k)) - END IF - END DO - DO i=1,mgncol - !================================================================= - ! apply limiter to ensure that ice/snow sublimation and rain evap - ! don't push conditions into supersaturation, and ice deposition/nucleation don't - ! push conditions into sub-saturation - ! note this is done after qc conservation since we don't know how large - ! vap_dep is before then - ! estimates are only approximate since other process terms haven't been limited - ! for conservation yet - ! first limit ice deposition/nucleation vap_dep + mnuccd - dum1 = vap_dep(i,k) + mnuccd(i,k) - IF (dum1 > 1.e-20_r8) THEN - dum = (q(i,k)-qvi(i,k))/(1._r8 + xxls_squared*qvi(i,k)/(cpp*rv*t(i,k)**2))/deltat - dum = max(dum,0._r8) - IF (dum1 > dum) THEN - ! Allocate the limited "dum" tendency to mnuccd and vap_dep - ! processes. Don't divide by cloud fraction; these are grid- - ! mean rates. - dum1 = mnuccd(i,k) / (vap_dep(i,k)+mnuccd(i,k)) - mnuccd(i,k) = dum*dum1 - vap_dep(i,k) = dum - mnuccd(i,k) - END IF - END IF - END DO - DO i=1,mgncol - !=================================================================== - ! conservation of nc - !------------------------------------------------------------------- - dum = (nprc1(i,k)+npra(i,k)+nnuccc(i,k)+nnucct(i,k)+ npsacws(i,k)-nsubc(i,k))*lcldm(i,k)*deltat - IF (dum.gt.nc(i,k)) THEN - ratio = nc(i,k)/deltat/((nprc1(i,k)+npra(i,k)+nnuccc(i,k)+nnucct(i,k)+ npsacws(i,k)-nsubc(& - i,k))*lcldm(i,k))*omsm - nprc1(i,k) = nprc1(i,k)*ratio - npra(i,k) = npra(i,k)*ratio - nnuccc(i,k) = nnuccc(i,k)*ratio - nnucct(i,k) = nnucct(i,k)*ratio - npsacws(i,k) = npsacws(i,k)*ratio - nsubc(i,k) = nsubc(i,k)*ratio - END IF - mnuccri(i,k) = 0._r8 - nnuccri(i,k) = 0._r8 - IF (do_cldice) THEN - ! freezing of rain to produce ice if mean rain size is smaller than Dcs - IF (lamr(i,k) > qsmall .and. 1._r8/lamr(i,k) < dcs) THEN - mnuccri(i,k) = mnuccr(i,k) - nnuccri(i,k) = nnuccr(i,k) - mnuccr(i,k) = 0._r8 - nnuccr(i,k) = 0._r8 - END IF - END IF - END DO - DO i=1,mgncol - ! conservation of rain mixing ratio - !------------------------------------------------------------------- - dum = ((-pre(i,k)+pracs(i,k)+mnuccr(i,k)+mnuccri(i,k))*precip_frac(i,k)- (pra(i,k)+prc(i,k))& - *lcldm(i,k))*deltat - ! note that qrtend is included below because of instantaneous freezing/melt - IF (dum.gt.qr(i,k).and. (-pre(i,k)+pracs(i,k)+mnuccr(i,k)+mnuccri(i,k)).ge.qsmall) THEN - ratio = (qr(i,k)/deltat+(pra(i,k)+prc(i,k))*lcldm(i,k))/ precip_frac(i,k)/(-pre(i,k)& - +pracs(i,k)+mnuccr(i,k)+mnuccri(i,k))*omsm - pre(i,k) = pre(i,k)*ratio - pracs(i,k) = pracs(i,k)*ratio - mnuccr(i,k) = mnuccr(i,k)*ratio - mnuccri(i,k) = mnuccri(i,k)*ratio - END IF - END DO - DO i=1,mgncol - ! conservation of rain number - !------------------------------------------------------------------- - ! Add evaporation of rain number. - IF (pre(i,k) < 0._r8) THEN - dum = pre(i,k)*deltat/qr(i,k) - dum = max(-1._r8,dum) - nsubr(i,k) = dum*nr(i,k)/deltat - ELSE - nsubr(i,k) = 0._r8 - END IF - END DO - DO i=1,mgncol - dum = ((-nsubr(i,k)+npracs(i,k)+nnuccr(i,k)+nnuccri(i,k)-nragg(i,k))*precip_frac(i,k)- nprc(i,k)& - *lcldm(i,k))*deltat - IF (dum.gt.nr(i,k)) THEN - ratio = (nr(i,k)/deltat+nprc(i,k)*lcldm(i,k)/precip_frac(i,k))/ (-nsubr(i,k)+npracs(i,k)& - +nnuccr(i,k)+nnuccri(i,k)-nragg(i,k))*omsm - nragg(i,k) = nragg(i,k)*ratio - npracs(i,k) = npracs(i,k)*ratio - nnuccr(i,k) = nnuccr(i,k)*ratio - nsubr(i,k) = nsubr(i,k)*ratio - nnuccri(i,k) = nnuccri(i,k)*ratio - END IF - END DO - IF (do_cldice) THEN - DO i=1,mgncol - ! conservation of qi - !------------------------------------------------------------------- - dum = ((-mnuccc(i,k)-mnucct(i,k)-mnudep(i,k)-msacwi(i,k))*lcldm(i,k)+(prci(i,k)+ prai(i,k)& - )*icldm(i,k)-mnuccri(i,k)*precip_frac(i,k) -ice_sublim(i,k)-vap_dep(i,k)-berg(i,k)-mnuccd(& - i,k))*deltat - IF (dum.gt.qi(i,k)) THEN - ratio = (qi(i,k)/deltat+vap_dep(i,k)+berg(i,k)+mnuccd(i,k)+ (mnuccc(i,k)+mnucct(i,& - k)+mnudep(i,k)+msacwi(i,k))*lcldm(i,k)+ mnuccri(i,k)*precip_frac(i,k))/ & - ((prci(i,k)+prai(i,k))*icldm(i,k)-ice_sublim(i,k))*omsm - prci(i,k) = prci(i,k)*ratio - prai(i,k) = prai(i,k)*ratio - ice_sublim(i,k) = ice_sublim(i,k)*ratio - END IF - END DO - END IF - IF (do_cldice) THEN - DO i=1,mgncol - ! conservation of ni - !------------------------------------------------------------------- - IF (use_hetfrz_classnuc) THEN - tmpfrz = nnuccc(i,k) - ELSE - tmpfrz = 0._r8 - END IF - dum = ((-nnucct(i,k)-tmpfrz-nnudep(i,k)-nsacwi(i,k))*lcldm(i,k)+(nprci(i,k)+ nprai(i,k)& - -nsubi(i,k))*icldm(i,k)-nnuccri(i,k)*precip_frac(i,k)- nnuccd(i,k))*deltat - IF (dum.gt.ni(i,k)) THEN - ratio = (ni(i,k)/deltat+nnuccd(i,k)+ (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k))& - *lcldm(i,k)+ nnuccri(i,k)*precip_frac(i,k))/ ((nprci(i,k)+nprai(& - i,k)-nsubi(i,k))*icldm(i,k))*omsm - nprci(i,k) = nprci(i,k)*ratio - nprai(i,k) = nprai(i,k)*ratio - nsubi(i,k) = nsubi(i,k)*ratio - END IF - END DO - END IF - DO i=1,mgncol - ! conservation of snow mixing ratio - !------------------------------------------------------------------- - dum = (-(prds(i,k)+pracs(i,k)+mnuccr(i,k))*precip_frac(i,k)-(prai(i,k)+prci(i,k))*icldm(i,k) -(& - bergs(i,k)+psacws(i,k))*lcldm(i,k))*deltat - IF (dum.gt.qs(i,k).and.-prds(i,k).ge.qsmall) THEN - ratio = (qs(i,k)/deltat+(prai(i,k)+prci(i,k))*icldm(i,k)+ (bergs(i,k)+psacws(i,k))*lcldm(& - i,k)+(pracs(i,k)+mnuccr(i,k))*precip_frac(i,k))/ precip_frac(i,k)/(-prds(i,k))*omsm - prds(i,k) = prds(i,k)*ratio - END IF - END DO - DO i=1,mgncol - ! conservation of snow number - !------------------------------------------------------------------- - ! calculate loss of number due to sublimation - ! for now neglect sublimation of ns - nsubs(i,k) = 0._r8 - dum = ((-nsagg(i,k)-nsubs(i,k)-nnuccr(i,k))*precip_frac(i,k)-nprci(i,k)*icldm(i,k))*deltat - IF (dum.gt.ns(i,k)) THEN - ratio = (ns(i,k)/deltat+nnuccr(i,k)* precip_frac(i,k)+nprci(i,k)*icldm(i,k))/precip_frac(& - i,k)/ (-nsubs(i,k)-nsagg(i,k))*omsm - nsubs(i,k) = nsubs(i,k)*ratio - nsagg(i,k) = nsagg(i,k)*ratio - END IF - END DO - DO i=1,mgncol - ! next limit ice and snow sublimation and rain evaporation - ! get estimate of q and t at end of time step - ! don't include other microphysical processes since they haven't - ! been limited via conservation checks yet - IF ((pre(i,k)+prds(i,k))*precip_frac(i,k)+ice_sublim(i,k) < -1.e-20_r8) THEN - qtmp = q(i,k)-(ice_sublim(i,k)+vap_dep(i,k)+mnuccd(i,k)+ (pre(i,k)+prds(i,k))*precip_frac(& - i,k))*deltat - ttmp = t(i,k)+((pre(i,k)*precip_frac(i,k))*xxlv+ (prds(i,k)*precip_frac(i,k)+vap_dep(i,k)& - +ice_sublim(i,k)+mnuccd(i,k))*xxls)*deltat/cpp - ! use rhw to allow ice supersaturation - CALL qsat_water(ttmp, p(i,k), esn, qvn) - ! modify ice/precip evaporation rate if q > qsat - IF (qtmp > qvn) THEN - dum1 = pre(i,k)*precip_frac(i,k)/((pre(i,k)+prds(i,k))*precip_frac(i,k)+ice_sublim(i,k)) - dum2 = prds(i,k)*precip_frac(i,k)/((pre(i,k)+prds(i,k))*precip_frac(i,k)+ice_sublim(i,k)) - ! recalculate q and t after vap_dep and mnuccd but without evap or sublim - qtmp = q(i,k)-(vap_dep(i,k)+mnuccd(i,k))*deltat - ttmp = t(i,k)+((vap_dep(i,k)+mnuccd(i,k))*xxls)*deltat/cpp - ! use rhw to allow ice supersaturation - CALL qsat_water(ttmp, p(i,k), esn, qvn) - dum = (qtmp-qvn)/(1._r8 + xxlv_squared*qvn/(cpp*rv*ttmp**2)) - dum = min(dum,0._r8) - ! modify rates if needed, divide by precip_frac to get local (in-precip) value - pre(i,k) = dum*dum1/deltat/precip_frac(i,k) - ! do separately using RHI for prds and ice_sublim - CALL qsat_ice(ttmp, p(i,k), esn, qvn) - dum = (qtmp-qvn)/(1._r8 + xxls_squared*qvn/(cpp*rv*ttmp**2)) - dum = min(dum,0._r8) - ! modify rates if needed, divide by precip_frac to get local (in-precip) value - prds(i,k) = dum*dum2/deltat/precip_frac(i,k) - ! don't divide ice_sublim by cloud fraction since it is grid-averaged - dum1 = (1._r8-dum1-dum2) - ice_sublim(i,k) = dum*dum1/deltat - END IF - END IF - END DO - ! Big "administration" loop enforces conservation, updates variables - ! that accumulate over substeps, and sets output variables. - DO i=1,mgncol - ! get tendencies due to microphysical conversion processes - !========================================================== - ! note: tendencies are multiplied by appropriate cloud/precip - ! fraction to get grid-scale values - ! note: vap_dep is already grid-average values - ! The net tendencies need to be added to rather than overwritten, - ! because they may have a value already set for instantaneous - ! melting/freezing. - qvlat(i,k) = qvlat(i,k)-(pre(i,k)+prds(i,k))*precip_frac(i,k)- vap_dep(i,k)-ice_sublim(i,k)& - -mnuccd(i,k)-mnudep(i,k)*lcldm(i,k) - tlat(i,k) = tlat(i,k)+((pre(i,k)*precip_frac(i,k)) *xxlv+(prds(i,k)*precip_frac(i,k)+vap_dep(i,k)& - +ice_sublim(i,k)+mnuccd(i,k)+mnudep(i,k)*lcldm(i,k))*xxls+ ((bergs(i,k)+psacws(i,k)+mnuccc(i,k)& - +mnucct(i,k)+msacwi(i,k))*lcldm(i,k)+(mnuccr(i,k)+ pracs(i,k)+mnuccri(i,k))*precip_frac(i,k)& - +berg(i,k))*xlf) - qctend(i,k) = qctend(i,k)+ (-pra(i,k)-prc(i,k)-mnuccc(i,k)-mnucct(i,k)-msacwi(i,k)- & - psacws(i,k)-bergs(i,k))*lcldm(i,k)-berg(i,k) - IF (do_cldice) THEN - qitend(i,k) = qitend(i,k)+ (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k))*lcldm(i,k)+(& - -prci(i,k)- prai(i,k))*icldm(i,k)+vap_dep(i,k)+berg(i,k)+ice_sublim(i,k)+ & - mnuccd(i,k)+mnuccri(i,k)*precip_frac(i,k) - END IF - qrtend(i,k) = qrtend(i,k)+ (pra(i,k)+prc(i,k))*lcldm(i,k)+(pre(i,k)-pracs(i,k)- & - mnuccr(i,k)-mnuccri(i,k))*precip_frac(i,k) - qstend(i,k) = qstend(i,k)+ (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+(& - prds(i,k)+ pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) - cmeout(i,k) = vap_dep(i,k) + ice_sublim(i,k) + mnuccd(i,k) - ! add output for cmei (accumulate) - cmeitot(i,k) = vap_dep(i,k) + ice_sublim(i,k) + mnuccd(i,k) - ! assign variables for trop_mozart, these are grid-average - !------------------------------------------------------------------- - ! evaporation/sublimation is stored here as positive term - evapsnow(i,k) = -prds(i,k)*precip_frac(i,k) - nevapr(i,k) = -pre(i,k)*precip_frac(i,k) - prer_evap(i,k) = -pre(i,k)*precip_frac(i,k) - ! change to make sure prain is positive: do not remove snow from - ! prain used for wet deposition - prain(i,k) = (pra(i,k)+prc(i,k))*lcldm(i,k)+(-pracs(i,k)- mnuccr(i,k)-mnuccri(i,k))*precip_frac(& - i,k) - prodsnow(i,k) = (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+(pracs(i,k)+mnuccr(i,k))& - *precip_frac(i,k) - ! following are used to calculate 1st order conversion rate of cloud water - ! to rain and snow (1/s), for later use in aerosol wet removal routine - ! previously, wetdepa used (prain/qc) for this, and the qc in wetdepa may be smaller than the qc - ! used to calculate pra, prc, ... in this routine - ! qcsinksum_rate1ord = { rate of direct transfer of cloud water to rain & snow } - ! (no cloud ice or bergeron terms) - qcsinksum_rate1ord(i,k) = (pra(i,k)+prc(i,k)+psacws(i,k))*lcldm(i,k) - ! Avoid zero/near-zero division. - qcsinksum_rate1ord(i,k) = qcsinksum_rate1ord(i,k) / max(qc(i,k),1.0e-30_r8) - ! microphysics output, note this is grid-averaged - pratot(i,k) = pra(i,k)*lcldm(i,k) - prctot(i,k) = prc(i,k)*lcldm(i,k) - mnuccctot(i,k) = mnuccc(i,k)*lcldm(i,k) - mnuccttot(i,k) = mnucct(i,k)*lcldm(i,k) - msacwitot(i,k) = msacwi(i,k)*lcldm(i,k) - psacwstot(i,k) = psacws(i,k)*lcldm(i,k) - bergstot(i,k) = bergs(i,k)*lcldm(i,k) - bergtot(i,k) = berg(i,k) - prcitot(i,k) = prci(i,k)*icldm(i,k) - praitot(i,k) = prai(i,k)*icldm(i,k) - mnuccdtot(i,k) = mnuccd(i,k)*icldm(i,k) - pracstot(i,k) = pracs(i,k)*precip_frac(i,k) - mnuccrtot(i,k) = mnuccr(i,k)*precip_frac(i,k) - nctend(i,k) = nctend(i,k)+ (-nnuccc(i,k)-nnucct(i,k)-npsacws(i,k)+nsubc(i,k) -npra(i,& - k)-nprc1(i,k))*lcldm(i,k) - IF (do_cldice) THEN - IF (use_hetfrz_classnuc) THEN - tmpfrz = nnuccc(i,k) - ELSE - tmpfrz = 0._r8 - END IF - nitend(i,k) = nitend(i,k)+ nnuccd(i,k)+ (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k))& - *lcldm(i,k)+(nsubi(i,k)-nprci(i,k)- nprai(i,k))*icldm(i,k)+nnuccri(i,k)*precip_frac(i,k) - END IF - nstend(i,k) = nstend(i,k)+(nsubs(i,k)+ nsagg(i,k)+nnuccr(i,k))*precip_frac(i,k)+nprci(i,k)*icldm(& - i,k) - nrtend(i,k) = nrtend(i,k)+ nprc(i,k)*lcldm(i,k)+(nsubr(i,k)-npracs(i,k)-nnuccr(i,k) & - -nnuccri(i,k)+nragg(i,k))*precip_frac(i,k) - ! make sure that ni at advanced time step does not exceed - ! maximum (existing N + source terms*dt), which is possible if mtime < deltat - ! note that currently mtime = deltat - !================================================================ - IF (do_cldice .and. nitend(i,k).gt.0._r8.and.ni(i,k)+nitend(i,k)*deltat.gt.nimax(i,k)) THEN - nitend(i,k) = max(0._r8,(nimax(i,k)-ni(i,k))/deltat) - END IF - END DO - ! End of "administration" loop - END DO micro_vert_loop ! end k loop - !----------------------------------------------------- - ! convert rain/snow q and N for output to history, note, - ! output is for gridbox average - qrout = qr - nrout = nr * rho - qsout = qs - nsout = ns * rho - ! calculate precip fluxes - ! calculate the precip flux (kg/m2/s) as mixingratio(kg/kg)*airdensity(kg/m3)*massweightedfallspeed(m/s) - ! --------------------------------------------------------------------- - rflx(:,2:) = rflx(:,2:) + (qric*rho*umr*precip_frac) - sflx(:,2:) = sflx(:,2:) + (qsic*rho*ums*precip_frac) - ! calculate n0r and lamr from rain mass and number - ! divide by precip fraction to get in-precip (local) values of - ! rain mass and number, divide by rhow to get rain number in kg^-1 - CALL size_dist_param_basic(mg_rain_props, qric, nric, lamr, n0r) - ! Calculate rercld - ! calculate mean size of combined rain and cloud water - CALL calc_rercld(lamr, n0r, lamc, pgam, qric, qcic, ncic, rercld) - ! Assign variables back to start-of-timestep values - ! Some state variables are changed before the main microphysics loop - ! to make "instantaneous" adjustments. Afterward, we must move those changes - ! back into the tendencies. - ! These processes: - ! - Droplet activation (npccn, impacts nc) - ! - Instantaneous snow melting (minstsm/ninstsm, impacts qr/qs/nr/ns) - ! - Instantaneous rain freezing (minstfr/ninstrf, impacts qr/qs/nr/ns) - !================================================================================ - ! Re-apply droplet activation tendency - nc = ncn - nctend = nctend + npccn - ! Re-apply rain freezing and snow melting. - dum_2d = qs - qs = qsn - qstend = qstend + (dum_2d-qs)/deltat - dum_2d = ns - ns = nsn - nstend = nstend + (dum_2d-ns)/deltat - dum_2d = qr - qr = qrn - qrtend = qrtend + (dum_2d-qr)/deltat - dum_2d = nr - nr = nrn - nrtend = nrtend + (dum_2d-nr)/deltat - !............................................................................. - !================================================================================ - ! modify to include snow. in prain & evap (diagnostic here: for wet dep) - nevapr = nevapr + evapsnow - prain = prain + prodsnow - sed_col_loop: DO i=1,mgncol - DO k=1,nlev - ! calculate sedimentation for cloud water and ice - !================================================================================ - ! update in-cloud cloud mixing ratio and number concentration - ! with microphysical tendencies to calculate sedimentation, assign to dummy vars - ! note: these are in-cloud values***, hence we divide by cloud fraction - dumc(i,k) = (qc(i,k)+qctend(i,k)*deltat)/lcldm(i,k) - dumi(i,k) = (qi(i,k)+qitend(i,k)*deltat)/icldm(i,k) - dumnc(i,k) = max((nc(i,k)+nctend(i,k)*deltat)/lcldm(i,k),0._r8) - dumni(i,k) = max((ni(i,k)+nitend(i,k)*deltat)/icldm(i,k),0._r8) - dumr(i,k) = (qr(i,k)+qrtend(i,k)*deltat)/precip_frac(i,k) - dumnr(i,k) = max((nr(i,k)+nrtend(i,k)*deltat)/precip_frac(i,k),0._r8) - dums(i,k) = (qs(i,k)+qstend(i,k)*deltat)/precip_frac(i,k) - dumns(i,k) = max((ns(i,k)+nstend(i,k)*deltat)/precip_frac(i,k),0._r8) - ! switch for specification of droplet and crystal number - IF (nccons) THEN - dumnc(i,k) = ncnst/rho(i,k) - END IF - ! switch for specification of cloud ice number - IF (nicons) THEN - dumni(i,k) = ninst/rho(i,k) - END IF - ! obtain new slope parameter to avoid possible singularity - CALL size_dist_param_basic(mg_ice_props, dumi(i,k), dumni(i,k), lami(i,k)) - CALL size_dist_param_liq(mg_liq_props, dumc(i,k), dumnc(i,k), rho(i,k), pgam(i,k), lamc(i,k)) - ! calculate number and mass weighted fall velocity for droplets and cloud ice - !------------------------------------------------------------------- - IF (dumc(i,k).ge.qsmall) THEN - vtrmc(i,k) = acn(i,k)*gamma(4._r8+bc+pgam(i,k))/ (lamc(i,k)**bc*gamma(pgam(i,k)+4._r8)) - fc(k) = g*rho(i,k)*vtrmc(i,k) - fnc(k) = g*rho(i,k)* acn(i,k)*gamma(1._r8+bc+pgam(i,k))/ (lamc(i,k)& - **bc*gamma(pgam(i,k)+1._r8)) - ELSE - fc(k) = 0._r8 - fnc(k) = 0._r8 - END IF - ! calculate number and mass weighted fall velocity for cloud ice - IF (dumi(i,k).ge.qsmall) THEN - vtrmi(i,k) = min(ain(i,k)*gamma_bi_plus4/(6._r8*lami(i,k)**bi), 1.2_r8*rhof(i,k)) - fi(k) = g*rho(i,k)*vtrmi(i,k) - fni(k) = g*rho(i,k)* min(ain(i,k)*gamma_bi_plus1/lami(i,k)**bi,1.2_r8*rhof(i,k)) - ELSE - fi(k) = 0._r8 - fni(k) = 0._r8 - END IF - ! fallspeed for rain - CALL size_dist_param_basic(mg_rain_props, dumr(i,k), dumnr(i,k), lamr(i,k)) - IF (lamr(i,k).ge.qsmall) THEN - ! 'final' values of number and mass weighted mean fallspeed for rain (m/s) - unr(i,k) = min(arn(i,k)*gamma_br_plus1/lamr(i,k)**br,9.1_r8*rhof(i,k)) - umr(i,k) = min(arn(i,k)*gamma_br_plus4/(6._r8*lamr(i,k)**br),9.1_r8*rhof(i,k)) - fr(k) = g*rho(i,k)*umr(i,k) - fnr(k) = g*rho(i,k)*unr(i,k) - ELSE - fr(k) = 0._r8 - fnr(k) = 0._r8 - END IF - ! fallspeed for snow - CALL size_dist_param_basic(mg_snow_props, dums(i,k), dumns(i,k), lams(i,k)) - IF (lams(i,k).ge.qsmall) THEN - ! 'final' values of number and mass weighted mean fallspeed for snow (m/s) - ums(i,k) = min(asn(i,k)*gamma_bs_plus4/(6._r8*lams(i,k)**bs),1.2_r8*rhof(i,k)) - uns(i,k) = min(asn(i,k)*gamma_bs_plus1/lams(i,k)**bs,1.2_r8*rhof(i,k)) - fs(k) = g*rho(i,k)*ums(i,k) - fns(k) = g*rho(i,k)*uns(i,k) - ELSE - fs(k) = 0._r8 - fns(k) = 0._r8 - END IF - ! redefine dummy variables - sedimentation is calculated over grid-scale - ! quantities to ensure conservation - dumc(i,k) = (qc(i,k)+qctend(i,k)*deltat) - dumnc(i,k) = max((nc(i,k)+nctend(i,k)*deltat),0._r8) - dumi(i,k) = (qi(i,k)+qitend(i,k)*deltat) - dumni(i,k) = max((ni(i,k)+nitend(i,k)*deltat),0._r8) - dumr(i,k) = (qr(i,k)+qrtend(i,k)*deltat) - dumnr(i,k) = max((nr(i,k)+nrtend(i,k)*deltat),0._r8) - dums(i,k) = (qs(i,k)+qstend(i,k)*deltat) - dumns(i,k) = max((ns(i,k)+nstend(i,k)*deltat),0._r8) - IF (dumc(i,k).lt.qsmall) dumnc(i,k) = 0._r8 - IF (dumi(i,k).lt.qsmall) dumni(i,k) = 0._r8 - IF (dumr(i,k).lt.qsmall) dumnr(i,k) = 0._r8 - IF (dums(i,k).lt.qsmall) dumns(i,k) = 0._r8 - END DO !!! vertical loop - ! initialize nstep for sedimentation sub-steps - ! calculate number of split time steps to ensure courant stability criteria - ! for sedimentation calculations - !------------------------------------------------------------------- - nstep = 1 + int(max( maxval( fi/pdel(i,:)), maxval(fni/pdel(i,:))) * deltat) - ! loop over sedimentation sub-time step to ensure stability - !============================================================== - DO n = 1,nstep - IF (do_cldice) THEN - falouti = fi * dumi(i,:) - faloutni = fni * dumni(i,:) - ELSE - falouti = 0._r8 - faloutni = 0._r8 - END IF - ! top of model - k = 1 - ! add fallout terms to microphysical tendencies - faltndi = falouti(k)/pdel(i,k) - faltndni = faloutni(k)/pdel(i,k) - qitend(i,k) = qitend(i,k)-faltndi/nstep - nitend(i,k) = nitend(i,k)-faltndni/nstep - ! sedimentation tendency for output - qisedten(i,k) = qisedten(i,k)-faltndi/nstep - dumi(i,k) = dumi(i,k)-faltndi*deltat/nstep - dumni(i,k) = dumni(i,k)-faltndni*deltat/nstep - DO k = 2,nlev - ! for cloud liquid and ice, if cloud fraction increases with height - ! then add flux from above to both vapor and cloud water of current level - ! this means that flux entering clear portion of cell from above evaporates - ! instantly - ! note: this is not an issue with precip, since we assume max overlap - dum1 = icldm(i,k)/icldm(i,k-1) - dum1 = min(dum1,1._r8) - faltndqie = (falouti(k)-falouti(k-1))/pdel(i,k) - faltndi = (falouti(k)-dum1*falouti(k-1))/pdel(i,k) - faltndni = (faloutni(k)-dum1*faloutni(k-1))/pdel(i,k) - ! add fallout terms to eulerian tendencies - qitend(i,k) = qitend(i,k)-faltndi/nstep - nitend(i,k) = nitend(i,k)-faltndni/nstep - ! sedimentation tendency for output - qisedten(i,k) = qisedten(i,k)-faltndi/nstep - ! add terms to to evap/sub of cloud water - qvlat(i,k) = qvlat(i,k)-(faltndqie-faltndi)/nstep - ! for output - qisevap(i,k) = qisevap(i,k)-(faltndqie-faltndi)/nstep - tlat(i,k) = tlat(i,k)+(faltndqie-faltndi)*xxls/nstep - dumi(i,k) = dumi(i,k)-faltndi*deltat/nstep - dumni(i,k) = dumni(i,k)-faltndni*deltat/nstep - END DO - ! units below are m/s - ! sedimentation flux at surface is added to precip flux at surface - ! to get total precip (cloud + precip water) rate - prect(i) = prect(i)+falouti(nlev)/g/real(nstep)/1000._r8 - preci(i) = preci(i)+falouti(nlev)/g/real(nstep)/1000._r8 - END DO - ! calculate number of split time steps to ensure courant stability criteria - ! for sedimentation calculations - !------------------------------------------------------------------- - nstep = 1 + int(max( maxval( fc/pdel(i,:)), maxval(fnc/pdel(i,:))) * deltat) - ! loop over sedimentation sub-time step to ensure stability - !============================================================== - DO n = 1,nstep - faloutc = fc * dumc(i,:) - faloutnc = fnc * dumnc(i,:) - ! top of model - k = 1 - ! add fallout terms to microphysical tendencies - faltndc = faloutc(k)/pdel(i,k) - faltndnc = faloutnc(k)/pdel(i,k) - qctend(i,k) = qctend(i,k)-faltndc/nstep - nctend(i,k) = nctend(i,k)-faltndnc/nstep - ! sedimentation tendency for output - qcsedten(i,k) = qcsedten(i,k)-faltndc/nstep - dumc(i,k) = dumc(i,k)-faltndc*deltat/nstep - dumnc(i,k) = dumnc(i,k)-faltndnc*deltat/nstep - DO k = 2,nlev - dum = lcldm(i,k)/lcldm(i,k-1) - dum = min(dum,1._r8) - faltndqce = (faloutc(k)-faloutc(k-1))/pdel(i,k) - faltndc = (faloutc(k)-dum*faloutc(k-1))/pdel(i,k) - faltndnc = (faloutnc(k)-dum*faloutnc(k-1))/pdel(i,k) - ! add fallout terms to eulerian tendencies - qctend(i,k) = qctend(i,k)-faltndc/nstep - nctend(i,k) = nctend(i,k)-faltndnc/nstep - ! sedimentation tendency for output - qcsedten(i,k) = qcsedten(i,k)-faltndc/nstep - ! add terms to to evap/sub of cloud water - qvlat(i,k) = qvlat(i,k)-(faltndqce-faltndc)/nstep - ! for output - qcsevap(i,k) = qcsevap(i,k)-(faltndqce-faltndc)/nstep - tlat(i,k) = tlat(i,k)+(faltndqce-faltndc)*xxlv/nstep - dumc(i,k) = dumc(i,k)-faltndc*deltat/nstep - dumnc(i,k) = dumnc(i,k)-faltndnc*deltat/nstep - END DO - prect(i) = prect(i)+faloutc(nlev)/g/real(nstep)/1000._r8 - END DO - ! calculate number of split time steps to ensure courant stability criteria - ! for sedimentation calculations - !------------------------------------------------------------------- - nstep = 1 + int(max( maxval( fr/pdel(i,:)), maxval(fnr/pdel(i,:))) * deltat) - ! loop over sedimentation sub-time step to ensure stability - !============================================================== - DO n = 1,nstep - faloutr = fr * dumr(i,:) - faloutnr = fnr * dumnr(i,:) - ! top of model - k = 1 - ! add fallout terms to microphysical tendencies - faltndr = faloutr(k)/pdel(i,k) - faltndnr = faloutnr(k)/pdel(i,k) - qrtend(i,k) = qrtend(i,k)-faltndr/nstep - nrtend(i,k) = nrtend(i,k)-faltndnr/nstep - ! sedimentation tendency for output - qrsedten(i,k) = qrsedten(i,k)-faltndr/nstep - dumr(i,k) = dumr(i,k)-faltndr*deltat/real(nstep) - dumnr(i,k) = dumnr(i,k)-faltndnr*deltat/real(nstep) - DO k = 2,nlev - faltndr = (faloutr(k)-faloutr(k-1))/pdel(i,k) - faltndnr = (faloutnr(k)-faloutnr(k-1))/pdel(i,k) - ! add fallout terms to eulerian tendencies - qrtend(i,k) = qrtend(i,k)-faltndr/nstep - nrtend(i,k) = nrtend(i,k)-faltndnr/nstep - ! sedimentation tendency for output - qrsedten(i,k) = qrsedten(i,k)-faltndr/nstep - dumr(i,k) = dumr(i,k)-faltndr*deltat/real(nstep) - dumnr(i,k) = dumnr(i,k)-faltndnr*deltat/real(nstep) - END DO - prect(i) = prect(i)+faloutr(nlev)/g/real(nstep)/1000._r8 - END DO - ! calculate number of split time steps to ensure courant stability criteria - ! for sedimentation calculations - !------------------------------------------------------------------- - nstep = 1 + int(max( maxval( fs/pdel(i,:)), maxval(fns/pdel(i,:))) * deltat) - ! loop over sedimentation sub-time step to ensure stability - !============================================================== - DO n = 1,nstep - falouts = fs * dums(i,:) - faloutns = fns * dumns(i,:) - ! top of model - k = 1 - ! add fallout terms to microphysical tendencies - faltnds = falouts(k)/pdel(i,k) - faltndns = faloutns(k)/pdel(i,k) - qstend(i,k) = qstend(i,k)-faltnds/nstep - nstend(i,k) = nstend(i,k)-faltndns/nstep - ! sedimentation tendency for output - qssedten(i,k) = qssedten(i,k)-faltnds/nstep - dums(i,k) = dums(i,k)-faltnds*deltat/real(nstep) - dumns(i,k) = dumns(i,k)-faltndns*deltat/real(nstep) - DO k = 2,nlev - faltnds = (falouts(k)-falouts(k-1))/pdel(i,k) - faltndns = (faloutns(k)-faloutns(k-1))/pdel(i,k) - ! add fallout terms to eulerian tendencies - qstend(i,k) = qstend(i,k)-faltnds/nstep - nstend(i,k) = nstend(i,k)-faltndns/nstep - ! sedimentation tendency for output - qssedten(i,k) = qssedten(i,k)-faltnds/nstep - dums(i,k) = dums(i,k)-faltnds*deltat/real(nstep) - dumns(i,k) = dumns(i,k)-faltndns*deltat/real(nstep) - END DO !! k loop - prect(i) = prect(i)+falouts(nlev)/g/real(nstep)/1000._r8 - preci(i) = preci(i)+falouts(nlev)/g/real(nstep)/1000._r8 - END DO !! nstep loop - ! end sedimentation - !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! get new update for variables that includes sedimentation tendency - ! note : here dum variables are grid-average, NOT in-cloud - DO k=1,nlev - dumc(i,k) = max(qc(i,k)+qctend(i,k)*deltat,0._r8) - dumi(i,k) = max(qi(i,k)+qitend(i,k)*deltat,0._r8) - dumnc(i,k) = max(nc(i,k)+nctend(i,k)*deltat,0._r8) - dumni(i,k) = max(ni(i,k)+nitend(i,k)*deltat,0._r8) - dumr(i,k) = max(qr(i,k)+qrtend(i,k)*deltat,0._r8) - dumnr(i,k) = max(nr(i,k)+nrtend(i,k)*deltat,0._r8) - dums(i,k) = max(qs(i,k)+qstend(i,k)*deltat,0._r8) - dumns(i,k) = max(ns(i,k)+nstend(i,k)*deltat,0._r8) - ! switch for specification of droplet and crystal number - IF (nccons) THEN - dumnc(i,k) = ncnst/rho(i,k)*lcldm(i,k) - END IF - ! switch for specification of cloud ice number - IF (nicons) THEN - dumni(i,k) = ninst/rho(i,k)*icldm(i,k) - END IF - IF (dumc(i,k).lt.qsmall) dumnc(i,k) = 0._r8 - IF (dumi(i,k).lt.qsmall) dumni(i,k) = 0._r8 - IF (dumr(i,k).lt.qsmall) dumnr(i,k) = 0._r8 - IF (dums(i,k).lt.qsmall) dumns(i,k) = 0._r8 - ! calculate instantaneous processes (melting, homogeneous freezing) - !==================================================================== - ! melting of snow at +2 C - IF (t(i,k)+tlat(i,k)/cpp*deltat > snowmelt) THEN - IF (dums(i,k) > 0._r8) THEN - ! make sure melting snow doesn't reduce temperature below threshold - dum = -xlf/cpp*dums(i,k) - IF (t(i,k)+tlat(i,k)/cpp*deltat+dum.lt. snowmelt) THEN - dum = (t(i,k)+tlat(i,k)/cpp*deltat-snowmelt)*cpp/xlf - dum = dum/dums(i,k) - dum = max(0._r8,dum) - dum = min(1._r8,dum) - ELSE - dum = 1._r8 - END IF - qstend(i,k) = qstend(i,k)-dum*dums(i,k)/deltat - nstend(i,k) = nstend(i,k)-dum*dumns(i,k)/deltat - qrtend(i,k) = qrtend(i,k)+dum*dums(i,k)/deltat - nrtend(i,k) = nrtend(i,k)+dum*dumns(i,k)/deltat - dum1 = -xlf*dum*dums(i,k)/deltat - tlat(i,k) = tlat(i,k)+dum1 - meltsdttot(i,k) = meltsdttot(i,k) + dum1 - END IF - END IF - ! freezing of rain at -5 C - IF (t(i,k)+tlat(i,k)/cpp*deltat < rainfrze) THEN - IF (dumr(i,k) > 0._r8) THEN - ! make sure freezing rain doesn't increase temperature above threshold - dum = xlf/cpp*dumr(i,k) - IF (t(i,k)+tlat(i,k)/cpp*deltat+dum.gt.rainfrze) THEN - dum = -(t(i,k)+tlat(i,k)/cpp*deltat-rainfrze)*cpp/xlf - dum = dum/dumr(i,k) - dum = max(0._r8,dum) - dum = min(1._r8,dum) - ELSE - dum = 1._r8 - END IF - qrtend(i,k) = qrtend(i,k)-dum*dumr(i,k)/deltat - nrtend(i,k) = nrtend(i,k)-dum*dumnr(i,k)/deltat - ! get mean size of rain = 1/lamr, add frozen rain to either snow or cloud ice - ! depending on mean rain size - CALL size_dist_param_basic(mg_rain_props, dumr(i,k), dumnr(i,k), lamr(i,k)) - IF (lamr(i,k) < 1._r8/dcs) THEN - qstend(i,k) = qstend(i,k)+dum*dumr(i,k)/deltat - nstend(i,k) = nstend(i,k)+dum*dumnr(i,k)/deltat - ELSE - qitend(i,k) = qitend(i,k)+dum*dumr(i,k)/deltat - nitend(i,k) = nitend(i,k)+dum*dumnr(i,k)/deltat - END IF - ! heating tendency - dum1 = xlf*dum*dumr(i,k)/deltat - frzrdttot(i,k) = frzrdttot(i,k) + dum1 - tlat(i,k) = tlat(i,k)+dum1 - END IF - END IF - IF (do_cldice) THEN - IF (t(i,k)+tlat(i,k)/cpp*deltat > tmelt) THEN - IF (dumi(i,k) > 0._r8) THEN - ! limit so that melting does not push temperature below freezing - !----------------------------------------------------------------- - dum = -dumi(i,k)*xlf/cpp - IF (t(i,k)+tlat(i,k)/cpp*deltat+dum.lt.tmelt) THEN - dum = (t(i,k)+tlat(i,k)/cpp*deltat-tmelt)*cpp/xlf - dum = dum/dumi(i,k) - dum = max(0._r8,dum) - dum = min(1._r8,dum) - ELSE - dum = 1._r8 - END IF - qctend(i,k) = qctend(i,k)+dum*dumi(i,k)/deltat - ! for output - melttot(i,k) = dum*dumi(i,k)/deltat - ! assume melting ice produces droplet - ! mean volume radius of 8 micron - nctend(i,k) = nctend(i,k)+3._r8*dum*dumi(i,k)/deltat/ (& - 4._r8*pi*5.12e-16_r8*rhow) - qitend(i,k) = ((1._r8-dum)*dumi(i,k)-qi(i,k))/deltat - nitend(i,k) = ((1._r8-dum)*dumni(i,k)-ni(i,k))/deltat - tlat(i,k) = tlat(i,k)-xlf*dum*dumi(i,k)/deltat - END IF - END IF - ! homogeneously freeze droplets at -40 C - !----------------------------------------------------------------- - IF (t(i,k)+tlat(i,k)/cpp*deltat < 233.15_r8) THEN - IF (dumc(i,k) > 0._r8) THEN - ! limit so that freezing does not push temperature above threshold - dum = dumc(i,k)*xlf/cpp - IF (t(i,k)+tlat(i,k)/cpp*deltat+dum.gt.233.15_r8) THEN - dum = -(t(i,k)+tlat(i,k)/cpp*deltat-233.15_r8)*cpp/xlf - dum = dum/dumc(i,k) - dum = max(0._r8,dum) - dum = min(1._r8,dum) - ELSE - dum = 1._r8 - END IF - qitend(i,k) = qitend(i,k)+dum*dumc(i,k)/deltat - ! for output - homotot(i,k) = dum*dumc(i,k)/deltat - ! assume 25 micron mean volume radius of homogeneously frozen droplets - ! consistent with size of detrained ice in stratiform.F90 - nitend(i,k) = nitend(i,k)+dum*3._r8*dumc(i,k)/(4._r8*3.14_r8*1.563e-14_r8* & - 500._r8)/deltat - qctend(i,k) = ((1._r8-dum)*dumc(i,k)-qc(i,k))/deltat - nctend(i,k) = ((1._r8-dum)*dumnc(i,k)-nc(i,k))/deltat - tlat(i,k) = tlat(i,k)+xlf*dum*dumc(i,k)/deltat - END IF - END IF - ! remove any excess over-saturation, which is possible due to non-linearity when adding - ! together all microphysical processes - !----------------------------------------------------------------- - ! follow code similar to old 1 scheme - qtmp = q(i,k)+qvlat(i,k)*deltat - ttmp = t(i,k)+tlat(i,k)/cpp*deltat - ! use rhw to allow ice supersaturation - CALL qsat_water(ttmp, p(i,k), esn, qvn) - IF (qtmp > qvn .and. qvn > 0) THEN - ! expression below is approximate since there may be ice deposition - dum = (qtmp-qvn)/(1._r8+xxlv_squared*qvn/(cpp*rv*ttmp**2))/deltat - ! add to output cme - cmeout(i,k) = cmeout(i,k)+dum - ! now add to tendencies, partition between liquid and ice based on temperature - IF (ttmp > 268.15_r8) THEN - dum1 = 0.0_r8 - ! now add to tendencies, partition between liquid and ice based on te - !------------------------------------------------------- - ELSE IF (ttmp < 238.15_r8) THEN - dum1 = 1.0_r8 - ELSE - dum1 = (268.15_r8-ttmp)/30._r8 - END IF - dum = (qtmp-qvn)/(1._r8+(xxls*dum1+xxlv*(1._r8-dum1))**2 *qvn/(cpp*rv*ttmp**2))/deltat - qctend(i,k) = qctend(i,k)+dum*(1._r8-dum1) - ! for output - qcrestot(i,k) = dum*(1._r8-dum1) - qitend(i,k) = qitend(i,k)+dum*dum1 - qirestot(i,k) = dum*dum1 - qvlat(i,k) = qvlat(i,k)-dum - ! for output - qvres(i,k) = -dum - tlat(i,k) = tlat(i,k)+dum*(1._r8-dum1)*xxlv+dum*dum1*xxls - END IF - END IF - ! calculate effective radius for pass to radiation code - !========================================================= - ! if no cloud water, default value is 10 micron for droplets, - ! 25 micron for cloud ice - ! update cloud variables after instantaneous processes to get effective radius - ! variables are in-cloud to calculate size dist parameters - dumc(i,k) = max(qc(i,k)+qctend(i,k)*deltat,0._r8)/lcldm(i,k) - dumi(i,k) = max(qi(i,k)+qitend(i,k)*deltat,0._r8)/icldm(i,k) - dumnc(i,k) = max(nc(i,k)+nctend(i,k)*deltat,0._r8)/lcldm(i,k) - dumni(i,k) = max(ni(i,k)+nitend(i,k)*deltat,0._r8)/icldm(i,k) - dumr(i,k) = max(qr(i,k)+qrtend(i,k)*deltat,0._r8)/precip_frac(i,k) - dumnr(i,k) = max(nr(i,k)+nrtend(i,k)*deltat,0._r8)/precip_frac(i,k) - dums(i,k) = max(qs(i,k)+qstend(i,k)*deltat,0._r8)/precip_frac(i,k) - dumns(i,k) = max(ns(i,k)+nstend(i,k)*deltat,0._r8)/precip_frac(i,k) - ! switch for specification of droplet and crystal number - IF (nccons) THEN - dumnc(i,k) = ncnst/rho(i,k) - END IF - ! switch for specification of cloud ice number - IF (nicons) THEN - dumni(i,k) = ninst/rho(i,k) - END IF - ! limit in-cloud mixing ratio to reasonable value of 5 g kg-1 - dumc(i,k) = min(dumc(i,k),5.e-3_r8) - dumi(i,k) = min(dumi(i,k),5.e-3_r8) - ! limit in-precip mixing ratios - dumr(i,k) = min(dumr(i,k),10.e-3_r8) - dums(i,k) = min(dums(i,k),10.e-3_r8) - ! cloud ice effective radius - !----------------------------------------------------------------- - IF (do_cldice) THEN - IF (dumi(i,k).ge.qsmall) THEN - dum_2d(i,k) = dumni(i,k) - CALL size_dist_param_basic(mg_ice_props, dumi(i,k), dumni(i,k), lami(i,k)) - IF (dumni(i,k) /=dum_2d(i,k)) THEN - ! adjust number conc if needed to keep mean size in reasonable range - nitend(i,k) = (dumni(i,k)*icldm(i,k)-ni(i,k))/deltat - END IF - effi(i,k) = 1.5_r8/lami(i,k)*1.e6_r8 - ELSE - effi(i,k) = 25._r8 - END IF - ! ice effective diameter for david mitchell's optics - deffi(i,k) = effi(i,k)*rhoi/rhows*2._r8 - ELSE - ! NOTE: If CARMA is doing the ice microphysics, then the ice effective - ! radius has already been determined from the size distribution. - effi(i,k) = re_ice(i,k) * 1.e6_r8 ! m -> um - deffi(i,k) = effi(i,k) * 2._r8 - END IF - ! cloud droplet effective radius - !----------------------------------------------------------------- - IF (dumc(i,k).ge.qsmall) THEN - ! switch for specification of droplet and crystal number - IF (nccons) THEN - ! make sure nc is consistence with the constant N by adjusting tendency, need - ! to multiply by cloud fraction - ! note that nctend may be further adjusted below if mean droplet size is - ! out of bounds - nctend(i,k) = (ncnst/rho(i,k)*lcldm(i,k)-nc(i,k))/deltat - END IF - dum = dumnc(i,k) - CALL size_dist_param_liq(mg_liq_props, dumc(i,k), dumnc(i,k), rho(i,k), pgam(i,k), lamc(i,k)) - IF (dum /= dumnc(i,k)) THEN - ! adjust number conc if needed to keep mean size in reasonable range - nctend(i,k) = (dumnc(i,k)*lcldm(i,k)-nc(i,k))/deltat - END IF - effc(i,k) = (pgam(i,k)+3._r8)/lamc(i,k)/2._r8*1.e6_r8 - !assign output fields for shape here - lamcrad(i,k) = lamc(i,k) - pgamrad(i,k) = pgam(i,k) - ! recalculate effective radius for constant number, in order to separate - ! first and second indirect effects - !====================================== - ! assume constant number of 10^8 kg-1 - dumnc(i,k) = 1.e8_r8 - ! Pass in "false" adjust flag to prevent number from being changed within - ! size distribution subroutine. - CALL size_dist_param_liq(mg_liq_props, dumc(i,k), dumnc(i,k), rho(i,k), pgam(i,k), lamc(i,k)) - effc_fn(i,k) = (pgam(i,k)+3._r8)/lamc(i,k)/2._r8*1.e6_r8 - ELSE - effc(i,k) = 10._r8 - lamcrad(i,k) = 0._r8 - pgamrad(i,k) = 0._r8 - effc_fn(i,k) = 10._r8 - END IF - ! recalculate 'final' rain size distribution parameters - ! to ensure that rain size is in bounds, adjust rain number if needed - IF (dumr(i,k).ge.qsmall) THEN - dum = dumnr(i,k) - CALL size_dist_param_basic(mg_rain_props, dumr(i,k), dumnr(i,k), lamr(i,k)) - IF (dum /= dumnr(i,k)) THEN - ! adjust number conc if needed to keep mean size in reasonable range - nrtend(i,k) = (dumnr(i,k)*precip_frac(i,k)-nr(i,k))/deltat - END IF - END IF - ! recalculate 'final' snow size distribution parameters - ! to ensure that snow size is in bounds, adjust snow number if needed - IF (dums(i,k).ge.qsmall) THEN - dum = dumns(i,k) - CALL size_dist_param_basic(mg_snow_props, dums(i,k), dumns(i,k), lams(i,k)) - IF (dum /= dumns(i,k)) THEN - ! adjust number conc if needed to keep mean size in reasonable range - nstend(i,k) = (dumns(i,k)*precip_frac(i,k)-ns(i,k))/deltat - END IF - END IF - END DO ! vertical k loop - DO k=1,nlev - ! if updated q (after microphysics) is zero, then ensure updated n is also zero - !================================================================================= - IF (qc(i,k)+qctend(i,k)*deltat.lt.qsmall) nctend(i,k) = -nc(i,k)/deltat - IF (do_cldice .and. qi(i,k)+qitend(i,k)*deltat.lt.qsmall) nitend(i,k) = -ni(i,k)/deltat - IF (qr(i,k)+qrtend(i,k)*deltat.lt.qsmall) nrtend(i,k) = -nr(i,k)/deltat - IF (qs(i,k)+qstend(i,k)*deltat.lt.qsmall) nstend(i,k) = -ns(i,k)/deltat - END DO - END DO sed_col_loop ! i loop - ! DO STUFF FOR OUTPUT: - !================================================== - ! qc and qi are only used for output calculations past here, - ! so add qctend and qitend back in one more time - qc = qc + qctend*deltat - qi = qi + qitend*deltat - ! averaging for snow and rain number and diameter - !-------------------------------------------------- - ! drout2/dsout2: - ! diameter of rain and snow - ! dsout: - ! scaled diameter of snow (passed to radiation in 1) - ! reff_rain/reff_snow: - ! calculate effective radius of rain and snow in microns for COSP using Eq. 9 of COSP v1.3 manual - WHERE ( qrout .gt. 1.e-7_r8 .and. nrout.gt.0._r8 ) - qrout2 = qrout * precip_frac - nrout2 = nrout * precip_frac - ! The avg_diameter call does the actual calculation; other diameter - ! outputs are just drout2 times constants. - drout2 = avg_diameter(qrout, nrout, rho, rhow) - freqr = precip_frac - reff_rain = 1.5_r8*drout2*1.e6_r8 - ELSEWHERE - qrout2 = 0._r8 - nrout2 = 0._r8 - drout2 = 0._r8 - freqr = 0._r8 - reff_rain = 0._r8 - END WHERE - WHERE ( qsout .gt. 1.e-7_r8 .and. nsout.gt.0._r8 ) - qsout2 = qsout * precip_frac - nsout2 = nsout * precip_frac - ! The avg_diameter call does the actual calculation; other diameter - ! outputs are just dsout2 times constants. - dsout2 = avg_diameter(qsout, nsout, rho, rhosn) - freqs = precip_frac - dsout = 3._r8*rhosn/rhows*dsout2 - reff_snow = 1.5_r8*dsout2*1.e6_r8 - ELSEWHERE - dsout = 0._r8 - qsout2 = 0._r8 - nsout2 = 0._r8 - dsout2 = 0._r8 - freqs = 0._r8 - reff_snow = 0._r8 - END WHERE - ! analytic radar reflectivity - !-------------------------------------------------- - ! formulas from Matthew Shupe, NOAA/CERES - ! *****note: radar reflectivity is local (in-precip average) - ! units of mm^6/m^3 - DO i = 1,mgncol - DO k=1,nlev - IF (qc(i,k).ge.qsmall) THEN - dum = (qc(i,k)/lcldm(i,k)*rho(i,k)*1000._r8)**2 /(0.109_r8*(nc(i,k)+nctend(i,k)*deltat)& - /lcldm(i,k)*rho(i,k)/1.e6_r8)*lcldm(i,k)/precip_frac(i,k) - ELSE - dum = 0._r8 - END IF - IF (qi(i,k).ge.qsmall) THEN - dum1 = (qi(i,k)*rho(i,k)/icldm(i,k)*1000._r8/0.1_r8)**(1._r8/0.63_r8)*icldm(i,k)/precip_frac(i,k) - ELSE - dum1 = 0._r8 - END IF - IF (qsout(i,k).ge.qsmall) THEN - dum1 = dum1+(qsout(i,k)*rho(i,k)*1000._r8/0.1_r8)**(1._r8/0.63_r8) - END IF - refl(i,k) = dum+dum1 - ! add rain rate, but for 37 GHz formulation instead of 94 GHz - ! formula approximated from data of Matrasov (2007) - ! rainrt is the rain rate in mm/hr - ! reflectivity (dum) is in DBz - IF (rainrt(i,k).ge.0.001_r8) THEN - dum = log10(rainrt(i,k)**6._r8)+16._r8 - ! convert from DBz to mm^6/m^3 - dum = 10._r8**(dum/10._r8) - ELSE - ! don't include rain rate in R calculation for values less than 0.001 mm/hr - dum = 0._r8 - END IF - ! add to refl - refl(i,k) = refl(i,k)+dum - !output reflectivity in Z. - areflz(i,k) = refl(i,k) * precip_frac(i,k) - ! convert back to DBz - IF (refl(i,k).gt.minrefl) THEN - refl(i,k) = 10._r8*log10(refl(i,k)) - ELSE - refl(i,k) = -9999._r8 - END IF - !set averaging flag - IF (refl(i,k).gt.mindbz) THEN - arefl(i,k) = refl(i,k) * precip_frac(i,k) - frefl(i,k) = precip_frac(i,k) - ELSE - arefl(i,k) = 0._r8 - areflz(i,k) = 0._r8 - frefl(i,k) = 0._r8 - END IF - ! bound cloudsat reflectivity - csrfl(i,k) = min(csmax,refl(i,k)) - !set averaging flag - IF (csrfl(i,k).gt.csmin) THEN - acsrfl(i,k) = refl(i,k) * precip_frac(i,k) - fcsrfl(i,k) = precip_frac(i,k) - ELSE - acsrfl(i,k) = 0._r8 - fcsrfl(i,k) = 0._r8 - END IF - END DO - END DO - !redefine fice here.... - dum_2d = qsout + qrout + qc + qi - dumi = qsout + qi - WHERE ( dumi .gt. qsmall .and. dum_2d .gt. qsmall ) - nfice = min(dumi/dum_2d,1._r8) - ELSEWHERE - nfice = 0._r8 - END WHERE - END SUBROUTINE micro_mg_tend - !======================================================================== - !OUTPUT CALCULATIONS - !======================================================================== - - elemental SUBROUTINE calc_rercld(lamr, n0r, lamc, pgam, qric, qcic, ncic, rercld) - REAL(KIND=r8), intent(in) :: lamr ! rain size parameter (slope) - REAL(KIND=r8), intent(in) :: n0r ! rain size parameter (intercept) - REAL(KIND=r8), intent(in) :: lamc ! size distribution parameter (slope) - REAL(KIND=r8), intent(in) :: pgam ! droplet size parameter - REAL(KIND=r8), intent(in) :: qric ! in-cloud rain mass mixing ratio - REAL(KIND=r8), intent(in) :: qcic ! in-cloud cloud liquid - REAL(KIND=r8), intent(in) :: ncic ! in-cloud droplet number concentration - REAL(KIND=r8), intent(inout) :: rercld ! effective radius calculation for rain + cloud - ! combined size of precip & cloud drops - REAL(KIND=r8) :: atmp - ! Rain drops - IF (lamr > 0._r8) THEN - atmp = n0r * pi / (2._r8 * lamr**3._r8) - ELSE - atmp = 0._r8 - END IF - ! Add cloud drops - IF (lamc > 0._r8) THEN - atmp = atmp + ncic * pi * rising_factorial(pgam+1._r8, 2)/(4._r8 * lamc**2._r8) - END IF - IF (atmp > 0._r8) THEN - rercld = rercld + 3._r8 *(qric + qcic) / (4._r8 * rhow * atmp) - END IF - END SUBROUTINE calc_rercld - !======================================================================== - !UTILITIES - !======================================================================== - - END MODULE micro_mg2_0 diff --git a/test/ncar_kernels/CAM5_mg2_pgi/src/micro_mg_cam.F90 b/test/ncar_kernels/CAM5_mg2_pgi/src/micro_mg_cam.F90 deleted file mode 100644 index afd230cc6b..0000000000 --- a/test/ncar_kernels/CAM5_mg2_pgi/src/micro_mg_cam.F90 +++ /dev/null @@ -1,1244 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : micro_mg_cam.F90 -! Generated at: 2015-03-31 09:44:40 -! KGEN version: 0.4.5 - - - - MODULE micro_mg_cam - !--------------------------------------------------------------------------------- - ! - ! 1 Interfaces for MG microphysics - ! - !--------------------------------------------------------------------------------- - ! - ! How to add new packed MG inputs to micro_mg_cam_tend: - ! - ! If you have an input with first dimension [psetcols, pver], the procedure - ! for adding inputs is as follows: - ! - ! 1) In addition to any variables you need to declare for the "unpacked" - ! (1 format) version, you must declare an allocatable or pointer array - ! for the "packed" (MG format) version. - ! - ! 2) After micro_mg_get_cols is called, allocate the "packed" array with - ! size [mgncol, nlev]. - ! - ! 3) Add a call similar to the following line (look before the - ! micro_mg_tend calls to see similar lines): - ! - ! packed_array = packer%pack(original_array) - ! - ! The packed array can then be passed into any of the MG schemes. - ! - ! This same procedure will also work for 1D arrays of size psetcols, 3-D - ! arrays with psetcols and pver as the first dimensions, and for arrays of - ! dimension [psetcols, pverp]. You only have to modify the allocation of - ! the packed array before the "pack" call. - ! - !--------------------------------------------------------------------------------- - ! - ! How to add new packed MG outputs to micro_mg_cam_tend: - ! - ! 1) As with inputs, in addition to the unpacked outputs you must declare - ! an allocatable or pointer array for packed data. The unpacked and - ! packed arrays must *also* be targets or pointers (but cannot be both). - ! - ! 2) Again as for inputs, allocate the packed array using mgncol and nlev, - ! which are set in micro_mg_get_cols. - ! - ! 3) Add the field to post-processing as in the following line (again, - ! there are many examples before the micro_mg_tend calls): - ! - ! call post_proc%add_field(p(final_array),p(packed_array)) - ! - ! This registers the field for post-MG averaging, and to scatter to the - ! final, unpacked version of the array. - ! - ! By default, any columns/levels that are not operated on by MG will be - ! set to 0 on output; this value can be adjusted using the "fillvalue" - ! optional argument to post_proc%add_field. - ! - ! Also by default, outputs from multiple substeps will be averaged after - ! MG's substepping is complete. Passing the optional argument - ! "accum_method=accum_null" will change this behavior so that the last - ! substep is always output. - ! - ! This procedure works on 1-D and 2-D outputs. Note that the final, - ! unpacked arrays are not set until the call to - ! "post_proc%process_and_unpack", which sets every single field that was - ! added with post_proc%add_field. - ! - !--------------------------------------------------------------------------------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - PRIVATE - PUBLIC kgen_read_externs_micro_mg_cam - INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - PUBLIC micro_mg_cam_tend - type, public :: check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - real(kind=kgen_dp) :: minvalue - end type check_t - ! Version number for MG. - ! Second part of version number. - ! type of precipitation fraction method - ! berg efficiency factor - ! Prognose cldliq flag - ! Prognose cldice flag - INTEGER :: num_steps ! Number of MG substeps - ! Number of constituents - ! Constituent names - ! cloud liquid amount index - ! cloud ice amount index - ! cloud liquid number index - ! cloud ice water index - ! rain index - ! snow index - ! rain number index - ! snow number index - ! Physics buffer indices for fields registered by this module - ! Fields for UNICON - ! Evaporation area of stratiform precipitation - ! Evaporation rate of stratiform rain [kg/kg/s]. >= 0. - ! Evaporation rate of stratiform snow [kg/kg/s]. >= 0. - ! Fields needed as inputs to COSP - ! Fields needed by Park macrophysics - ! Used to replace aspects of MG microphysics - ! (e.g. by CARMA) - ! Index fields for precipitation efficiency. - ! Physics buffer indices for fields registered by other modules - ! Pbuf fields needed for subcol_SILHS - ! pbuf fields for heterogeneous freezing - - !=============================================================================== - CONTAINS - - ! write subroutines - ! No subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_micro_mg_cam(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) num_steps - END SUBROUTINE kgen_read_externs_micro_mg_cam - - subroutine kgen_init_check(check, tolerance, minvalue) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - real(kind=kgen_dp), intent(in), optional :: minvalue - - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.E-14 - endif - if(present(minvalue)) then - check%minvalue = minvalue - else - check%minvalue = 1.0D-15 - endif - end subroutine kgen_init_check - subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif - end subroutine kgen_print_check - !=============================================================================== - - - !================================================================================================ - - !=============================================================================== - - !=============================================================================== - - !=============================================================================== - - !=============================================================================== - - SUBROUTINE micro_mg_cam_tend(dtime, kgen_unit) - USE micro_mg2_0, ONLY: micro_mg_tend2_0 => micro_mg_tend - integer, intent(in) :: kgen_unit - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - REAL(KIND=r8), intent(in) :: dtime - ! Local variables - ! ice nucleation number - ! ice nucleation number (homogeneous) - ! liquid activation number tendency - ! Evaporation area of stratiform precipitation. 0<= am_evp_st <=1. - ! Evaporation rate of stratiform rain [kg/kg/s] - ! Evaporation rate of stratiform snow [kg/kg/s] - ! [Total] Sfc flux of precip from stratiform [ m/s ] - ! [Total] Sfc flux of snow from stratiform [ m/s ] - ! Surface flux of total cloud water from sedimentation - ! Surface flux of cloud ice from sedimentation - ! Sfc flux of precip from microphysics [ m/s ] - ! Sfc flux of snow from microphysics [ m/s ] - ! Relative humidity cloud fraction - ! Old cloud fraction - ! Evaporation of total precipitation (rain + snow) - ! precipitation evaporation rate - ! relative variance of cloud water - ! optional accretion enhancement for experimentation - ! Total precipitation (rain + snow) - ! Ice effective diameter (meters) (AG: microns?) - ! Size distribution shape parameter for radiation - ! Size distribution slope parameter for radiation - ! Snow effective diameter (m) - ! array to hold rate1ord_cw2pr_st from microphysics - ! Area over which precip evaporates - ! Local evaporation of snow - ! Local production of snow - ! Rate of cond-evap of ice within the cloud - ! Snow mixing ratio - ! grid-box average rain flux (kg m^-2 s^-1) - ! grid-box average snow flux (kg m^-2 s^-1) - ! Rain mixing ratio - ! Evaporation of falling cloud water - ! Sublimation of falling cloud ice - ! Residual condensation term to remove excess saturation - ! Deposition/sublimation rate of cloud ice - ! Mass-weighted cloud water fallspeed - ! Mass-weighted cloud ice fallspeed - ! Mass-weighted rain fallspeed - ! Mass-weighted snow fallspeed - ! Cloud water mixing ratio tendency from sedimentation - ! Cloud ice mixing ratio tendency from sedimentation - ! Rain mixing ratio tendency from sedimentation - ! Snow mixing ratio tendency from sedimentation - ! analytic radar reflectivity - ! average reflectivity will zero points outside valid range - ! average reflectivity in z. - ! cloudsat reflectivity - ! cloudsat average - ! effective radius calculation for rain + cloud - ! output number conc of ice nuclei available (1/m3) - ! output number conc of CCN (1/m3) - ! qc limiter ratio (1=no limit) - ! Object that packs columns with clouds/precip. - ! Packed versions of inputs. - REAL(KIND=r8), allocatable :: packed_t(:,:) - REAL(KIND=r8), allocatable :: packed_q(:,:) - REAL(KIND=r8), allocatable :: packed_qc(:,:) - REAL(KIND=r8), allocatable :: packed_nc(:,:) - REAL(KIND=r8), allocatable :: packed_qi(:,:) - REAL(KIND=r8), allocatable :: packed_ni(:,:) - REAL(KIND=r8), allocatable :: packed_qr(:,:) - REAL(KIND=r8), allocatable :: packed_nr(:,:) - REAL(KIND=r8), allocatable :: packed_qs(:,:) - REAL(KIND=r8), allocatable :: packed_ns(:,:) - REAL(KIND=r8), allocatable :: packed_relvar(:,:) - REAL(KIND=r8), allocatable :: packed_accre_enhan(:,:) - REAL(KIND=r8), allocatable :: packed_p(:,:) - REAL(KIND=r8), allocatable :: packed_pdel(:,:) - ! This is only needed for MG1.5, and can be removed when support for - ! that version is dropped. - REAL(KIND=r8), allocatable :: packed_cldn(:,:) - REAL(KIND=r8), allocatable :: packed_liqcldf(:,:) - REAL(KIND=r8), allocatable :: packed_icecldf(:,:) - REAL(KIND=r8), allocatable :: packed_naai(:,:) - REAL(KIND=r8), allocatable :: packed_npccn(:,:) - REAL(KIND=r8), allocatable :: packed_rndst(:,:,:) - REAL(KIND=r8), allocatable :: packed_nacon(:,:,:) - ! Optional outputs. - REAL(KIND=r8), pointer :: packed_tnd_qsnow(:,:) - REAL(KIND=r8), pointer :: packed_tnd_nsnow(:,:) - REAL(KIND=r8), pointer :: packed_re_ice(:,:) - REAL(KIND=r8), pointer :: packed_frzimm(:,:) - REAL(KIND=r8), pointer :: packed_frzcnt(:,:) - REAL(KIND=r8), pointer :: packed_frzdep(:,:) - ! Output field post-processing. - ! Packed versions of outputs. - REAL(KIND=r8), allocatable, target :: packed_rate1ord_cw2pr_st(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_rate1ord_cw2pr_st(:,:) - REAL(KIND=r8), allocatable, target :: packed_tlat(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_tlat(:,:) - REAL(KIND=r8), allocatable, target :: packed_qvlat(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_qvlat(:,:) - REAL(KIND=r8), allocatable, target :: packed_qctend(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_qctend(:,:) - REAL(KIND=r8), allocatable, target :: packed_qitend(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_qitend(:,:) - REAL(KIND=r8), allocatable, target :: packed_nctend(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_nctend(:,:) - REAL(KIND=r8), allocatable, target :: packed_nitend(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_nitend(:,:) - REAL(KIND=r8), allocatable, target :: packed_qrtend(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_qrtend(:,:) - REAL(KIND=r8), allocatable, target :: packed_qstend(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_qstend(:,:) - REAL(KIND=r8), allocatable, target :: packed_nrtend(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_nrtend(:,:) - REAL(KIND=r8), allocatable, target :: packed_nstend(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_nstend(:,:) - REAL(KIND=r8), allocatable, target :: packed_prect(:) - REAL(KIND=r8), allocatable, target :: ref_packed_prect(:) - REAL(KIND=r8), allocatable, target :: packed_preci(:) - REAL(KIND=r8), allocatable, target :: ref_packed_preci(:) - REAL(KIND=r8), allocatable, target :: packed_nevapr(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_nevapr(:,:) - REAL(KIND=r8), allocatable, target :: packed_evapsnow(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_evapsnow(:,:) - REAL(KIND=r8), allocatable, target :: packed_prain(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_prain(:,:) - REAL(KIND=r8), allocatable, target :: packed_prodsnow(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_prodsnow(:,:) - REAL(KIND=r8), allocatable, target :: packed_cmeout(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_cmeout(:,:) - REAL(KIND=r8), allocatable, target :: packed_qsout(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_qsout(:,:) - REAL(KIND=r8), allocatable, target :: packed_rflx(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_rflx(:,:) - REAL(KIND=r8), allocatable, target :: packed_sflx(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_sflx(:,:) - REAL(KIND=r8), allocatable, target :: packed_qrout(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_qrout(:,:) - REAL(KIND=r8), allocatable, target :: packed_qcsevap(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_qcsevap(:,:) - REAL(KIND=r8), allocatable, target :: packed_qisevap(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_qisevap(:,:) - REAL(KIND=r8), allocatable, target :: packed_qvres(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_qvres(:,:) - REAL(KIND=r8), allocatable, target :: packed_cmei(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_cmei(:,:) - REAL(KIND=r8), allocatable, target :: packed_vtrmc(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_vtrmc(:,:) - REAL(KIND=r8), allocatable, target :: packed_vtrmi(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_vtrmi(:,:) - REAL(KIND=r8), allocatable, target :: packed_qcsedten(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_qcsedten(:,:) - REAL(KIND=r8), allocatable, target :: packed_qisedten(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_qisedten(:,:) - REAL(KIND=r8), allocatable, target :: packed_qrsedten(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_qrsedten(:,:) - REAL(KIND=r8), allocatable, target :: packed_qssedten(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_qssedten(:,:) - REAL(KIND=r8), allocatable, target :: packed_umr(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_umr(:,:) - REAL(KIND=r8), allocatable, target :: packed_ums(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_ums(:,:) - REAL(KIND=r8), allocatable, target :: packed_pra(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_pra(:,:) - REAL(KIND=r8), allocatable, target :: packed_prc(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_prc(:,:) - REAL(KIND=r8), allocatable, target :: packed_mnuccc(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_mnuccc(:,:) - REAL(KIND=r8), allocatable, target :: packed_mnucct(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_mnucct(:,:) - REAL(KIND=r8), allocatable, target :: packed_msacwi(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_msacwi(:,:) - REAL(KIND=r8), allocatable, target :: packed_psacws(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_psacws(:,:) - REAL(KIND=r8), allocatable, target :: packed_bergs(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_bergs(:,:) - REAL(KIND=r8), allocatable, target :: packed_berg(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_berg(:,:) - REAL(KIND=r8), allocatable, target :: packed_melt(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_melt(:,:) - REAL(KIND=r8), allocatable, target :: packed_homo(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_homo(:,:) - REAL(KIND=r8), allocatable, target :: packed_qcres(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_qcres(:,:) - REAL(KIND=r8), allocatable, target :: packed_prci(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_prci(:,:) - REAL(KIND=r8), allocatable, target :: packed_prai(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_prai(:,:) - REAL(KIND=r8), allocatable, target :: packed_qires(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_qires(:,:) - REAL(KIND=r8), allocatable, target :: packed_mnuccr(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_mnuccr(:,:) - REAL(KIND=r8), allocatable, target :: packed_pracs(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_pracs(:,:) - REAL(KIND=r8), allocatable, target :: packed_meltsdt(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_meltsdt(:,:) - REAL(KIND=r8), allocatable, target :: packed_frzrdt(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_frzrdt(:,:) - REAL(KIND=r8), allocatable, target :: packed_mnuccd(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_mnuccd(:,:) - REAL(KIND=r8), allocatable, target :: packed_nrout(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_nrout(:,:) - REAL(KIND=r8), allocatable, target :: packed_nsout(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_nsout(:,:) - REAL(KIND=r8), allocatable, target :: packed_refl(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_refl(:,:) - REAL(KIND=r8), allocatable, target :: packed_arefl(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_arefl(:,:) - REAL(KIND=r8), allocatable, target :: packed_areflz(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_areflz(:,:) - REAL(KIND=r8), allocatable, target :: packed_frefl(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_frefl(:,:) - REAL(KIND=r8), allocatable, target :: packed_csrfl(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_csrfl(:,:) - REAL(KIND=r8), allocatable, target :: packed_acsrfl(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_acsrfl(:,:) - REAL(KIND=r8), allocatable, target :: packed_fcsrfl(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_fcsrfl(:,:) - REAL(KIND=r8), allocatable, target :: packed_rercld(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_rercld(:,:) - REAL(KIND=r8), allocatable, target :: packed_ncai(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_ncai(:,:) - REAL(KIND=r8), allocatable, target :: packed_ncal(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_ncal(:,:) - REAL(KIND=r8), allocatable, target :: packed_qrout2(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_qrout2(:,:) - REAL(KIND=r8), allocatable, target :: packed_qsout2(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_qsout2(:,:) - REAL(KIND=r8), allocatable, target :: packed_nrout2(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_nrout2(:,:) - REAL(KIND=r8), allocatable, target :: packed_nsout2(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_nsout2(:,:) - REAL(KIND=r8), allocatable, target :: packed_freqs(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_freqs(:,:) - REAL(KIND=r8), allocatable, target :: packed_freqr(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_freqr(:,:) - REAL(KIND=r8), allocatable, target :: packed_nfice(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_nfice(:,:) - REAL(KIND=r8), allocatable, target :: packed_prer_evap(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_prer_evap(:,:) - REAL(KIND=r8), allocatable, target :: packed_qcrat(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_qcrat(:,:) - REAL(KIND=r8), allocatable, target :: packed_rel(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_rel(:,:) - REAL(KIND=r8), allocatable, target :: packed_rei(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_rei(:,:) - REAL(KIND=r8), allocatable, target :: packed_lambdac(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_lambdac(:,:) - REAL(KIND=r8), allocatable, target :: packed_mu(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_mu(:,:) - REAL(KIND=r8), allocatable, target :: packed_des(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_des(:,:) - REAL(KIND=r8), allocatable, target :: packed_dei(:,:) - REAL(KIND=r8), allocatable, target :: ref_packed_dei(:,:) - ! Dummy arrays for cases where we throw away the MG version and - ! recalculate sizes on the 1 grid to avoid time/subcolumn averaging - ! issues. - REAL(KIND=r8), allocatable :: rel_fn_dum(:,:) - REAL(KIND=r8), allocatable :: ref_rel_fn_dum(:,:) - REAL(KIND=r8), allocatable :: dsout2_dum(:,:) - REAL(KIND=r8), allocatable :: ref_dsout2_dum(:,:) - REAL(KIND=r8), allocatable :: drout_dum(:,:) - REAL(KIND=r8), allocatable :: ref_drout_dum(:,:) - REAL(KIND=r8), allocatable :: reff_rain_dum(:,:) - REAL(KIND=r8), allocatable :: ref_reff_rain_dum(:,:) - REAL(KIND=r8), allocatable :: reff_snow_dum(:,:) - REAL(KIND=r8), allocatable :: ref_reff_snow_dum(:,:) - ! Heterogeneous-only version of mnuccdo. - ! physics buffer fields for COSP simulator - ! MG grid-box mean flux_large_scale_cloud_rain+snow at interfaces (kg/m2/s) - ! MG grid-box mean flux_large_scale_cloud_snow at interfaces (kg/m2/s) - ! MG grid-box mean mixingratio_large_scale_cloud_rain+snow at interfaces (kg/kg) - ! MG grid-box mean mixingratio_large_scale_cloud_snow at interfaces (kg/kg) - ! MG diagnostic rain effective radius (um) - ! MG diagnostic snow effective radius (um) - ! convective cloud liquid effective radius (um) - ! convective cloud ice effective radius (um) - ! physics buffer fields used with CARMA - ! external tendency on snow mass (kg/kg/s) - ! external tendency on snow number(#/kg/s) - ! ice effective radius (m) - ! 1st order rate for direct conversion of - ! strat. cloud water to precip (1/s) ! rce 2010/05/01 - ! Sedimentation velocity of liquid stratus cloud droplet [ m/s ] - ! Grid-mean microphysical tendency - ! Grid-mean microphysical tendency - ! Grid-mean microphysical tendency - ! Grid-mean microphysical tendency - ! Grid-mean microphysical tendency - ! Grid-mean microphysical tendency - ! In-liquid stratus microphysical tendency - ! variables for heterogeneous freezing - ! A local copy of state is used for diagnostic calculations - ! Ice cloud fraction - ! Liquid cloud fraction (combined into cloud) - ! Liquid effective drop radius (microns) - ! Ice effective drop size (microns) - ! Total cloud fraction - ! Convective cloud fraction - ! Stratiform in-cloud ice water path for radiation - ! Stratiform in-cloud liquid water path for radiation - ! Cloud fraction for liquid+snow - ! In-cloud snow water path - ! In stratus ice mixing ratio - ! In stratus water mixing ratio - ! In cloud ice number conc - ! In cloud water number conc - ! Vertically-integrated in-cloud Liquid WP before microphysics - ! Vertically-integrated in-cloud Ice WP before microphysics - ! Averaging arrays for effective radius and number.... - ! Vertically-integrated droplet concentration - ! In stratus ice mixing ratio - ! In stratus water mixing ratio - ! Cloud fraction used for precipitation. - ! Average cloud top radius & number - ! Variables for precip efficiency calculation - ! LWP threshold - ! accumulated precip across timesteps - ! accumulated condensation across timesteps - ! counter for # timesteps accumulated - ! Variables for liquid water path and column condensation - ! column liquid - ! column condensation rate (units) - ! precip efficiency for output - ! fraction of time precip efficiency is written out - ! average accumulated precipitation rate in pe calculation - ! variables for autoconversion and accretion vertical averages - ! vertical average autoconversion - ! vertical average accretion - ! ratio of vertical averages - ! counters - ! stratus ice mixing ratio - on grid - ! stratus water mixing ratio - on grid - ! Ice effective drop size at fixed number (indirect effect) (microns) - on grid - INTEGER :: nlev ! number of levels where cloud physics is done - INTEGER :: mgncol ! size of mgcols - ! Columns with microphysics performed - ! Flag to store whether accessing grid or sub-columns in pbuf_get_field - CHARACTER(LEN=128) :: errstring - CHARACTER(LEN=128) :: ref_errstring ! return status (non-blank for error return) - ! For rrtmg optics. specified distribution. - ! Convective size distribution effective radius (meters) - ! Convective size distribution shape parameter - ! Convective ice effective diameter (meters) - !------------------------------------------------------------------------------- - ! Find the number of levels used in the microphysics. - ! Set the col_type flag to grid or subcolumn dependent on the value of use_subcol_microp - !----------------------- - ! These physics buffer fields are read only and not set in this parameterization - ! If these fields do not have subcolumn data, copy the grid to the subcolumn if subcolumns is turned on - ! If subcolumns is not turned on, then these fields will be grid data - !----------------------- - ! These physics buffer fields are calculated and set in this parameterization - ! If subcolumns is turned on, then these fields will be calculated on a subcolumn grid, otherwise they will be a - ! normal grid - !----------------------- - ! If subcolumns is turned on, all calculated fields which are on subcolumns - ! need to be retrieved on the grid as well for storing averaged values - !----------------------- - ! These are only on the grid regardless of whether subcolumns are turned on or not - ! Only MG 1 defines this field so far. - !------------------------------------------------------------------------------------- - ! Microphysics assumes 'liquid stratus frac = ice stratus frac - ! = max( liquid stratus frac, ice stratus frac )'. - ! Output initial in-cloud LWP (before microphysics) - ! Initialize local state from input. - ! Initialize ptend for output. - ! the name 'cldwat' triggers special tests on cldliq - ! and cldice in physics_update - ! workaround an apparent pgi compiler bug on goldbach - ! The following are all variables related to sizes, where it does not - ! necessarily make sense to average over time steps. Instead, we keep - ! the value from the last substep, which is what "accum_null" does. - ! Allocate all the dummies with MG sizes. - ! Pack input variables that are not updated during substeps. - ! Allocate input variables that are updated during substeps. - tolerance = 1.E-14 - CALL kgen_init_check(check_status, tolerance) - CALL kgen_read_real_r8_dim2_alloc(packed_t, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_q, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_qc, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_nc, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_qi, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_ni, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_qr, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_nr, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_qs, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_ns, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_relvar, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_accre_enhan, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_p, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_pdel, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_cldn, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_liqcldf, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_icecldf, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_naai, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_npccn, kgen_unit) - CALL kgen_read_real_r8_dim3_alloc(packed_rndst, kgen_unit) - CALL kgen_read_real_r8_dim3_alloc(packed_nacon, kgen_unit) - CALL kgen_read_real_r8_dim2_ptr(packed_tnd_qsnow, kgen_unit) - CALL kgen_read_real_r8_dim2_ptr(packed_tnd_nsnow, kgen_unit) - CALL kgen_read_real_r8_dim2_ptr(packed_re_ice, kgen_unit) - CALL kgen_read_real_r8_dim2_ptr(packed_frzimm, kgen_unit) - CALL kgen_read_real_r8_dim2_ptr(packed_frzcnt, kgen_unit) - CALL kgen_read_real_r8_dim2_ptr(packed_frzdep, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_rate1ord_cw2pr_st, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_tlat, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_qvlat, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_qctend, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_qitend, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_nctend, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_nitend, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_qrtend, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_qstend, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_nrtend, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_nstend, kgen_unit) - CALL kgen_read_real_r8_dim1_alloc(packed_prect, kgen_unit) - CALL kgen_read_real_r8_dim1_alloc(packed_preci, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_nevapr, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_evapsnow, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_prain, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_prodsnow, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_cmeout, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_qsout, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_rflx, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_sflx, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_qrout, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_qcsevap, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_qisevap, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_qvres, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_cmei, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_vtrmc, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_vtrmi, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_qcsedten, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_qisedten, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_qrsedten, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_qssedten, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_umr, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_ums, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_pra, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_prc, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_mnuccc, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_mnucct, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_msacwi, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_psacws, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_bergs, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_berg, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_melt, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_homo, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_qcres, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_prci, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_prai, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_qires, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_mnuccr, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_pracs, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_meltsdt, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_frzrdt, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_mnuccd, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_nrout, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_nsout, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_refl, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_arefl, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_areflz, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_frefl, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_csrfl, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_acsrfl, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_fcsrfl, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_rercld, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_ncai, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_ncal, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_qrout2, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_qsout2, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_nrout2, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_nsout2, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_freqs, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_freqr, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_nfice, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_prer_evap, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_qcrat, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_rel, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_rei, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_lambdac, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_mu, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_des, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(packed_dei, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(rel_fn_dum, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(dsout2_dum, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(drout_dum, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(reff_rain_dum, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(reff_snow_dum, kgen_unit) - READ(UNIT=kgen_unit) nlev - READ(UNIT=kgen_unit) mgncol - READ(UNIT=kgen_unit) errstring - - CALL kgen_read_real_r8_dim2_alloc(ref_packed_rate1ord_cw2pr_st, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_tlat, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_qvlat, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_qctend, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_qitend, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_nctend, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_nitend, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_qrtend, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_qstend, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_nrtend, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_nstend, kgen_unit) - CALL kgen_read_real_r8_dim1_alloc(ref_packed_prect, kgen_unit) - CALL kgen_read_real_r8_dim1_alloc(ref_packed_preci, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_nevapr, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_evapsnow, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_prain, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_prodsnow, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_cmeout, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_qsout, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_rflx, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_sflx, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_qrout, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_qcsevap, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_qisevap, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_qvres, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_cmei, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_vtrmc, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_vtrmi, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_qcsedten, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_qisedten, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_qrsedten, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_qssedten, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_umr, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_ums, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_pra, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_prc, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_mnuccc, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_mnucct, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_msacwi, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_psacws, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_bergs, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_berg, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_melt, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_homo, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_qcres, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_prci, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_prai, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_qires, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_mnuccr, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_pracs, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_meltsdt, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_frzrdt, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_mnuccd, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_nrout, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_nsout, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_refl, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_arefl, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_areflz, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_frefl, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_csrfl, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_acsrfl, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_fcsrfl, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_rercld, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_ncai, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_ncal, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_qrout2, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_qsout2, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_nrout2, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_nsout2, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_freqs, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_freqr, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_nfice, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_prer_evap, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_qcrat, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_rel, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_rei, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_lambdac, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_mu, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_des, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_packed_dei, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_rel_fn_dum, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_dsout2_dum, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_drout_dum, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_reff_rain_dum, kgen_unit) - CALL kgen_read_real_r8_dim2_alloc(ref_reff_snow_dum, kgen_unit) - READ(UNIT=kgen_unit) ref_errstring - - ! call to kernel - CALL micro_mg_tend2_0(mgncol, nlev, dtime / num_steps, packed_t, packed_q, packed_qc, packed_qi, & - packed_nc, packed_ni, packed_qr, packed_qs, packed_nr, packed_ns, packed_relvar, & - packed_accre_enhan, packed_p, packed_pdel, packed_cldn, packed_liqcldf, packed_icecldf, & - packed_rate1ord_cw2pr_st, packed_naai, packed_npccn, packed_rndst, packed_nacon, packed_tlat, & - packed_qvlat, packed_qctend, packed_qitend, packed_nctend, packed_nitend, packed_qrtend, & - packed_qstend, packed_nrtend, packed_nstend, packed_rel, rel_fn_dum, packed_rei, packed_prect, & - packed_preci, packed_nevapr, packed_evapsnow, packed_prain, packed_prodsnow, packed_cmeout, & - packed_dei, packed_mu, packed_lambdac, packed_qsout, packed_des, packed_rflx, packed_sflx, & - packed_qrout, reff_rain_dum, reff_snow_dum, packed_qcsevap, packed_qisevap, packed_qvres, & - packed_cmei, packed_vtrmc, packed_vtrmi, packed_umr, packed_ums, packed_qcsedten, & - packed_qisedten, packed_qrsedten, packed_qssedten, packed_pra, packed_prc, packed_mnuccc, & - packed_mnucct, packed_msacwi, packed_psacws, packed_bergs, packed_berg, packed_melt, & - packed_homo, packed_qcres, packed_prci, packed_prai, packed_qires, packed_mnuccr, & - packed_pracs, packed_meltsdt, packed_frzrdt, packed_mnuccd, packed_nrout, packed_nsout, & - packed_refl, packed_arefl, packed_areflz, packed_frefl, packed_csrfl, packed_acsrfl, & - packed_fcsrfl, packed_rercld, packed_ncai, packed_ncal, packed_qrout2, packed_qsout2, & - packed_nrout2, packed_nsout2, drout_dum, dsout2_dum, packed_freqs, packed_freqr, & - packed_nfice, packed_qcrat, errstring, packed_tnd_qsnow, packed_tnd_nsnow, packed_re_ice, & - packed_prer_evap, packed_frzimm, packed_frzcnt, packed_frzdep) - ! kernel verification for output variables - CALL kgen_verify_real_r8_dim2_alloc( "packed_rate1ord_cw2pr_st", check_status, packed_rate1ord_cw2pr_st, ref_packed_rate1ord_cw2pr_st) - CALL kgen_verify_real_r8_dim2_alloc( "packed_tlat", check_status, packed_tlat, ref_packed_tlat) - CALL kgen_verify_real_r8_dim2_alloc( "packed_qvlat", check_status, packed_qvlat, ref_packed_qvlat) - CALL kgen_verify_real_r8_dim2_alloc( "packed_qctend", check_status, packed_qctend, ref_packed_qctend) - CALL kgen_verify_real_r8_dim2_alloc( "packed_qitend", check_status, packed_qitend, ref_packed_qitend) - CALL kgen_verify_real_r8_dim2_alloc( "packed_nctend", check_status, packed_nctend, ref_packed_nctend) - ! Temporarily increase tolerance to 5.0e-13 - check_status%tolerance = 5.E-13 - CALL kgen_verify_real_r8_dim2_alloc( "packed_nitend", check_status, packed_nitend, ref_packed_nitend) - check_status%tolerance = tolerance - CALL kgen_verify_real_r8_dim2_alloc( "packed_qrtend", check_status, packed_qrtend, ref_packed_qrtend) - CALL kgen_verify_real_r8_dim2_alloc( "packed_qstend", check_status, packed_qstend, ref_packed_qstend) - ! Temporarily increase tolerance to 5.0e-14 - check_status%tolerance = 5.E-14 - CALL kgen_verify_real_r8_dim2_alloc( "packed_nrtend", check_status, packed_nrtend, ref_packed_nrtend) - check_status%tolerance = tolerance - CALL kgen_verify_real_r8_dim2_alloc( "packed_nstend", check_status, packed_nstend, ref_packed_nstend) - CALL kgen_verify_real_r8_dim1_alloc( "packed_prect", check_status, packed_prect, ref_packed_prect) - CALL kgen_verify_real_r8_dim1_alloc( "packed_preci", check_status, packed_preci, ref_packed_preci) - CALL kgen_verify_real_r8_dim2_alloc( "packed_nevapr", check_status, packed_nevapr, ref_packed_nevapr) - CALL kgen_verify_real_r8_dim2_alloc( "packed_evapsnow", check_status, packed_evapsnow, ref_packed_evapsnow) - CALL kgen_verify_real_r8_dim2_alloc( "packed_prain", check_status, packed_prain, ref_packed_prain) - CALL kgen_verify_real_r8_dim2_alloc( "packed_prodsnow", check_status, packed_prodsnow, ref_packed_prodsnow) - CALL kgen_verify_real_r8_dim2_alloc( "packed_cmeout", check_status, packed_cmeout, ref_packed_cmeout) - CALL kgen_verify_real_r8_dim2_alloc( "packed_qsout", check_status, packed_qsout, ref_packed_qsout) - CALL kgen_verify_real_r8_dim2_alloc( "packed_rflx", check_status, packed_rflx, ref_packed_rflx) - CALL kgen_verify_real_r8_dim2_alloc( "packed_sflx", check_status, packed_sflx, ref_packed_sflx) - CALL kgen_verify_real_r8_dim2_alloc( "packed_qrout", check_status, packed_qrout, ref_packed_qrout) - CALL kgen_verify_real_r8_dim2_alloc( "packed_qcsevap", check_status, packed_qcsevap, ref_packed_qcsevap) - CALL kgen_verify_real_r8_dim2_alloc( "packed_qisevap", check_status, packed_qisevap, ref_packed_qisevap) - CALL kgen_verify_real_r8_dim2_alloc( "packed_qvres", check_status, packed_qvres, ref_packed_qvres) - CALL kgen_verify_real_r8_dim2_alloc( "packed_cmei", check_status, packed_cmei, ref_packed_cmei) - CALL kgen_verify_real_r8_dim2_alloc( "packed_vtrmc", check_status, packed_vtrmc, ref_packed_vtrmc) - ! Temporarily increase tolerance to 5.0e-12 - check_status%tolerance = 5.E-12 - CALL kgen_verify_real_r8_dim2_alloc( "packed_vtrmi", check_status, packed_vtrmi, ref_packed_vtrmi) - check_status%tolerance = tolerance - CALL kgen_verify_real_r8_dim2_alloc( "packed_qcsedten", check_status, packed_qcsedten, ref_packed_qcsedten) - ! Temporarily increase tolerance to 1.0e-11 - check_status%tolerance = 1.E-11 !djp djp - CALL kgen_verify_real_r8_dim2_alloc( "packed_qisedten", check_status, packed_qisedten, ref_packed_qisedten) - check_status%tolerance = tolerance - CALL kgen_verify_real_r8_dim2_alloc( "packed_qrsedten", check_status, packed_qrsedten, ref_packed_qrsedten) - ! Temporarily increase tolerance to 5.0e-12 - check_status%tolerance = 1.E-11 - CALL kgen_verify_real_r8_dim2_alloc( "packed_qssedten", check_status, packed_qssedten, ref_packed_qssedten) - check_status%tolerance = tolerance - CALL kgen_verify_real_r8_dim2_alloc( "packed_umr", check_status, packed_umr, ref_packed_umr) - CALL kgen_verify_real_r8_dim2_alloc( "packed_ums", check_status, packed_ums, ref_packed_ums) - CALL kgen_verify_real_r8_dim2_alloc( "packed_pra", check_status, packed_pra, ref_packed_pra) - CALL kgen_verify_real_r8_dim2_alloc( "packed_prc", check_status, packed_prc, ref_packed_prc) - CALL kgen_verify_real_r8_dim2_alloc( "packed_mnuccc", check_status, packed_mnuccc, ref_packed_mnuccc) - CALL kgen_verify_real_r8_dim2_alloc( "packed_mnucct", check_status, packed_mnucct, ref_packed_mnucct) - CALL kgen_verify_real_r8_dim2_alloc( "packed_msacwi", check_status, packed_msacwi, ref_packed_msacwi) - CALL kgen_verify_real_r8_dim2_alloc( "packed_psacws", check_status, packed_psacws, ref_packed_psacws) - CALL kgen_verify_real_r8_dim2_alloc( "packed_bergs", check_status, packed_bergs, ref_packed_bergs) - CALL kgen_verify_real_r8_dim2_alloc( "packed_berg", check_status, packed_berg, ref_packed_berg) - CALL kgen_verify_real_r8_dim2_alloc( "packed_melt", check_status, packed_melt, ref_packed_melt) - CALL kgen_verify_real_r8_dim2_alloc( "packed_homo", check_status, packed_homo, ref_packed_homo) - CALL kgen_verify_real_r8_dim2_alloc( "packed_qcres", check_status, packed_qcres, ref_packed_qcres) - CALL kgen_verify_real_r8_dim2_alloc( "packed_prci", check_status, packed_prci, ref_packed_prci) - CALL kgen_verify_real_r8_dim2_alloc( "packed_prai", check_status, packed_prai, ref_packed_prai) - CALL kgen_verify_real_r8_dim2_alloc( "packed_qires", check_status, packed_qires, ref_packed_qires) - CALL kgen_verify_real_r8_dim2_alloc( "packed_mnuccr", check_status, packed_mnuccr, ref_packed_mnuccr) - CALL kgen_verify_real_r8_dim2_alloc( "packed_pracs", check_status, packed_pracs, ref_packed_pracs) - CALL kgen_verify_real_r8_dim2_alloc( "packed_meltsdt", check_status, packed_meltsdt, ref_packed_meltsdt) - CALL kgen_verify_real_r8_dim2_alloc( "packed_frzrdt", check_status, packed_frzrdt, ref_packed_frzrdt) - CALL kgen_verify_real_r8_dim2_alloc( "packed_mnuccd", check_status, packed_mnuccd, ref_packed_mnuccd) - CALL kgen_verify_real_r8_dim2_alloc( "packed_nrout", check_status, packed_nrout, ref_packed_nrout) - CALL kgen_verify_real_r8_dim2_alloc( "packed_nsout", check_status, packed_nsout, ref_packed_nsout) - CALL kgen_verify_real_r8_dim2_alloc( "packed_refl", check_status, packed_refl, ref_packed_refl) - CALL kgen_verify_real_r8_dim2_alloc( "packed_arefl", check_status, packed_arefl, ref_packed_arefl) - CALL kgen_verify_real_r8_dim2_alloc( "packed_areflz", check_status, packed_areflz, ref_packed_areflz) - CALL kgen_verify_real_r8_dim2_alloc( "packed_frefl", check_status, packed_frefl, ref_packed_frefl) - CALL kgen_verify_real_r8_dim2_alloc( "packed_csrfl", check_status, packed_csrfl, ref_packed_csrfl) - CALL kgen_verify_real_r8_dim2_alloc( "packed_acsrfl", check_status, packed_acsrfl, ref_packed_acsrfl) - CALL kgen_verify_real_r8_dim2_alloc( "packed_fcsrfl", check_status, packed_fcsrfl, ref_packed_fcsrfl) - CALL kgen_verify_real_r8_dim2_alloc( "packed_rercld", check_status, packed_rercld, ref_packed_rercld) - CALL kgen_verify_real_r8_dim2_alloc( "packed_ncai", check_status, packed_ncai, ref_packed_ncai) - CALL kgen_verify_real_r8_dim2_alloc( "packed_ncal", check_status, packed_ncal, ref_packed_ncal) - CALL kgen_verify_real_r8_dim2_alloc( "packed_qrout2", check_status, packed_qrout2, ref_packed_qrout2) - CALL kgen_verify_real_r8_dim2_alloc( "packed_qsout2", check_status, packed_qsout2, ref_packed_qsout2) - CALL kgen_verify_real_r8_dim2_alloc( "packed_nrout2", check_status, packed_nrout2, ref_packed_nrout2) - CALL kgen_verify_real_r8_dim2_alloc( "packed_nsout2", check_status, packed_nsout2, ref_packed_nsout2) - CALL kgen_verify_real_r8_dim2_alloc( "packed_freqs", check_status, packed_freqs, ref_packed_freqs) - CALL kgen_verify_real_r8_dim2_alloc( "packed_freqr", check_status, packed_freqr, ref_packed_freqr) - CALL kgen_verify_real_r8_dim2_alloc( "packed_nfice", check_status, packed_nfice, ref_packed_nfice) - CALL kgen_verify_real_r8_dim2_alloc( "packed_prer_evap", check_status, packed_prer_evap, ref_packed_prer_evap) - CALL kgen_verify_real_r8_dim2_alloc( "packed_qcrat", check_status, packed_qcrat, ref_packed_qcrat) - ! Temporarily increase tolerance to 1.0e-11 - check_status%tolerance = 1.E-11 - CALL kgen_verify_real_r8_dim2_alloc( "packed_rel", check_status, packed_rel, ref_packed_rel) - check_status%tolerance = tolerance - CALL kgen_verify_real_r8_dim2_alloc( "packed_rei", check_status, packed_rei, ref_packed_rei) - ! Temporarily increase tolerance to 1.0e-11 - check_status%tolerance = 1.E-11 - CALL kgen_verify_real_r8_dim2_alloc( "packed_lambdac", check_status, packed_lambdac, ref_packed_lambdac) - check_status%tolerance = tolerance - CALL kgen_verify_real_r8_dim2_alloc( "packed_mu", check_status, packed_mu, ref_packed_mu) - CALL kgen_verify_real_r8_dim2_alloc( "packed_des", check_status, packed_des, ref_packed_des) - CALL kgen_verify_real_r8_dim2_alloc( "packed_dei", check_status, packed_dei, ref_packed_dei) - CALL kgen_verify_real_r8_dim2_alloc( "rel_fn_dum", check_status, rel_fn_dum, ref_rel_fn_dum) - CALL kgen_verify_real_r8_dim2_alloc( "dsout2_dum", check_status, dsout2_dum, ref_dsout2_dum) - CALL kgen_verify_real_r8_dim2_alloc( "drout_dum", check_status, drout_dum, ref_drout_dum) - CALL kgen_verify_real_r8_dim2_alloc( "reff_rain_dum", check_status, reff_rain_dum, ref_reff_rain_dum) - CALL kgen_verify_real_r8_dim2_alloc( "reff_snow_dum", check_status, reff_snow_dum, ref_reff_snow_dum) - CALL kgen_verify_character( "errstring", check_status, errstring, ref_errstring) - CALL kgen_print_check("micro_mg_tend", check_status) - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,10 - CALL micro_mg_tend2_0(mgncol, nlev, dtime / num_steps, packed_t, packed_q, packed_qc, & - packed_qi, packed_nc, packed_ni, packed_qr, packed_qs, packed_nr, packed_ns, & - packed_relvar, packed_accre_enhan, packed_p, packed_pdel, packed_cldn, packed_liqcldf, & - packed_icecldf, packed_rate1ord_cw2pr_st, packed_naai, packed_npccn, packed_rndst, & - packed_nacon, packed_tlat, packed_qvlat, packed_qctend, packed_qitend, packed_nctend, & - packed_nitend, packed_qrtend, packed_qstend, packed_nrtend, packed_nstend, packed_rel, & - rel_fn_dum, packed_rei, packed_prect, packed_preci, packed_nevapr, packed_evapsnow, & - packed_prain, packed_prodsnow, packed_cmeout, packed_dei, packed_mu, packed_lambdac, & - packed_qsout, packed_des, packed_rflx, packed_sflx, packed_qrout, reff_rain_dum, & - reff_snow_dum, packed_qcsevap, packed_qisevap, packed_qvres, packed_cmei, packed_vtrmc, & - packed_vtrmi, packed_umr, packed_ums, packed_qcsedten, packed_qisedten, packed_qrsedten, & - packed_qssedten, packed_pra, packed_prc, packed_mnuccc, packed_mnucct, packed_msacwi, & - packed_psacws, packed_bergs, packed_berg, packed_melt, packed_homo, packed_qcres, & - packed_prci, packed_prai, packed_qires, packed_mnuccr, packed_pracs, packed_meltsdt, & - packed_frzrdt, packed_mnuccd, packed_nrout, packed_nsout, packed_refl, packed_arefl, & - packed_areflz, packed_frefl, packed_csrfl, packed_acsrfl, packed_fcsrfl, packed_rercld, & - packed_ncai, packed_ncal, packed_qrout2, packed_qsout2, packed_nrout2, packed_nsout2, & - drout_dum, dsout2_dum, packed_freqs, packed_freqr, packed_nfice, packed_qcrat, errstring, & - packed_tnd_qsnow, packed_tnd_nsnow, packed_re_ice, packed_prer_evap, packed_frzimm, & - packed_frzcnt, packed_frzdep) - END DO - CALL system_clock(stop_clock, rate_clock) - WRITE(*,*) - PRINT *, "Elapsed time (sec): ", (stop_clock - start_clock)/REAL(rate_clock*10) - ! Divide ptend by substeps. - ! Use summed outputs to produce averages - ! Check to make sure that the microphysics code is respecting the flags that control - ! whether MG should be prognosing cloud ice and cloud liquid or not. - !! calculate effective radius of convective liquid and ice using dcon and deicon (not used by code, not useful for - ! COSP) - !! hard-coded as average of hard-coded values used for deep/shallow convective detrainment (near line 1502/1505) - ! Reassign rate1 if modal aerosols - ! Sedimentation velocity for liquid stratus cloud droplet - ! Microphysical tendencies for use in the macrophysics at the next time step - ! Net micro_mg_cam condensation rate - ! For precip, accumulate only total precip in prec_pcw and snow_pcw variables. - ! Other precip output variables are set to 0 - ! Do not subscript by ncol here, because in physpkg we divide the whole - ! array and need to avoid an FPE due to uninitialized data. - ! ------------------------------------------------------------ ! - ! Compute in cloud ice and liquid mixing ratios ! - ! Note that 'iclwp, iciwp' are used for radiation computation. ! - ! ------------------------------------------------------------ ! - ! Calculate cloud fraction for prognostic precip sizes. - ! ------------------------------------------------------ ! - ! ------------------------------------------------------ ! - ! All code from here to the end is on grid columns only ! - ! ------------------------------------------------------ ! - ! ------------------------------------------------------ ! - ! Average the fields which are needed later in this paramterization to be on the grid - ! If on subcolumns, average the rest of the pbuf fields which were modified on subcolumns but are not used further in - ! this parameterization (no need to assign in the non-subcolumn case -- the else step) - ! ------------------------------------- ! - ! Size distribution calculation ! - ! ------------------------------------- ! - ! Calculate rho (on subcolumns if turned on) for size distribution - ! parameter calculations and average it if needed - ! - ! State instead of state_loc to preserve answers for MG1 (and in any - ! case, it is unlikely to make much difference). - ! Effective radius for cloud liquid, fixed number. - ! Effective radius for cloud liquid, and size parameters - ! mu_grid and lambdac_grid. - ! Calculate ncic on the grid - ! Rain/Snow effective diameter. - ! Effective radius and diameter for cloud ice. - ! Limiters for low cloud fraction. - ! ------------------------------------- ! - ! Precipitation efficiency Calculation ! - ! ------------------------------------- ! - !----------------------------------------------------------------------- - ! Liquid water path - ! Compute liquid water paths, and column condensation - ! note: 1e-6 kgho2/kgair/s * 1000. pa / (9.81 m/s2) / 1000 kgh2o/m3 = 1e-7 m/s - ! this is 1ppmv of h2o in 10hpa - ! alternatively: 0.1 mm/day * 1.e-4 m/mm * 1/86400 day/s = 1.e-9 - !----------------------------------------------------------------------- - ! precipitation efficiency calculation (accumulate cme and precip) - !minimum lwp threshold (kg/m3) - ! zero out precip efficiency and total averaged precip - ! accumulate precip and condensation - !----------------------------------------------------------------------- - ! vertical average of non-zero accretion, autoconversion and ratio. - ! vars: vprco_grid(i),vprao_grid(i),racau_grid(i),cnt_grid - ! --------------------- ! - ! History Output Fields ! - ! --------------------- ! - ! Column droplet concentration - ! Averaging for new output fields - ! Cloud top effective radius and number. - ! Evaporation of stratiform precipitation fields for UNICON - ! Assign the values to the pbuf pointers if they exist in pbuf - ! --------------------------------------------- ! - ! General outfield calls for microphysics ! - ! --------------------------------------------- ! - ! Output a handle of variables which are calculated on the fly - ! Output fields which have not been averaged already, averaging if use_subcol_microp is true - ! Example subcolumn outfld call - ! Output fields which are already on the grid - ! ptend_loc is deallocated in physics_update above - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_r8_dim2_alloc(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim2_alloc - - SUBROUTINE kgen_read_real_r8_dim3_alloc(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2,idx3 - INTEGER, DIMENSION(2,3) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim3_alloc - - SUBROUTINE kgen_read_real_r8_dim2_ptr(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), POINTER, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim2_ptr - - SUBROUTINE kgen_read_real_r8_dim1_alloc(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim1_alloc - - - ! verify subroutines - SUBROUTINE kgen_verify_real_r8_dim2_alloc( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:), ALLOCATABLE :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:) :: temp, temp2 - integer :: n - IF ( ALLOCATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END IF - END SUBROUTINE kgen_verify_real_r8_dim2_alloc - - SUBROUTINE kgen_verify_real_r8_dim1_alloc( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:), ALLOCATABLE :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:) :: temp, temp2 - integer :: n - IF ( ALLOCATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1))) - allocate(temp2(SIZE(var,dim=1))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END IF - END SUBROUTINE kgen_verify_real_r8_dim1_alloc - - SUBROUTINE kgen_verify_character( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - character(LEN=128), intent(in) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - END SUBROUTINE kgen_verify_character - - END SUBROUTINE micro_mg_cam_tend - - - END MODULE micro_mg_cam diff --git a/test/ncar_kernels/CAM5_mg2_pgi/src/micro_mg_utils.F90 b/test/ncar_kernels/CAM5_mg2_pgi/src/micro_mg_utils.F90 deleted file mode 100644 index b002229909..0000000000 --- a/test/ncar_kernels/CAM5_mg2_pgi/src/micro_mg_utils.F90 +++ /dev/null @@ -1,960 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : micro_mg_utils.F90 -! Generated at: 2015-03-31 09:44:40 -! KGEN version: 0.4.5 - - - - MODULE micro_mg_utils - !-------------------------------------------------------------------------- - ! - ! This module contains process rates and utility functions used by the MG - ! microphysics. - ! - ! Original MG authors: Andrew Gettelman, Hugh Morrison - ! Contributions from: Peter Caldwell, Xiaohong Liu and Steve Ghan - ! - ! Separated from MG 1.5 by B. Eaton. - ! Separated module switched to MG 2.0 and further changes by S. Santos. - ! - ! for questions contact Hugh Morrison, Andrew Gettelman - ! e-mail: morrison@ucar.edu, andrew@ucar.edu - ! - !-------------------------------------------------------------------------- - ! - ! List of required external functions that must be supplied: - ! gamma --> standard mathematical gamma function (if gamma is an - ! intrinsic, define HAVE_GAMMA_INTRINSICS) - ! - !-------------------------------------------------------------------------- - ! - ! Constants that must be specified in the "init" method (module variables): - ! - ! kind kind of reals (to verify correct linkage only) - - ! gravit acceleration due to gravity m s-2 - ! rair dry air gas constant for air J kg-1 K-1 - ! rh2o gas constant for water vapor J kg-1 K-1 - ! cpair specific heat at constant pressure for dry air J kg-1 K-1 - ! tmelt temperature of melting point for water K - ! latvap latent heat of vaporization J kg-1 - ! latice latent heat of fusion J kg-1 - ! - !-------------------------------------------------------------------------- - USE shr_spfn_mod, ONLY: gamma => shr_spfn_gamma - IMPLICIT NONE - PRIVATE - PUBLIC size_dist_param_liq, rising_factorial, size_dist_param_basic, kk2000_liq_autoconversion, ice_autoconversion, & - immersion_freezing, contact_freezing, snow_self_aggregation, accrete_cloud_water_snow, secondary_ice_production, & - accrete_rain_snow, heterogeneous_rain_freezing, accrete_cloud_water_rain, self_collection_rain, accrete_cloud_ice_snow, & - evaporate_sublimate_precip, bergeron_process_snow, ice_deposition_sublimation, avg_diameter - ! 8 byte real and integer - INTEGER, parameter, public :: r8 = selected_real_kind(12) - INTEGER, parameter, public :: i8 = selected_int_kind(18) - PUBLIC mghydrometeorprops - TYPE mghydrometeorprops - ! Density (kg/m^3) - REAL(KIND=r8) :: rho - ! Information for size calculations. - ! Basic calculation of mean size is: - ! lambda = (shape_coef*nic/qic)^(1/eff_dim) - ! Then lambda is constrained by bounds. - REAL(KIND=r8) :: eff_dim - REAL(KIND=r8) :: shape_coef - REAL(KIND=r8) :: lambda_bounds(2) - ! Minimum average particle mass (kg). - ! Limit is applied at the beginning of the size distribution calculations. - REAL(KIND=r8) :: min_mean_mass - END TYPE mghydrometeorprops - - TYPE(mghydrometeorprops), public :: mg_liq_props - TYPE(mghydrometeorprops), public :: mg_ice_props - TYPE(mghydrometeorprops), public :: mg_rain_props - TYPE(mghydrometeorprops), public :: mg_snow_props - !================================================= - ! Public module parameters (mostly for MG itself) - !================================================= - ! Pi to 20 digits; more than enough to reach the limit of double precision. - REAL(KIND=r8), parameter, public :: pi = 3.14159265358979323846_r8 - ! "One minus small number": number near unity for round-off issues. - REAL(KIND=r8), parameter, public :: omsm = 1._r8 - 1.e-5_r8 - ! Smallest mixing ratio considered in microphysics. - REAL(KIND=r8), parameter, public :: qsmall = 1.e-18_r8 - ! minimum allowed cloud fraction - REAL(KIND=r8), parameter, public :: mincld = 0.0001_r8 - REAL(KIND=r8), parameter, public :: rhosn = 250._r8 ! bulk density snow - REAL(KIND=r8), parameter, public :: rhoi = 500._r8 ! bulk density ice - REAL(KIND=r8), parameter, public :: rhow = 1000._r8 ! bulk density liquid - REAL(KIND=r8), parameter, public :: rhows = 917._r8 ! bulk density water solid - ! fall speed parameters, V = aD^b (V is in m/s) - ! droplets - REAL(KIND=r8), parameter, public :: bc = 2._r8 - ! snow - REAL(KIND=r8), parameter, public :: as = 11.72_r8 - REAL(KIND=r8), parameter, public :: bs = 0.41_r8 - ! cloud ice - REAL(KIND=r8), parameter, public :: ai = 700._r8 - REAL(KIND=r8), parameter, public :: bi = 1._r8 - ! rain - REAL(KIND=r8), parameter, public :: ar = 841.99667_r8 - REAL(KIND=r8), parameter, public :: br = 0.8_r8 - ! mass of new crystal due to aerosol freezing and growth (kg) - REAL(KIND=r8), parameter, public :: mi0 = 4._r8/3._r8*pi*rhoi*(10.e-6_r8)**3 - !================================================= - ! Private module parameters - !================================================= - ! Signaling NaN bit pattern that represents a limiter that's turned off. - INTEGER(KIND=i8), parameter :: limiter_off = int(z'7FF1111111111111', i8) - ! alternate threshold used for some in-cloud mmr - REAL(KIND=r8), parameter :: icsmall = 1.e-8_r8 - ! particle mass-diameter relationship - ! currently we assume spherical particles for cloud ice/snow - ! m = cD^d - ! exponent - ! Bounds for mean diameter for different constituents. - ! Minimum average mass of particles. - ! ventilation parameters - ! for snow - REAL(KIND=r8), parameter :: f1s = 0.86_r8 - REAL(KIND=r8), parameter :: f2s = 0.28_r8 - ! for rain - REAL(KIND=r8), parameter :: f1r = 0.78_r8 - REAL(KIND=r8), parameter :: f2r = 0.308_r8 - ! collection efficiencies - ! aggregation of cloud ice and snow - REAL(KIND=r8), parameter :: eii = 0.5_r8 - ! immersion freezing parameters, bigg 1953 - REAL(KIND=r8), parameter :: bimm = 100._r8 - REAL(KIND=r8), parameter :: aimm = 0.66_r8 - ! Mass of each raindrop created from autoconversion. - REAL(KIND=r8), parameter :: droplet_mass_25um = 4._r8/3._r8*pi*rhow*(25.e-6_r8)**3 - !========================================================= - ! Constants set in initialization - !========================================================= - ! Set using arguments to micro_mg_init - REAL(KIND=r8) :: rv ! water vapor gas constant - REAL(KIND=r8) :: cpp ! specific heat of dry air - REAL(KIND=r8) :: tmelt ! freezing point of water (K) - ! latent heats of: - REAL(KIND=r8) :: xxlv ! vaporization - ! freezing - REAL(KIND=r8) :: xxls ! sublimation - ! additional constants to help speed up code - REAL(KIND=r8) :: gamma_bs_plus3 - REAL(KIND=r8) :: gamma_half_br_plus5 - REAL(KIND=r8) :: gamma_half_bs_plus5 - !========================================================= - ! Utilities that are cheaper if the compiler knows that - ! some argument is an integer. - !========================================================= - - INTERFACE rising_factorial - MODULE PROCEDURE rising_factorial_r8 - MODULE PROCEDURE rising_factorial_integer - END INTERFACE rising_factorial - - INTERFACE var_coef - MODULE PROCEDURE var_coef_r8 - MODULE PROCEDURE var_coef_integer - END INTERFACE var_coef - !========================================================================== - PUBLIC kgen_read_externs_micro_mg_utils - - ! read interface - PUBLIC kgen_read - INTERFACE kgen_read - MODULE PROCEDURE kgen_read_mghydrometeorprops - END INTERFACE kgen_read - - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_micro_mg_utils(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) rv - READ(UNIT=kgen_unit) cpp - READ(UNIT=kgen_unit) tmelt - READ(UNIT=kgen_unit) xxlv - READ(UNIT=kgen_unit) xxls - READ(UNIT=kgen_unit) gamma_bs_plus3 - READ(UNIT=kgen_unit) gamma_half_br_plus5 - READ(UNIT=kgen_unit) gamma_half_bs_plus5 - CALL kgen_read_mghydrometeorprops(mg_liq_props, kgen_unit) - CALL kgen_read_mghydrometeorprops(mg_ice_props, kgen_unit) - CALL kgen_read_mghydrometeorprops(mg_rain_props, kgen_unit) - CALL kgen_read_mghydrometeorprops(mg_snow_props, kgen_unit) - END SUBROUTINE kgen_read_externs_micro_mg_utils - - SUBROUTINE kgen_read_mghydrometeorprops(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(mghydrometeorprops), INTENT(out) :: var - READ(UNIT=kgen_unit) var%rho - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%rho **", var%rho - END IF - READ(UNIT=kgen_unit) var%eff_dim - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%eff_dim **", var%eff_dim - END IF - READ(UNIT=kgen_unit) var%shape_coef - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%shape_coef **", var%shape_coef - END IF - READ(UNIT=kgen_unit) var%lambda_bounds - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%lambda_bounds **", var%lambda_bounds - END IF - READ(UNIT=kgen_unit) var%min_mean_mass - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%min_mean_mass **", var%min_mean_mass - END IF - END SUBROUTINE - !========================================================================== - ! Initialize module variables. - ! - ! "kind" serves no purpose here except to check for unlikely linking - ! issues; always pass in the kind for a double precision real. - ! - ! "errstring" is the only output; it is blank if there is no error, or set - ! to a message if there is an error. - ! - ! Check the list at the top of this module for descriptions of all other - ! arguments. - - ! Constructor for a constituent property object. - - !======================================================================== - !FORMULAS - !======================================================================== - ! Use gamma function to implement rising factorial extended to the reals. - - pure FUNCTION rising_factorial_r8(x, n) RESULT ( res ) - REAL(KIND=r8), intent(in) :: x - REAL(KIND=r8), intent(in) :: n - REAL(KIND=r8) :: res - res = gamma(x+n)/gamma(x) - END FUNCTION rising_factorial_r8 - ! Rising factorial can be performed much cheaper if n is a small integer. - - pure FUNCTION rising_factorial_integer(x, n) RESULT ( res ) - REAL(KIND=r8), intent(in) :: x - INTEGER, intent(in) :: n - REAL(KIND=r8) :: res - INTEGER :: i - REAL(KIND=r8) :: factor - res = 1._r8 - factor = x - DO i = 1, n - res = res * factor - factor = factor + 1._r8 - END DO - END FUNCTION rising_factorial_integer - ! Calculate correction due to latent heat for evaporation/sublimation - - elemental FUNCTION calc_ab(t, qv, xxl) RESULT ( ab ) - REAL(KIND=r8), intent(in) :: t ! Temperature - REAL(KIND=r8), intent(in) :: qv ! Saturation vapor pressure - REAL(KIND=r8), intent(in) :: xxl ! Latent heat - REAL(KIND=r8) :: ab - REAL(KIND=r8) :: dqsdt - dqsdt = xxl*qv / (rv * t**2) - ab = 1._r8 + dqsdt*xxl/cpp - END FUNCTION calc_ab - ! get cloud droplet size distribution parameters - - elemental SUBROUTINE size_dist_param_liq(props, qcic, ncic, rho, pgam, lamc) - TYPE(mghydrometeorprops), intent(in) :: props - REAL(KIND=r8), intent(in) :: qcic - REAL(KIND=r8), intent(inout) :: ncic - REAL(KIND=r8), intent(in) :: rho - REAL(KIND=r8), intent(out) :: pgam - REAL(KIND=r8), intent(out) :: lamc - TYPE(mghydrometeorprops) :: props_loc - IF (qcic > qsmall) THEN - ! Local copy of properties that can be modified. - ! (Elemental routines that operate on arrays can't modify scalar - ! arguments.) - props_loc = props - ! Get pgam from fit to observations of martin et al. 1994 - pgam = 0.0005714_r8*1.e-6_r8*ncic*rho + 0.2714_r8 - pgam = 1._r8/(pgam**2) - 1._r8 - pgam = max(pgam, 2._r8) - ! Set coefficient for use in size_dist_param_basic. - ! The 3D case is so common and optimizable that we specialize it: - IF (props_loc%eff_dim == 3._r8) THEN - props_loc%shape_coef = pi / 6._r8 * props_loc%rho * rising_factorial(pgam+1._r8, 3) - ELSE - props_loc%shape_coef = pi / 6._r8 * props_loc%rho * rising_factorial(pgam+1._r8, & - props_loc%eff_dim) - END IF - ! Limit to between 2 and 50 microns mean size. - props_loc%lambda_bounds = (pgam+1._r8)*1._r8/[50.e-6_r8, 2.e-6_r8] - CALL size_dist_param_basic(props_loc, qcic, ncic, lamc) - ELSE - ! pgam not calculated in this case, so set it to a value likely to - ! cause an error if it is accidentally used - ! (gamma function undefined for negative integers) - pgam = -100._r8 - lamc = 0._r8 - END IF - END SUBROUTINE size_dist_param_liq - ! Basic routine for getting size distribution parameters. - - elemental SUBROUTINE size_dist_param_basic(props, qic, nic, lam, n0) - TYPE(mghydrometeorprops), intent(in) :: props - REAL(KIND=r8), intent(in) :: qic - REAL(KIND=r8), intent(inout) :: nic - REAL(KIND=r8), intent(out) :: lam - REAL(KIND=r8), intent(out), optional :: n0 - IF (qic > qsmall) THEN - ! add upper limit to in-cloud number concentration to prevent - ! numerical error - IF (limiter_is_on(props%min_mean_mass)) THEN - nic = min(nic, qic / props%min_mean_mass) - END IF - ! lambda = (c n/q)^(1/d) - lam = (props%shape_coef * nic/qic)**(1._r8/props%eff_dim) - ! check for slope - ! adjust vars - IF (lam < props%lambda_bounds(1)) THEN - lam = props%lambda_bounds(1) - nic = lam**(props%eff_dim) * qic/props%shape_coef - ELSE IF (lam > props%lambda_bounds(2)) THEN - lam = props%lambda_bounds(2) - nic = lam**(props%eff_dim) * qic/props%shape_coef - END IF - ELSE - lam = 0._r8 - END IF - IF (present(n0)) n0 = nic * lam - END SUBROUTINE size_dist_param_basic - - elemental real(r8) FUNCTION avg_diameter(q, n, rho_air, rho_sub) - ! Finds the average diameter of particles given their density, and - ! mass/number concentrations in the air. - ! Assumes that diameter follows an exponential distribution. - REAL(KIND=r8), intent(in) :: q ! mass mixing ratio - REAL(KIND=r8), intent(in) :: n ! number concentration (per volume) - REAL(KIND=r8), intent(in) :: rho_air ! local density of the air - REAL(KIND=r8), intent(in) :: rho_sub ! density of the particle substance - avg_diameter = (pi * rho_sub * n/(q*rho_air))**(-1._r8/3._r8) - END FUNCTION avg_diameter - - elemental FUNCTION var_coef_r8(relvar, a) RESULT ( res ) - ! Finds a coefficient for process rates based on the relative variance - ! of cloud water. - REAL(KIND=r8), intent(in) :: relvar - REAL(KIND=r8), intent(in) :: a - REAL(KIND=r8) :: res - res = rising_factorial(relvar, a) / relvar**a - END FUNCTION var_coef_r8 - - elemental FUNCTION var_coef_integer(relvar, a) RESULT ( res ) - ! Finds a coefficient for process rates based on the relative variance - ! of cloud water. - REAL(KIND=r8), intent(in) :: relvar - INTEGER, intent(in) :: a - REAL(KIND=r8) :: res - res = rising_factorial(relvar, a) / relvar**a - END FUNCTION var_coef_integer - !======================================================================== - !MICROPHYSICAL PROCESS CALCULATIONS - !======================================================================== - !======================================================================== - ! Initial ice deposition and sublimation loop. - ! Run before the main loop - ! This subroutine written by Peter Caldwell - - elemental SUBROUTINE ice_deposition_sublimation(t, qv, qi, ni, icldm, rho, dv, qvl, qvi, berg, vap_dep, ice_sublim) - !INPUT VARS: - !=============================================== - REAL(KIND=r8), intent(in) :: t - REAL(KIND=r8), intent(in) :: qv - REAL(KIND=r8), intent(in) :: qi - REAL(KIND=r8), intent(in) :: ni - REAL(KIND=r8), intent(in) :: icldm - REAL(KIND=r8), intent(in) :: rho - REAL(KIND=r8), intent(in) :: dv - REAL(KIND=r8), intent(in) :: qvl - REAL(KIND=r8), intent(in) :: qvi - !OUTPUT VARS: - !=============================================== - REAL(KIND=r8), intent(out) :: vap_dep !ice deposition (cell-ave value) - REAL(KIND=r8), intent(out) :: ice_sublim !ice sublimation (cell-ave value) - REAL(KIND=r8), intent(out) :: berg !bergeron enhancement (cell-ave value) - !INTERNAL VARS: - !=============================================== - REAL(KIND=r8) :: ab - REAL(KIND=r8) :: epsi - REAL(KIND=r8) :: qiic - REAL(KIND=r8) :: niic - REAL(KIND=r8) :: lami - REAL(KIND=r8) :: n0i - IF (qi>=qsmall) THEN - !GET IN-CLOUD qi, ni - !=============================================== - qiic = qi/icldm - niic = ni/icldm - !Compute linearized condensational heating correction - ab = calc_ab(t, qvi, xxls) - !Get slope and intercept of gamma distn for ice. - CALL size_dist_param_basic(mg_ice_props, qiic, niic, lami, n0i) - !Get depletion timescale=1/eps - epsi = 2._r8*pi*n0i*rho*dv/(lami*lami) - !Compute deposition/sublimation - vap_dep = epsi/ab*(qv - qvi) - !Make this a grid-averaged quantity - vap_dep = vap_dep*icldm - !Split into deposition or sublimation. - IF (t < tmelt .and. vap_dep>0._r8) THEN - ice_sublim = 0._r8 - ELSE - ! make ice_sublim negative for consistency with other evap/sub processes - ice_sublim = min(vap_dep,0._r8) - vap_dep = 0._r8 - END IF - !sublimation occurs @ any T. Not so for berg. - IF (t < tmelt) THEN - !Compute bergeron rate assuming cloud for whole step. - berg = max(epsi/ab*(qvl - qvi), 0._r8) - ELSE !T>frz - berg = 0._r8 - END IF !Tqsmall - END SUBROUTINE ice_deposition_sublimation - !======================================================================== - ! autoconversion of cloud liquid water to rain - ! formula from Khrouditnov and Kogan (2000), modified for sub-grid distribution of qc - ! minimum qc of 1 x 10^-8 prevents floating point error - - elemental SUBROUTINE kk2000_liq_autoconversion(microp_uniform, qcic, ncic, rho, relvar, prc, nprc, nprc1) - LOGICAL, intent(in) :: microp_uniform - REAL(KIND=r8), intent(in) :: qcic - REAL(KIND=r8), intent(in) :: ncic - REAL(KIND=r8), intent(in) :: rho - REAL(KIND=r8), intent(in) :: relvar - REAL(KIND=r8), intent(out) :: prc - REAL(KIND=r8), intent(out) :: nprc - REAL(KIND=r8), intent(out) :: nprc1 - REAL(KIND=r8) :: prc_coef - ! Take variance into account, or use uniform value. - IF (.not. microp_uniform) THEN - prc_coef = var_coef(relvar, 2.47_r8) - ELSE - prc_coef = 1._r8 - END IF - IF (qcic >= icsmall) THEN - ! nprc is increase in rain number conc due to autoconversion - ! nprc1 is decrease in cloud droplet conc due to autoconversion - ! assume exponential sub-grid distribution of qc, resulting in additional - ! factor related to qcvar below - ! switch for sub-columns, don't include sub-grid qc - prc = prc_coef * 1350._r8 * qcic**2.47_r8 * (ncic*1.e-6_r8*rho)**(-1.79_r8) - nprc = prc * (1._r8/droplet_mass_25um) - nprc1 = prc*ncic/qcic - ELSE - prc = 0._r8 - nprc = 0._r8 - nprc1 = 0._r8 - END IF - END SUBROUTINE kk2000_liq_autoconversion - !======================================================================== - ! Autoconversion of cloud ice to snow - ! similar to Ferrier (1994) - - elemental SUBROUTINE ice_autoconversion(t, qiic, lami, n0i, dcs, prci, nprci) - REAL(KIND=r8), intent(in) :: t - REAL(KIND=r8), intent(in) :: qiic - REAL(KIND=r8), intent(in) :: lami - REAL(KIND=r8), intent(in) :: n0i - REAL(KIND=r8), intent(in) :: dcs - REAL(KIND=r8), intent(out) :: prci - REAL(KIND=r8), intent(out) :: nprci - ! Assume autoconversion timescale of 180 seconds. - REAL(KIND=r8), parameter :: ac_time = 180._r8 - ! Average mass of an ice particle. - REAL(KIND=r8) :: m_ip - ! Ratio of autoconversion diameter to average diameter. - REAL(KIND=r8) :: d_rat - IF (t <= tmelt .and. qiic >= qsmall) THEN - d_rat = lami*dcs - ! Rate of ice particle conversion (number). - nprci = n0i/(lami*ac_time)*exp(-d_rat) - m_ip = (rhoi*pi/6._r8) / lami**3 - ! Rate of mass conversion. - ! Note that this is: - ! m n (d^3 + 3 d^2 + 6 d + 6) - prci = m_ip * nprci * (((d_rat + 3._r8)*d_rat + 6._r8)*d_rat + 6._r8) - ELSE - prci = 0._r8 - nprci = 0._r8 - END IF - END SUBROUTINE ice_autoconversion - ! immersion freezing (Bigg, 1953) - !=================================== - - elemental SUBROUTINE immersion_freezing(microp_uniform, t, pgam, lamc, qcic, ncic, relvar, mnuccc, nnuccc) - LOGICAL, intent(in) :: microp_uniform - ! Temperature - REAL(KIND=r8), intent(in) :: t - ! Cloud droplet size distribution parameters - REAL(KIND=r8), intent(in) :: pgam - REAL(KIND=r8), intent(in) :: lamc - ! MMR and number concentration of in-cloud liquid water - REAL(KIND=r8), intent(in) :: qcic - REAL(KIND=r8), intent(in) :: ncic - ! Relative variance of cloud water - REAL(KIND=r8), intent(in) :: relvar - ! Output tendencies - REAL(KIND=r8), intent(out) :: mnuccc ! MMR - REAL(KIND=r8), intent(out) :: nnuccc ! Number - ! Coefficients that will be omitted for sub-columns - REAL(KIND=r8) :: dum - IF (.not. microp_uniform) THEN - dum = var_coef(relvar, 2) - ELSE - dum = 1._r8 - END IF - IF (qcic >= qsmall .and. t < 269.15_r8) THEN - nnuccc = pi/6._r8*ncic*rising_factorial(pgam+1._r8, 3)* bimm*(exp(aimm*(tmelt - t))-1._r8)/lamc**3 - mnuccc = dum * nnuccc * pi/6._r8*rhow* rising_factorial(pgam+4._r8, 3)/lamc**3 - ELSE - mnuccc = 0._r8 - nnuccc = 0._r8 - END IF ! qcic > qsmall and t < 4 deg C - END SUBROUTINE immersion_freezing - ! contact freezing (-40= qsmall .and. t(i) < 269.15_r8) THEN - IF (.not. microp_uniform) THEN - dum = var_coef(relvar(i), 4._r8/3._r8) - dum1 = var_coef(relvar(i), 1._r8/3._r8) - ELSE - dum = 1._r8 - dum1 = 1._r8 - END IF - tcnt = (270.16_r8-t(i))**1.3_r8 - viscosity = 1.8e-5_r8*(t(i)/298.0_r8)**0.85_r8 ! Viscosity (kg/m/s) - mfp = 2.0_r8*viscosity/ (p(i)*sqrt( 8.0_r8*28.96e-3_r8/(pi*8.314409_r8*t(i)) )) ! Mean free path (m) - ! Note that these two are vectors. - nslip = 1.0_r8+(mfp/rndst(i,:))*(1.257_r8+(0.4_r8*exp(-(1.1_r8*rndst(i,:)/mfp)))) ! Slip correction factor - ndfaer = 1.381e-23_r8*t(i)*nslip/(6._r8*pi*viscosity*rndst(i,:)) ! aerosol diffusivity (m2/s) - contact_factor = dot_product(ndfaer,nacon(i,:)*tcnt) * pi * ncic(i) * (pgam(i) + 1._r8) / lamc(i) - mnucct(i) = dum * contact_factor * pi/3._r8*rhow*rising_factorial(pgam(i)+2._r8, 3)/lamc(i)**3 - nnucct(i) = dum1 * 2._r8 * contact_factor - ELSE - mnucct(i) = 0._r8 - nnucct(i) = 0._r8 - END IF ! qcic > qsmall and t < 4 deg C - END DO - END SUBROUTINE contact_freezing - ! snow self-aggregation from passarelli, 1978, used by reisner, 1998 - !=================================================================== - ! this is hard-wired for bs = 0.4 for now - ! ignore self-collection of cloud ice - - elemental SUBROUTINE snow_self_aggregation(t, rho, asn, rhosn, qsic, nsic, nsagg) - REAL(KIND=r8), intent(in) :: t ! Temperature - REAL(KIND=r8), intent(in) :: rho ! Density - REAL(KIND=r8), intent(in) :: asn ! fall speed parameter for snow - REAL(KIND=r8), intent(in) :: rhosn ! density of snow - ! In-cloud snow - REAL(KIND=r8), intent(in) :: qsic ! MMR - REAL(KIND=r8), intent(in) :: nsic ! Number - ! Output number tendency - REAL(KIND=r8), intent(out) :: nsagg - IF (qsic >= qsmall .and. t <= tmelt) THEN - nsagg = -1108._r8*eii/(4._r8*720._r8*rhosn)*asn*qsic*nsic*rho* ((qsic/nsic)*(1._r8/(rhosn*pi)))**((& - bs-1._r8)/3._r8) - ELSE - nsagg = 0._r8 - END IF - END SUBROUTINE snow_self_aggregation - ! accretion of cloud droplets onto snow/graupel - !=================================================================== - ! here use continuous collection equation with - ! simple gravitational collection kernel - ! ignore collisions between droplets/cloud ice - ! since minimum size ice particle for accretion is 50 - 150 micron - - elemental SUBROUTINE accrete_cloud_water_snow(t, rho, asn, uns, mu, qcic, ncic, qsic, pgam, lamc, lams, n0s, psacws, & - npsacws) - REAL(KIND=r8), intent(in) :: t ! Temperature - REAL(KIND=r8), intent(in) :: rho ! Density - REAL(KIND=r8), intent(in) :: asn ! Fallspeed parameter (snow) - REAL(KIND=r8), intent(in) :: uns ! Current fallspeed (snow) - REAL(KIND=r8), intent(in) :: mu ! Viscosity - ! In-cloud liquid water - REAL(KIND=r8), intent(in) :: qcic ! MMR - REAL(KIND=r8), intent(in) :: ncic ! Number - ! In-cloud snow - REAL(KIND=r8), intent(in) :: qsic ! MMR - ! Cloud droplet size parameters - REAL(KIND=r8), intent(in) :: pgam - REAL(KIND=r8), intent(in) :: lamc - ! Snow size parameters - REAL(KIND=r8), intent(in) :: lams - REAL(KIND=r8), intent(in) :: n0s - ! Output tendencies - REAL(KIND=r8), intent(out) :: psacws ! Mass mixing ratio - REAL(KIND=r8), intent(out) :: npsacws ! Number concentration - REAL(KIND=r8) :: dc0 ! Provisional mean droplet size - REAL(KIND=r8) :: dum - REAL(KIND=r8) :: eci ! collection efficiency for riming of snow by droplets - ! Fraction of cloud droplets accreted per second - REAL(KIND=r8) :: accrete_rate - ! ignore collision of snow with droplets above freezing - IF (qsic >= qsmall .and. t <= tmelt .and. qcic >= qsmall) THEN - ! put in size dependent collection efficiency - ! mean diameter of snow is area-weighted, since - ! accretion is function of crystal geometric area - ! collection efficiency is approximation based on stoke's law (Thompson et al. 2004) - dc0 = (pgam+1._r8)/lamc - dum = dc0*dc0*uns*rhow*lams/(9._r8*mu) - eci = dum*dum/((dum+0.4_r8)*(dum+0.4_r8)) - eci = max(eci,0._r8) - eci = min(eci,1._r8) - ! no impact of sub-grid distribution of qc since psacws - ! is linear in qc - accrete_rate = pi/4._r8*asn*rho*n0s*eci*gamma_bs_plus3 / lams**(bs+3._r8) - psacws = accrete_rate*qcic - npsacws = accrete_rate*ncic - ELSE - psacws = 0._r8 - npsacws = 0._r8 - END IF - END SUBROUTINE accrete_cloud_water_snow - ! add secondary ice production due to accretion of droplets by snow - !=================================================================== - ! (Hallet-Mossop process) (from Cotton et al., 1986) - - elemental SUBROUTINE secondary_ice_production(t, psacws, msacwi, nsacwi) - REAL(KIND=r8), intent(in) :: t ! Temperature - ! Accretion of cloud water to snow tendencies - REAL(KIND=r8), intent(inout) :: psacws ! MMR - ! Output (ice) tendencies - REAL(KIND=r8), intent(out) :: msacwi ! MMR - REAL(KIND=r8), intent(out) :: nsacwi ! Number - IF ((t < 270.16_r8) .and. (t >= 268.16_r8)) THEN - nsacwi = 3.5e8_r8*(270.16_r8-t)/2.0_r8*psacws - ELSE IF ((t < 268.16_r8) .and. (t >= 265.16_r8)) THEN - nsacwi = 3.5e8_r8*(t-265.16_r8)/3.0_r8*psacws - ELSE - nsacwi = 0.0_r8 - END IF - msacwi = min(nsacwi*mi0, psacws) - psacws = psacws - msacwi - END SUBROUTINE secondary_ice_production - ! accretion of rain water by snow - !=================================================================== - ! formula from ikawa and saito, 1991, used by reisner et al., 1998 - - elemental SUBROUTINE accrete_rain_snow(t, rho, umr, ums, unr, uns, qric, qsic, lamr, n0r, lams, n0s, pracs, npracs) - REAL(KIND=r8), intent(in) :: t ! Temperature - REAL(KIND=r8), intent(in) :: rho ! Density - ! Fallspeeds - ! mass-weighted - REAL(KIND=r8), intent(in) :: umr ! rain - REAL(KIND=r8), intent(in) :: ums ! snow - ! number-weighted - REAL(KIND=r8), intent(in) :: unr ! rain - REAL(KIND=r8), intent(in) :: uns ! snow - ! In cloud MMRs - REAL(KIND=r8), intent(in) :: qric ! rain - REAL(KIND=r8), intent(in) :: qsic ! snow - ! Size distribution parameters - ! rain - REAL(KIND=r8), intent(in) :: lamr - REAL(KIND=r8), intent(in) :: n0r - ! snow - REAL(KIND=r8), intent(in) :: lams - REAL(KIND=r8), intent(in) :: n0s - ! Output tendencies - REAL(KIND=r8), intent(out) :: pracs ! MMR - REAL(KIND=r8), intent(out) :: npracs ! Number - ! Collection efficiency for accretion of rain by snow - REAL(KIND=r8), parameter :: ecr = 1.0_r8 - ! Ratio of average snow diameter to average rain diameter. - REAL(KIND=r8) :: d_rat - ! Common factor between mass and number expressions - REAL(KIND=r8) :: common_factor - IF (qric >= icsmall .and. qsic >= icsmall .and. t <= tmelt) THEN - common_factor = pi*ecr*rho*n0r*n0s/(lamr**3 * lams) - d_rat = lamr/lams - pracs = common_factor*pi*rhow* sqrt((1.2_r8*umr-0.95_r8*ums)**2 + 0.08_r8*ums*umr) / lamr**3 * & - ((0.5_r8*d_rat + 2._r8)*d_rat + 5._r8) - npracs = common_factor*0.5_r8* sqrt(1.7_r8*(unr-uns)**2 + 0.3_r8*unr*uns) * ((d_rat + 1._r8)& - *d_rat + 1._r8) - ELSE - pracs = 0._r8 - npracs = 0._r8 - END IF - END SUBROUTINE accrete_rain_snow - ! heterogeneous freezing of rain drops - !=================================================================== - ! follows from Bigg (1953) - - elemental SUBROUTINE heterogeneous_rain_freezing(t, qric, nric, lamr, mnuccr, nnuccr) - REAL(KIND=r8), intent(in) :: t ! Temperature - ! In-cloud rain - REAL(KIND=r8), intent(in) :: qric ! MMR - REAL(KIND=r8), intent(in) :: nric ! Number - REAL(KIND=r8), intent(in) :: lamr ! size parameter - ! Output tendencies - REAL(KIND=r8), intent(out) :: mnuccr ! MMR - REAL(KIND=r8), intent(out) :: nnuccr ! Number - IF (t < 269.15_r8 .and. qric >= qsmall) THEN - nnuccr = pi*nric*bimm* (exp(aimm*(tmelt - t))-1._r8)/lamr**3 - mnuccr = nnuccr * 20._r8*pi*rhow/lamr**3 - ELSE - mnuccr = 0._r8 - nnuccr = 0._r8 - END IF - END SUBROUTINE heterogeneous_rain_freezing - ! accretion of cloud liquid water by rain - !=================================================================== - ! formula from Khrouditnov and Kogan (2000) - ! gravitational collection kernel, droplet fall speed neglected - - elemental SUBROUTINE accrete_cloud_water_rain(microp_uniform, qric, qcic, ncic, relvar, accre_enhan, pra, npra) - LOGICAL, intent(in) :: microp_uniform - ! In-cloud rain - REAL(KIND=r8), intent(in) :: qric ! MMR - ! Cloud droplets - REAL(KIND=r8), intent(in) :: qcic ! MMR - REAL(KIND=r8), intent(in) :: ncic ! Number - ! SGS variability - REAL(KIND=r8), intent(in) :: relvar - REAL(KIND=r8), intent(in) :: accre_enhan - ! Output tendencies - REAL(KIND=r8), intent(out) :: pra ! MMR - REAL(KIND=r8), intent(out) :: npra ! Number - ! Coefficient that varies for subcolumns - REAL(KIND=r8) :: pra_coef - IF (.not. microp_uniform) THEN - pra_coef = accre_enhan * var_coef(relvar, 1.15_r8) - ELSE - pra_coef = 1._r8 - END IF - IF (qric >= qsmall .and. qcic >= qsmall) THEN - ! include sub-grid distribution of cloud water - pra = pra_coef * 67._r8*(qcic*qric)**1.15_r8 - npra = pra*ncic/qcic - ELSE - pra = 0._r8 - npra = 0._r8 - END IF - END SUBROUTINE accrete_cloud_water_rain - ! Self-collection of rain drops - !=================================================================== - ! from Beheng(1994) - - elemental SUBROUTINE self_collection_rain(rho, qric, nric, nragg) - REAL(KIND=r8), intent(in) :: rho ! Air density - ! Rain - REAL(KIND=r8), intent(in) :: qric ! MMR - REAL(KIND=r8), intent(in) :: nric ! Number - ! Output number tendency - REAL(KIND=r8), intent(out) :: nragg - IF (qric >= qsmall) THEN - nragg = -8._r8*nric*qric*rho - ELSE - nragg = 0._r8 - END IF - END SUBROUTINE self_collection_rain - ! Accretion of cloud ice by snow - !=================================================================== - ! For this calculation, it is assumed that the Vs >> Vi - ! and Ds >> Di for continuous collection - - elemental SUBROUTINE accrete_cloud_ice_snow(t, rho, asn, qiic, niic, qsic, lams, n0s, prai, nprai) - REAL(KIND=r8), intent(in) :: t ! Temperature - REAL(KIND=r8), intent(in) :: rho ! Density - REAL(KIND=r8), intent(in) :: asn ! Snow fallspeed parameter - ! Cloud ice - REAL(KIND=r8), intent(in) :: qiic ! MMR - REAL(KIND=r8), intent(in) :: niic ! Number - REAL(KIND=r8), intent(in) :: qsic ! Snow MMR - ! Snow size parameters - REAL(KIND=r8), intent(in) :: lams - REAL(KIND=r8), intent(in) :: n0s - ! Output tendencies - REAL(KIND=r8), intent(out) :: prai ! MMR - REAL(KIND=r8), intent(out) :: nprai ! Number - ! Fraction of cloud ice particles accreted per second - REAL(KIND=r8) :: accrete_rate - IF (qsic >= qsmall .and. qiic >= qsmall .and. t <= tmelt) THEN - accrete_rate = pi/4._r8 * eii * asn * rho * n0s * gamma_bs_plus3/ lams**(bs+3._r8) - prai = accrete_rate * qiic - nprai = accrete_rate * niic - ELSE - prai = 0._r8 - nprai = 0._r8 - END IF - END SUBROUTINE accrete_cloud_ice_snow - ! calculate evaporation/sublimation of rain and snow - !=================================================================== - ! note: evaporation/sublimation occurs only in cloud-free portion of grid cell - ! in-cloud condensation/deposition of rain and snow is neglected - ! except for transfer of cloud water to snow through bergeron process - - elemental SUBROUTINE evaporate_sublimate_precip(t, rho, dv, mu, sc, q, qvl, qvi, lcldm, precip_frac, arn, asn, qcic, qiic,& - qric, qsic, lamr, n0r, lams, n0s, pre, prds) - REAL(KIND=r8), intent(in) :: t ! temperature - REAL(KIND=r8), intent(in) :: rho ! air density - REAL(KIND=r8), intent(in) :: dv ! water vapor diffusivity - REAL(KIND=r8), intent(in) :: mu ! viscosity - REAL(KIND=r8), intent(in) :: sc ! schmidt number - REAL(KIND=r8), intent(in) :: q ! humidity - REAL(KIND=r8), intent(in) :: qvl ! saturation humidity (water) - REAL(KIND=r8), intent(in) :: qvi ! saturation humidity (ice) - REAL(KIND=r8), intent(in) :: lcldm ! liquid cloud fraction - REAL(KIND=r8), intent(in) :: precip_frac ! precipitation fraction (maximum overlap) - ! fallspeed parameters - REAL(KIND=r8), intent(in) :: arn ! rain - REAL(KIND=r8), intent(in) :: asn ! snow - ! In-cloud MMRs - REAL(KIND=r8), intent(in) :: qcic ! cloud liquid - REAL(KIND=r8), intent(in) :: qiic ! cloud ice - REAL(KIND=r8), intent(in) :: qric ! rain - REAL(KIND=r8), intent(in) :: qsic ! snow - ! Size parameters - ! rain - REAL(KIND=r8), intent(in) :: lamr - REAL(KIND=r8), intent(in) :: n0r - ! snow - REAL(KIND=r8), intent(in) :: lams - REAL(KIND=r8), intent(in) :: n0s - ! Output tendencies - REAL(KIND=r8), intent(out) :: pre - REAL(KIND=r8), intent(out) :: prds - REAL(KIND=r8) :: qclr ! water vapor mixing ratio in clear air - REAL(KIND=r8) :: ab ! correction to account for latent heat - REAL(KIND=r8) :: eps ! 1/ sat relaxation timescale - REAL(KIND=r8) :: dum - ! set temporary cloud fraction to zero if cloud water + ice is very small - ! this will ensure that evaporation/sublimation of precip occurs over - ! entire grid cell, since min cloud fraction is specified otherwise - IF (qcic+qiic < 1.e-6_r8) THEN - dum = 0._r8 - ELSE - dum = lcldm - END IF - ! only calculate if there is some precip fraction > cloud fraction - IF (precip_frac > dum) THEN - ! calculate q for out-of-cloud region - qclr = (q-dum*qvl)/(1._r8-dum) - ! evaporation of rain - IF (qric >= qsmall) THEN - ab = calc_ab(t, qvl, xxlv) - eps = 2._r8*pi*n0r*rho*dv* (f1r/(lamr*lamr)+ f2r*(arn*rho/mu)**0.5_r8* & - sc**(1._r8/3._r8)*gamma_half_br_plus5/ (lamr**(5._r8/2._r8+br/2._r8))) - pre = eps*(qclr-qvl)/ab - ! only evaporate in out-of-cloud region - ! and distribute across precip_frac - pre = min(pre*(precip_frac-dum),0._r8) - pre = pre/precip_frac - ELSE - pre = 0._r8 - END IF - ! sublimation of snow - IF (qsic >= qsmall) THEN - ab = calc_ab(t, qvi, xxls) - eps = 2._r8*pi*n0s*rho*dv* (f1s/(lams*lams)+ f2s*(asn*rho/mu)**0.5_r8* & - sc**(1._r8/3._r8)*gamma_half_bs_plus5/ (lams**(5._r8/2._r8+bs/2._r8))) - prds = eps*(qclr-qvi)/ab - ! only sublimate in out-of-cloud region and distribute over precip_frac - prds = min(prds*(precip_frac-dum),0._r8) - prds = prds/precip_frac - ELSE - prds = 0._r8 - END IF - ELSE - prds = 0._r8 - pre = 0._r8 - END IF - END SUBROUTINE evaporate_sublimate_precip - ! bergeron process - evaporation of droplets and deposition onto snow - !=================================================================== - - elemental SUBROUTINE bergeron_process_snow(t, rho, dv, mu, sc, qvl, qvi, asn, qcic, qsic, lams, n0s, bergs) - REAL(KIND=r8), intent(in) :: t ! temperature - REAL(KIND=r8), intent(in) :: rho ! air density - REAL(KIND=r8), intent(in) :: dv ! water vapor diffusivity - REAL(KIND=r8), intent(in) :: mu ! viscosity - REAL(KIND=r8), intent(in) :: sc ! schmidt number - REAL(KIND=r8), intent(in) :: qvl ! saturation humidity (water) - REAL(KIND=r8), intent(in) :: qvi ! saturation humidity (ice) - ! fallspeed parameter for snow - REAL(KIND=r8), intent(in) :: asn - ! In-cloud MMRs - REAL(KIND=r8), intent(in) :: qcic ! cloud liquid - REAL(KIND=r8), intent(in) :: qsic ! snow - ! Size parameters for snow - REAL(KIND=r8), intent(in) :: lams - REAL(KIND=r8), intent(in) :: n0s - ! Output tendencies - REAL(KIND=r8), intent(out) :: bergs - REAL(KIND=r8) :: ab ! correction to account for latent heat - REAL(KIND=r8) :: eps ! 1/ sat relaxation timescale - IF (qsic >= qsmall.and. qcic >= qsmall .and. t < tmelt) THEN - ab = calc_ab(t, qvi, xxls) - eps = 2._r8*pi*n0s*rho*dv* (f1s/(lams*lams)+ f2s*(asn*rho/mu)**0.5_r8* sc**(& - 1._r8/3._r8)*gamma_half_bs_plus5/ (lams**(5._r8/2._r8+bs/2._r8))) - bergs = eps*(qvl-qvi)/ab - ELSE - bergs = 0._r8 - END IF - END SUBROUTINE bergeron_process_snow - !======================================================================== - !UTILITIES - !======================================================================== - - - pure FUNCTION limiter_is_on(lim) - REAL(KIND=r8), intent(in) :: lim - LOGICAL :: limiter_is_on - limiter_is_on = transfer(lim, limiter_off) /= limiter_off - END FUNCTION limiter_is_on - END MODULE micro_mg_utils diff --git a/test/ncar_kernels/CAM5_mg2_pgi/src/shr_const_mod.F90 b/test/ncar_kernels/CAM5_mg2_pgi/src/shr_const_mod.F90 deleted file mode 100644 index c7e22c38c1..0000000000 --- a/test/ncar_kernels/CAM5_mg2_pgi/src/shr_const_mod.F90 +++ /dev/null @@ -1,65 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : shr_const_mod.F90 -! Generated at: 2015-03-31 09:44:41 -! KGEN version: 0.4.5 - - - - MODULE shr_const_mod - USE shr_kind_mod, only : shr_kind_in - USE shr_kind_mod, only : shr_kind_r8 - INTEGER(KIND=shr_kind_in), parameter, private :: r8 = shr_kind_r8 ! rename for local readability only - !---------------------------------------------------------------------------- - ! physical constants (all data public) - !---------------------------------------------------------------------------- - PUBLIC - REAL(KIND=r8), parameter :: shr_const_pi = 3.14159265358979323846_r8 ! pi - ! sec in calendar day ~ sec - ! sec in siderial day ~ sec - ! earth rot ~ rad/sec - ! radius of earth ~ m - ! acceleration of gravity ~ m/s^2 - ! Stefan-Boltzmann constant ~ W/m^2/K^4 - ! Boltzmann's constant ~ J/K/molecule - ! Avogadro's number ~ molecules/kmole - ! Universal gas constant ~ J/K/kmole - ! molecular weight dry air ~ kg/kmole - ! molecular weight water vapor - ! Dry air gas constant ~ J/K/kg - ! Water vapor gas constant ~ J/K/kg - ! RWV/RDAIR - 1.0 - ! Von Karman constant - ! standard pressure ~ pascals - ! ratio of 13C/12C in Pee Dee Belemnite (C isotope standard) - ! triple point of fresh water ~ K - ! freezing T of fresh water ~ K - ! freezing T of salt water ~ K - ! density of dry air at STP ~ kg/m^3 - ! density of fresh water ~ kg/m^3 - ! density of sea water ~ kg/m^3 - ! density of ice ~ kg/m^3 - ! specific heat of dry air ~ J/kg/K - ! specific heat of water vap ~ J/kg/K - ! CPWV/CPDAIR - 1.0 - ! specific heat of fresh h2o ~ J/kg/K - ! specific heat of sea h2o ~ J/kg/K - ! specific heat of fresh ice ~ J/kg/K - ! latent heat of fusion ~ J/kg - ! latent heat of evaporation ~ J/kg - ! latent heat of sublimation ~ J/kg - ! ocn ref salinity (psu) - ! ice ref salinity (psu) - ! special missing value - ! min spval tolerance - ! max spval tolerance - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !----------------------------------------------------------------------------- - - !----------------------------------------------------------------------------- - END MODULE shr_const_mod diff --git a/test/ncar_kernels/CAM5_mg2_pgi/src/shr_kind_mod.F90 b/test/ncar_kernels/CAM5_mg2_pgi/src/shr_kind_mod.F90 deleted file mode 100644 index 60f3771dd1..0000000000 --- a/test/ncar_kernels/CAM5_mg2_pgi/src/shr_kind_mod.F90 +++ /dev/null @@ -1,30 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : shr_kind_mod.F90 -! Generated at: 2015-03-31 09:44:40 -! KGEN version: 0.4.5 - - - - MODULE shr_kind_mod - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - PUBLIC - INTEGER, parameter :: shr_kind_r8 = selected_real_kind(12) ! 8 byte real - ! 4 byte real - ! native real - ! 8 byte integer - ! 4 byte integer - INTEGER, parameter :: shr_kind_in = kind(1) ! native integer - ! short char - ! mid-sized char - ! long char - ! extra-long char - ! extra-extra-long char - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE shr_kind_mod diff --git a/test/ncar_kernels/CAM5_mg2_pgi/src/shr_spfn_mod.F90 b/test/ncar_kernels/CAM5_mg2_pgi/src/shr_spfn_mod.F90 deleted file mode 100644 index 72408ec636..0000000000 --- a/test/ncar_kernels/CAM5_mg2_pgi/src/shr_spfn_mod.F90 +++ /dev/null @@ -1,457 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : shr_spfn_mod.F90 -! Generated at: 2015-03-31 09:44:41 -! KGEN version: 0.4.5 - - - - MODULE shr_spfn_mod - ! Module for common mathematical functions - ! This #ifdef is to allow the module to be compiled with no dependencies, - ! even on shr_kind_mod. - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - USE shr_const_mod, ONLY: pi => shr_const_pi - IMPLICIT NONE - PRIVATE - ! Error functions - - - - ! Gamma functions - ! Note that we lack an implementation of log_gamma, but we do have an - ! implementation of the upper incomplete gamma function, which is not in - ! Fortran 2008. - ! Note also that this gamma function is only for double precision. We - ! haven't needed an r4 version yet. - PUBLIC shr_spfn_gamma - - INTERFACE shr_spfn_gamma - MODULE PROCEDURE shr_spfn_gamma_r8 - END INTERFACE shr_spfn_gamma - ! Mathematical constants - ! sqrt(pi) - ! Define machine-specific constants needed in this module. - ! These were used by the original gamma and calerf functions to guarantee - ! safety against overflow, and precision, on many different machines. - ! By defining the constants in this way, we assume that 1/xmin is - ! representable (i.e. does not overflow the real type). This assumption was - ! not in the original code, but is valid for IEEE single and double - ! precision. - ! Double precision - !--------------------------------------------------------------------- - ! Machine epsilon - REAL(KIND=r8), parameter :: epsr8 = epsilon(1._r8) - ! "Huge" value is returned when actual value would be infinite. - REAL(KIND=r8), parameter :: xinfr8 = huge(1._r8) - ! Smallest normal value. - REAL(KIND=r8), parameter :: xminr8 = tiny(1._r8) - ! Largest number that, when added to 1., yields 1. - ! Largest argument for which erfcx > 0. - ! Single precision - !--------------------------------------------------------------------- - ! Machine epsilon - ! "Huge" value is returned when actual value would be infinite. - ! Smallest normal value. - ! Largest number that, when added to 1., yields 1. - ! Largest argument for which erfcx > 0. - ! For gamma/igamma - ! Approximate value of largest acceptable argument to gamma, - ! for IEEE double-precision. - REAL(KIND=r8), parameter :: xbig_gamma = 171.624_r8 - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - ! Wrapper functions for erf - - - - - - - ! Wrapper functions for erfc - - - - - - - ! Wrapper functions for erfc_scaled - - - - elemental FUNCTION shr_spfn_gamma_r8(x) RESULT ( res ) - REAL(KIND=r8), intent(in) :: x - REAL(KIND=r8) :: res - ! No intrinsic - res = shr_spfn_gamma_nonintrinsic_r8(x) - END FUNCTION shr_spfn_gamma_r8 - !------------------------------------------------------------------ - ! - ! 6 December 2006 -- B. Eaton - ! The following comments are from the original version of CALERF. - ! The only changes in implementing this module are that the function - ! names previously used for the single precision versions have been - ! adopted for the new generic interfaces. To support these interfaces - ! there is now both a single precision version (calerf_r4) and a - ! double precision version (calerf_r8) of CALERF below. These versions - ! are hardcoded to use IEEE arithmetic. - ! - !------------------------------------------------------------------ - ! - ! This packet evaluates erf(x), erfc(x), and exp(x*x)*erfc(x) - ! for a real argument x. It contains three FUNCTION type - ! subprograms: ERF, ERFC, and ERFCX (or ERF_R8, ERFC_R8, and ERFCX_R8), - ! and one SUBROUTINE type subprogram, CALERF. The calling - ! statements for the primary entries are: - ! - ! Y=ERF(X) (or Y=ERF_R8(X)), - ! - ! Y=ERFC(X) (or Y=ERFC_R8(X)), - ! and - ! Y=ERFCX(X) (or Y=ERFCX_R8(X)). - ! - ! The routine CALERF is intended for internal packet use only, - ! all computations within the packet being concentrated in this - ! routine. The function subprograms invoke CALERF with the - ! statement - ! - ! CALL CALERF(ARG,RESULT,JINT) - ! - ! where the parameter usage is as follows - ! - ! Function Parameters for CALERF - ! call ARG Result JINT - ! - ! ERF(ARG) ANY REAL ARGUMENT ERF(ARG) 0 - ! ERFC(ARG) ABS(ARG) .LT. XBIG ERFC(ARG) 1 - ! ERFCX(ARG) XNEG .LT. ARG .LT. XMAX ERFCX(ARG) 2 - ! - ! The main computation evaluates near-minimax approximations - ! from "Rational Chebyshev approximations for the error function" - ! by W. J. Cody, Math. Comp., 1969, PP. 631-638. This - ! transportable program uses rational functions that theoretically - ! approximate erf(x) and erfc(x) to at least 18 significant - ! decimal digits. The accuracy achieved depends on the arithmetic - ! system, the compiler, the intrinsic functions, and proper - ! selection of the machine-dependent constants. - ! - !******************************************************************* - !******************************************************************* - ! - ! Explanation of machine-dependent constants - ! - ! XMIN = the smallest positive floating-point number. - ! XINF = the largest positive finite floating-point number. - ! XNEG = the largest negative argument acceptable to ERFCX; - ! the negative of the solution to the equation - ! 2*exp(x*x) = XINF. - ! XSMALL = argument below which erf(x) may be represented by - ! 2*x/sqrt(pi) and above which x*x will not underflow. - ! A conservative value is the largest machine number X - ! such that 1.0 + X = 1.0 to machine precision. - ! XBIG = largest argument acceptable to ERFC; solution to - ! the equation: W(x) * (1-0.5/x**2) = XMIN, where - ! W(x) = exp(-x*x)/[x*sqrt(pi)]. - ! XHUGE = argument above which 1.0 - 1/(2*x*x) = 1.0 to - ! machine precision. A conservative value is - ! 1/[2*sqrt(XSMALL)] - ! XMAX = largest acceptable argument to ERFCX; the minimum - ! of XINF and 1/[sqrt(pi)*XMIN]. - ! - ! Approximate values for some important machines are: - ! - ! XMIN XINF XNEG XSMALL - ! - ! CDC 7600 (S.P.) 3.13E-294 1.26E+322 -27.220 7.11E-15 - ! CRAY-1 (S.P.) 4.58E-2467 5.45E+2465 -75.345 7.11E-15 - ! IEEE (IBM/XT, - ! SUN, etc.) (S.P.) 1.18E-38 3.40E+38 -9.382 5.96E-8 - ! IEEE (IBM/XT, - ! SUN, etc.) (D.P.) 2.23D-308 1.79D+308 -26.628 1.11D-16 - ! IBM 195 (D.P.) 5.40D-79 7.23E+75 -13.190 1.39D-17 - ! UNIVAC 1108 (D.P.) 2.78D-309 8.98D+307 -26.615 1.73D-18 - ! VAX D-Format (D.P.) 2.94D-39 1.70D+38 -9.345 1.39D-17 - ! VAX G-Format (D.P.) 5.56D-309 8.98D+307 -26.615 1.11D-16 - ! - ! - ! XBIG XHUGE XMAX - ! - ! CDC 7600 (S.P.) 25.922 8.39E+6 1.80X+293 - ! CRAY-1 (S.P.) 75.326 8.39E+6 5.45E+2465 - ! IEEE (IBM/XT, - ! SUN, etc.) (S.P.) 9.194 2.90E+3 4.79E+37 - ! IEEE (IBM/XT, - ! SUN, etc.) (D.P.) 26.543 6.71D+7 2.53D+307 - ! IBM 195 (D.P.) 13.306 1.90D+8 7.23E+75 - ! UNIVAC 1108 (D.P.) 26.582 5.37D+8 8.98D+307 - ! VAX D-Format (D.P.) 9.269 1.90D+8 1.70D+38 - ! VAX G-Format (D.P.) 26.569 6.71D+7 8.98D+307 - ! - !******************************************************************* - !******************************************************************* - ! - ! Error returns - ! - ! The program returns ERFC = 0 for ARG .GE. XBIG; - ! - ! ERFCX = XINF for ARG .LT. XNEG; - ! and - ! ERFCX = 0 for ARG .GE. XMAX. - ! - ! - ! Intrinsic functions required are: - ! - ! ABS, AINT, EXP - ! - ! - ! Author: W. J. Cody - ! Mathematics and Computer Science Division - ! Argonne National Laboratory - ! Argonne, IL 60439 - ! - ! Latest modification: March 19, 1990 - ! - !------------------------------------------------------------------ - - !------------------------------------------------------------------------------------------ - - !------------------------------------------------------------------------------------------ - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - pure FUNCTION shr_spfn_gamma_nonintrinsic_r8(x) RESULT ( gamma ) - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! - ! 7 Feb 2013 -- S. Santos - ! The following comments are from the original version. Changes have - ! been made to update syntax and allow inclusion into this module. - ! - !---------------------------------------------------------------------- - ! - ! THIS ROUTINE CALCULATES THE GAMMA FUNCTION FOR A REAL ARGUMENT X. - ! COMPUTATION IS BASED ON AN ALGORITHM OUTLINED IN REFERENCE 1. - ! THE PROGRAM USES RATIONAL FUNCTIONS THAT APPROXIMATE THE GAMMA - ! FUNCTION TO AT LEAST 20 SIGNIFICANT DECIMAL DIGITS. COEFFICIENTS - ! FOR THE APPROXIMATION OVER THE INTERVAL (1,2) ARE UNPUBLISHED. - ! THOSE FOR THE APPROXIMATION FOR X .GE. 12 ARE FROM REFERENCE 2. - ! THE ACCURACY ACHIEVED DEPENDS ON THE ARITHMETIC SYSTEM, THE - ! COMPILER, THE INTRINSIC FUNCTIONS, AND PROPER SELECTION OF THE - ! MACHINE-DEPENDENT CONSTANTS. - ! - ! - !******************************************************************* - !******************************************************************* - ! - ! EXPLANATION OF MACHINE-DEPENDENT CONSTANTS - ! - ! BETA - RADIX FOR THE FLOATING-POINT REPRESENTATION - ! MAXEXP - THE SMALLEST POSITIVE POWER OF BETA THAT OVERFLOWS - ! XBIG - THE LARGEST ARGUMENT FOR WHICH GAMMA(X) IS REPRESENTABLE - ! IN THE MACHINE, I.E., THE SOLUTION TO THE EQUATION - ! GAMMA(XBIG) = BETA**MAXEXP - ! XINF - THE LARGEST MACHINE REPRESENTABLE FLOATING-POINT NUMBER; - ! APPROXIMATELY BETA**MAXEXP - ! EPS - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT - ! 1.0+EPS .GT. 1.0 - ! XMININ - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT - ! 1/XMININ IS MACHINE REPRESENTABLE - ! - ! APPROXIMATE VALUES FOR SOME IMPORTANT MACHINES ARE: - ! - ! BETA MAXEXP XBIG - ! - ! CRAY-1 (S.P.) 2 8191 966.961 - ! CYBER 180/855 - ! UNDER NOS (S.P.) 2 1070 177.803 - ! IEEE (IBM/XT, - ! SUN, ETC.) (S.P.) 2 128 35.040 - ! IEEE (IBM/XT, - ! SUN, ETC.) (D.P.) 2 1024 171.624 - ! IBM 3033 (D.P.) 16 63 57.574 - ! VAX D-FORMAT (D.P.) 2 127 34.844 - ! VAX G-FORMAT (D.P.) 2 1023 171.489 - ! - ! XINF EPS XMININ - ! - ! CRAY-1 (S.P.) 5.45E+2465 7.11E-15 1.84E-2466 - ! CYBER 180/855 - ! UNDER NOS (S.P.) 1.26E+322 3.55E-15 3.14E-294 - ! IEEE (IBM/XT, - ! SUN, ETC.) (S.P.) 3.40E+38 1.19E-7 1.18E-38 - ! IEEE (IBM/XT, - ! SUN, ETC.) (D.P.) 1.79D+308 2.22D-16 2.23D-308 - ! IBM 3033 (D.P.) 7.23D+75 2.22D-16 1.39D-76 - ! VAX D-FORMAT (D.P.) 1.70D+38 1.39D-17 5.88D-39 - ! VAX G-FORMAT (D.P.) 8.98D+307 1.11D-16 1.12D-308 - ! - !******************************************************************* - !******************************************************************* - ! - ! ERROR RETURNS - ! - ! THE PROGRAM RETURNS THE VALUE XINF FOR SINGULARITIES OR - ! WHEN OVERFLOW WOULD OCCUR. THE COMPUTATION IS BELIEVED - ! TO BE FREE OF UNDERFLOW AND OVERFLOW. - ! - ! - ! INTRINSIC FUNCTIONS REQUIRED ARE: - ! - ! INT, DBLE, EXP, LOG, REAL, SIN - ! - ! - ! REFERENCES: AN OVERVIEW OF SOFTWARE DEVELOPMENT FOR SPECIAL - ! FUNCTIONS W. J. CODY, LECTURE NOTES IN MATHEMATICS, - ! 506, NUMERICAL ANALYSIS DUNDEE, 1975, G. A. WATSON - ! (ED.), SPRINGER VERLAG, BERLIN, 1976. - ! - ! COMPUTER APPROXIMATIONS, HART, ET. AL., WILEY AND - ! SONS, NEW YORK, 1968. - ! - ! LATEST MODIFICATION: OCTOBER 12, 1989 - ! - ! AUTHORS: W. J. CODY AND L. STOLTZ - ! APPLIED MATHEMATICS DIVISION - ! ARGONNE NATIONAL LABORATORY - ! ARGONNE, IL 60439 - ! - !---------------------------------------------------------------------- - REAL(KIND=r8), intent(in) :: x - REAL(KIND=r8) :: gamma - REAL(KIND=r8) :: fact - REAL(KIND=r8) :: sum - REAL(KIND=r8) :: y - REAL(KIND=r8) :: y1 - REAL(KIND=r8) :: res - REAL(KIND=r8) :: z - REAL(KIND=r8) :: xnum - REAL(KIND=r8) :: xden - REAL(KIND=r8) :: ysq - INTEGER :: n - INTEGER :: i - LOGICAL :: negative_odd - ! log(2*pi)/2 - REAL(KIND=r8), parameter :: logsqrt2pi = 0.9189385332046727417803297e0_r8 - !---------------------------------------------------------------------- - ! NUMERATOR AND DENOMINATOR COEFFICIENTS FOR RATIONAL MINIMAX - ! APPROXIMATION OVER (1,2). - !---------------------------------------------------------------------- - REAL(KIND=r8), parameter :: p(8) = (/-1.71618513886549492533811e+0_r8, 2.47656508055759199108314e+1_r8, & - -3.79804256470945635097577e+2_r8, 6.29331155312818442661052e+2_r8, 8.66966202790413211295064e+2_r8,& - -3.14512729688483675254357e+4_r8, -3.61444134186911729807069e+4_r8, 6.64561438202405440627855e+4_r8 /) - REAL(KIND=r8), parameter :: q(8) = (/-3.08402300119738975254353e+1_r8, 3.15350626979604161529144e+2_r8, & - -1.01515636749021914166146e+3_r8,-3.10777167157231109440444e+3_r8, 2.25381184209801510330112e+4_r8, & - 4.75584627752788110767815e+3_r8, -1.34659959864969306392456e+5_r8,-1.15132259675553483497211e+5_r8 /) - !---------------------------------------------------------------------- - ! COEFFICIENTS FOR MINIMAX APPROXIMATION OVER (12, INF). - !---------------------------------------------------------------------- - REAL(KIND=r8), parameter :: c(7) = (/-1.910444077728e-03_r8, 8.4171387781295e-04_r8, & - -5.952379913043012e-04_r8, 7.93650793500350248e-04_r8, -2.777777777777681622553e-03_r8, & - 8.333333333333333331554247e-02_r8, 5.7083835261e-03_r8 /) - negative_odd = .false. - fact = 1._r8 - n = 0 - y = x - IF (y <= 0._r8) THEN - !---------------------------------------------------------------------- - ! ARGUMENT IS NEGATIVE - !---------------------------------------------------------------------- - y = -x - y1 = aint(y) - res = y - y1 - IF (res /= 0._r8) THEN - negative_odd = (y1 /= aint(y1*0.5_r8)*2._r8) - fact = -pi/sin(pi*res) - y = y + 1._r8 - ELSE - gamma = xinfr8 - RETURN - END IF - END IF - !---------------------------------------------------------------------- - ! ARGUMENT IS POSITIVE - !---------------------------------------------------------------------- - IF (y < epsr8) THEN - !---------------------------------------------------------------------- - ! ARGUMENT .LT. EPS - !---------------------------------------------------------------------- - IF (y >= xminr8) THEN - res = 1._r8/y - ELSE - gamma = xinfr8 - RETURN - END IF - ELSE IF (y < 12._r8) THEN - y1 = y - IF (y < 1._r8) THEN - !---------------------------------------------------------------------- - ! 0.0 .LT. ARGUMENT .LT. 1.0 - !---------------------------------------------------------------------- - z = y - y = y + 1._r8 - ELSE - !---------------------------------------------------------------------- - ! 1.0 .LT. ARGUMENT .LT. 12.0, REDUCE ARGUMENT IF NECESSARY - !---------------------------------------------------------------------- - n = int(y) - 1 - y = y - real(n, r8) - z = y - 1._r8 - END IF - !---------------------------------------------------------------------- - ! EVALUATE APPROXIMATION FOR 1.0 .LT. ARGUMENT .LT. 2.0 - !---------------------------------------------------------------------- - xnum = 0._r8 - xden = 1._r8 - DO i=1,8 - xnum = (xnum+p(i))*z - xden = xden*z + q(i) - END DO - res = xnum/xden + 1._r8 - IF (y1 < y) THEN - !---------------------------------------------------------------------- - ! ADJUST RESULT FOR CASE 0.0 .LT. ARGUMENT .LT. 1.0 - !---------------------------------------------------------------------- - res = res/y1 - ELSE IF (y1 > y) THEN - !---------------------------------------------------------------------- - ! ADJUST RESULT FOR CASE 2.0 .LT. ARGUMENT .LT. 12.0 - !---------------------------------------------------------------------- - DO i = 1,n - res = res*y - y = y + 1._r8 - END DO - END IF - ELSE - !---------------------------------------------------------------------- - ! EVALUATE FOR ARGUMENT .GE. 12.0, - !---------------------------------------------------------------------- - IF (y <= xbig_gamma) THEN - ysq = y*y - sum = c(7) - DO i=1,6 - sum = sum/ysq + c(i) - END DO - sum = sum/y - y + logsqrt2pi - sum = sum + (y-0.5_r8)*log(y) - res = exp(sum) - ELSE - gamma = xinfr8 - RETURN - END IF - END IF - !---------------------------------------------------------------------- - ! FINAL ADJUSTMENTS AND RETURN - !---------------------------------------------------------------------- - IF (negative_odd) res = -res - IF (fact /= 1._r8) res = fact/res - gamma = res - ! ---------- LAST LINE OF GAMMA ---------- - END FUNCTION shr_spfn_gamma_nonintrinsic_r8 - !! Incomplete Gamma function - !! - !! @author Tianyi Fan - !! @version August-2010 - - END MODULE shr_spfn_mod diff --git a/test/ncar_kernels/CAM5_mg2_pgi/src/wv_sat_methods.F90 b/test/ncar_kernels/CAM5_mg2_pgi/src/wv_sat_methods.F90 deleted file mode 100644 index f953436dbe..0000000000 --- a/test/ncar_kernels/CAM5_mg2_pgi/src/wv_sat_methods.F90 +++ /dev/null @@ -1,299 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : wv_sat_methods.F90 -! Generated at: 2015-03-31 09:44:41 -! KGEN version: 0.4.5 - - - - MODULE wv_sat_methods - ! This portable module contains all 1 methods for estimating - ! the saturation vapor pressure of water. - ! - ! wv_saturation provides 1-specific interfaces and utilities - ! based on these formulae. - ! - ! Typical usage of this module: - ! - ! Init: - ! call wv_sat_methods_init(r8, , errstring) - ! - ! Get scheme index from a name string: - ! scheme_idx = wv_sat_get_scheme_idx(scheme_name) - ! if (.not. wv_sat_valid_idx(scheme_idx)) - ! - ! Get pressures: - ! es = wv_sat_svp_water(t, scheme_idx) - ! es = wv_sat_svp_ice(t, scheme_idx) - ! - ! Use ice/water transition range: - ! es = wv_sat_svp_trice(t, ttrice, scheme_idx) - ! - ! Note that elemental functions cannot be pointed to, nor passed - ! as arguments. If you need to do either, it is recommended to - ! wrap the function so that it can be given an explicit (non- - ! elemental) interface. - IMPLICIT NONE - PRIVATE - INTEGER, parameter :: r8 = selected_real_kind(12) ! 8 byte real - REAL(KIND=r8) :: tmelt ! Melting point of water at 1 atm (K) - REAL(KIND=r8) :: h2otrip ! Triple point temperature of water (K) - REAL(KIND=r8) :: tboil ! Boiling point of water at 1 atm (K) - ! Ice-water transition range - REAL(KIND=r8) :: epsilo ! Ice-water transition range - REAL(KIND=r8) :: omeps ! 1._r8 - epsilo - ! Indices representing individual schemes - INTEGER, parameter :: oldgoffgratch_idx = 0 - INTEGER, parameter :: goffgratch_idx = 1 - INTEGER, parameter :: murphykoop_idx = 2 - INTEGER, parameter :: bolton_idx = 3 - ! Index representing the current default scheme. - INTEGER, parameter :: initial_default_idx = goffgratch_idx - INTEGER :: default_idx = initial_default_idx - PUBLIC wv_sat_svp_water - PUBLIC wv_sat_svp_ice - ! pressure -> humidity conversion - PUBLIC wv_sat_svp_to_qsat - ! Combined qsat operations - PUBLIC wv_sat_qsat_water - PUBLIC wv_sat_qsat_ice - PUBLIC kgen_read_externs_wv_sat_methods - CONTAINS - - ! write subroutines - ! No subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_wv_sat_methods(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) tmelt - READ(UNIT=kgen_unit) h2otrip - READ(UNIT=kgen_unit) tboil - READ(UNIT=kgen_unit) epsilo - READ(UNIT=kgen_unit) omeps - READ(UNIT=kgen_unit) default_idx - END SUBROUTINE kgen_read_externs_wv_sat_methods - - !--------------------------------------------------------------------- - ! ADMINISTRATIVE FUNCTIONS - !--------------------------------------------------------------------- - ! Get physical constants - - ! Look up index by name. - - ! Check validity of an index from the above routine. - - ! Set default scheme (otherwise, Goff & Gratch is default) - ! Returns a logical representing success (.true.) or - ! failure (.false.). - - ! Reset default scheme to initial value. - ! The same thing can be accomplished with wv_sat_set_default; - ! the real reason to provide this routine is to reset the - ! module for testing purposes. - - !--------------------------------------------------------------------- - ! UTILITIES - !--------------------------------------------------------------------- - ! Get saturation specific humidity given pressure and SVP. - ! Specific humidity is limited to range 0-1. - - elemental FUNCTION wv_sat_svp_to_qsat(es, p) RESULT ( qs ) - REAL(KIND=r8), intent(in) :: es ! SVP - REAL(KIND=r8), intent(in) :: p ! Current pressure. - REAL(KIND=r8) :: qs - ! If pressure is less than SVP, set qs to maximum of 1. - IF ((p - es) <= 0._r8) THEN - qs = 1.0_r8 - ELSE - qs = epsilo*es / (p - omeps*es) - END IF - END FUNCTION wv_sat_svp_to_qsat - - elemental SUBROUTINE wv_sat_qsat_water(t, p, es, qs, idx) - !------------------------------------------------------------------! - ! Purpose: ! - ! Calculate SVP over water at a given temperature, and then ! - ! calculate and return saturation specific humidity. ! - !------------------------------------------------------------------! - ! Inputs - REAL(KIND=r8), intent(in) :: t ! Temperature - REAL(KIND=r8), intent(in) :: p ! Pressure - ! Outputs - REAL(KIND=r8), intent(out) :: es ! Saturation vapor pressure - REAL(KIND=r8), intent(out) :: qs ! Saturation specific humidity - INTEGER, intent(in), optional :: idx ! Scheme index - es = wv_sat_svp_water(t, idx) - qs = wv_sat_svp_to_qsat(es, p) - ! Ensures returned es is consistent with limiters on qs. - es = min(es, p) - END SUBROUTINE wv_sat_qsat_water - - elemental SUBROUTINE wv_sat_qsat_ice(t, p, es, qs, idx) - !------------------------------------------------------------------! - ! Purpose: ! - ! Calculate SVP over ice at a given temperature, and then ! - ! calculate and return saturation specific humidity. ! - !------------------------------------------------------------------! - ! Inputs - REAL(KIND=r8), intent(in) :: t ! Temperature - REAL(KIND=r8), intent(in) :: p ! Pressure - ! Outputs - REAL(KIND=r8), intent(out) :: es ! Saturation vapor pressure - REAL(KIND=r8), intent(out) :: qs ! Saturation specific humidity - INTEGER, intent(in), optional :: idx ! Scheme index - es = wv_sat_svp_ice(t, idx) - qs = wv_sat_svp_to_qsat(es, p) - ! Ensures returned es is consistent with limiters on qs. - es = min(es, p) - END SUBROUTINE wv_sat_qsat_ice - - !--------------------------------------------------------------------- - ! SVP INTERFACE FUNCTIONS - !--------------------------------------------------------------------- - - elemental FUNCTION wv_sat_svp_water(t, idx) RESULT ( es ) - REAL(KIND=r8), intent(in) :: t - INTEGER, intent(in), optional :: idx - REAL(KIND=r8) :: es - INTEGER :: use_idx - IF (present(idx)) THEN - use_idx = idx - ELSE - use_idx = default_idx - END IF - SELECT CASE ( use_idx ) - CASE ( goffgratch_idx ) - es = goffgratch_svp_water(t) - CASE ( murphykoop_idx ) - es = murphykoop_svp_water(t) - CASE ( oldgoffgratch_idx ) - es = oldgoffgratch_svp_water(t) - CASE ( bolton_idx ) - es = bolton_svp_water(t) - END SELECT - END FUNCTION wv_sat_svp_water - - elemental FUNCTION wv_sat_svp_ice(t, idx) RESULT ( es ) - REAL(KIND=r8), intent(in) :: t - INTEGER, intent(in), optional :: idx - REAL(KIND=r8) :: es - INTEGER :: use_idx - IF (present(idx)) THEN - use_idx = idx - ELSE - use_idx = default_idx - END IF - SELECT CASE ( use_idx ) - CASE ( goffgratch_idx ) - es = goffgratch_svp_ice(t) - CASE ( murphykoop_idx ) - es = murphykoop_svp_ice(t) - CASE ( oldgoffgratch_idx ) - es = oldgoffgratch_svp_ice(t) - CASE ( bolton_idx ) - es = bolton_svp_water(t) - END SELECT - END FUNCTION wv_sat_svp_ice - - !--------------------------------------------------------------------- - ! SVP METHODS - !--------------------------------------------------------------------- - ! Goff & Gratch (1946) - - elemental FUNCTION goffgratch_svp_water(t) RESULT ( es ) - REAL(KIND=r8), intent(in) :: t ! Temperature in Kelvin - REAL(KIND=r8) :: es ! SVP in Pa - ! uncertain below -70 C - es = 10._r8**(-7.90298_r8*(tboil/t-1._r8)+ 5.02808_r8*log10(tboil/t)- 1.3816e-7_r8*(10._r8**(11.344_r8*(& - 1._r8-t/tboil))-1._r8)+ 8.1328e-3_r8*(10._r8**(-3.49149_r8*(tboil/t-1._r8))-1._r8)+ log10(1013.246_r8))*100._r8 - END FUNCTION goffgratch_svp_water - - elemental FUNCTION goffgratch_svp_ice(t) RESULT ( es ) - REAL(KIND=r8), intent(in) :: t ! Temperature in Kelvin - REAL(KIND=r8) :: es ! SVP in Pa - ! good down to -100 C - es = 10._r8**(-9.09718_r8*(h2otrip/t-1._r8)-3.56654_r8* log10(h2otrip/t)+0.876793_r8*(1._r8-t/h2otrip)+ & - log10(6.1071_r8))*100._r8 - END FUNCTION goffgratch_svp_ice - ! Murphy & Koop (2005) - - elemental FUNCTION murphykoop_svp_water(t) RESULT ( es ) - REAL(KIND=r8), intent(in) :: t ! Temperature in Kelvin - REAL(KIND=r8) :: es ! SVP in Pa - ! (good for 123 < T < 332 K) - es = exp(54.842763_r8 - (6763.22_r8 / t) - (4.210_r8 * log(t)) + (0.000367_r8 * t) + (tanh(0.0415_r8 * (t - & - 218.8_r8)) * (53.878_r8 - (1331.22_r8 / t) - (9.44523_r8 * log(t)) + 0.014025_r8 * t))) - END FUNCTION murphykoop_svp_water - - elemental FUNCTION murphykoop_svp_ice(t) RESULT ( es ) - REAL(KIND=r8), intent(in) :: t ! Temperature in Kelvin - REAL(KIND=r8) :: es ! SVP in Pa - ! (good down to 110 K) - es = exp(9.550426_r8 - (5723.265_r8 / t) + (3.53068_r8 * log(t)) - (0.00728332_r8 * t)) - END FUNCTION murphykoop_svp_ice - ! Old 1 implementation, also labelled Goff & Gratch (1946) - ! The water formula differs only due to compiler-dependent order of - ! operations, so differences are roundoff level, usually 0. - ! The ice formula gives fairly close answers to the current - ! implementation, but has been rearranged, and uses the - ! 1 atm melting point of water as the triple point. - ! Differences are thus small but above roundoff. - ! A curious fact: although using the melting point of water was - ! probably a mistake, it mildly improves accuracy for ice svp, - ! since it compensates for a systematic error in Goff & Gratch. - - elemental FUNCTION oldgoffgratch_svp_water(t) RESULT ( es ) - REAL(KIND=r8), intent(in) :: t - REAL(KIND=r8) :: es - REAL(KIND=r8) :: ps - REAL(KIND=r8) :: e1 - REAL(KIND=r8) :: e2 - REAL(KIND=r8) :: f1 - REAL(KIND=r8) :: f2 - REAL(KIND=r8) :: f3 - REAL(KIND=r8) :: f4 - REAL(KIND=r8) :: f5 - REAL(KIND=r8) :: f - ps = 1013.246_r8 - e1 = 11.344_r8*(1.0_r8 - t/tboil) - e2 = -3.49149_r8*(tboil/t - 1.0_r8) - f1 = -7.90298_r8*(tboil/t - 1.0_r8) - f2 = 5.02808_r8*log10(tboil/t) - f3 = -1.3816_r8*(10.0_r8**e1 - 1.0_r8)/10000000.0_r8 - f4 = 8.1328_r8*(10.0_r8**e2 - 1.0_r8)/1000.0_r8 - f5 = log10(ps) - f = f1 + f2 + f3 + f4 + f5 - es = (10.0_r8**f)*100.0_r8 - END FUNCTION oldgoffgratch_svp_water - - elemental FUNCTION oldgoffgratch_svp_ice(t) RESULT ( es ) - REAL(KIND=r8), intent(in) :: t - REAL(KIND=r8) :: es - REAL(KIND=r8) :: term1 - REAL(KIND=r8) :: term2 - REAL(KIND=r8) :: term3 - term1 = 2.01889049_r8/(tmelt/t) - term2 = 3.56654_r8*log(tmelt/t) - term3 = 20.947031_r8*(tmelt/t) - es = 575.185606e10_r8*exp(-(term1 + term2 + term3)) - END FUNCTION oldgoffgratch_svp_ice - ! Bolton (1980) - ! zm_conv deep convection scheme contained this SVP calculation. - ! It appears to be from D. Bolton, 1980, Monthly Weather Review. - ! Unlike the other schemes, no distinct ice formula is associated - ! with it. (However, a Bolton ice formula exists in CLUBB.) - ! The original formula used degrees C, but this function - ! takes Kelvin and internally converts. - - elemental FUNCTION bolton_svp_water(t) RESULT ( es ) - REAL(KIND=r8), parameter :: c1 = 611.2_r8 - REAL(KIND=r8), parameter :: c2 = 17.67_r8 - REAL(KIND=r8), parameter :: c3 = 243.5_r8 - REAL(KIND=r8), intent(in) :: t ! Temperature in Kelvin - REAL(KIND=r8) :: es ! SVP in Pa - es = c1*exp((c2*(t - tmelt))/((t - tmelt)+c3)) - END FUNCTION bolton_svp_water - END MODULE wv_sat_methods diff --git a/test/ncar_kernels/CAM5_wetdepa/CESM_license.txt b/test/ncar_kernels/CAM5_wetdepa/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/CAM5_wetdepa/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/CAM5_wetdepa/README b/test/ncar_kernels/CAM5_wetdepa/README deleted file mode 100644 index 78befe241f..0000000000 --- a/test/ncar_kernels/CAM5_wetdepa/README +++ /dev/null @@ -1,20 +0,0 @@ -WETDEPA_V2 driver ------------------ - -The Wetdepa_v2 driver represents a piece of code that consumes a relatively -large amount of time in the CAM5 model. In particular in its original form -it consumed 2.5% of CAM5-SE @ ne=16 on 384 cores. This code was identified -using Extrae, Paraver, and BSC clustering and folding tools as consuming -a large amount of time and executing rather poorly. In particular the original -version did not vectorize due to unnecessary if loops. Two versions of the -subroutine are provide: - - wetdep_orig.F90: original verison - wetdep.F90: modified version - -A makefile is provided which will build a modified version of the driver -'wetdepa_driver', and the original version of the driver 'wetdepa_orig_driver'. - -Questions: -John Dennis -dennis@ucar.edu diff --git a/test/ncar_kernels/CAM5_wetdepa/inc/t1.mk b/test/ncar_kernels/CAM5_wetdepa/inc/t1.mk deleted file mode 100644 index b6496718f9..0000000000 --- a/test/ncar_kernels/CAM5_wetdepa/inc/t1.mk +++ /dev/null @@ -1,86 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# Intel default flags -# -# FC_FLAGS := -## BASE = -mmic -vec-report=6 -fp-model fast -ftz -traceback -# BASE = -qopt-report=5 -ftz -fp-model fast -traceback -# -02 -# FFLAGS = -O2 $(BASE) - -# -O3 -# FFLAGS = -O3 $(BASE) - -# -O3 -fast -# FFLAGS = -O3 -fast -mmic $(BASE) -# -# Makefile for KGEN-generated kernel -FC_FLAGS := $(OPT) - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - -.SUFFIXES: -.SUFFIXES: .F90 .f90 .o -FPP := cpp -FPPFLAGS := -I. -traditional -P - - -OBJS := wetdepa_driver.o wetdep.o kinds_mod.o params.o shr_const_mod.o shr_kind_mod.o -OBJS0 := wetdepa_driver.o wetdep_orig.o kinds_mod.o params.o shr_const_mod.o shr_kind_mod.o -ALL_OBJS :=$(OBJS) - - -run: build - ./kernel.exe - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -.F90.o: - $(FC) $(FFLAGS) -c $< - -#.F90.f90: -# $(FPP) $(FPPFLAGS) $< >$*.f90 - -wetdepa_driver.o: $(SRC_DIR)/wetdepa_driver.F90 shr_kind_mod.o wetdep.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -wetdep.o: $(SRC_DIR)/wetdep.F90 kinds_mod.o params.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_kind_mod.o: $(SRC_DIR)/shr_kind_mod.F90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -kinds_mod.o: $(SRC_DIR)/kinds_mod.F90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -params.o: $(SRC_DIR)/params.F90 shr_const_mod.o kinds_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_const_mod.o: $(SRC_DIR)/shr_const_mod.F90 shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -verify: run - @echo "nothing to be done for verify" - -clean: - rm -rf *.o *.mod wetdepa_driver wetdepa_driver_v0 *.optrpt diff --git a/test/ncar_kernels/CAM5_wetdepa/lit/runmake b/test/ncar_kernels/CAM5_wetdepa/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/CAM5_wetdepa/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/CAM5_wetdepa/makefile b/test/ncar_kernels/CAM5_wetdepa/makefile deleted file mode 100644 index 12261469d1..0000000000 --- a/test/ncar_kernels/CAM5_wetdepa/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. -# - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/CAM5_wetdepa/src/kinds_mod.F90 b/test/ncar_kernels/CAM5_wetdepa/src/kinds_mod.F90 deleted file mode 100644 index 17906b5a0e..0000000000 --- a/test/ncar_kernels/CAM5_wetdepa/src/kinds_mod.F90 +++ /dev/null @@ -1,8 +0,0 @@ -module kinds_mod - - integer, public, parameter :: i4 = selected_int_kind ( 6) ! 4 byte integer - integer, public, parameter :: r4 = selected_real_kind ( 6) ! 4 byte real - integer, public, parameter :: r8 = selected_real_kind (12) ! 8 byte real - - -end module kinds_mod diff --git a/test/ncar_kernels/CAM5_wetdepa/src/params.F90 b/test/ncar_kernels/CAM5_wetdepa/src/params.F90 deleted file mode 100644 index 272ba77cf8..0000000000 --- a/test/ncar_kernels/CAM5_wetdepa/src/params.F90 +++ /dev/null @@ -1,12 +0,0 @@ -module params - - use kinds_mod - use shr_const_mod - integer, public, parameter :: pcols=16 - integer, public, parameter :: pver=30 - real(r8), parameter :: gravit = shr_const_g - real(r8), parameter :: tmelt = shr_const_tkfrz - real(r8), parameter :: rair = shr_const_rdair - character(len=4), parameter :: cam_physpkg_is = 'cam5' - -end module params diff --git a/test/ncar_kernels/CAM5_wetdepa/src/shr_const_mod.F90 b/test/ncar_kernels/CAM5_wetdepa/src/shr_const_mod.F90 deleted file mode 100644 index cf4c17a0f1..0000000000 --- a/test/ncar_kernels/CAM5_wetdepa/src/shr_const_mod.F90 +++ /dev/null @@ -1,61 +0,0 @@ -!=============================================================================== -! SVN $Id$ -! SVN $URL$ -!=============================================================================== - -MODULE shr_const_mod - - use shr_kind_mod - - integer(SHR_KIND_IN),parameter,private :: R8 = SHR_KIND_R8 ! rename for local readability only - - !---------------------------------------------------------------------------- - ! physical constants (all data public) - !---------------------------------------------------------------------------- - public - - real(R8),parameter :: SHR_CONST_PI = 3.14159265358979323846_R8 ! pi - real(R8),parameter :: SHR_CONST_CDAY = 86400.0_R8 ! sec in calendar day ~ sec - real(R8),parameter :: SHR_CONST_SDAY = 86164.0_R8 ! sec in siderial day ~ sec - real(R8),parameter :: SHR_CONST_OMEGA = 2.0_R8*SHR_CONST_PI/SHR_CONST_SDAY ! earth rot ~ rad/sec - real(R8),parameter :: SHR_CONST_REARTH = 6.37122e6_R8 ! radius of earth ~ m - real(R8),parameter :: SHR_CONST_G = 9.80616_R8 ! acceleration of gravity ~ m/s^2 - - real(R8),parameter :: SHR_CONST_STEBOL = 5.67e-8_R8 ! Stefan-Boltzmann constant ~ W/m^2/K^4 - real(R8),parameter :: SHR_CONST_BOLTZ = 1.38065e-23_R8 ! Boltzmann's constant ~ J/K/molecule - real(R8),parameter :: SHR_CONST_AVOGAD = 6.02214e26_R8 ! Avogadro's number ~ molecules/kmole - real(R8),parameter :: SHR_CONST_RGAS = SHR_CONST_AVOGAD*SHR_CONST_BOLTZ ! Universal gas constant ~ J/K/kmole - real(R8),parameter :: SHR_CONST_MWDAIR = 28.966_R8 ! molecular weight dry air ~ kg/kmole - real(R8),parameter :: SHR_CONST_MWWV = 18.016_R8 ! molecular weight water vapor - real(R8),parameter :: SHR_CONST_RDAIR = SHR_CONST_RGAS/SHR_CONST_MWDAIR ! Dry air gas constant ~ J/K/kg - real(R8),parameter :: SHR_CONST_RWV = SHR_CONST_RGAS/SHR_CONST_MWWV ! Water vapor gas constant ~ J/K/kg - real(R8),parameter :: SHR_CONST_ZVIR = (SHR_CONST_RWV/SHR_CONST_RDAIR)-1.0_R8 ! RWV/RDAIR - 1.0 - real(R8),parameter :: SHR_CONST_KARMAN = 0.4_R8 ! Von Karman constant - real(R8),parameter :: SHR_CONST_PSTD = 101325.0_R8 ! standard pressure ~ pascals - real(R8),parameter :: SHR_CONST_PDB = 0.0112372_R8 ! ratio of 13C/12C in Pee Dee Belemnite (C isotope standard) - - real(R8),parameter :: SHR_CONST_TKTRIP = 273.16_R8 ! triple point of fresh water ~ K - real(R8),parameter :: SHR_CONST_TKFRZ = 273.15_R8 ! freezing T of fresh water ~ K - real(R8),parameter :: SHR_CONST_TKFRZSW = SHR_CONST_TKFRZ - 1.8_R8 ! freezing T of salt water ~ K - - real(R8),parameter :: SHR_CONST_RHODAIR = & ! density of dry air at STP ~ kg/m^3 - SHR_CONST_PSTD/(SHR_CONST_RDAIR*SHR_CONST_TKFRZ) - real(R8),parameter :: SHR_CONST_RHOFW = 1.000e3_R8 ! density of fresh water ~ kg/m^3 - real(R8),parameter :: SHR_CONST_RHOSW = 1.026e3_R8 ! density of sea water ~ kg/m^3 - real(R8),parameter :: SHR_CONST_RHOICE = 0.917e3_R8 ! density of ice ~ kg/m^3 - real(R8),parameter :: SHR_CONST_CPDAIR = 1.00464e3_R8 ! specific heat of dry air ~ J/kg/K - real(R8),parameter :: SHR_CONST_CPWV = 1.810e3_R8 ! specific heat of water vap ~ J/kg/K - real(R8),parameter :: SHR_CONST_CPVIR = (SHR_CONST_CPWV/SHR_CONST_CPDAIR)-1.0_R8 ! CPWV/CPDAIR - 1.0 - real(R8),parameter :: SHR_CONST_CPFW = 4.188e3_R8 ! specific heat of fresh h2o ~ J/kg/K - real(R8),parameter :: SHR_CONST_CPSW = 3.996e3_R8 ! specific heat of sea h2o ~ J/kg/K - real(R8),parameter :: SHR_CONST_CPICE = 2.11727e3_R8 ! specific heat of fresh ice ~ J/kg/K - real(R8),parameter :: SHR_CONST_LATICE = 3.337e5_R8 ! latent heat of fusion ~ J/kg - real(R8),parameter :: SHR_CONST_LATVAP = 2.501e6_R8 ! latent heat of evaporation ~ J/kg - real(R8),parameter :: SHR_CONST_LATSUB = & ! latent heat of sublimation ~ J/kg - SHR_CONST_LATICE + SHR_CONST_LATVAP - real(R8),parameter :: SHR_CONST_OCN_REF_SAL = 34.7_R8 ! ocn ref salinity (psu) - real(R8),parameter :: SHR_CONST_ICE_REF_SAL = 4.0_R8 ! ice ref salinity (psu) - - real(R8),parameter :: SHR_CONST_SPVAL = 1.0e30_R8 ! special missing value - -END MODULE shr_const_mod diff --git a/test/ncar_kernels/CAM5_wetdepa/src/shr_kind_mod.F90 b/test/ncar_kernels/CAM5_wetdepa/src/shr_kind_mod.F90 deleted file mode 100644 index 212bde0891..0000000000 --- a/test/ncar_kernels/CAM5_wetdepa/src/shr_kind_mod.F90 +++ /dev/null @@ -1,23 +0,0 @@ -!=============================================================================== -! SVN $Id$ -! SVN $URL$ -!=============================================================================== - -MODULE shr_kind_mod - - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - public - integer,parameter :: SHR_KIND_R8 = selected_real_kind(12) ! 8 byte real - integer,parameter :: SHR_KIND_R4 = selected_real_kind( 6) ! 4 byte real - integer,parameter :: SHR_KIND_RN = kind(1.0) ! native real - integer,parameter :: SHR_KIND_I8 = selected_int_kind (13) ! 8 byte integer - integer,parameter :: SHR_KIND_I4 = selected_int_kind ( 6) ! 4 byte integer - integer,parameter :: SHR_KIND_IN = kind(1) ! native integer - integer,parameter :: SHR_KIND_CS = 80 ! short char - integer,parameter :: SHR_KIND_CL = 256 ! long char - integer,parameter :: SHR_KIND_CX = 512 ! extra-long char - integer,parameter :: SHR_KIND_CXX= 4096 ! extra-extra-long char - -END MODULE shr_kind_mod diff --git a/test/ncar_kernels/CAM5_wetdepa/src/wetdep.F90 b/test/ncar_kernels/CAM5_wetdepa/src/wetdep.F90 deleted file mode 100644 index 475453c745..0000000000 --- a/test/ncar_kernels/CAM5_wetdepa/src/wetdep.F90 +++ /dev/null @@ -1,1009 +0,0 @@ -!#define GENERATE_DRIVER - - - - -module wetdep - -!----------------------------------------------------------------------- -! -! Wet deposition routines for both aerosols and gas phase constituents. -! -!----------------------------------------------------------------------- - - - -use kinds_mod -use params, only: pcols, pver, gravit, rair, tmelt - - - - - - - -implicit none -save -private - -public :: wetdepa_v1 ! scavenging codes for very soluble aerosols -- CAM4 version -public :: wetdepa_v2 ! scavenging codes for very soluble aerosols -- CAM5 version -public :: wetdepg ! scavenging of gas phase constituents by henry's law -public :: clddiag ! calc of cloudy volume and rain mixing ratio - -real(r8), parameter :: cmftau = 3600._r8 -real(r8), parameter :: rhoh2o = 1000._r8 ! density of water -real(r8), parameter :: molwta = 28.97_r8 ! molecular weight dry air gm/mole - -!============================================================================== -contains -!============================================================================== - -subroutine clddiag(t, pmid, pdel, cmfdqr, evapc, & - cldt, cldcu, cldst, cme, evapr, & - prain, cldv, cldvcu, cldvst, rain, & - ncol) - - ! ------------------------------------------------------------------------------------ - ! Estimate the cloudy volume which is occupied by rain or cloud water as - ! the max between the local cloud amount or the - ! sum above of (cloud*positive precip production) sum total precip from above - ! ---------------------------------- x ------------------------ - ! sum above of (positive precip ) sum positive precip from above - ! Author: P. Rasch - ! Sungsu Park. Mar.2010 - ! ------------------------------------------------------------------------------------ - - ! Input arguments: - real(r8), intent(in) :: t(pcols,pver) ! temperature (K) - real(r8), intent(in) :: pmid(pcols,pver) ! pressure at layer midpoints - real(r8), intent(in) :: pdel(pcols,pver) ! pressure difference across layers - real(r8), intent(in) :: cmfdqr(pcols,pver) ! dq/dt due to convective rainout - real(r8), intent(in) :: evapc(pcols,pver) ! Evaporation rate of convective precipitation ( >= 0 ) - real(r8), intent(in) :: cldt(pcols,pver) ! total cloud fraction - real(r8), intent(in) :: cldcu(pcols,pver) ! Cumulus cloud fraction - real(r8), intent(in) :: cldst(pcols,pver) ! Stratus cloud fraction - real(r8), intent(in) :: cme(pcols,pver) ! rate of cond-evap within the cloud - real(r8), intent(in) :: evapr(pcols,pver) ! rate of evaporation of falling precipitation (kg/kg/s) - real(r8), intent(in) :: prain(pcols,pver) ! rate of conversion of condensate to precipitation (kg/kg/s) - integer, intent(in) :: ncol - - ! Output arguments: - real(r8), intent(out) :: cldv(pcols,pver) ! fraction occupied by rain or cloud water - real(r8), intent(out) :: cldvcu(pcols,pver) ! Convective precipitation volume - real(r8), intent(out) :: cldvst(pcols,pver) ! Stratiform precipitation volume - real(r8), intent(out) :: rain(pcols,pver) ! mixing ratio of rain (kg/kg) - - ! Local variables: - integer i, k - real(r8) convfw ! used in fallspeed calculation; taken from findmcnew - real(r8) sumppr(pcols) ! precipitation rate (kg/m2-s) - real(r8) sumpppr(pcols) ! sum of positive precips from above - real(r8) cldv1(pcols) ! precip weighted cloud fraction from above - real(r8) lprec ! local production rate of precip (kg/m2/s) - real(r8) lprecp ! local production rate of precip (kg/m2/s) if positive - real(r8) rho ! air density - real(r8) vfall - real(r8) sumppr_cu(pcols) ! Convective precipitation rate (kg/m2-s) - real(r8) sumpppr_cu(pcols) ! Sum of positive convective precips from above - real(r8) cldv1_cu(pcols) ! Convective precip weighted convective cloud fraction from above - real(r8) lprec_cu ! Local production rate of convective precip (kg/m2/s) - real(r8) lprecp_cu ! Local production rate of convective precip (kg/m2/s) if positive - real(r8) sumppr_st(pcols) ! Stratiform precipitation rate (kg/m2-s) - real(r8) sumpppr_st(pcols) ! Sum of positive stratiform precips from above - real(r8) cldv1_st(pcols) ! Stratiform precip weighted stratiform cloud fraction from above - real(r8) lprec_st ! Local production rate of stratiform precip (kg/m2/s) - real(r8) lprecp_st ! Local production rate of stratiform precip (kg/m2/s) if positive - ! ----------------------------------------------------------------------- - - convfw = 1.94_r8*2.13_r8*sqrt(rhoh2o*gravit*2.7e-4_r8) - do i=1,ncol - sumppr(i) = 0._r8 - cldv1(i) = 0._r8 - sumpppr(i) = 1.e-36_r8 - sumppr_cu(i) = 0._r8 - cldv1_cu(i) = 0._r8 - sumpppr_cu(i) = 1.e-36_r8 - sumppr_st(i) = 0._r8 - cldv1_st(i) = 0._r8 - sumpppr_st(i) = 1.e-36_r8 - end do - - do k = 1,pver - do i = 1,ncol - cldv(i,k) = & - max(min(1._r8, & - cldv1(i)/sumpppr(i) & - )*sumppr(i)/sumpppr(i), & - cldt(i,k) & - ) - lprec = pdel(i,k)/gravit & - *(prain(i,k)+cmfdqr(i,k)-evapr(i,k)) - lprecp = max(lprec,1.e-30_r8) - cldv1(i) = cldv1(i) + cldt(i,k)*lprecp - sumppr(i) = sumppr(i) + lprec - sumpppr(i) = sumpppr(i) + lprecp - - ! For convective precipitation volume at the top interface of each layer. Neglect the current layer. - cldvcu(i,k) = max(min(1._r8,cldv1_cu(i)/sumpppr_cu(i))*(sumppr_cu(i)/sumpppr_cu(i)),0._r8) - lprec_cu = (pdel(i,k)/gravit)*(cmfdqr(i,k)-evapc(i,k)) - lprecp_cu = max(lprec_cu,1.e-30_r8) - cldv1_cu(i) = cldv1_cu(i) + cldcu(i,k)*lprecp_cu - sumppr_cu(i) = sumppr_cu(i) + lprec_cu - sumpppr_cu(i) = sumpppr_cu(i) + lprecp_cu - - ! For stratiform precipitation volume at the top interface of each layer. Neglect the current layer. - cldvst(i,k) = max(min(1._r8,cldv1_st(i)/sumpppr_st(i))*(sumppr_st(i)/sumpppr_st(i)),0._r8) - lprec_st = (pdel(i,k)/gravit)*(prain(i,k)-evapr(i,k)) - lprecp_st = max(lprec_st,1.e-30_r8) - cldv1_st(i) = cldv1_st(i) + cldst(i,k)*lprecp_st - sumppr_st(i) = sumppr_st(i) + lprec_st - sumpppr_st(i) = sumpppr_st(i) + lprecp_st - - rain(i,k) = 0._r8 - if(t(i,k) .gt. tmelt) then - rho = pmid(i,k)/(rair*t(i,k)) - vfall = convfw/sqrt(rho) - rain(i,k) = sumppr(i)/(rho*vfall) - if (rain(i,k).lt.1.e-14_r8) rain(i,k) = 0._r8 - endif - end do - end do - -end subroutine clddiag - -!============================================================================== - -! This is the CAM5 version of wetdepa. - -subroutine wetdepa_v2(t, p, q, pdel, & - cldt, cldc, cmfdqr, evapc, conicw, precs, conds, & - evaps, cwat, tracer, deltat, & - scavt, iscavt, cldv, cldvcu, cldvst, dlf, fracis, sol_fact, ncol, & - scavcoef, is_strat_cloudborne, rate1ord_cw2pr_st, qqcw, f_act_conv, & - icscavt, isscavt, bcscavt, bsscavt, & - sol_facti_in, sol_factbi_in, sol_factii_in, & - sol_factic_in, sol_factiic_in ) - - !----------------------------------------------------------------------- - ! Purpose: - ! scavenging code for very soluble aerosols - ! - ! Author: P. Rasch - ! Modified by T. Bond 3/2003 to track different removals - ! Sungsu Park. Mar.2010 : Impose consistencies with a few changes in physics. - !----------------------------------------------------------------------- - - - - implicit none - - real(r8), intent(in) ::& - t(pcols,pver), &! temperature - p(pcols,pver), &! pressure - q(pcols,pver), &! moisture - pdel(pcols,pver), &! pressure thikness - cldt(pcols,pver), &! total cloud fraction - cldc(pcols,pver), &! convective cloud fraction - cmfdqr(pcols,pver), &! rate of production of convective precip -! Sungsu - evapc(pcols,pver), &! Evaporation rate of convective precipitation -! Sungsu - conicw(pcols,pver), &! convective cloud water - cwat(pcols,pver), &! cloud water amount - precs(pcols,pver), &! rate of production of stratiform precip - conds(pcols,pver), &! rate of production of condensate - evaps(pcols,pver), &! rate of evaporation of precip - cldv(pcols,pver), &! total cloud fraction -! Sungsu - cldvcu(pcols,pver), &! Convective precipitation area at the top interface of each layer - cldvst(pcols,pver), &! Stratiform precipitation area at the top interface of each layer - dlf(pcols,pver), &! Detrainment of convective condensate [kg/kg/s] -! Sungsu - deltat, &! time step - tracer(pcols,pver) ! trace species - - ! If subroutine is called with just sol_fact: - ! sol_fact is used for both in- and below-cloud scavenging - ! If subroutine is called with optional argument sol_facti_in: - ! sol_fact is used for below cloud scavenging - ! sol_facti is used for in cloud scavenging - real(r8), intent(in) :: sol_fact ! solubility factor (fraction of aer scavenged below & in, or just below or sol_facti_in is provided) - integer, intent(in) :: ncol - real(r8), intent(in) :: scavcoef(pcols,pver) ! Dana and Hales coefficient (/mm) (0.1 if not MODAL_AERO) - real(r8), intent(out) ::& - scavt(pcols,pver), &! scavenging tend - iscavt(pcols,pver), &! incloud scavenging tends - fracis(pcols,pver) ! fraction of species not scavenged - ! rce 2010/05/01 - ! is_strat_cloudborne = .true. if tracer is stratiform-cloudborne aerosol; else .false. - logical, intent(in), optional :: is_strat_cloudborne - ! rate1ord_cw2pr_st = 1st order rate for strat cw to precip (1/s) - real(r8), intent(in), optional :: rate1ord_cw2pr_st(pcols,pver) - ! qqcw = strat-cloudborne aerosol corresponding to tracer when is_strat_cloudborne==.false.; else 0.0 - real(r8), intent(in), optional :: qqcw(pcols,pver) - ! f_act_conv = conv-cloud activation fraction when is_strat_cloudborne==.false.; else 0.0 - real(r8), intent(in), optional :: f_act_conv(pcols,pver) - ! end rce 2010/05/01 - - real(r8), intent(in), optional :: sol_facti_in ! solubility factor (frac of aerosol scavenged in cloud) - real(r8), intent(in), optional :: sol_factbi_in ! solubility factor (frac of aerosol scavenged below cloud by ice) - real(r8), intent(in), optional :: sol_factii_in ! solubility factor (frac of aerosol scavenged in cloud by ice) - real(r8), intent(in), optional :: sol_factic_in(pcols,pver) ! sol_facti_in for convective clouds - real(r8), intent(in), optional :: sol_factiic_in ! sol_factii_in for convective clouds - - - real(r8), intent(out), optional :: icscavt(pcols,pver) ! incloud, convective - real(r8), intent(out), optional :: isscavt(pcols,pver) ! incloud, stratiform - real(r8), intent(out), optional :: bcscavt(pcols,pver) ! below cloud, convective - real(r8), intent(out), optional :: bsscavt(pcols,pver) ! below cloud, stratiform - - - - ! local variables - - integer i ! x index - integer k ! z index - - real(r8) adjfac ! factor stolen from cmfmca - real(r8) aqfrac ! fraction of tracer in aqueous phase - real(r8) cwatc ! local convective total water amount - real(r8) cwats ! local stratiform total water amount - real(r8) cwatp ! local water amount falling from above precip - real(r8) fracev(pcols) ! fraction of precip from above that is evaporating -! Sungsu - real(r8) fracev_cu(pcols) ! Fraction of convective precip from above that is evaporating -! Sungsu - real(r8) fracp(pcols) ! fraction of cloud water converted to precip - real(r8) gafrac ! fraction of tracer in gas phasea - real(r8) hconst ! henry's law solubility constant when equation is expressed - ! in terms of mixing ratios - real(r8) mpla ! moles / liter H2O entering the layer from above - real(r8) mplb ! moles / liter H2O leaving the layer below - real(r8) omsm ! 1 - (a small number) - real(r8) part ! partial pressure of tracer in atmospheres - real(r8) patm ! total pressure in atmospheres - real(r8) pdog(pcols) ! work variable (pdel/gravit) - real(r8) rpdog(pcols) ! work variable (gravit/pdel) - real(r8) precabc(pcols) ! conv precip from above (work array) - real(r8) precabs(pcols) ! strat precip from above (work array) - real(r8) precbl ! precip falling out of level (work array) - real(r8) precmin ! minimum convective precip causing scavenging - real(r8) rat(pcols) ! ratio of amount available to amount removed - real(r8) scavab(pcols) ! scavenged tracer flux from above (work array) - real(r8) scavabc(pcols) ! scavenged tracer flux from above (work array) - real(r8) srcc(pcols) ! tend for convective rain - real(r8) srcs(pcols) ! tend for stratiform rain - real(r8) srct(pcols) ! work variable - real(r8) tracab(pcols) ! column integrated tracer amount -! real(r8) vfall ! fall speed of precip - real(r8) fins(pcols) ! fraction of rem. rate by strat rain - real(r8) finc(pcols) ! fraction of rem. rate by conv. rain - real(r8) srcs1(pcols) ! work variable - real(r8) srcs2(pcols) ! work variable - real(r8) tc(pcols) ! temp in celcius - real(r8) weight(pcols) ! fraction of condensate which is ice - real(r8) cldmabs(pcols) ! maximum cloud at or above this level - real(r8) cldmabc(pcols) ! maximum cloud at or above this level - real(r8) odds(pcols) ! limit on removal rate (proportional to prec) - real(r8) dblchek(pcols) - logical :: found - - ! Jan.16.2009. Sungsu for wet scavenging below clouds. - ! real(r8) cldovr_cu(pcols) ! Convective precipitation area at the base of each layer - ! real(r8) cldovr_st(pcols) ! Stratiform precipitation area at the base of each layer - - real(r8) tracer_incu(pcols) - real(r8) tracer_mean(pcols) - - ! End by Sungsu - - real(r8) sol_facti, sol_factb ! in cloud and below cloud fraction of aerosol scavenged - real(r8) sol_factii, sol_factbi ! in cloud and below cloud fraction of aerosol scavenged by ice - real(r8) sol_factic(pcols,pver) ! sol_facti for convective clouds - real(r8) sol_factiic ! sol_factii for convective clouds - ! sol_factic & solfact_iic added for MODAL_AERO. - ! For stratiform cloud, cloudborne aerosol is treated explicitly, - ! and sol_facti is 1.0 for cloudborne, 0.0 for interstitial. - ! For convective cloud, cloudborne aerosol is not treated explicitly, - ! and sol_factic is 1.0 for both cloudborne and interstitial. - real(r8) :: rdeltat - - - - ! ------------------------------------------------------------------------ -! omsm = 1.-1.e-10 ! used to prevent roundoff errors below zero - omsm = 1._r8-2*epsilon(1._r8) ! used to prevent roundoff errors below zero - precmin = 0.1_r8/8.64e4_r8 ! set critical value to 0.1 mm/day in kg/m2/s - - adjfac = deltat/(max(deltat,cmftau)) ! adjustment factor from hack scheme - - ! assume 4 m/s fall speed currently (should be improved) -! vfall = 4. - - ! default (if other sol_facts aren't in call, set all to required sol_fact - sol_facti = sol_fact - sol_factb = sol_fact - sol_factii = sol_fact - sol_factbi = sol_fact - - if ( present(sol_facti_in) ) sol_facti = sol_facti_in - if ( present(sol_factii_in) ) sol_factii = sol_factii_in - if ( present(sol_factbi_in) ) sol_factbi = sol_factbi_in - - sol_factic = sol_facti - sol_factiic = sol_factii - if ( present(sol_factic_in ) ) sol_factic = sol_factic_in - if ( present(sol_factiic_in) ) sol_factiic = sol_factiic_in - - ! this section of code is for highly soluble aerosols, - ! the assumption is that within the cloud that - ! all the tracer is in the cloud water - ! - ! for both convective and stratiform clouds, - ! the fraction of cloud water converted to precip defines - ! the amount of tracer which is pulled out. - ! - - do i = 1,pcols - precabs(i) = 0 - precabc(i) = 0 - scavab(i) = 0 - scavabc(i) = 0 - tracab(i) = 0 - cldmabs(i) = 0 - cldmabc(i) = 0 - - ! Jan.16. Sungsu - ! I added below to compute vertically projected cumulus and stratus fractions from the top to the - ! current model layer by assuming a simple independent maximum overlapping assumption for - ! each cloud. - ! cldovr_cu(i) = 0._r8 - ! cldovr_st(i) = 0._r8 - ! End by Sungsu - - end do - - do k = 1,pver - do i = 1,ncol - tc(i) = t(i,k) - tmelt - weight(i) = max(0._r8,min(-tc(i)*0.05_r8,1.0_r8)) ! fraction of condensate that is ice - weight(i) = 0._r8 ! assume no ice - - pdog(i) = pdel(i,k)/gravit - rpdog(i) = gravit/pdel(i,k) - rdeltat = 1.0_r8/deltat - - ! ****************** Evaporation ************************** - ! calculate the fraction of strat precip from above - ! which evaporates within this layer - fracev(i) = evaps(i,k)*pdog(i) & - /max(1.e-12_r8,precabs(i)) - - ! trap to ensure reasonable ratio bounds - fracev(i) = max(0._r8,min(1._r8,fracev(i))) - -! Sungsu : Same as above but convective precipitation part - fracev_cu(i) = evapc(i,k)*pdog(i)/max(1.e-12_r8,precabc(i)) - fracev_cu(i) = max(0._r8,min(1._r8,fracev_cu(i))) -! Sungsu - ! ****************** Convection *************************** - ! now do the convective scavenging - - ! set odds proportional to fraction of the grid box that is swept by the - ! precipitation =precabc/rhoh20*(area of sphere projected on plane - ! /volume of sphere)*deltat - ! assume the radius of a raindrop is 1 e-3 m from Rogers and Yau, - ! unless the fraction of the area that is cloud is less than odds, in which - ! case use the cloud fraction (assumes precabs is in kg/m2/s) - ! is really: precabs*3/4/1000./1e-3*deltat - ! here I use .1 from Balkanski - ! - ! use a local rate of convective rain production for incloud scav - !odds=max(min(1._r8, & - ! cmfdqr(i,k)*pdel(i,k)/gravit*0.1_r8*deltat),0._r8) - !++mcb -- change cldc to cldt; change cldt to cldv (9/17/96) - ! srcs1 = cldt(i,k)*odds*tracer(i,k)*(1.-weight) & - ! srcs1 = cldv(i,k)*odds*tracer(i,k)*(1.-weight) & - !srcs1 = cldc(i,k)*odds*tracer(i,k)*(1.-weight) & - ! /deltat - - ! fraction of convective cloud water converted to rain - ! Dec.29.2009 : Sungsu multiplied cldc(i,k) to conicw(i,k) below - ! fracp = cmfdqr(i,k)*deltat/max(1.e-8_r8,conicw(i,k)) - ! fracp = cmfdqr(i,k)*deltat/max(1.e-8_r8,cldc(i,k)*conicw(i,k)) - ! Sungsu: Below new formula of 'fracp' is necessary since 'conicw' is a LWC/IWC - ! that has already precipitated out, that is, 'conicw' does not contain - ! precipitation at all ! - fracp(i) = cmfdqr(i,k)*deltat/max(1.e-12_r8,cldc(i,k)*conicw(i,k)+(cmfdqr(i,k)+dlf(i,k))*deltat) ! Sungsu.Mar.19.2010. - ! Dec.29.2009 - ! Note cmfdrq can be negative from evap of rain, so constrain it <-- This is wrong. cmfdqr does not - ! contain evaporation of precipitation. - fracp(i) = max(min(1._r8,fracp(i)),0._r8) - - !--mcb - ! scavenge below cloud - ! cldmabc(i) = max(cldc(i,k),cldmabc(i)) - ! cldmabc(i) = max(cldt(i,k),cldmabc(i)) - ! cldmabc(i) = max(cldv(i,k),cldmabc(i)) - ! cldmabc(i) = cldv(i,k) - cldmabc(i) = cldvcu(i,k) - - ! Jan. 16. 2010. Sungsu - ! cldmabc(i) = cldmabc(i) * cldovr_cu(i) / max( 0.01_r8, cldovr_cu(i) + cldovr_st(i) ) - ! End by Sungsu - - enddo - ! remove that amount from within the convective area -! srcs1 = cldc(i,k)*fracp*tracer(i,k)*(1._r8-weight)/deltat ! liquid only -! srcs1 = cldc(i,k)*fracp*tracer(i,k)/deltat ! any condensation -! srcs1 = 0. -! Jan.02.2010. Sungsu : cldt --> cldc below. - ! rce 2010/05/01 - if (present(is_strat_cloudborne)) then ! Tianyi, 2011/03/29 - if ( is_strat_cloudborne ) then - do i=1,ncol - ! only strat in-cloud removal affects strat-cloudborne aerosol - srcs1(i) = 0._r8 - ! only strat in-cloud removal affects strat-cloudborne aerosol - srcs2(i) = 0._r8 - !Note that using the temperature-determined weight doesn't make much sense here - srcc(i) = srcs1(i) + srcs2(i) ! convective tend by both processes - finc(i) = srcs1(i)/(srcc(i) + 1.e-36_r8) ! fraction in-cloud - ! new code for stratiform incloud scav of cloudborne (modal) aerosol - ! >> use the 1st order cw to precip rate calculated in microphysics routine - ! >> cloudborne aerosol resides in cloudy portion of grid cell, so do not apply "cldt" factor - ! fracp = rate1ord_cw2pr_st(i,k)*deltat - ! fracp = max(0._r8,min(1._r8,fracp)) - fracp(i) = precs(i,k)*deltat/max(cwat(i,k)+precs(i,k)*deltat,1.e-12_r8) ! Sungsu. Mar.19.2010. - fracp(i) = max(0._r8,min(1._r8,fracp(i))) - srcs1(i) = sol_facti *fracp(i)*tracer(i,k)*rdeltat*(1._r8-weight(i)) & ! Liquid - + sol_factii*fracp(i)*tracer(i,k)*rdeltat*(weight(i)) ! Ice - ! only strat in-cloud removal affects strat-cloudborne aerosol - srcs2(i) = 0._r8 - enddo - else - do i=1,ncol - tracer_incu(i) = f_act_conv(i,k)*(tracer(i,k)+& - min(qqcw(i,k),tracer(i,k)*((cldt(i,k)-cldc(i,k))/max(0.01_r8,(1._r8-(cldt(i,k)-cldc(i,k))))))) - srcs1(i) = sol_factic(i,k)*cldc(i,k)*fracp(i)*tracer_incu(i)*(1._r8-weight(i))*rdeltat & ! Liquid - + sol_factiic *cldc(i,k)*fracp(i)*tracer_incu(i)*(weight(i))*rdeltat ! Ice - - tracer_mean(i) = tracer(i,k)*(1._r8-cldc(i,k)*f_act_conv(i,k))-cldc(i,k)*f_act_conv(i,k)*& - min(qqcw(i,k),tracer(i,k)*((cldt(i,k)-cldc(i,k))/max(0.01_r8,(1._r8-(cldt(i,k)-cldc(i,k)))))) - tracer_mean(i) = max(0._r8,tracer_mean(i)) - odds(i) = max(min(1._r8,precabc(i)/max(cldmabc(i),1.e-5_r8)*scavcoef(i,k)*deltat),0._r8) ! Dana and Hales coefficient (/mm) - - srcs2(i) = sol_factb *cldmabc(i)*odds(i)*tracer_mean(i)*(1._r8-weight(i))*rdeltat & ! Liquid - + sol_factbi*cldmabc(i)*odds(i)*tracer_mean(i)*(weight(i))*rdeltat ! Ice - !Note that using the temperature-determined weight doesn't make much sense here - srcc(i) = srcs1(i) + srcs2(i) ! convective tend by both processes - finc(i) = srcs1(i)/(srcc(i) + 1.e-36_r8) ! fraction in-cloud - ! strat in-cloud removal only affects strat-cloudborne aerosol - srcs1(i) = 0._r8 - odds(i) = precabs(i)/max(cldvst(i,k),1.e-5_r8)*scavcoef(i,k)*deltat - odds(i) = max(min(1._r8,odds(i)),0._r8) - - srcs2(i) = sol_factb *cldvst(i,k)*odds(i)*tracer_mean(i)*(1._r8-weight(i))*rdeltat & ! Liquid - + sol_factbi*cldvst(i,k)*odds(i)*tracer_mean(i)*(weight(i))*rdeltat ! Ice - enddo - end if - else - do i=1,ncol - srcs1(i) = sol_factic(i,k)*cldc(i,k)*fracp(i)*tracer(i,k)*(1._r8-weight(i))*rdeltat & ! liquid - + sol_factiic*cldc(i,k)*fracp(i)*tracer(i,k)*(weight(i))*rdeltat ! ice - odds(i) = max( & - min(1._r8,precabc(i)/max(cldmabc(i),1.e-5_r8) & - * scavcoef(i,k)*deltat),0._r8) ! Dana and Hales coefficient (/mm) - srcs2(i) = sol_factb*cldmabc(i)*odds(i)*tracer(i,k)*(1._r8-weight(i))*rdeltat & ! liquid - + sol_factbi*cldmabc(i)*odds(i)*tracer(i,k)*(weight(i))*rdeltat !ice - !Note that using the temperature-determined weight doesn't make much sense here - srcc(i) = srcs1(i) + srcs2(i) ! convective tend by both processes - finc(i) = srcs1(i)/(srcc(i) + 1.e-36_r8) ! fraction in-cloud - ! fracp is the fraction of cloud water converted to precip - ! Sungsu modified fracp as the convectiv case. - ! Below new formula by Sungsu of 'fracp' is necessary since 'cwat' is a LWC/IWC - ! that has already precipitated out, that is, 'cwat' does not contain - ! precipitation at all ! - ! fracp = precs(i,k)*deltat/max(cwat(i,k),1.e-12_r8) - fracp(i) = precs(i,k)*deltat/max(cwat(i,k)+precs(i,k)*deltat,1.e-12_r8) ! Sungsu. Mar.19.2010. - fracp(i) = max(0._r8,min(1._r8,fracp(i))) - ! fracp = 0. ! for debug - ! assume the corresponding amnt of tracer is removed - !++mcb -- remove cldc; change cldt to cldv - ! srcs1 = (cldt(i,k)-cldc(i,k))*fracp*tracer(i,k)/deltat - ! srcs1 = cldv(i,k)*fracp*tracer(i,k)/deltat & - ! srcs1 = cldt(i,k)*fracp*tracer(i,k)/deltat ! all condensate - ! Jan.02.2010. Sungsu : cldt --> cldt - cldc below. - srcs1(i) = sol_facti*(cldt(i,k)-cldc(i,k))*fracp(i)*tracer(i,k)*rdeltat*(1._r8-weight(i)) & ! liquid - + sol_factii*(cldt(i,k)-cldc(i,k))*fracp(i)*tracer(i,k)*rdeltat*(weight(i)) ! ice - - odds(i) = precabs(i)/max(cldvst(i,k),1.e-5_r8)*scavcoef(i,k)*deltat - odds(i) = max(min(1._r8,odds(i)),0._r8) - srcs2 = sol_factb*(cldvst(i,k)*odds(i)) *tracer(i,k)*(1._r8-weight(i))*rdeltat & ! liquid - + sol_factbi*(cldvst(i,k)*odds(i)) *tracer(i,k)*(weight(i))*rdeltat ! ice - enddo - end if - - do i=1,ncol - - !Note that using the temperature-determined weight doesn't make much sense here - - srcs(i) = srcs1(i) + srcs2(i) ! total stratiform scavenging - fins(i) = srcs1(i)/(srcs(i) + 1.e-36_r8) ! fraction taken by incloud processes - - ! make sure we dont take out more than is there - ! ratio of amount available to amount removed - rat(i) = tracer(i,k)/max(deltat*(srcc(i)+srcs(i)),1.e-36_r8) - if (rat(i).lt.1._r8) then - srcs(i) = srcs(i)*rat(i) - srcc(i) = srcc(i)*rat(i) - endif - srct(i) = (srcc(i)+srcs(i))*omsm - - - ! fraction that is not removed within the cloud - ! (assumed to be interstitial, and subject to convective transport) - fracp(i) = deltat*srct(i)/max(cldvst(i,k)*tracer(i,k),1.e-36_r8) ! amount removed - fracp(i) = max(0._r8,min(1._r8,fracp(i))) - fracis(i,k) = 1._r8 - fracp(i) - - ! tend is all tracer removed by scavenging, plus all re-appearing from evaporation above - ! Sungsu added cumulus contribution in the below 3 blocks - - scavt(i,k) = -srct(i) + (fracev(i)*scavab(i)+fracev_cu(i)*scavabc(i))*rpdog(i) - iscavt(i,k) = -(srcc(i)*finc(i) + srcs(i)*fins(i))*omsm - - if ( present(icscavt) ) icscavt(i,k) = -(srcc(i)*finc(i)) * omsm - if ( present(isscavt) ) isscavt(i,k) = -(srcs(i)*fins(i)) * omsm - if ( present(bcscavt) ) bcscavt(i,k) = -(srcc(i) * (1-finc(i))) * omsm + & - fracev_cu(i)*scavabc(i)*rpdog(i) - if ( present(bsscavt) ) bsscavt(i,k) = -(srcs(i) * (1-fins(i))) * omsm + & - fracev(i)*scavab(i)*rpdog(i) - - dblchek(i) = tracer(i,k) + deltat*scavt(i,k) - - ! now keep track of scavenged mass and precip - - scavab(i) = scavab(i)*(1-fracev(i)) + srcs(i)*pdog(i) - precabs(i) = precabs(i) + (precs(i,k) - evaps(i,k))*pdog(i) - scavabc(i) = scavabc(i)*(1-fracev_cu(i)) + srcc(i)*pdog(i) - precabc(i) = precabc(i) + (cmfdqr(i,k) - evapc(i,k))*pdog(i) - tracab(i) = tracab(i) + tracer(i,k)*pdog(i) - - - ! Jan.16.2010. Sungsu - ! Compute convective and stratiform precipitation areas at the base interface - ! of current layer. These are for computing 'below cloud scavenging' in the - ! next layer below. - - ! cldovr_cu(i) = max( cldovr_cu(i), cldc(i,k) ) - ! cldovr_st(i) = max( cldovr_st(i), max( 0._r8, cldt(i,k) - cldc(i,k) ) ) - - ! cldovr_cu(i) = max( 0._r8, min ( 1._r8, cldovr_cu(i) ) ) - ! cldovr_st(i) = max( 0._r8, min ( 1._r8, cldovr_st(i) ) ) - - ! End by Sungsu - - end do ! End of i = 1, ncol - - found = .false. - do i = 1,ncol - if ( dblchek(i) < 0._r8 ) then - found = .true. - exit - end if - end do - - if ( found ) then - do i = 1,ncol - if (dblchek(i) .lt. 0._r8) then - write(*,*) ' wetdapa: negative value ', i, k, tracer(i,k), & - dblchek(i), scavt(i,k), srct(i), rat(i), fracev(i) - endif - end do - endif - - end do ! End of k = 1, pver - - - end subroutine wetdepa_v2 - - -!============================================================================== - -! This is the frozen CAM4 version of wetdepa. - - - subroutine wetdepa_v1( t, p, q, pdel, & - cldt, cldc, cmfdqr, conicw, precs, conds, & - evaps, cwat, tracer, deltat, & - scavt, iscavt, cldv, fracis, sol_fact, ncol, & - scavcoef,icscavt, isscavt, bcscavt, bsscavt, & - sol_facti_in, sol_factbi_in, sol_factii_in, & - sol_factic_in, sol_factiic_in ) - - !----------------------------------------------------------------------- - ! Purpose: - ! scavenging code for very soluble aerosols - ! - ! Author: P. Rasch - ! Modified by T. Bond 3/2003 to track different removals - !----------------------------------------------------------------------- - - implicit none - - real(r8), intent(in) ::& - t(pcols,pver), &! temperature - p(pcols,pver), &! pressure - q(pcols,pver), &! moisture - pdel(pcols,pver), &! pressure thikness - cldt(pcols,pver), &! total cloud fraction - cldc(pcols,pver), &! convective cloud fraction - cmfdqr(pcols,pver), &! rate of production of convective precip - conicw(pcols,pver), &! convective cloud water - cwat(pcols,pver), &! cloud water amount - precs(pcols,pver), &! rate of production of stratiform precip - conds(pcols,pver), &! rate of production of condensate - evaps(pcols,pver), &! rate of evaporation of precip - cldv(pcols,pver), &! total cloud fraction - deltat, &! time step - tracer(pcols,pver) ! trace species - ! If subroutine is called with just sol_fact: - ! sol_fact is used for both in- and below-cloud scavenging - ! If subroutine is called with optional argument sol_facti_in: - ! sol_fact is used for below cloud scavenging - ! sol_facti is used for in cloud scavenging - real(r8), intent(in) :: sol_fact ! solubility factor (fraction of aer scavenged below & in, or just below or sol_facti_in is provided) - real(r8), intent(in), optional :: sol_facti_in ! solubility factor (frac of aerosol scavenged in cloud) - real(r8), intent(in), optional :: sol_factbi_in ! solubility factor (frac of aerosol scavenged below cloud by ice) - real(r8), intent(in), optional :: sol_factii_in ! solubility factor (frac of aerosol scavenged in cloud by ice) - real(r8), intent(in), optional :: sol_factic_in(pcols,pver) ! sol_facti_in for convective clouds - real(r8), intent(in), optional :: sol_factiic_in ! sol_factii_in for convective clouds - real(r8), intent(in) :: scavcoef(pcols,pver) ! Dana and Hales coefficient (/mm) (0.1 if not MODAL_AERO) - - integer, intent(in) :: ncol - - real(r8), intent(out) ::& - scavt(pcols,pver), &! scavenging tend - iscavt(pcols,pver), &! incloud scavenging tends - fracis(pcols,pver) ! fraction of species not scavenged - - real(r8), intent(out), optional :: icscavt(pcols,pver) ! incloud, convective - real(r8), intent(out), optional :: isscavt(pcols,pver) ! incloud, stratiform - real(r8), intent(out), optional :: bcscavt(pcols,pver) ! below cloud, convective - real(r8), intent(out), optional :: bsscavt(pcols,pver) ! below cloud, stratiform - - ! local variables - - integer i ! x index - integer k ! z index - - real(r8) adjfac ! factor stolen from cmfmca - real(r8) aqfrac ! fraction of tracer in aqueous phase - real(r8) cwatc ! local convective total water amount - real(r8) cwats ! local stratiform total water amount - real(r8) cwatp ! local water amount falling from above precip - real(r8) fracev(pcols) ! fraction of precip from above that is evaporating - real(r8) fracp ! fraction of cloud water converted to precip - real(r8) gafrac ! fraction of tracer in gas phasea - real(r8) hconst ! henry's law solubility constant when equation is expressed - ! in terms of mixing ratios - real(r8) mpla ! moles / liter H2O entering the layer from above - real(r8) mplb ! moles / liter H2O leaving the layer below - real(r8) omsm ! 1 - (a small number) - real(r8) part ! partial pressure of tracer in atmospheres - real(r8) patm ! total pressure in atmospheres - real(r8) pdog ! work variable (pdel/gravit) - real(r8) precabc(pcols) ! conv precip from above (work array) - real(r8) precabs(pcols) ! strat precip from above (work array) - real(r8) precbl ! precip falling out of level (work array) - real(r8) precmin ! minimum convective precip causing scavenging - real(r8) rat(pcols) ! ratio of amount available to amount removed - real(r8) scavab(pcols) ! scavenged tracer flux from above (work array) - real(r8) scavabc(pcols) ! scavenged tracer flux from above (work array) - real(r8) srcc ! tend for convective rain - real(r8) srcs ! tend for stratiform rain - real(r8) srct(pcols) ! work variable - real(r8) tracab(pcols) ! column integrated tracer amount -! real(r8) vfall ! fall speed of precip - real(r8) fins ! fraction of rem. rate by strat rain - real(r8) finc ! fraction of rem. rate by conv. rain - real(r8) srcs1 ! work variable - real(r8) srcs2 ! work variable - real(r8) tc ! temp in celcius - real(r8) weight ! fraction of condensate which is ice - real(r8) cldmabs(pcols) ! maximum cloud at or above this level - real(r8) cldmabc(pcols) ! maximum cloud at or above this level - real(r8) odds ! limit on removal rate (proportional to prec) - real(r8) dblchek(pcols) - logical :: found - - real(r8) sol_facti, sol_factb ! in cloud and below cloud fraction of aerosol scavenged - real(r8) sol_factii, sol_factbi ! in cloud and below cloud fraction of aerosol scavenged by ice - real(r8) sol_factic(pcols,pver) ! sol_facti for convective clouds - real(r8) sol_factiic ! sol_factii for convective clouds - ! sol_factic & solfact_iic added for MODAL_AERO. - ! For stratiform cloud, cloudborne aerosol is treated explicitly, - ! and sol_facti is 1.0 for cloudborne, 0.0 for interstitial. - ! For convective cloud, cloudborne aerosol is not treated explicitly, - ! and sol_factic is 1.0 for both cloudborne and interstitial. - - ! ------------------------------------------------------------------------ -! omsm = 1.-1.e-10 ! used to prevent roundoff errors below zero - omsm = 1._r8-2*epsilon(1._r8) ! used to prevent roundoff errors below zero - precmin = 0.1_r8/8.64e4_r8 ! set critical value to 0.1 mm/day in kg/m2/s - - adjfac = deltat/(max(deltat,cmftau)) ! adjustment factor from hack scheme - - ! assume 4 m/s fall speed currently (should be improved) -! vfall = 4. - - ! default (if other sol_facts aren't in call, set all to required sol_fact - sol_facti = sol_fact - sol_factb = sol_fact - sol_factii = sol_fact - sol_factbi = sol_fact - - if ( present(sol_facti_in) ) sol_facti = sol_facti_in - if ( present(sol_factii_in) ) sol_factii = sol_factii_in - if ( present(sol_factbi_in) ) sol_factbi = sol_factbi_in - - sol_factic = sol_facti - sol_factiic = sol_factii - if ( present(sol_factic_in ) ) sol_factic = sol_factic_in - if ( present(sol_factiic_in) ) sol_factiic = sol_factiic_in - - ! this section of code is for highly soluble aerosols, - ! the assumption is that within the cloud that - ! all the tracer is in the cloud water - ! - ! for both convective and stratiform clouds, - ! the fraction of cloud water converted to precip defines - ! the amount of tracer which is pulled out. - ! - - - end subroutine wetdepa_v1 - -!============================================================================== - -! wetdepg is currently being used for both CAM4 and CAM5 by making use of the -! cam_physpkg_is method. - - subroutine wetdepg( t, p, q, pdel, & - cldt, cldc, cmfdqr, evapc, precs, evaps, & - rain, cwat, tracer, deltat, molwt, & - solconst, scavt, iscavt, cldv, icwmr1, & - icwmr2, fracis, ncol ) - - !----------------------------------------------------------------------- - ! Purpose: - ! scavenging of gas phase constituents by henry's law - ! - ! Author: P. Rasch - !----------------------------------------------------------------------- - - real(r8), intent(in) ::& - t(pcols,pver), &! temperature - p(pcols,pver), &! pressure - q(pcols,pver), &! moisture - pdel(pcols,pver), &! pressure thikness - cldt(pcols,pver), &! total cloud fraction - cldc(pcols,pver), &! convective cloud fraction - cmfdqr(pcols,pver), &! rate of production of convective precip - rain (pcols,pver), &! total rainwater mixing ratio - cwat(pcols,pver), &! cloud water amount - precs(pcols,pver), &! rate of production of stratiform precip - evaps(pcols,pver), &! rate of evaporation of precip -! Sungsu - evapc(pcols,pver), &! Rate of evaporation of convective precipitation -! Sungsu - cldv(pcols,pver), &! estimate of local volume occupied by clouds - icwmr1 (pcols,pver), &! in cloud water mixing ration for zhang scheme - icwmr2 (pcols,pver), &! in cloud water mixing ration for hack scheme - deltat, &! time step - tracer(pcols,pver), &! trace species - molwt ! molecular weights - - integer, intent(in) :: ncol - - real(r8) & - solconst(pcols,pver) ! Henry's law coefficient - - real(r8), intent(out) ::& - scavt(pcols,pver), &! scavenging tend - iscavt(pcols,pver), &! incloud scavenging tends - fracis(pcols, pver) ! fraction of constituent that is insoluble - - ! local variables - - integer i ! x index - integer k ! z index - - real(r8) adjfac ! factor stolen from cmfmca - real(r8) aqfrac ! fraction of tracer in aqueous phase - real(r8) cwatc ! local convective total water amount - real(r8) cwats ! local stratiform total water amount - real(r8) cwatl ! local cloud liq water amount - real(r8) cwatp ! local water amount falling from above precip - real(r8) cwatpl ! local water amount falling from above precip (liq) - real(r8) cwatt ! local sum of strat + conv total water amount - real(r8) cwatti ! cwatt/cldv = cloudy grid volume mixing ratio - real(r8) fracev ! fraction of precip from above that is evaporating - real(r8) fracp ! fraction of cloud water converted to precip - real(r8) gafrac ! fraction of tracer in gas phasea - real(r8) hconst ! henry's law solubility constant when equation is expressed - ! in terms of mixing ratios - real(r8) mpla ! moles / liter H2O entering the layer from above - real(r8) mplb ! moles / liter H2O leaving the layer below - real(r8) omsm ! 1 - (a small number) - real(r8) part ! partial pressure of tracer in atmospheres - real(r8) patm ! total pressure in atmospheres - real(r8) pdog ! work variable (pdel/gravit) - real(r8) precab(pcols) ! precip from above (work array) - real(r8) precbl ! precip work variable - real(r8) precxx ! precip work variable - real(r8) precxx2 ! - real(r8) precic ! precip work variable - real(r8) rat ! ratio of amount available to amount removed - real(r8) scavab(pcols) ! scavenged tracer flux from above (work array) - real(r8) scavabc(pcols) ! scavenged tracer flux from above (work array) - ! real(r8) vfall ! fall speed of precip - real(r8) scavmax ! an estimate of the max tracer avail for removal - real(r8) scavbl ! flux removed at bottom of layer - real(r8) fins ! in cloud fraction removed by strat rain - real(r8) finc ! in cloud fraction removed by conv rain - real(r8) rate ! max removal rate estimate - real(r8) scavlimt ! limiting value 1 - real(r8) scavt1 ! limiting value 2 - real(r8) scavin ! scavenging by incloud processes - real(r8) scavbc ! scavenging by below cloud processes - real(r8) tc - real(r8) weight ! ice fraction - real(r8) wtpl ! work variable - real(r8) cldmabs(pcols) ! maximum cloud at or above this level - real(r8) cldmabc(pcols) ! maximum cloud at or above this level - !----------------------------------------------------------- - - omsm = 1._r8-2*epsilon(1._r8) ! used to prevent roundoff errors below zero - - adjfac = deltat/(max(deltat,cmftau)) ! adjustment factor from hack scheme - - ! assume 4 m/s fall speed currently (should be improved) - ! vfall = 4. - - ! zero accumulators - do i = 1,pcols - precab(i) = 1.e-36_r8 - scavab(i) = 0._r8 - cldmabs(i) = 0._r8 - end do - - do k = 1,pver - do i = 1,ncol - - tc = t(i,k) - tmelt - weight = max(0._r8,min(-tc*0.05_r8,1.0_r8)) ! fraction of condensate that is ice - - cldmabs(i) = max(cldmabs(i),cldt(i,k)) - - ! partitioning coefs for gas and aqueous phase - ! take as a cloud water amount, the sum of the stratiform amount - ! plus the convective rain water amount - - ! convective amnt is just the local precip rate from the hack scheme - ! since there is no storage of water, this ignores that falling from above - ! cwatc = cmfdqr(i,k)*deltat/adjfac - !++mcb -- test cwatc - cwatc = (icwmr1(i,k) + icwmr2(i,k)) * (1._r8-weight) - !--mcb - - ! strat cloud water amount and also ignore the part falling from above - cwats = cwat(i,k) - - ! cloud water as liq - !++mcb -- add cwatc later (in cwatti) - ! cwatl = (1.-weight)*(cwatc+cwats) - cwatl = (1._r8-weight)*cwats - ! cloud water as ice - !*not used cwati = weight*(cwatc+cwats) - - ! total suspended condensate as liquid - cwatt = cwatl + rain(i,k) - - ! incloud version - !++mcb -- add cwatc here - cwatti = cwatt/max(cldv(i,k), 0.00001_r8) + cwatc - - ! partitioning terms - patm = p(i,k)/1.013e5_r8 ! pressure in atmospheres - hconst = molwta*patm*solconst(i,k)*cwatti/rhoh2o - aqfrac = hconst/(1._r8+hconst) - gafrac = 1/(1._r8+hconst) - fracis(i,k) = gafrac - - - ! partial pressure of the tracer in the gridbox in atmospheres - part = patm*gafrac*tracer(i,k)*molwta/molwt - - ! use henrys law to give moles tracer /liter of water - ! in this volume - ! then convert to kg tracer /liter of water (kg tracer / kg water) - mplb = solconst(i,k)*part*molwt/1000._r8 - - - pdog = pdel(i,k)/gravit - - ! this part of precip will be carried downward but at a new molarity of mpl - precic = pdog*(precs(i,k) + cmfdqr(i,k)) - - ! we cant take out more than entered, plus that available in the cloud - ! scavmax = scavab(i)+tracer(i,k)*cldt(i,k)/deltat*pdog - scavmax = scavab(i)+tracer(i,k)*cldv(i,k)/deltat*pdog - - ! flux of tracer by incloud processes - scavin = precic*(1._r8-weight)*mplb - - ! fraction of precip which entered above that leaves below - if (.TRUE.) then - ! Sungsu added evaporation of convective precipitation below. - precxx = precab(i)-pdog*(evaps(i,k)+evapc(i,k)) - else - precxx = precab(i)-pdog*evaps(i,k) - end if - precxx = max (precxx,0.0_r8) - - ! flux of tracer by below cloud processes - !++mcb -- removed wtpl because it is now not assigned and previously - ! when it was assigned it was unnecessary: if(tc.gt.0)wtpl=1 - if (tc.gt.0) then - ! scavbc = precxx*wtpl*mplb ! if liquid - scavbc = precxx*mplb ! if liquid - else - precxx2=max(precxx,1.e-36_r8) - scavbc = scavab(i)*precxx2/(precab(i)) ! if ice - endif - - scavbl = min(scavbc + scavin, scavmax) - - ! first guess assuming that henries law works - scavt1 = (scavab(i)-scavbl)/pdog*omsm - - ! pjr this should not be required, but we put it in to make sure we cant remove too much - ! remember, scavt1 is generally negative (indicating removal) - scavt1 = max(scavt1,-tracer(i,k)*cldv(i,k)/deltat) - - !++mcb -- remove this limitation for gas species - !c use the dana and hales or balkanski limit on scavenging - !c rate = precab(i)*0.1 - ! rate = (precic + precxx)*0.1 - ! scavlimt = -tracer(i,k)*cldv(i,k) - ! $ *rate/(1.+rate*deltat) - - ! scavt(i,k) = max(scavt1, scavlimt) - - ! instead just set scavt to scavt1 - scavt(i,k) = scavt1 - !--mcb - - ! now update the amount leaving the layer - scavbl = scavab(i) - scavt(i,k)*pdog - - ! in cloud amount is that formed locally over the total flux out bottom - fins = scavin/(scavin + scavbc + 1.e-36_r8) - iscavt(i,k) = scavt(i,k)*fins - - scavab(i) = scavbl - precab(i) = max(precxx + precic,1.e-36_r8) - - - - end do - end do - - end subroutine wetdepg - -!############################################################################## - -end module wetdep diff --git a/test/ncar_kernels/CAM5_wetdepa/src/wetdep.f90 b/test/ncar_kernels/CAM5_wetdepa/src/wetdep.f90 deleted file mode 100644 index 475453c745..0000000000 --- a/test/ncar_kernels/CAM5_wetdepa/src/wetdep.f90 +++ /dev/null @@ -1,1009 +0,0 @@ -!#define GENERATE_DRIVER - - - - -module wetdep - -!----------------------------------------------------------------------- -! -! Wet deposition routines for both aerosols and gas phase constituents. -! -!----------------------------------------------------------------------- - - - -use kinds_mod -use params, only: pcols, pver, gravit, rair, tmelt - - - - - - - -implicit none -save -private - -public :: wetdepa_v1 ! scavenging codes for very soluble aerosols -- CAM4 version -public :: wetdepa_v2 ! scavenging codes for very soluble aerosols -- CAM5 version -public :: wetdepg ! scavenging of gas phase constituents by henry's law -public :: clddiag ! calc of cloudy volume and rain mixing ratio - -real(r8), parameter :: cmftau = 3600._r8 -real(r8), parameter :: rhoh2o = 1000._r8 ! density of water -real(r8), parameter :: molwta = 28.97_r8 ! molecular weight dry air gm/mole - -!============================================================================== -contains -!============================================================================== - -subroutine clddiag(t, pmid, pdel, cmfdqr, evapc, & - cldt, cldcu, cldst, cme, evapr, & - prain, cldv, cldvcu, cldvst, rain, & - ncol) - - ! ------------------------------------------------------------------------------------ - ! Estimate the cloudy volume which is occupied by rain or cloud water as - ! the max between the local cloud amount or the - ! sum above of (cloud*positive precip production) sum total precip from above - ! ---------------------------------- x ------------------------ - ! sum above of (positive precip ) sum positive precip from above - ! Author: P. Rasch - ! Sungsu Park. Mar.2010 - ! ------------------------------------------------------------------------------------ - - ! Input arguments: - real(r8), intent(in) :: t(pcols,pver) ! temperature (K) - real(r8), intent(in) :: pmid(pcols,pver) ! pressure at layer midpoints - real(r8), intent(in) :: pdel(pcols,pver) ! pressure difference across layers - real(r8), intent(in) :: cmfdqr(pcols,pver) ! dq/dt due to convective rainout - real(r8), intent(in) :: evapc(pcols,pver) ! Evaporation rate of convective precipitation ( >= 0 ) - real(r8), intent(in) :: cldt(pcols,pver) ! total cloud fraction - real(r8), intent(in) :: cldcu(pcols,pver) ! Cumulus cloud fraction - real(r8), intent(in) :: cldst(pcols,pver) ! Stratus cloud fraction - real(r8), intent(in) :: cme(pcols,pver) ! rate of cond-evap within the cloud - real(r8), intent(in) :: evapr(pcols,pver) ! rate of evaporation of falling precipitation (kg/kg/s) - real(r8), intent(in) :: prain(pcols,pver) ! rate of conversion of condensate to precipitation (kg/kg/s) - integer, intent(in) :: ncol - - ! Output arguments: - real(r8), intent(out) :: cldv(pcols,pver) ! fraction occupied by rain or cloud water - real(r8), intent(out) :: cldvcu(pcols,pver) ! Convective precipitation volume - real(r8), intent(out) :: cldvst(pcols,pver) ! Stratiform precipitation volume - real(r8), intent(out) :: rain(pcols,pver) ! mixing ratio of rain (kg/kg) - - ! Local variables: - integer i, k - real(r8) convfw ! used in fallspeed calculation; taken from findmcnew - real(r8) sumppr(pcols) ! precipitation rate (kg/m2-s) - real(r8) sumpppr(pcols) ! sum of positive precips from above - real(r8) cldv1(pcols) ! precip weighted cloud fraction from above - real(r8) lprec ! local production rate of precip (kg/m2/s) - real(r8) lprecp ! local production rate of precip (kg/m2/s) if positive - real(r8) rho ! air density - real(r8) vfall - real(r8) sumppr_cu(pcols) ! Convective precipitation rate (kg/m2-s) - real(r8) sumpppr_cu(pcols) ! Sum of positive convective precips from above - real(r8) cldv1_cu(pcols) ! Convective precip weighted convective cloud fraction from above - real(r8) lprec_cu ! Local production rate of convective precip (kg/m2/s) - real(r8) lprecp_cu ! Local production rate of convective precip (kg/m2/s) if positive - real(r8) sumppr_st(pcols) ! Stratiform precipitation rate (kg/m2-s) - real(r8) sumpppr_st(pcols) ! Sum of positive stratiform precips from above - real(r8) cldv1_st(pcols) ! Stratiform precip weighted stratiform cloud fraction from above - real(r8) lprec_st ! Local production rate of stratiform precip (kg/m2/s) - real(r8) lprecp_st ! Local production rate of stratiform precip (kg/m2/s) if positive - ! ----------------------------------------------------------------------- - - convfw = 1.94_r8*2.13_r8*sqrt(rhoh2o*gravit*2.7e-4_r8) - do i=1,ncol - sumppr(i) = 0._r8 - cldv1(i) = 0._r8 - sumpppr(i) = 1.e-36_r8 - sumppr_cu(i) = 0._r8 - cldv1_cu(i) = 0._r8 - sumpppr_cu(i) = 1.e-36_r8 - sumppr_st(i) = 0._r8 - cldv1_st(i) = 0._r8 - sumpppr_st(i) = 1.e-36_r8 - end do - - do k = 1,pver - do i = 1,ncol - cldv(i,k) = & - max(min(1._r8, & - cldv1(i)/sumpppr(i) & - )*sumppr(i)/sumpppr(i), & - cldt(i,k) & - ) - lprec = pdel(i,k)/gravit & - *(prain(i,k)+cmfdqr(i,k)-evapr(i,k)) - lprecp = max(lprec,1.e-30_r8) - cldv1(i) = cldv1(i) + cldt(i,k)*lprecp - sumppr(i) = sumppr(i) + lprec - sumpppr(i) = sumpppr(i) + lprecp - - ! For convective precipitation volume at the top interface of each layer. Neglect the current layer. - cldvcu(i,k) = max(min(1._r8,cldv1_cu(i)/sumpppr_cu(i))*(sumppr_cu(i)/sumpppr_cu(i)),0._r8) - lprec_cu = (pdel(i,k)/gravit)*(cmfdqr(i,k)-evapc(i,k)) - lprecp_cu = max(lprec_cu,1.e-30_r8) - cldv1_cu(i) = cldv1_cu(i) + cldcu(i,k)*lprecp_cu - sumppr_cu(i) = sumppr_cu(i) + lprec_cu - sumpppr_cu(i) = sumpppr_cu(i) + lprecp_cu - - ! For stratiform precipitation volume at the top interface of each layer. Neglect the current layer. - cldvst(i,k) = max(min(1._r8,cldv1_st(i)/sumpppr_st(i))*(sumppr_st(i)/sumpppr_st(i)),0._r8) - lprec_st = (pdel(i,k)/gravit)*(prain(i,k)-evapr(i,k)) - lprecp_st = max(lprec_st,1.e-30_r8) - cldv1_st(i) = cldv1_st(i) + cldst(i,k)*lprecp_st - sumppr_st(i) = sumppr_st(i) + lprec_st - sumpppr_st(i) = sumpppr_st(i) + lprecp_st - - rain(i,k) = 0._r8 - if(t(i,k) .gt. tmelt) then - rho = pmid(i,k)/(rair*t(i,k)) - vfall = convfw/sqrt(rho) - rain(i,k) = sumppr(i)/(rho*vfall) - if (rain(i,k).lt.1.e-14_r8) rain(i,k) = 0._r8 - endif - end do - end do - -end subroutine clddiag - -!============================================================================== - -! This is the CAM5 version of wetdepa. - -subroutine wetdepa_v2(t, p, q, pdel, & - cldt, cldc, cmfdqr, evapc, conicw, precs, conds, & - evaps, cwat, tracer, deltat, & - scavt, iscavt, cldv, cldvcu, cldvst, dlf, fracis, sol_fact, ncol, & - scavcoef, is_strat_cloudborne, rate1ord_cw2pr_st, qqcw, f_act_conv, & - icscavt, isscavt, bcscavt, bsscavt, & - sol_facti_in, sol_factbi_in, sol_factii_in, & - sol_factic_in, sol_factiic_in ) - - !----------------------------------------------------------------------- - ! Purpose: - ! scavenging code for very soluble aerosols - ! - ! Author: P. Rasch - ! Modified by T. Bond 3/2003 to track different removals - ! Sungsu Park. Mar.2010 : Impose consistencies with a few changes in physics. - !----------------------------------------------------------------------- - - - - implicit none - - real(r8), intent(in) ::& - t(pcols,pver), &! temperature - p(pcols,pver), &! pressure - q(pcols,pver), &! moisture - pdel(pcols,pver), &! pressure thikness - cldt(pcols,pver), &! total cloud fraction - cldc(pcols,pver), &! convective cloud fraction - cmfdqr(pcols,pver), &! rate of production of convective precip -! Sungsu - evapc(pcols,pver), &! Evaporation rate of convective precipitation -! Sungsu - conicw(pcols,pver), &! convective cloud water - cwat(pcols,pver), &! cloud water amount - precs(pcols,pver), &! rate of production of stratiform precip - conds(pcols,pver), &! rate of production of condensate - evaps(pcols,pver), &! rate of evaporation of precip - cldv(pcols,pver), &! total cloud fraction -! Sungsu - cldvcu(pcols,pver), &! Convective precipitation area at the top interface of each layer - cldvst(pcols,pver), &! Stratiform precipitation area at the top interface of each layer - dlf(pcols,pver), &! Detrainment of convective condensate [kg/kg/s] -! Sungsu - deltat, &! time step - tracer(pcols,pver) ! trace species - - ! If subroutine is called with just sol_fact: - ! sol_fact is used for both in- and below-cloud scavenging - ! If subroutine is called with optional argument sol_facti_in: - ! sol_fact is used for below cloud scavenging - ! sol_facti is used for in cloud scavenging - real(r8), intent(in) :: sol_fact ! solubility factor (fraction of aer scavenged below & in, or just below or sol_facti_in is provided) - integer, intent(in) :: ncol - real(r8), intent(in) :: scavcoef(pcols,pver) ! Dana and Hales coefficient (/mm) (0.1 if not MODAL_AERO) - real(r8), intent(out) ::& - scavt(pcols,pver), &! scavenging tend - iscavt(pcols,pver), &! incloud scavenging tends - fracis(pcols,pver) ! fraction of species not scavenged - ! rce 2010/05/01 - ! is_strat_cloudborne = .true. if tracer is stratiform-cloudborne aerosol; else .false. - logical, intent(in), optional :: is_strat_cloudborne - ! rate1ord_cw2pr_st = 1st order rate for strat cw to precip (1/s) - real(r8), intent(in), optional :: rate1ord_cw2pr_st(pcols,pver) - ! qqcw = strat-cloudborne aerosol corresponding to tracer when is_strat_cloudborne==.false.; else 0.0 - real(r8), intent(in), optional :: qqcw(pcols,pver) - ! f_act_conv = conv-cloud activation fraction when is_strat_cloudborne==.false.; else 0.0 - real(r8), intent(in), optional :: f_act_conv(pcols,pver) - ! end rce 2010/05/01 - - real(r8), intent(in), optional :: sol_facti_in ! solubility factor (frac of aerosol scavenged in cloud) - real(r8), intent(in), optional :: sol_factbi_in ! solubility factor (frac of aerosol scavenged below cloud by ice) - real(r8), intent(in), optional :: sol_factii_in ! solubility factor (frac of aerosol scavenged in cloud by ice) - real(r8), intent(in), optional :: sol_factic_in(pcols,pver) ! sol_facti_in for convective clouds - real(r8), intent(in), optional :: sol_factiic_in ! sol_factii_in for convective clouds - - - real(r8), intent(out), optional :: icscavt(pcols,pver) ! incloud, convective - real(r8), intent(out), optional :: isscavt(pcols,pver) ! incloud, stratiform - real(r8), intent(out), optional :: bcscavt(pcols,pver) ! below cloud, convective - real(r8), intent(out), optional :: bsscavt(pcols,pver) ! below cloud, stratiform - - - - ! local variables - - integer i ! x index - integer k ! z index - - real(r8) adjfac ! factor stolen from cmfmca - real(r8) aqfrac ! fraction of tracer in aqueous phase - real(r8) cwatc ! local convective total water amount - real(r8) cwats ! local stratiform total water amount - real(r8) cwatp ! local water amount falling from above precip - real(r8) fracev(pcols) ! fraction of precip from above that is evaporating -! Sungsu - real(r8) fracev_cu(pcols) ! Fraction of convective precip from above that is evaporating -! Sungsu - real(r8) fracp(pcols) ! fraction of cloud water converted to precip - real(r8) gafrac ! fraction of tracer in gas phasea - real(r8) hconst ! henry's law solubility constant when equation is expressed - ! in terms of mixing ratios - real(r8) mpla ! moles / liter H2O entering the layer from above - real(r8) mplb ! moles / liter H2O leaving the layer below - real(r8) omsm ! 1 - (a small number) - real(r8) part ! partial pressure of tracer in atmospheres - real(r8) patm ! total pressure in atmospheres - real(r8) pdog(pcols) ! work variable (pdel/gravit) - real(r8) rpdog(pcols) ! work variable (gravit/pdel) - real(r8) precabc(pcols) ! conv precip from above (work array) - real(r8) precabs(pcols) ! strat precip from above (work array) - real(r8) precbl ! precip falling out of level (work array) - real(r8) precmin ! minimum convective precip causing scavenging - real(r8) rat(pcols) ! ratio of amount available to amount removed - real(r8) scavab(pcols) ! scavenged tracer flux from above (work array) - real(r8) scavabc(pcols) ! scavenged tracer flux from above (work array) - real(r8) srcc(pcols) ! tend for convective rain - real(r8) srcs(pcols) ! tend for stratiform rain - real(r8) srct(pcols) ! work variable - real(r8) tracab(pcols) ! column integrated tracer amount -! real(r8) vfall ! fall speed of precip - real(r8) fins(pcols) ! fraction of rem. rate by strat rain - real(r8) finc(pcols) ! fraction of rem. rate by conv. rain - real(r8) srcs1(pcols) ! work variable - real(r8) srcs2(pcols) ! work variable - real(r8) tc(pcols) ! temp in celcius - real(r8) weight(pcols) ! fraction of condensate which is ice - real(r8) cldmabs(pcols) ! maximum cloud at or above this level - real(r8) cldmabc(pcols) ! maximum cloud at or above this level - real(r8) odds(pcols) ! limit on removal rate (proportional to prec) - real(r8) dblchek(pcols) - logical :: found - - ! Jan.16.2009. Sungsu for wet scavenging below clouds. - ! real(r8) cldovr_cu(pcols) ! Convective precipitation area at the base of each layer - ! real(r8) cldovr_st(pcols) ! Stratiform precipitation area at the base of each layer - - real(r8) tracer_incu(pcols) - real(r8) tracer_mean(pcols) - - ! End by Sungsu - - real(r8) sol_facti, sol_factb ! in cloud and below cloud fraction of aerosol scavenged - real(r8) sol_factii, sol_factbi ! in cloud and below cloud fraction of aerosol scavenged by ice - real(r8) sol_factic(pcols,pver) ! sol_facti for convective clouds - real(r8) sol_factiic ! sol_factii for convective clouds - ! sol_factic & solfact_iic added for MODAL_AERO. - ! For stratiform cloud, cloudborne aerosol is treated explicitly, - ! and sol_facti is 1.0 for cloudborne, 0.0 for interstitial. - ! For convective cloud, cloudborne aerosol is not treated explicitly, - ! and sol_factic is 1.0 for both cloudborne and interstitial. - real(r8) :: rdeltat - - - - ! ------------------------------------------------------------------------ -! omsm = 1.-1.e-10 ! used to prevent roundoff errors below zero - omsm = 1._r8-2*epsilon(1._r8) ! used to prevent roundoff errors below zero - precmin = 0.1_r8/8.64e4_r8 ! set critical value to 0.1 mm/day in kg/m2/s - - adjfac = deltat/(max(deltat,cmftau)) ! adjustment factor from hack scheme - - ! assume 4 m/s fall speed currently (should be improved) -! vfall = 4. - - ! default (if other sol_facts aren't in call, set all to required sol_fact - sol_facti = sol_fact - sol_factb = sol_fact - sol_factii = sol_fact - sol_factbi = sol_fact - - if ( present(sol_facti_in) ) sol_facti = sol_facti_in - if ( present(sol_factii_in) ) sol_factii = sol_factii_in - if ( present(sol_factbi_in) ) sol_factbi = sol_factbi_in - - sol_factic = sol_facti - sol_factiic = sol_factii - if ( present(sol_factic_in ) ) sol_factic = sol_factic_in - if ( present(sol_factiic_in) ) sol_factiic = sol_factiic_in - - ! this section of code is for highly soluble aerosols, - ! the assumption is that within the cloud that - ! all the tracer is in the cloud water - ! - ! for both convective and stratiform clouds, - ! the fraction of cloud water converted to precip defines - ! the amount of tracer which is pulled out. - ! - - do i = 1,pcols - precabs(i) = 0 - precabc(i) = 0 - scavab(i) = 0 - scavabc(i) = 0 - tracab(i) = 0 - cldmabs(i) = 0 - cldmabc(i) = 0 - - ! Jan.16. Sungsu - ! I added below to compute vertically projected cumulus and stratus fractions from the top to the - ! current model layer by assuming a simple independent maximum overlapping assumption for - ! each cloud. - ! cldovr_cu(i) = 0._r8 - ! cldovr_st(i) = 0._r8 - ! End by Sungsu - - end do - - do k = 1,pver - do i = 1,ncol - tc(i) = t(i,k) - tmelt - weight(i) = max(0._r8,min(-tc(i)*0.05_r8,1.0_r8)) ! fraction of condensate that is ice - weight(i) = 0._r8 ! assume no ice - - pdog(i) = pdel(i,k)/gravit - rpdog(i) = gravit/pdel(i,k) - rdeltat = 1.0_r8/deltat - - ! ****************** Evaporation ************************** - ! calculate the fraction of strat precip from above - ! which evaporates within this layer - fracev(i) = evaps(i,k)*pdog(i) & - /max(1.e-12_r8,precabs(i)) - - ! trap to ensure reasonable ratio bounds - fracev(i) = max(0._r8,min(1._r8,fracev(i))) - -! Sungsu : Same as above but convective precipitation part - fracev_cu(i) = evapc(i,k)*pdog(i)/max(1.e-12_r8,precabc(i)) - fracev_cu(i) = max(0._r8,min(1._r8,fracev_cu(i))) -! Sungsu - ! ****************** Convection *************************** - ! now do the convective scavenging - - ! set odds proportional to fraction of the grid box that is swept by the - ! precipitation =precabc/rhoh20*(area of sphere projected on plane - ! /volume of sphere)*deltat - ! assume the radius of a raindrop is 1 e-3 m from Rogers and Yau, - ! unless the fraction of the area that is cloud is less than odds, in which - ! case use the cloud fraction (assumes precabs is in kg/m2/s) - ! is really: precabs*3/4/1000./1e-3*deltat - ! here I use .1 from Balkanski - ! - ! use a local rate of convective rain production for incloud scav - !odds=max(min(1._r8, & - ! cmfdqr(i,k)*pdel(i,k)/gravit*0.1_r8*deltat),0._r8) - !++mcb -- change cldc to cldt; change cldt to cldv (9/17/96) - ! srcs1 = cldt(i,k)*odds*tracer(i,k)*(1.-weight) & - ! srcs1 = cldv(i,k)*odds*tracer(i,k)*(1.-weight) & - !srcs1 = cldc(i,k)*odds*tracer(i,k)*(1.-weight) & - ! /deltat - - ! fraction of convective cloud water converted to rain - ! Dec.29.2009 : Sungsu multiplied cldc(i,k) to conicw(i,k) below - ! fracp = cmfdqr(i,k)*deltat/max(1.e-8_r8,conicw(i,k)) - ! fracp = cmfdqr(i,k)*deltat/max(1.e-8_r8,cldc(i,k)*conicw(i,k)) - ! Sungsu: Below new formula of 'fracp' is necessary since 'conicw' is a LWC/IWC - ! that has already precipitated out, that is, 'conicw' does not contain - ! precipitation at all ! - fracp(i) = cmfdqr(i,k)*deltat/max(1.e-12_r8,cldc(i,k)*conicw(i,k)+(cmfdqr(i,k)+dlf(i,k))*deltat) ! Sungsu.Mar.19.2010. - ! Dec.29.2009 - ! Note cmfdrq can be negative from evap of rain, so constrain it <-- This is wrong. cmfdqr does not - ! contain evaporation of precipitation. - fracp(i) = max(min(1._r8,fracp(i)),0._r8) - - !--mcb - ! scavenge below cloud - ! cldmabc(i) = max(cldc(i,k),cldmabc(i)) - ! cldmabc(i) = max(cldt(i,k),cldmabc(i)) - ! cldmabc(i) = max(cldv(i,k),cldmabc(i)) - ! cldmabc(i) = cldv(i,k) - cldmabc(i) = cldvcu(i,k) - - ! Jan. 16. 2010. Sungsu - ! cldmabc(i) = cldmabc(i) * cldovr_cu(i) / max( 0.01_r8, cldovr_cu(i) + cldovr_st(i) ) - ! End by Sungsu - - enddo - ! remove that amount from within the convective area -! srcs1 = cldc(i,k)*fracp*tracer(i,k)*(1._r8-weight)/deltat ! liquid only -! srcs1 = cldc(i,k)*fracp*tracer(i,k)/deltat ! any condensation -! srcs1 = 0. -! Jan.02.2010. Sungsu : cldt --> cldc below. - ! rce 2010/05/01 - if (present(is_strat_cloudborne)) then ! Tianyi, 2011/03/29 - if ( is_strat_cloudborne ) then - do i=1,ncol - ! only strat in-cloud removal affects strat-cloudborne aerosol - srcs1(i) = 0._r8 - ! only strat in-cloud removal affects strat-cloudborne aerosol - srcs2(i) = 0._r8 - !Note that using the temperature-determined weight doesn't make much sense here - srcc(i) = srcs1(i) + srcs2(i) ! convective tend by both processes - finc(i) = srcs1(i)/(srcc(i) + 1.e-36_r8) ! fraction in-cloud - ! new code for stratiform incloud scav of cloudborne (modal) aerosol - ! >> use the 1st order cw to precip rate calculated in microphysics routine - ! >> cloudborne aerosol resides in cloudy portion of grid cell, so do not apply "cldt" factor - ! fracp = rate1ord_cw2pr_st(i,k)*deltat - ! fracp = max(0._r8,min(1._r8,fracp)) - fracp(i) = precs(i,k)*deltat/max(cwat(i,k)+precs(i,k)*deltat,1.e-12_r8) ! Sungsu. Mar.19.2010. - fracp(i) = max(0._r8,min(1._r8,fracp(i))) - srcs1(i) = sol_facti *fracp(i)*tracer(i,k)*rdeltat*(1._r8-weight(i)) & ! Liquid - + sol_factii*fracp(i)*tracer(i,k)*rdeltat*(weight(i)) ! Ice - ! only strat in-cloud removal affects strat-cloudborne aerosol - srcs2(i) = 0._r8 - enddo - else - do i=1,ncol - tracer_incu(i) = f_act_conv(i,k)*(tracer(i,k)+& - min(qqcw(i,k),tracer(i,k)*((cldt(i,k)-cldc(i,k))/max(0.01_r8,(1._r8-(cldt(i,k)-cldc(i,k))))))) - srcs1(i) = sol_factic(i,k)*cldc(i,k)*fracp(i)*tracer_incu(i)*(1._r8-weight(i))*rdeltat & ! Liquid - + sol_factiic *cldc(i,k)*fracp(i)*tracer_incu(i)*(weight(i))*rdeltat ! Ice - - tracer_mean(i) = tracer(i,k)*(1._r8-cldc(i,k)*f_act_conv(i,k))-cldc(i,k)*f_act_conv(i,k)*& - min(qqcw(i,k),tracer(i,k)*((cldt(i,k)-cldc(i,k))/max(0.01_r8,(1._r8-(cldt(i,k)-cldc(i,k)))))) - tracer_mean(i) = max(0._r8,tracer_mean(i)) - odds(i) = max(min(1._r8,precabc(i)/max(cldmabc(i),1.e-5_r8)*scavcoef(i,k)*deltat),0._r8) ! Dana and Hales coefficient (/mm) - - srcs2(i) = sol_factb *cldmabc(i)*odds(i)*tracer_mean(i)*(1._r8-weight(i))*rdeltat & ! Liquid - + sol_factbi*cldmabc(i)*odds(i)*tracer_mean(i)*(weight(i))*rdeltat ! Ice - !Note that using the temperature-determined weight doesn't make much sense here - srcc(i) = srcs1(i) + srcs2(i) ! convective tend by both processes - finc(i) = srcs1(i)/(srcc(i) + 1.e-36_r8) ! fraction in-cloud - ! strat in-cloud removal only affects strat-cloudborne aerosol - srcs1(i) = 0._r8 - odds(i) = precabs(i)/max(cldvst(i,k),1.e-5_r8)*scavcoef(i,k)*deltat - odds(i) = max(min(1._r8,odds(i)),0._r8) - - srcs2(i) = sol_factb *cldvst(i,k)*odds(i)*tracer_mean(i)*(1._r8-weight(i))*rdeltat & ! Liquid - + sol_factbi*cldvst(i,k)*odds(i)*tracer_mean(i)*(weight(i))*rdeltat ! Ice - enddo - end if - else - do i=1,ncol - srcs1(i) = sol_factic(i,k)*cldc(i,k)*fracp(i)*tracer(i,k)*(1._r8-weight(i))*rdeltat & ! liquid - + sol_factiic*cldc(i,k)*fracp(i)*tracer(i,k)*(weight(i))*rdeltat ! ice - odds(i) = max( & - min(1._r8,precabc(i)/max(cldmabc(i),1.e-5_r8) & - * scavcoef(i,k)*deltat),0._r8) ! Dana and Hales coefficient (/mm) - srcs2(i) = sol_factb*cldmabc(i)*odds(i)*tracer(i,k)*(1._r8-weight(i))*rdeltat & ! liquid - + sol_factbi*cldmabc(i)*odds(i)*tracer(i,k)*(weight(i))*rdeltat !ice - !Note that using the temperature-determined weight doesn't make much sense here - srcc(i) = srcs1(i) + srcs2(i) ! convective tend by both processes - finc(i) = srcs1(i)/(srcc(i) + 1.e-36_r8) ! fraction in-cloud - ! fracp is the fraction of cloud water converted to precip - ! Sungsu modified fracp as the convectiv case. - ! Below new formula by Sungsu of 'fracp' is necessary since 'cwat' is a LWC/IWC - ! that has already precipitated out, that is, 'cwat' does not contain - ! precipitation at all ! - ! fracp = precs(i,k)*deltat/max(cwat(i,k),1.e-12_r8) - fracp(i) = precs(i,k)*deltat/max(cwat(i,k)+precs(i,k)*deltat,1.e-12_r8) ! Sungsu. Mar.19.2010. - fracp(i) = max(0._r8,min(1._r8,fracp(i))) - ! fracp = 0. ! for debug - ! assume the corresponding amnt of tracer is removed - !++mcb -- remove cldc; change cldt to cldv - ! srcs1 = (cldt(i,k)-cldc(i,k))*fracp*tracer(i,k)/deltat - ! srcs1 = cldv(i,k)*fracp*tracer(i,k)/deltat & - ! srcs1 = cldt(i,k)*fracp*tracer(i,k)/deltat ! all condensate - ! Jan.02.2010. Sungsu : cldt --> cldt - cldc below. - srcs1(i) = sol_facti*(cldt(i,k)-cldc(i,k))*fracp(i)*tracer(i,k)*rdeltat*(1._r8-weight(i)) & ! liquid - + sol_factii*(cldt(i,k)-cldc(i,k))*fracp(i)*tracer(i,k)*rdeltat*(weight(i)) ! ice - - odds(i) = precabs(i)/max(cldvst(i,k),1.e-5_r8)*scavcoef(i,k)*deltat - odds(i) = max(min(1._r8,odds(i)),0._r8) - srcs2 = sol_factb*(cldvst(i,k)*odds(i)) *tracer(i,k)*(1._r8-weight(i))*rdeltat & ! liquid - + sol_factbi*(cldvst(i,k)*odds(i)) *tracer(i,k)*(weight(i))*rdeltat ! ice - enddo - end if - - do i=1,ncol - - !Note that using the temperature-determined weight doesn't make much sense here - - srcs(i) = srcs1(i) + srcs2(i) ! total stratiform scavenging - fins(i) = srcs1(i)/(srcs(i) + 1.e-36_r8) ! fraction taken by incloud processes - - ! make sure we dont take out more than is there - ! ratio of amount available to amount removed - rat(i) = tracer(i,k)/max(deltat*(srcc(i)+srcs(i)),1.e-36_r8) - if (rat(i).lt.1._r8) then - srcs(i) = srcs(i)*rat(i) - srcc(i) = srcc(i)*rat(i) - endif - srct(i) = (srcc(i)+srcs(i))*omsm - - - ! fraction that is not removed within the cloud - ! (assumed to be interstitial, and subject to convective transport) - fracp(i) = deltat*srct(i)/max(cldvst(i,k)*tracer(i,k),1.e-36_r8) ! amount removed - fracp(i) = max(0._r8,min(1._r8,fracp(i))) - fracis(i,k) = 1._r8 - fracp(i) - - ! tend is all tracer removed by scavenging, plus all re-appearing from evaporation above - ! Sungsu added cumulus contribution in the below 3 blocks - - scavt(i,k) = -srct(i) + (fracev(i)*scavab(i)+fracev_cu(i)*scavabc(i))*rpdog(i) - iscavt(i,k) = -(srcc(i)*finc(i) + srcs(i)*fins(i))*omsm - - if ( present(icscavt) ) icscavt(i,k) = -(srcc(i)*finc(i)) * omsm - if ( present(isscavt) ) isscavt(i,k) = -(srcs(i)*fins(i)) * omsm - if ( present(bcscavt) ) bcscavt(i,k) = -(srcc(i) * (1-finc(i))) * omsm + & - fracev_cu(i)*scavabc(i)*rpdog(i) - if ( present(bsscavt) ) bsscavt(i,k) = -(srcs(i) * (1-fins(i))) * omsm + & - fracev(i)*scavab(i)*rpdog(i) - - dblchek(i) = tracer(i,k) + deltat*scavt(i,k) - - ! now keep track of scavenged mass and precip - - scavab(i) = scavab(i)*(1-fracev(i)) + srcs(i)*pdog(i) - precabs(i) = precabs(i) + (precs(i,k) - evaps(i,k))*pdog(i) - scavabc(i) = scavabc(i)*(1-fracev_cu(i)) + srcc(i)*pdog(i) - precabc(i) = precabc(i) + (cmfdqr(i,k) - evapc(i,k))*pdog(i) - tracab(i) = tracab(i) + tracer(i,k)*pdog(i) - - - ! Jan.16.2010. Sungsu - ! Compute convective and stratiform precipitation areas at the base interface - ! of current layer. These are for computing 'below cloud scavenging' in the - ! next layer below. - - ! cldovr_cu(i) = max( cldovr_cu(i), cldc(i,k) ) - ! cldovr_st(i) = max( cldovr_st(i), max( 0._r8, cldt(i,k) - cldc(i,k) ) ) - - ! cldovr_cu(i) = max( 0._r8, min ( 1._r8, cldovr_cu(i) ) ) - ! cldovr_st(i) = max( 0._r8, min ( 1._r8, cldovr_st(i) ) ) - - ! End by Sungsu - - end do ! End of i = 1, ncol - - found = .false. - do i = 1,ncol - if ( dblchek(i) < 0._r8 ) then - found = .true. - exit - end if - end do - - if ( found ) then - do i = 1,ncol - if (dblchek(i) .lt. 0._r8) then - write(*,*) ' wetdapa: negative value ', i, k, tracer(i,k), & - dblchek(i), scavt(i,k), srct(i), rat(i), fracev(i) - endif - end do - endif - - end do ! End of k = 1, pver - - - end subroutine wetdepa_v2 - - -!============================================================================== - -! This is the frozen CAM4 version of wetdepa. - - - subroutine wetdepa_v1( t, p, q, pdel, & - cldt, cldc, cmfdqr, conicw, precs, conds, & - evaps, cwat, tracer, deltat, & - scavt, iscavt, cldv, fracis, sol_fact, ncol, & - scavcoef,icscavt, isscavt, bcscavt, bsscavt, & - sol_facti_in, sol_factbi_in, sol_factii_in, & - sol_factic_in, sol_factiic_in ) - - !----------------------------------------------------------------------- - ! Purpose: - ! scavenging code for very soluble aerosols - ! - ! Author: P. Rasch - ! Modified by T. Bond 3/2003 to track different removals - !----------------------------------------------------------------------- - - implicit none - - real(r8), intent(in) ::& - t(pcols,pver), &! temperature - p(pcols,pver), &! pressure - q(pcols,pver), &! moisture - pdel(pcols,pver), &! pressure thikness - cldt(pcols,pver), &! total cloud fraction - cldc(pcols,pver), &! convective cloud fraction - cmfdqr(pcols,pver), &! rate of production of convective precip - conicw(pcols,pver), &! convective cloud water - cwat(pcols,pver), &! cloud water amount - precs(pcols,pver), &! rate of production of stratiform precip - conds(pcols,pver), &! rate of production of condensate - evaps(pcols,pver), &! rate of evaporation of precip - cldv(pcols,pver), &! total cloud fraction - deltat, &! time step - tracer(pcols,pver) ! trace species - ! If subroutine is called with just sol_fact: - ! sol_fact is used for both in- and below-cloud scavenging - ! If subroutine is called with optional argument sol_facti_in: - ! sol_fact is used for below cloud scavenging - ! sol_facti is used for in cloud scavenging - real(r8), intent(in) :: sol_fact ! solubility factor (fraction of aer scavenged below & in, or just below or sol_facti_in is provided) - real(r8), intent(in), optional :: sol_facti_in ! solubility factor (frac of aerosol scavenged in cloud) - real(r8), intent(in), optional :: sol_factbi_in ! solubility factor (frac of aerosol scavenged below cloud by ice) - real(r8), intent(in), optional :: sol_factii_in ! solubility factor (frac of aerosol scavenged in cloud by ice) - real(r8), intent(in), optional :: sol_factic_in(pcols,pver) ! sol_facti_in for convective clouds - real(r8), intent(in), optional :: sol_factiic_in ! sol_factii_in for convective clouds - real(r8), intent(in) :: scavcoef(pcols,pver) ! Dana and Hales coefficient (/mm) (0.1 if not MODAL_AERO) - - integer, intent(in) :: ncol - - real(r8), intent(out) ::& - scavt(pcols,pver), &! scavenging tend - iscavt(pcols,pver), &! incloud scavenging tends - fracis(pcols,pver) ! fraction of species not scavenged - - real(r8), intent(out), optional :: icscavt(pcols,pver) ! incloud, convective - real(r8), intent(out), optional :: isscavt(pcols,pver) ! incloud, stratiform - real(r8), intent(out), optional :: bcscavt(pcols,pver) ! below cloud, convective - real(r8), intent(out), optional :: bsscavt(pcols,pver) ! below cloud, stratiform - - ! local variables - - integer i ! x index - integer k ! z index - - real(r8) adjfac ! factor stolen from cmfmca - real(r8) aqfrac ! fraction of tracer in aqueous phase - real(r8) cwatc ! local convective total water amount - real(r8) cwats ! local stratiform total water amount - real(r8) cwatp ! local water amount falling from above precip - real(r8) fracev(pcols) ! fraction of precip from above that is evaporating - real(r8) fracp ! fraction of cloud water converted to precip - real(r8) gafrac ! fraction of tracer in gas phasea - real(r8) hconst ! henry's law solubility constant when equation is expressed - ! in terms of mixing ratios - real(r8) mpla ! moles / liter H2O entering the layer from above - real(r8) mplb ! moles / liter H2O leaving the layer below - real(r8) omsm ! 1 - (a small number) - real(r8) part ! partial pressure of tracer in atmospheres - real(r8) patm ! total pressure in atmospheres - real(r8) pdog ! work variable (pdel/gravit) - real(r8) precabc(pcols) ! conv precip from above (work array) - real(r8) precabs(pcols) ! strat precip from above (work array) - real(r8) precbl ! precip falling out of level (work array) - real(r8) precmin ! minimum convective precip causing scavenging - real(r8) rat(pcols) ! ratio of amount available to amount removed - real(r8) scavab(pcols) ! scavenged tracer flux from above (work array) - real(r8) scavabc(pcols) ! scavenged tracer flux from above (work array) - real(r8) srcc ! tend for convective rain - real(r8) srcs ! tend for stratiform rain - real(r8) srct(pcols) ! work variable - real(r8) tracab(pcols) ! column integrated tracer amount -! real(r8) vfall ! fall speed of precip - real(r8) fins ! fraction of rem. rate by strat rain - real(r8) finc ! fraction of rem. rate by conv. rain - real(r8) srcs1 ! work variable - real(r8) srcs2 ! work variable - real(r8) tc ! temp in celcius - real(r8) weight ! fraction of condensate which is ice - real(r8) cldmabs(pcols) ! maximum cloud at or above this level - real(r8) cldmabc(pcols) ! maximum cloud at or above this level - real(r8) odds ! limit on removal rate (proportional to prec) - real(r8) dblchek(pcols) - logical :: found - - real(r8) sol_facti, sol_factb ! in cloud and below cloud fraction of aerosol scavenged - real(r8) sol_factii, sol_factbi ! in cloud and below cloud fraction of aerosol scavenged by ice - real(r8) sol_factic(pcols,pver) ! sol_facti for convective clouds - real(r8) sol_factiic ! sol_factii for convective clouds - ! sol_factic & solfact_iic added for MODAL_AERO. - ! For stratiform cloud, cloudborne aerosol is treated explicitly, - ! and sol_facti is 1.0 for cloudborne, 0.0 for interstitial. - ! For convective cloud, cloudborne aerosol is not treated explicitly, - ! and sol_factic is 1.0 for both cloudborne and interstitial. - - ! ------------------------------------------------------------------------ -! omsm = 1.-1.e-10 ! used to prevent roundoff errors below zero - omsm = 1._r8-2*epsilon(1._r8) ! used to prevent roundoff errors below zero - precmin = 0.1_r8/8.64e4_r8 ! set critical value to 0.1 mm/day in kg/m2/s - - adjfac = deltat/(max(deltat,cmftau)) ! adjustment factor from hack scheme - - ! assume 4 m/s fall speed currently (should be improved) -! vfall = 4. - - ! default (if other sol_facts aren't in call, set all to required sol_fact - sol_facti = sol_fact - sol_factb = sol_fact - sol_factii = sol_fact - sol_factbi = sol_fact - - if ( present(sol_facti_in) ) sol_facti = sol_facti_in - if ( present(sol_factii_in) ) sol_factii = sol_factii_in - if ( present(sol_factbi_in) ) sol_factbi = sol_factbi_in - - sol_factic = sol_facti - sol_factiic = sol_factii - if ( present(sol_factic_in ) ) sol_factic = sol_factic_in - if ( present(sol_factiic_in) ) sol_factiic = sol_factiic_in - - ! this section of code is for highly soluble aerosols, - ! the assumption is that within the cloud that - ! all the tracer is in the cloud water - ! - ! for both convective and stratiform clouds, - ! the fraction of cloud water converted to precip defines - ! the amount of tracer which is pulled out. - ! - - - end subroutine wetdepa_v1 - -!============================================================================== - -! wetdepg is currently being used for both CAM4 and CAM5 by making use of the -! cam_physpkg_is method. - - subroutine wetdepg( t, p, q, pdel, & - cldt, cldc, cmfdqr, evapc, precs, evaps, & - rain, cwat, tracer, deltat, molwt, & - solconst, scavt, iscavt, cldv, icwmr1, & - icwmr2, fracis, ncol ) - - !----------------------------------------------------------------------- - ! Purpose: - ! scavenging of gas phase constituents by henry's law - ! - ! Author: P. Rasch - !----------------------------------------------------------------------- - - real(r8), intent(in) ::& - t(pcols,pver), &! temperature - p(pcols,pver), &! pressure - q(pcols,pver), &! moisture - pdel(pcols,pver), &! pressure thikness - cldt(pcols,pver), &! total cloud fraction - cldc(pcols,pver), &! convective cloud fraction - cmfdqr(pcols,pver), &! rate of production of convective precip - rain (pcols,pver), &! total rainwater mixing ratio - cwat(pcols,pver), &! cloud water amount - precs(pcols,pver), &! rate of production of stratiform precip - evaps(pcols,pver), &! rate of evaporation of precip -! Sungsu - evapc(pcols,pver), &! Rate of evaporation of convective precipitation -! Sungsu - cldv(pcols,pver), &! estimate of local volume occupied by clouds - icwmr1 (pcols,pver), &! in cloud water mixing ration for zhang scheme - icwmr2 (pcols,pver), &! in cloud water mixing ration for hack scheme - deltat, &! time step - tracer(pcols,pver), &! trace species - molwt ! molecular weights - - integer, intent(in) :: ncol - - real(r8) & - solconst(pcols,pver) ! Henry's law coefficient - - real(r8), intent(out) ::& - scavt(pcols,pver), &! scavenging tend - iscavt(pcols,pver), &! incloud scavenging tends - fracis(pcols, pver) ! fraction of constituent that is insoluble - - ! local variables - - integer i ! x index - integer k ! z index - - real(r8) adjfac ! factor stolen from cmfmca - real(r8) aqfrac ! fraction of tracer in aqueous phase - real(r8) cwatc ! local convective total water amount - real(r8) cwats ! local stratiform total water amount - real(r8) cwatl ! local cloud liq water amount - real(r8) cwatp ! local water amount falling from above precip - real(r8) cwatpl ! local water amount falling from above precip (liq) - real(r8) cwatt ! local sum of strat + conv total water amount - real(r8) cwatti ! cwatt/cldv = cloudy grid volume mixing ratio - real(r8) fracev ! fraction of precip from above that is evaporating - real(r8) fracp ! fraction of cloud water converted to precip - real(r8) gafrac ! fraction of tracer in gas phasea - real(r8) hconst ! henry's law solubility constant when equation is expressed - ! in terms of mixing ratios - real(r8) mpla ! moles / liter H2O entering the layer from above - real(r8) mplb ! moles / liter H2O leaving the layer below - real(r8) omsm ! 1 - (a small number) - real(r8) part ! partial pressure of tracer in atmospheres - real(r8) patm ! total pressure in atmospheres - real(r8) pdog ! work variable (pdel/gravit) - real(r8) precab(pcols) ! precip from above (work array) - real(r8) precbl ! precip work variable - real(r8) precxx ! precip work variable - real(r8) precxx2 ! - real(r8) precic ! precip work variable - real(r8) rat ! ratio of amount available to amount removed - real(r8) scavab(pcols) ! scavenged tracer flux from above (work array) - real(r8) scavabc(pcols) ! scavenged tracer flux from above (work array) - ! real(r8) vfall ! fall speed of precip - real(r8) scavmax ! an estimate of the max tracer avail for removal - real(r8) scavbl ! flux removed at bottom of layer - real(r8) fins ! in cloud fraction removed by strat rain - real(r8) finc ! in cloud fraction removed by conv rain - real(r8) rate ! max removal rate estimate - real(r8) scavlimt ! limiting value 1 - real(r8) scavt1 ! limiting value 2 - real(r8) scavin ! scavenging by incloud processes - real(r8) scavbc ! scavenging by below cloud processes - real(r8) tc - real(r8) weight ! ice fraction - real(r8) wtpl ! work variable - real(r8) cldmabs(pcols) ! maximum cloud at or above this level - real(r8) cldmabc(pcols) ! maximum cloud at or above this level - !----------------------------------------------------------- - - omsm = 1._r8-2*epsilon(1._r8) ! used to prevent roundoff errors below zero - - adjfac = deltat/(max(deltat,cmftau)) ! adjustment factor from hack scheme - - ! assume 4 m/s fall speed currently (should be improved) - ! vfall = 4. - - ! zero accumulators - do i = 1,pcols - precab(i) = 1.e-36_r8 - scavab(i) = 0._r8 - cldmabs(i) = 0._r8 - end do - - do k = 1,pver - do i = 1,ncol - - tc = t(i,k) - tmelt - weight = max(0._r8,min(-tc*0.05_r8,1.0_r8)) ! fraction of condensate that is ice - - cldmabs(i) = max(cldmabs(i),cldt(i,k)) - - ! partitioning coefs for gas and aqueous phase - ! take as a cloud water amount, the sum of the stratiform amount - ! plus the convective rain water amount - - ! convective amnt is just the local precip rate from the hack scheme - ! since there is no storage of water, this ignores that falling from above - ! cwatc = cmfdqr(i,k)*deltat/adjfac - !++mcb -- test cwatc - cwatc = (icwmr1(i,k) + icwmr2(i,k)) * (1._r8-weight) - !--mcb - - ! strat cloud water amount and also ignore the part falling from above - cwats = cwat(i,k) - - ! cloud water as liq - !++mcb -- add cwatc later (in cwatti) - ! cwatl = (1.-weight)*(cwatc+cwats) - cwatl = (1._r8-weight)*cwats - ! cloud water as ice - !*not used cwati = weight*(cwatc+cwats) - - ! total suspended condensate as liquid - cwatt = cwatl + rain(i,k) - - ! incloud version - !++mcb -- add cwatc here - cwatti = cwatt/max(cldv(i,k), 0.00001_r8) + cwatc - - ! partitioning terms - patm = p(i,k)/1.013e5_r8 ! pressure in atmospheres - hconst = molwta*patm*solconst(i,k)*cwatti/rhoh2o - aqfrac = hconst/(1._r8+hconst) - gafrac = 1/(1._r8+hconst) - fracis(i,k) = gafrac - - - ! partial pressure of the tracer in the gridbox in atmospheres - part = patm*gafrac*tracer(i,k)*molwta/molwt - - ! use henrys law to give moles tracer /liter of water - ! in this volume - ! then convert to kg tracer /liter of water (kg tracer / kg water) - mplb = solconst(i,k)*part*molwt/1000._r8 - - - pdog = pdel(i,k)/gravit - - ! this part of precip will be carried downward but at a new molarity of mpl - precic = pdog*(precs(i,k) + cmfdqr(i,k)) - - ! we cant take out more than entered, plus that available in the cloud - ! scavmax = scavab(i)+tracer(i,k)*cldt(i,k)/deltat*pdog - scavmax = scavab(i)+tracer(i,k)*cldv(i,k)/deltat*pdog - - ! flux of tracer by incloud processes - scavin = precic*(1._r8-weight)*mplb - - ! fraction of precip which entered above that leaves below - if (.TRUE.) then - ! Sungsu added evaporation of convective precipitation below. - precxx = precab(i)-pdog*(evaps(i,k)+evapc(i,k)) - else - precxx = precab(i)-pdog*evaps(i,k) - end if - precxx = max (precxx,0.0_r8) - - ! flux of tracer by below cloud processes - !++mcb -- removed wtpl because it is now not assigned and previously - ! when it was assigned it was unnecessary: if(tc.gt.0)wtpl=1 - if (tc.gt.0) then - ! scavbc = precxx*wtpl*mplb ! if liquid - scavbc = precxx*mplb ! if liquid - else - precxx2=max(precxx,1.e-36_r8) - scavbc = scavab(i)*precxx2/(precab(i)) ! if ice - endif - - scavbl = min(scavbc + scavin, scavmax) - - ! first guess assuming that henries law works - scavt1 = (scavab(i)-scavbl)/pdog*omsm - - ! pjr this should not be required, but we put it in to make sure we cant remove too much - ! remember, scavt1 is generally negative (indicating removal) - scavt1 = max(scavt1,-tracer(i,k)*cldv(i,k)/deltat) - - !++mcb -- remove this limitation for gas species - !c use the dana and hales or balkanski limit on scavenging - !c rate = precab(i)*0.1 - ! rate = (precic + precxx)*0.1 - ! scavlimt = -tracer(i,k)*cldv(i,k) - ! $ *rate/(1.+rate*deltat) - - ! scavt(i,k) = max(scavt1, scavlimt) - - ! instead just set scavt to scavt1 - scavt(i,k) = scavt1 - !--mcb - - ! now update the amount leaving the layer - scavbl = scavab(i) - scavt(i,k)*pdog - - ! in cloud amount is that formed locally over the total flux out bottom - fins = scavin/(scavin + scavbc + 1.e-36_r8) - iscavt(i,k) = scavt(i,k)*fins - - scavab(i) = scavbl - precab(i) = max(precxx + precic,1.e-36_r8) - - - - end do - end do - - end subroutine wetdepg - -!############################################################################## - -end module wetdep diff --git a/test/ncar_kernels/CAM5_wetdepa/src/wetdep_orig.F90 b/test/ncar_kernels/CAM5_wetdepa/src/wetdep_orig.F90 deleted file mode 100644 index c130e3044b..0000000000 --- a/test/ncar_kernels/CAM5_wetdepa/src/wetdep_orig.F90 +++ /dev/null @@ -1,1199 +0,0 @@ -!#define GENERATE_DRIVER -module wetdep - -!----------------------------------------------------------------------- -! -! Wet deposition routines for both aerosols and gas phase constituents. -! -!----------------------------------------------------------------------- - -use kinds_mod -use params, only: pcols, pver, gravit, rair, tmelt - - - - - - -implicit none -save -private - -public :: wetdepa_v1 ! scavenging codes for very soluble aerosols -- CAM4 version -public :: wetdepa_v2 ! scavenging codes for very soluble aerosols -- CAM5 version -public :: wetdepg ! scavenging of gas phase constituents by henry's law -public :: clddiag ! calc of cloudy volume and rain mixing ratio - -real(r8), parameter :: cmftau = 3600._r8 -real(r8), parameter :: rhoh2o = 1000._r8 ! density of water -real(r8), parameter :: molwta = 28.97_r8 ! molecular weight dry air gm/mole - - - - -!============================================================================== -contains -!============================================================================== - -subroutine clddiag(t, pmid, pdel, cmfdqr, evapc, & - cldt, cldcu, cldst, cme, evapr, & - prain, cldv, cldvcu, cldvst, rain, & - ncol) - - ! ------------------------------------------------------------------------------------ - ! Estimate the cloudy volume which is occupied by rain or cloud water as - ! the max between the local cloud amount or the - ! sum above of (cloud*positive precip production) sum total precip from above - ! ---------------------------------- x ------------------------ - ! sum above of (positive precip ) sum positive precip from above - ! Author: P. Rasch - ! Sungsu Park. Mar.2010 - ! ------------------------------------------------------------------------------------ - - ! Input arguments: - real(r8), intent(in) :: t(pcols,pver) ! temperature (K) - real(r8), intent(in) :: pmid(pcols,pver) ! pressure at layer midpoints - real(r8), intent(in) :: pdel(pcols,pver) ! pressure difference across layers - real(r8), intent(in) :: cmfdqr(pcols,pver) ! dq/dt due to convective rainout - real(r8), intent(in) :: evapc(pcols,pver) ! Evaporation rate of convective precipitation ( >= 0 ) - real(r8), intent(in) :: cldt(pcols,pver) ! total cloud fraction - real(r8), intent(in) :: cldcu(pcols,pver) ! Cumulus cloud fraction - real(r8), intent(in) :: cldst(pcols,pver) ! Stratus cloud fraction - real(r8), intent(in) :: cme(pcols,pver) ! rate of cond-evap within the cloud - real(r8), intent(in) :: evapr(pcols,pver) ! rate of evaporation of falling precipitation (kg/kg/s) - real(r8), intent(in) :: prain(pcols,pver) ! rate of conversion of condensate to precipitation (kg/kg/s) - integer, intent(in) :: ncol - - ! Output arguments: - real(r8), intent(out) :: cldv(pcols,pver) ! fraction occupied by rain or cloud water - real(r8), intent(out) :: cldvcu(pcols,pver) ! Convective precipitation volume - real(r8), intent(out) :: cldvst(pcols,pver) ! Stratiform precipitation volume - real(r8), intent(out) :: rain(pcols,pver) ! mixing ratio of rain (kg/kg) - - ! Local variables: - integer i, k - real(r8) convfw ! used in fallspeed calculation; taken from findmcnew - real(r8) sumppr(pcols) ! precipitation rate (kg/m2-s) - real(r8) sumpppr(pcols) ! sum of positive precips from above - real(r8) cldv1(pcols) ! precip weighted cloud fraction from above - real(r8) lprec ! local production rate of precip (kg/m2/s) - real(r8) lprecp ! local production rate of precip (kg/m2/s) if positive - real(r8) rho ! air density - real(r8) vfall - real(r8) sumppr_cu(pcols) ! Convective precipitation rate (kg/m2-s) - real(r8) sumpppr_cu(pcols) ! Sum of positive convective precips from above - real(r8) cldv1_cu(pcols) ! Convective precip weighted convective cloud fraction from above - real(r8) lprec_cu ! Local production rate of convective precip (kg/m2/s) - real(r8) lprecp_cu ! Local production rate of convective precip (kg/m2/s) if positive - real(r8) sumppr_st(pcols) ! Stratiform precipitation rate (kg/m2-s) - real(r8) sumpppr_st(pcols) ! Sum of positive stratiform precips from above - real(r8) cldv1_st(pcols) ! Stratiform precip weighted stratiform cloud fraction from above - real(r8) lprec_st ! Local production rate of stratiform precip (kg/m2/s) - real(r8) lprecp_st ! Local production rate of stratiform precip (kg/m2/s) if positive - ! ----------------------------------------------------------------------- - - convfw = 1.94_r8*2.13_r8*sqrt(rhoh2o*gravit*2.7e-4_r8) - do i=1,ncol - sumppr(i) = 0._r8 - cldv1(i) = 0._r8 - sumpppr(i) = 1.e-36_r8 - sumppr_cu(i) = 0._r8 - cldv1_cu(i) = 0._r8 - sumpppr_cu(i) = 1.e-36_r8 - sumppr_st(i) = 0._r8 - cldv1_st(i) = 0._r8 - sumpppr_st(i) = 1.e-36_r8 - end do - - do k = 1,pver - do i = 1,ncol - cldv(i,k) = & - max(min(1._r8, & - cldv1(i)/sumpppr(i) & - )*sumppr(i)/sumpppr(i), & - cldt(i,k) & - ) - lprec = pdel(i,k)/gravit & - *(prain(i,k)+cmfdqr(i,k)-evapr(i,k)) - lprecp = max(lprec,1.e-30_r8) - cldv1(i) = cldv1(i) + cldt(i,k)*lprecp - sumppr(i) = sumppr(i) + lprec - sumpppr(i) = sumpppr(i) + lprecp - - ! For convective precipitation volume at the top interface of each layer. Neglect the current layer. - cldvcu(i,k) = max(min(1._r8,cldv1_cu(i)/sumpppr_cu(i))*(sumppr_cu(i)/sumpppr_cu(i)),0._r8) - lprec_cu = (pdel(i,k)/gravit)*(cmfdqr(i,k)-evapc(i,k)) - lprecp_cu = max(lprec_cu,1.e-30_r8) - cldv1_cu(i) = cldv1_cu(i) + cldcu(i,k)*lprecp_cu - sumppr_cu(i) = sumppr_cu(i) + lprec_cu - sumpppr_cu(i) = sumpppr_cu(i) + lprecp_cu - - ! For stratiform precipitation volume at the top interface of each layer. Neglect the current layer. - cldvst(i,k) = max(min(1._r8,cldv1_st(i)/sumpppr_st(i))*(sumppr_st(i)/sumpppr_st(i)),0._r8) - lprec_st = (pdel(i,k)/gravit)*(prain(i,k)-evapr(i,k)) - lprecp_st = max(lprec_st,1.e-30_r8) - cldv1_st(i) = cldv1_st(i) + cldst(i,k)*lprecp_st - sumppr_st(i) = sumppr_st(i) + lprec_st - sumpppr_st(i) = sumpppr_st(i) + lprecp_st - - rain(i,k) = 0._r8 - if(t(i,k) .gt. tmelt) then - rho = pmid(i,k)/(rair*t(i,k)) - vfall = convfw/sqrt(rho) - rain(i,k) = sumppr(i)/(rho*vfall) - if (rain(i,k).lt.1.e-14_r8) rain(i,k) = 0._r8 - endif - end do - end do - -end subroutine clddiag - -!============================================================================== - -! This is the CAM5 version of wetdepa. - -subroutine wetdepa_v2(t, p, q, pdel, & - cldt, cldc, cmfdqr, evapc, conicw, precs, conds, & - evaps, cwat, tracer, deltat, & - scavt, iscavt, cldv, cldvcu, cldvst, dlf, fracis, sol_fact, ncol, & - scavcoef, is_strat_cloudborne, rate1ord_cw2pr_st, qqcw, f_act_conv, & - icscavt, isscavt, bcscavt, bsscavt, & - sol_facti_in, sol_factbi_in, sol_factii_in, & - sol_factic_in, sol_factiic_in ) - - !----------------------------------------------------------------------- - ! Purpose: - ! scavenging code for very soluble aerosols - ! - ! Author: P. Rasch - ! Modified by T. Bond 3/2003 to track different removals - ! Sungsu Park. Mar.2010 : Impose consistencies with a few changes in physics. - !----------------------------------------------------------------------- - - - - implicit none - - real(r8), intent(in) ::& - t(pcols,pver), &! temperature - p(pcols,pver), &! pressure - q(pcols,pver), &! moisture - pdel(pcols,pver), &! pressure thikness - cldt(pcols,pver), &! total cloud fraction - cldc(pcols,pver), &! convective cloud fraction - cmfdqr(pcols,pver), &! rate of production of convective precip -! Sungsu - evapc(pcols,pver), &! Evaporation rate of convective precipitation -! Sungsu - conicw(pcols,pver), &! convective cloud water - cwat(pcols,pver), &! cloud water amount - precs(pcols,pver), &! rate of production of stratiform precip - conds(pcols,pver), &! rate of production of condensate - evaps(pcols,pver), &! rate of evaporation of precip - cldv(pcols,pver), &! total cloud fraction -! Sungsu - cldvcu(pcols,pver), &! Convective precipitation area at the top interface of each layer - cldvst(pcols,pver), &! Stratiform precipitation area at the top interface of each layer - dlf(pcols,pver), &! Detrainment of convective condensate [kg/kg/s] -! Sungsu - deltat, &! time step - tracer(pcols,pver) ! trace species - - ! If subroutine is called with just sol_fact: - ! sol_fact is used for both in- and below-cloud scavenging - ! If subroutine is called with optional argument sol_facti_in: - ! sol_fact is used for below cloud scavenging - ! sol_facti is used for in cloud scavenging - real(r8), intent(in) :: sol_fact ! solubility factor (fraction of aer scavenged below & in, or just below or sol_facti_in is provided) - integer, intent(in) :: ncol - real(r8), intent(in) :: scavcoef(pcols,pver) ! Dana and Hales coefficient (/mm) (0.1 if not MODAL_AERO) - real(r8), intent(out) ::& - scavt(pcols,pver), &! scavenging tend - iscavt(pcols,pver), &! incloud scavenging tends - fracis(pcols,pver) ! fraction of species not scavenged - ! rce 2010/05/01 - ! is_strat_cloudborne = .true. if tracer is stratiform-cloudborne aerosol; else .false. - logical, intent(in), optional :: is_strat_cloudborne - ! rate1ord_cw2pr_st = 1st order rate for strat cw to precip (1/s) - real(r8), intent(in), optional :: rate1ord_cw2pr_st(pcols,pver) - ! qqcw = strat-cloudborne aerosol corresponding to tracer when is_strat_cloudborne==.false.; else 0.0 - real(r8), intent(in), optional :: qqcw(pcols,pver) - ! f_act_conv = conv-cloud activation fraction when is_strat_cloudborne==.false.; else 0.0 - real(r8), intent(in), optional :: f_act_conv(pcols,pver) - ! end rce 2010/05/01 - - real(r8), intent(in), optional :: sol_facti_in ! solubility factor (frac of aerosol scavenged in cloud) - real(r8), intent(in), optional :: sol_factbi_in ! solubility factor (frac of aerosol scavenged below cloud by ice) - real(r8), intent(in), optional :: sol_factii_in ! solubility factor (frac of aerosol scavenged in cloud by ice) - real(r8), intent(in), optional :: sol_factic_in(pcols,pver) ! sol_facti_in for convective clouds - real(r8), intent(in), optional :: sol_factiic_in ! sol_factii_in for convective clouds - - - real(r8), intent(out), optional :: icscavt(pcols,pver) ! incloud, convective - real(r8), intent(out), optional :: isscavt(pcols,pver) ! incloud, stratiform - real(r8), intent(out), optional :: bcscavt(pcols,pver) ! below cloud, convective - real(r8), intent(out), optional :: bsscavt(pcols,pver) ! below cloud, stratiform - - - - ! local variables - - integer i ! x index - integer k ! z index - - real(r8) adjfac ! factor stolen from cmfmca - real(r8) aqfrac ! fraction of tracer in aqueous phase - real(r8) cwatc ! local convective total water amount - real(r8) cwats ! local stratiform total water amount - real(r8) cwatp ! local water amount falling from above precip - real(r8) fracev(pcols) ! fraction of precip from above that is evaporating -! Sungsu - real(r8) fracev_cu(pcols) ! Fraction of convective precip from above that is evaporating -! Sungsu - real(r8) fracp ! fraction of cloud water converted to precip - real(r8) gafrac ! fraction of tracer in gas phasea - real(r8) hconst ! henry's law solubility constant when equation is expressed - ! in terms of mixing ratios - real(r8) mpla ! moles / liter H2O entering the layer from above - real(r8) mplb ! moles / liter H2O leaving the layer below - real(r8) omsm ! 1 - (a small number) - real(r8) part ! partial pressure of tracer in atmospheres - real(r8) patm ! total pressure in atmospheres - real(r8) pdog ! work variable (pdel/gravit) - real(r8) precabc(pcols) ! conv precip from above (work array) - real(r8) precabs(pcols) ! strat precip from above (work array) - real(r8) precbl ! precip falling out of level (work array) - real(r8) precmin ! minimum convective precip causing scavenging - real(r8) rat(pcols) ! ratio of amount available to amount removed - real(r8) scavab(pcols) ! scavenged tracer flux from above (work array) - real(r8) scavabc(pcols) ! scavenged tracer flux from above (work array) - real(r8) srcc ! tend for convective rain - real(r8) srcs ! tend for stratiform rain - real(r8) srct(pcols) ! work variable - real(r8) tracab(pcols) ! column integrated tracer amount -! real(r8) vfall ! fall speed of precip - real(r8) fins ! fraction of rem. rate by strat rain - real(r8) finc ! fraction of rem. rate by conv. rain - real(r8) srcs1 ! work variable - real(r8) srcs2 ! work variable - real(r8) tc ! temp in celcius - real(r8) weight ! fraction of condensate which is ice - real(r8) cldmabs(pcols) ! maximum cloud at or above this level - real(r8) cldmabc(pcols) ! maximum cloud at or above this level - real(r8) odds ! limit on removal rate (proportional to prec) - real(r8) dblchek(pcols) - logical :: found - - ! Jan.16.2009. Sungsu for wet scavenging below clouds. - ! real(r8) cldovr_cu(pcols) ! Convective precipitation area at the base of each layer - ! real(r8) cldovr_st(pcols) ! Stratiform precipitation area at the base of each layer - - real(r8) tracer_incu - real(r8) tracer_mean - - ! End by Sungsu - - real(r8) sol_facti, sol_factb ! in cloud and below cloud fraction of aerosol scavenged - real(r8) sol_factii, sol_factbi ! in cloud and below cloud fraction of aerosol scavenged by ice - real(r8) sol_factic(pcols,pver) ! sol_facti for convective clouds - real(r8) sol_factiic ! sol_factii for convective clouds - ! sol_factic & solfact_iic added for MODAL_AERO. - ! For stratiform cloud, cloudborne aerosol is treated explicitly, - ! and sol_facti is 1.0 for cloudborne, 0.0 for interstitial. - ! For convective cloud, cloudborne aerosol is not treated explicitly, - ! and sol_factic is 1.0 for both cloudborne and interstitial. - - - - ! ------------------------------------------------------------------------ -! omsm = 1.-1.e-10 ! used to prevent roundoff errors below zero - omsm = 1._r8-2*epsilon(1._r8) ! used to prevent roundoff errors below zero - precmin = 0.1_r8/8.64e4_r8 ! set critical value to 0.1 mm/day in kg/m2/s - - adjfac = deltat/(max(deltat,cmftau)) ! adjustment factor from hack scheme - - ! assume 4 m/s fall speed currently (should be improved) -! vfall = 4. - - ! default (if other sol_facts aren't in call, set all to required sol_fact - sol_facti = sol_fact - sol_factb = sol_fact - sol_factii = sol_fact - sol_factbi = sol_fact - - if ( present(sol_facti_in) ) sol_facti = sol_facti_in - if ( present(sol_factii_in) ) sol_factii = sol_factii_in - if ( present(sol_factbi_in) ) sol_factbi = sol_factbi_in - - sol_factic = sol_facti - sol_factiic = sol_factii - if ( present(sol_factic_in ) ) sol_factic = sol_factic_in - if ( present(sol_factiic_in) ) sol_factiic = sol_factiic_in - - ! this section of code is for highly soluble aerosols, - ! the assumption is that within the cloud that - ! all the tracer is in the cloud water - ! - ! for both convective and stratiform clouds, - ! the fraction of cloud water converted to precip defines - ! the amount of tracer which is pulled out. - ! - - do i = 1,pcols - precabs(i) = 0 - precabc(i) = 0 - scavab(i) = 0 - scavabc(i) = 0 - tracab(i) = 0 - cldmabs(i) = 0 - cldmabc(i) = 0 - - ! Jan.16. Sungsu - ! I added below to compute vertically projected cumulus and stratus fractions from the top to the - ! current model layer by assuming a simple independent maximum overlapping assumption for - ! each cloud. - ! cldovr_cu(i) = 0._r8 - ! cldovr_st(i) = 0._r8 - ! End by Sungsu - - end do - - do k = 1,pver - do i = 1,ncol - tc = t(i,k) - tmelt - weight = max(0._r8,min(-tc*0.05_r8,1.0_r8)) ! fraction of condensate that is ice - weight = 0._r8 ! assume no ice - - pdog = pdel(i,k)/gravit - - ! ****************** Evaporation ************************** - ! calculate the fraction of strat precip from above - ! which evaporates within this layer - fracev(i) = evaps(i,k)*pdel(i,k)/gravit & - /max(1.e-12_r8,precabs(i)) - - ! trap to ensure reasonable ratio bounds - fracev(i) = max(0._r8,min(1._r8,fracev(i))) - -! Sungsu : Same as above but convective precipitation part - fracev_cu(i) = evapc(i,k)*pdel(i,k)/gravit/max(1.e-12_r8,precabc(i)) - fracev_cu(i) = max(0._r8,min(1._r8,fracev_cu(i))) -! Sungsu - ! ****************** Convection *************************** - ! now do the convective scavenging - - ! set odds proportional to fraction of the grid box that is swept by the - ! precipitation =precabc/rhoh20*(area of sphere projected on plane - ! /volume of sphere)*deltat - ! assume the radius of a raindrop is 1 e-3 m from Rogers and Yau, - ! unless the fraction of the area that is cloud is less than odds, in which - ! case use the cloud fraction (assumes precabs is in kg/m2/s) - ! is really: precabs*3/4/1000./1e-3*deltat - ! here I use .1 from Balkanski - ! - ! use a local rate of convective rain production for incloud scav - !odds=max(min(1._r8, & - ! cmfdqr(i,k)*pdel(i,k)/gravit*0.1_r8*deltat),0._r8) - !++mcb -- change cldc to cldt; change cldt to cldv (9/17/96) - ! srcs1 = cldt(i,k)*odds*tracer(i,k)*(1.-weight) & - ! srcs1 = cldv(i,k)*odds*tracer(i,k)*(1.-weight) & - !srcs1 = cldc(i,k)*odds*tracer(i,k)*(1.-weight) & - ! /deltat - - ! fraction of convective cloud water converted to rain - ! Dec.29.2009 : Sungsu multiplied cldc(i,k) to conicw(i,k) below - ! fracp = cmfdqr(i,k)*deltat/max(1.e-8_r8,conicw(i,k)) - ! fracp = cmfdqr(i,k)*deltat/max(1.e-8_r8,cldc(i,k)*conicw(i,k)) - ! Sungsu: Below new formula of 'fracp' is necessary since 'conicw' is a LWC/IWC - ! that has already precipitated out, that is, 'conicw' does not contain - ! precipitation at all ! - fracp = cmfdqr(i,k)*deltat/max(1.e-12_r8,cldc(i,k)*conicw(i,k)+(cmfdqr(i,k)+dlf(i,k))*deltat) ! Sungsu.Mar.19.2010. - ! Dec.29.2009 - ! Note cmfdrq can be negative from evap of rain, so constrain it <-- This is wrong. cmfdqr does not - ! contain evaporation of precipitation. - fracp = max(min(1._r8,fracp),0._r8) - ! remove that amount from within the convective area -! srcs1 = cldc(i,k)*fracp*tracer(i,k)*(1._r8-weight)/deltat ! liquid only -! srcs1 = cldc(i,k)*fracp*tracer(i,k)/deltat ! any condensation -! srcs1 = 0. -! Jan.02.2010. Sungsu : cldt --> cldc below. - ! rce 2010/05/01 - if (present(is_strat_cloudborne)) then ! Tianyi, 2011/03/29 - if ( is_strat_cloudborne ) then - ! only strat in-cloud removal affects strat-cloudborne aerosol - srcs1 = 0._r8 - else - tracer_incu = f_act_conv(i,k)*(tracer(i,k)+& - min(qqcw(i,k),tracer(i,k)*((cldt(i,k)-cldc(i,k))/max(0.01_r8,(1._r8-(cldt(i,k)-cldc(i,k))))))) - srcs1 = sol_factic(i,k)*cldc(i,k)*fracp*tracer_incu*(1._r8-weight)/deltat & ! Liquid - + sol_factiic *cldc(i,k)*fracp*tracer_incu*(weight)/deltat ! Ice - end if - else - srcs1 = sol_factic(i,k)*cldc(i,k)*fracp*tracer(i,k)*(1._r8-weight)/deltat & ! liquid - + sol_factiic*cldc(i,k)*fracp*tracer(i,k)*(weight)/deltat ! ice - end if - - - !--mcb - - ! scavenge below cloud - - ! cldmabc(i) = max(cldc(i,k),cldmabc(i)) - ! cldmabc(i) = max(cldt(i,k),cldmabc(i)) - ! cldmabc(i) = max(cldv(i,k),cldmabc(i)) - ! cldmabc(i) = cldv(i,k) - cldmabc(i) = cldvcu(i,k) - - ! Jan. 16. 2010. Sungsu - ! cldmabc(i) = cldmabc(i) * cldovr_cu(i) / max( 0.01_r8, cldovr_cu(i) + cldovr_st(i) ) - ! End by Sungsu - - ! rce 2010/05/01 - if (present(is_strat_cloudborne)) then ! Tianyi, 2011/03/29 - if ( is_strat_cloudborne ) then - ! only strat in-cloud removal affects strat-cloudborne aerosol - srcs2 = 0._r8 - else - tracer_mean = tracer(i,k)*(1._r8-cldc(i,k)*f_act_conv(i,k))-cldc(i,k)*f_act_conv(i,k)*& - min(qqcw(i,k),tracer(i,k)*((cldt(i,k)-cldc(i,k))/max(0.01_r8,(1._r8-(cldt(i,k)-cldc(i,k)))))) - tracer_mean = max(0._r8,tracer_mean) - odds = max(min(1._r8,precabc(i)/max(cldmabc(i),1.e-5_r8)*scavcoef(i,k)*deltat),0._r8) ! Dana and Hales coefficient (/mm) - srcs2 = sol_factb *cldmabc(i)*odds*tracer_mean*(1._r8-weight)/deltat & ! Liquid - + sol_factbi*cldmabc(i)*odds*tracer_mean*(weight)/deltat ! Ice - end if - else - odds=max( & - min(1._r8,precabc(i)/max(cldmabc(i),1.e-5_r8) & - *scavcoef(i,k)*deltat),0._r8) ! Dana and Hales coefficient (/mm) - srcs2 = sol_factb*cldmabc(i)*odds*tracer(i,k)*(1._r8-weight)/deltat & ! liquid - + sol_factbi*cldmabc(i)*odds*tracer(i,k)*(weight)/deltat !ice - end if - - - !Note that using the temperature-determined weight doesn't make much sense here - - - srcc = srcs1 + srcs2 ! convective tend by both processes - finc = srcs1/(srcc + 1.e-36_r8) ! fraction in-cloud - - ! ****************** Stratiform *********************** - ! now do the stratiform scavenging - - ! incloud scavenging - - ! rce 2010/05/01 - if(present(is_strat_cloudborne)) then ! Tianyi 2011/03/29 - if ( is_strat_cloudborne ) then - ! new code for stratiform incloud scav of cloudborne (modal) aerosol - ! >> use the 1st order cw to precip rate calculated in microphysics routine - ! >> cloudborne aerosol resides in cloudy portion of grid cell, so do not apply "cldt" factor - ! fracp = rate1ord_cw2pr_st(i,k)*deltat - ! fracp = max(0._r8,min(1._r8,fracp)) - fracp = precs(i,k)*deltat/max(cwat(i,k)+precs(i,k)*deltat,1.e-12_r8) ! Sungsu. Mar.19.2010. - fracp = max(0._r8,min(1._r8,fracp)) - srcs1 = sol_facti *fracp*tracer(i,k)/deltat*(1._r8-weight) & ! Liquid - + sol_factii*fracp*tracer(i,k)/deltat*(weight) ! Ice - else - ! strat in-cloud removal only affects strat-cloudborne aerosol - srcs1 = 0._r8 - end if - else - ! fracp is the fraction of cloud water converted to precip - ! Sungsu modified fracp as the convectiv case. - ! Below new formula by Sungsu of 'fracp' is necessary since 'cwat' is a LWC/IWC - ! that has already precipitated out, that is, 'cwat' does not contain - ! precipitation at all ! - ! fracp = precs(i,k)*deltat/max(cwat(i,k),1.e-12_r8) - fracp = precs(i,k)*deltat/max(cwat(i,k)+precs(i,k)*deltat,1.e-12_r8) ! Sungsu. Mar.19.2010. - fracp = max(0._r8,min(1._r8,fracp)) - ! fracp = 0. ! for debug - - ! assume the corresponding amnt of tracer is removed - !++mcb -- remove cldc; change cldt to cldv - ! srcs1 = (cldt(i,k)-cldc(i,k))*fracp*tracer(i,k)/deltat - ! srcs1 = cldv(i,k)*fracp*tracer(i,k)/deltat & - ! srcs1 = cldt(i,k)*fracp*tracer(i,k)/deltat ! all condensate - ! Jan.02.2010. Sungsu : cldt --> cldt - cldc below. - srcs1 = sol_facti*(cldt(i,k)-cldc(i,k))*fracp*tracer(i,k)/deltat*(1._r8-weight) & ! liquid - + sol_factii*(cldt(i,k)-cldc(i,k))*fracp*tracer(i,k)/deltat*(weight) ! ice - end if - ! end rce 2010/05/01 - - - ! below cloud scavenging - -! volume undergoing below cloud scavenging -! cldmabs(i) = cldv(i,k) ! precipitating volume -! cldmabs(i) = cldt(i,k) ! local cloud volume - cldmabs(i) = cldvst(i,k) ! Stratiform precipitation area at the top interface of current layer - - ! Jan. 16. 2010. Sungsu - ! cldmabs(i) = cldmabs(i) * cldovr_st(i) / max( 0.01_r8, cldovr_cu(i) + cldovr_st(i) ) - ! End by Sungsu - - ! rce 2010/05/01 - if (present(is_strat_cloudborne)) then ! Tianyi 2011/03/29 - if ( is_strat_cloudborne ) then - ! only strat in-cloud removal affects strat-cloudborne aerosol - srcs2 = 0._r8 - else - odds = precabs(i)/max(cldmabs(i),1.e-5_r8)*scavcoef(i,k)*deltat - odds = max(min(1._r8,odds),0._r8) - srcs2 = sol_factb *cldmabs(i)*odds*tracer_mean*(1._r8-weight)/deltat & ! Liquid - + sol_factbi*cldmabs(i)*odds*tracer_mean*(weight)/deltat ! Ice - end if - else - odds = precabs(i)/max(cldmabs(i),1.e-5_r8)*scavcoef(i,k)*deltat - odds = max(min(1._r8,odds),0._r8) - srcs2 =sol_factb*(cldmabs(i)*odds) *tracer(i,k)*(1._r8-weight)/deltat & ! liquid - + sol_factbi*(cldmabs(i)*odds) *tracer(i,k)*(weight)/deltat ! ice - end if - - !Note that using the temperature-determined weight doesn't make much sense here - - srcs = srcs1 + srcs2 ! total stratiform scavenging - fins=srcs1/(srcs + 1.e-36_r8) ! fraction taken by incloud processes - - ! make sure we dont take out more than is there - ! ratio of amount available to amount removed - rat(i) = tracer(i,k)/max(deltat*(srcc+srcs),1.e-36_r8) - if (rat(i).lt.1._r8) then - srcs = srcs*rat(i) - srcc = srcc*rat(i) - endif - srct(i) = (srcc+srcs)*omsm - - - ! fraction that is not removed within the cloud - ! (assumed to be interstitial, and subject to convective transport) - fracp = deltat*srct(i)/max(cldmabs(i)*tracer(i,k),1.e-36_r8) ! amount removed - fracp = max(0._r8,min(1._r8,fracp)) - fracis(i,k) = 1._r8 - fracp - - ! tend is all tracer removed by scavenging, plus all re-appearing from evaporation above - ! Sungsu added cumulus contribution in the below 3 blocks - - scavt(i,k) = -srct(i) + (fracev(i)*scavab(i)+fracev_cu(i)*scavabc(i))*gravit/pdel(i,k) - iscavt(i,k) = -(srcc*finc + srcs*fins)*omsm - - if ( present(icscavt) ) icscavt(i,k) = -(srcc*finc) * omsm - if ( present(isscavt) ) isscavt(i,k) = -(srcs*fins) * omsm - if ( present(bcscavt) ) bcscavt(i,k) = -(srcc * (1-finc)) * omsm + & - fracev_cu(i)*scavabc(i)*gravit/pdel(i,k) - if ( present(bsscavt) ) bsscavt(i,k) = -(srcs * (1-fins)) * omsm + & - fracev(i)*scavab(i)*gravit/pdel(i,k) - - dblchek(i) = tracer(i,k) + deltat*scavt(i,k) - - ! now keep track of scavenged mass and precip - scavab(i) = scavab(i)*(1-fracev(i)) + srcs*pdel(i,k)/gravit - precabs(i) = precabs(i) + (precs(i,k) - evaps(i,k))*pdel(i,k)/gravit - scavabc(i) = scavabc(i)*(1-fracev_cu(i)) + srcc*pdel(i,k)/gravit - precabc(i) = precabc(i) + (cmfdqr(i,k) - evapc(i,k))*pdel(i,k)/gravit - tracab(i) = tracab(i) + tracer(i,k)*pdel(i,k)/gravit - - ! Jan.16.2010. Sungsu - ! Compute convective and stratiform precipitation areas at the base interface - ! of current layer. These are for computing 'below cloud scavenging' in the - ! next layer below. - - ! cldovr_cu(i) = max( cldovr_cu(i), cldc(i,k) ) - ! cldovr_st(i) = max( cldovr_st(i), max( 0._r8, cldt(i,k) - cldc(i,k) ) ) - - ! cldovr_cu(i) = max( 0._r8, min ( 1._r8, cldovr_cu(i) ) ) - ! cldovr_st(i) = max( 0._r8, min ( 1._r8, cldovr_st(i) ) ) - - ! End by Sungsu - - end do ! End of i = 1, ncol - - found = .false. - do i = 1,ncol - if ( dblchek(i) < 0._r8 ) then - found = .true. - exit - end if - end do - - if ( found ) then - do i = 1,ncol - if (dblchek(i) .lt. 0._r8) then - write(*,*) ' wetdapa: negative value ', i, k, tracer(i,k), & - dblchek(i), scavt(i,k), srct(i), rat(i), fracev(i) - endif - end do - endif - - end do ! End of k = 1, pver - - - end subroutine wetdepa_v2 - - -!============================================================================== - -! This is the frozen CAM4 version of wetdepa. - - - subroutine wetdepa_v1( t, p, q, pdel, & - cldt, cldc, cmfdqr, conicw, precs, conds, & - evaps, cwat, tracer, deltat, & - scavt, iscavt, cldv, fracis, sol_fact, ncol, & - scavcoef,icscavt, isscavt, bcscavt, bsscavt, & - sol_facti_in, sol_factbi_in, sol_factii_in, & - sol_factic_in, sol_factiic_in ) - - !----------------------------------------------------------------------- - ! Purpose: - ! scavenging code for very soluble aerosols - ! - ! Author: P. Rasch - ! Modified by T. Bond 3/2003 to track different removals - !----------------------------------------------------------------------- - - implicit none - - real(r8), intent(in) ::& - t(pcols,pver), &! temperature - p(pcols,pver), &! pressure - q(pcols,pver), &! moisture - pdel(pcols,pver), &! pressure thikness - cldt(pcols,pver), &! total cloud fraction - cldc(pcols,pver), &! convective cloud fraction - cmfdqr(pcols,pver), &! rate of production of convective precip - conicw(pcols,pver), &! convective cloud water - cwat(pcols,pver), &! cloud water amount - precs(pcols,pver), &! rate of production of stratiform precip - conds(pcols,pver), &! rate of production of condensate - evaps(pcols,pver), &! rate of evaporation of precip - cldv(pcols,pver), &! total cloud fraction - deltat, &! time step - tracer(pcols,pver) ! trace species - ! If subroutine is called with just sol_fact: - ! sol_fact is used for both in- and below-cloud scavenging - ! If subroutine is called with optional argument sol_facti_in: - ! sol_fact is used for below cloud scavenging - ! sol_facti is used for in cloud scavenging - real(r8), intent(in) :: sol_fact ! solubility factor (fraction of aer scavenged below & in, or just below or sol_facti_in is provided) - real(r8), intent(in), optional :: sol_facti_in ! solubility factor (frac of aerosol scavenged in cloud) - real(r8), intent(in), optional :: sol_factbi_in ! solubility factor (frac of aerosol scavenged below cloud by ice) - real(r8), intent(in), optional :: sol_factii_in ! solubility factor (frac of aerosol scavenged in cloud by ice) - real(r8), intent(in), optional :: sol_factic_in(pcols,pver) ! sol_facti_in for convective clouds - real(r8), intent(in), optional :: sol_factiic_in ! sol_factii_in for convective clouds - real(r8), intent(in) :: scavcoef(pcols,pver) ! Dana and Hales coefficient (/mm) (0.1 if not MODAL_AERO) - - integer, intent(in) :: ncol - - real(r8), intent(out) ::& - scavt(pcols,pver), &! scavenging tend - iscavt(pcols,pver), &! incloud scavenging tends - fracis(pcols,pver) ! fraction of species not scavenged - - real(r8), intent(out), optional :: icscavt(pcols,pver) ! incloud, convective - real(r8), intent(out), optional :: isscavt(pcols,pver) ! incloud, stratiform - real(r8), intent(out), optional :: bcscavt(pcols,pver) ! below cloud, convective - real(r8), intent(out), optional :: bsscavt(pcols,pver) ! below cloud, stratiform - - ! local variables - - integer i ! x index - integer k ! z index - - real(r8) adjfac ! factor stolen from cmfmca - real(r8) aqfrac ! fraction of tracer in aqueous phase - real(r8) cwatc ! local convective total water amount - real(r8) cwats ! local stratiform total water amount - real(r8) cwatp ! local water amount falling from above precip - real(r8) fracev(pcols) ! fraction of precip from above that is evaporating - real(r8) fracp ! fraction of cloud water converted to precip - real(r8) gafrac ! fraction of tracer in gas phasea - real(r8) hconst ! henry's law solubility constant when equation is expressed - ! in terms of mixing ratios - real(r8) mpla ! moles / liter H2O entering the layer from above - real(r8) mplb ! moles / liter H2O leaving the layer below - real(r8) omsm ! 1 - (a small number) - real(r8) part ! partial pressure of tracer in atmospheres - real(r8) patm ! total pressure in atmospheres - real(r8) pdog ! work variable (pdel/gravit) - real(r8) precabc(pcols) ! conv precip from above (work array) - real(r8) precabs(pcols) ! strat precip from above (work array) - real(r8) precbl ! precip falling out of level (work array) - real(r8) precmin ! minimum convective precip causing scavenging - real(r8) rat(pcols) ! ratio of amount available to amount removed - real(r8) scavab(pcols) ! scavenged tracer flux from above (work array) - real(r8) scavabc(pcols) ! scavenged tracer flux from above (work array) - real(r8) srcc ! tend for convective rain - real(r8) srcs ! tend for stratiform rain - real(r8) srct(pcols) ! work variable - real(r8) tracab(pcols) ! column integrated tracer amount -! real(r8) vfall ! fall speed of precip - real(r8) fins ! fraction of rem. rate by strat rain - real(r8) finc ! fraction of rem. rate by conv. rain - real(r8) srcs1 ! work variable - real(r8) srcs2 ! work variable - real(r8) tc ! temp in celcius - real(r8) weight ! fraction of condensate which is ice - real(r8) cldmabs(pcols) ! maximum cloud at or above this level - real(r8) cldmabc(pcols) ! maximum cloud at or above this level - real(r8) odds ! limit on removal rate (proportional to prec) - real(r8) dblchek(pcols) - logical :: found - - real(r8) sol_facti, sol_factb ! in cloud and below cloud fraction of aerosol scavenged - real(r8) sol_factii, sol_factbi ! in cloud and below cloud fraction of aerosol scavenged by ice - real(r8) sol_factic(pcols,pver) ! sol_facti for convective clouds - real(r8) sol_factiic ! sol_factii for convective clouds - ! sol_factic & solfact_iic added for MODAL_AERO. - ! For stratiform cloud, cloudborne aerosol is treated explicitly, - ! and sol_facti is 1.0 for cloudborne, 0.0 for interstitial. - ! For convective cloud, cloudborne aerosol is not treated explicitly, - ! and sol_factic is 1.0 for both cloudborne and interstitial. - - ! ------------------------------------------------------------------------ -! omsm = 1.-1.e-10 ! used to prevent roundoff errors below zero - omsm = 1._r8-2*epsilon(1._r8) ! used to prevent roundoff errors below zero - precmin = 0.1_r8/8.64e4_r8 ! set critical value to 0.1 mm/day in kg/m2/s - - adjfac = deltat/(max(deltat,cmftau)) ! adjustment factor from hack scheme - - ! assume 4 m/s fall speed currently (should be improved) -! vfall = 4. - - ! default (if other sol_facts aren't in call, set all to required sol_fact - sol_facti = sol_fact - sol_factb = sol_fact - sol_factii = sol_fact - sol_factbi = sol_fact - - if ( present(sol_facti_in) ) sol_facti = sol_facti_in - if ( present(sol_factii_in) ) sol_factii = sol_factii_in - if ( present(sol_factbi_in) ) sol_factbi = sol_factbi_in - - sol_factic = sol_facti - sol_factiic = sol_factii - if ( present(sol_factic_in ) ) sol_factic = sol_factic_in - if ( present(sol_factiic_in) ) sol_factiic = sol_factiic_in - - ! this section of code is for highly soluble aerosols, - ! the assumption is that within the cloud that - ! all the tracer is in the cloud water - ! - ! for both convective and stratiform clouds, - ! the fraction of cloud water converted to precip defines - ! the amount of tracer which is pulled out. - ! - - do i = 1,pcols - precabs(i) = 0 - precabc(i) = 0 - scavab(i) = 0 - scavabc(i) = 0 - tracab(i) = 0 - cldmabs(i) = 0 - cldmabc(i) = 0 - end do - - do k = 1,pver - do i = 1,ncol - tc = t(i,k) - tmelt - weight = max(0._r8,min(-tc*0.05_r8,1.0_r8)) ! fraction of condensate that is ice - weight = 0._r8 ! assume no ice - - pdog = pdel(i,k)/gravit - - ! ****************** Evaporation ************************** - ! calculate the fraction of strat precip from above - ! which evaporates within this layer - fracev(i) = evaps(i,k)*pdel(i,k)/gravit & - /max(1.e-12_r8,precabs(i)) - - ! trap to ensure reasonable ratio bounds - fracev(i) = max(0._r8,min(1._r8,fracev(i))) - - ! ****************** Convection *************************** - ! now do the convective scavenging - - ! set odds proportional to fraction of the grid box that is swept by the - ! precipitation =precabc/rhoh20*(area of sphere projected on plane - ! /volume of sphere)*deltat - ! assume the radius of a raindrop is 1 e-3 m from Rogers and Yau, - ! unless the fraction of the area that is cloud is less than odds, in which - ! case use the cloud fraction (assumes precabs is in kg/m2/s) - ! is really: precabs*3/4/1000./1e-3*deltat - ! here I use .1 from Balkanski - ! - ! use a local rate of convective rain production for incloud scav - !odds=max(min(1._r8, & - ! cmfdqr(i,k)*pdel(i,k)/gravit*0.1_r8*deltat),0._r8) - !++mcb -- change cldc to cldt; change cldt to cldv (9/17/96) - ! srcs1 = cldt(i,k)*odds*tracer(i,k)*(1.-weight) & - ! srcs1 = cldv(i,k)*odds*tracer(i,k)*(1.-weight) & - !srcs1 = cldc(i,k)*odds*tracer(i,k)*(1.-weight) & - ! /deltat - - ! fraction of convective cloud water converted to rain - fracp = cmfdqr(i,k)*deltat/max(1.e-8_r8,conicw(i,k)) - ! note cmfdrq can be negative from evap of rain, so constrain it - fracp = max(min(1._r8,fracp),0._r8) - ! remove that amount from within the convective area -! srcs1 = cldc(i,k)*fracp*tracer(i,k)*(1._r8-weight)/deltat ! liquid only -! srcs1 = cldc(i,k)*fracp*tracer(i,k)/deltat ! any condensation -! srcs1 = 0. - srcs1 = sol_factic(i,k)*cldt(i,k)*fracp*tracer(i,k)*(1._r8-weight)/deltat & ! liquid - + sol_factiic*cldt(i,k)*fracp*tracer(i,k)*(weight)/deltat ! ice - - - !--mcb - - ! scavenge below cloud - - ! cldmabc(i) = max(cldc(i,k),cldmabc(i)) - ! cldmabc(i) = max(cldt(i,k),cldmabc(i)) - cldmabc(i) = max(cldv(i,k),cldmabc(i)) - cldmabc(i) = cldv(i,k) - - odds=max( & - min(1._r8,precabc(i)/max(cldmabc(i),1.e-5_r8) & - *scavcoef(i,k)*deltat),0._r8) ! Dana and Hales coefficient (/mm) - srcs2 = sol_factb*cldmabc(i)*odds*tracer(i,k)*(1._r8-weight)/deltat & ! liquid - + sol_factbi*cldmabc(i)*odds*tracer(i,k)*(weight)/deltat !ice - !Note that using the temperature-determined weight doesn't make much sense here - - - srcc = srcs1 + srcs2 ! convective tend by both processes - finc = srcs1/(srcc + 1.e-36_r8) ! fraction in-cloud - - ! ****************** Stratiform *********************** - ! now do the stratiform scavenging - - ! incloud scavenging - - ! fracp is the fraction of cloud water converted to precip - fracp = precs(i,k)*deltat/max(cwat(i,k),1.e-12_r8) - fracp = max(0._r8,min(1._r8,fracp)) -! fracp = 0. ! for debug - - ! assume the corresponding amnt of tracer is removed - !++mcb -- remove cldc; change cldt to cldv - ! srcs1 = (cldt(i,k)-cldc(i,k))*fracp*tracer(i,k)/deltat - ! srcs1 = cldv(i,k)*fracp*tracer(i,k)/deltat & -! srcs1 = cldt(i,k)*fracp*tracer(i,k)/deltat ! all condensate - srcs1 = sol_facti*cldt(i,k)*fracp*tracer(i,k)/deltat*(1._r8-weight) & ! liquid - + sol_factii*cldt(i,k)*fracp*tracer(i,k)/deltat*(weight) ! ice - - - ! below cloud scavenging - -! volume undergoing below cloud scavenging - cldmabs(i) = cldv(i,k) ! precipitating volume -! cldmabs(i) = cldt(i,k) ! local cloud volume - - odds = precabs(i)/max(cldmabs(i),1.e-5_r8)*scavcoef(i,k)*deltat - odds = max(min(1._r8,odds),0._r8) - srcs2 =sol_factb*(cldmabs(i)*odds) *tracer(i,k)*(1._r8-weight)/deltat & ! liquid - + sol_factbi*(cldmabs(i)*odds) *tracer(i,k)*(weight)/deltat ! ice - !Note that using the temperature-determined weight doesn't make much sense here - - - srcs = srcs1 + srcs2 ! total stratiform scavenging - fins=srcs1/(srcs + 1.e-36_r8) ! fraction taken by incloud processes - - ! make sure we dont take out more than is there - ! ratio of amount available to amount removed - rat(i) = tracer(i,k)/max(deltat*(srcc+srcs),1.e-36_r8) - if (rat(i).lt.1._r8) then - srcs = srcs*rat(i) - srcc = srcc*rat(i) - endif - srct(i) = (srcc+srcs)*omsm - - - ! fraction that is not removed within the cloud - ! (assumed to be interstitial, and subject to convective transport) - fracp = deltat*srct(i)/max(cldmabs(i)*tracer(i,k),1.e-36_r8) ! amount removed - fracp = max(0._r8,min(1._r8,fracp)) - fracis(i,k) = 1._r8 - fracp - - ! tend is all tracer removed by scavenging, plus all re-appearing from evaporation above - scavt(i,k) = -srct(i) + fracev(i)*scavab(i)*gravit/pdel(i,k) - iscavt(i,k) = -(srcc*finc + srcs*fins)*omsm - - if ( present(icscavt) ) icscavt(i,k) = -(srcc*finc) * omsm - if ( present(isscavt) ) isscavt(i,k) = -(srcs*fins) * omsm - if ( present(bcscavt) ) bcscavt(i,k) = -(srcc * (1-finc)) * omsm - if ( present(bsscavt) ) bsscavt(i,k) = -(srcs * (1-fins)) * omsm + & - fracev(i)*scavab(i)*gravit/pdel(i,k) - - dblchek(i) = tracer(i,k) + deltat*scavt(i,k) - - ! now keep track of scavenged mass and precip - scavab(i) = scavab(i)*(1-fracev(i)) + srcs*pdel(i,k)/gravit - precabs(i) = precabs(i) + (precs(i,k) - evaps(i,k))*pdel(i,k)/gravit - scavabc(i) = scavabc(i) + srcc*pdel(i,k)/gravit - precabc(i) = precabc(i) + (cmfdqr(i,k))*pdel(i,k)/gravit - tracab(i) = tracab(i) + tracer(i,k)*pdel(i,k)/gravit - - end do - - found = .false. - do i = 1,ncol - if ( dblchek(i) < 0._r8 ) then - found = .true. - exit - end if - end do - - if ( found ) then - do i = 1,ncol - if (dblchek(i) .lt. 0._r8) then - write(*,*) ' wetdapa: negative value ', i, k, tracer(i,k), & - dblchek(i), scavt(i,k), srct(i), rat(i), fracev(i) - endif - end do - endif - - end do - - end subroutine wetdepa_v1 - -!============================================================================== - -! wetdepg is currently being used for both CAM4 and CAM5 by making use of the -! cam_physpkg_is method. - - subroutine wetdepg( t, p, q, pdel, & - cldt, cldc, cmfdqr, evapc, precs, evaps, & - rain, cwat, tracer, deltat, molwt, & - solconst, scavt, iscavt, cldv, icwmr1, & - icwmr2, fracis, ncol ) - - !----------------------------------------------------------------------- - ! Purpose: - ! scavenging of gas phase constituents by henry's law - ! - ! Author: P. Rasch - !----------------------------------------------------------------------- - - real(r8), intent(in) ::& - t(pcols,pver), &! temperature - p(pcols,pver), &! pressure - q(pcols,pver), &! moisture - pdel(pcols,pver), &! pressure thikness - cldt(pcols,pver), &! total cloud fraction - cldc(pcols,pver), &! convective cloud fraction - cmfdqr(pcols,pver), &! rate of production of convective precip - rain (pcols,pver), &! total rainwater mixing ratio - cwat(pcols,pver), &! cloud water amount - precs(pcols,pver), &! rate of production of stratiform precip - evaps(pcols,pver), &! rate of evaporation of precip -! Sungsu - evapc(pcols,pver), &! Rate of evaporation of convective precipitation -! Sungsu - cldv(pcols,pver), &! estimate of local volume occupied by clouds - icwmr1 (pcols,pver), &! in cloud water mixing ration for zhang scheme - icwmr2 (pcols,pver), &! in cloud water mixing ration for hack scheme - deltat, &! time step - tracer(pcols,pver), &! trace species - molwt ! molecular weights - - integer, intent(in) :: ncol - - real(r8) & - solconst(pcols,pver) ! Henry's law coefficient - - real(r8), intent(out) ::& - scavt(pcols,pver), &! scavenging tend - iscavt(pcols,pver), &! incloud scavenging tends - fracis(pcols, pver) ! fraction of constituent that is insoluble - - ! local variables - - integer i ! x index - integer k ! z index - - real(r8) adjfac ! factor stolen from cmfmca - real(r8) aqfrac ! fraction of tracer in aqueous phase - real(r8) cwatc ! local convective total water amount - real(r8) cwats ! local stratiform total water amount - real(r8) cwatl ! local cloud liq water amount - real(r8) cwatp ! local water amount falling from above precip - real(r8) cwatpl ! local water amount falling from above precip (liq) - real(r8) cwatt ! local sum of strat + conv total water amount - real(r8) cwatti ! cwatt/cldv = cloudy grid volume mixing ratio - real(r8) fracev ! fraction of precip from above that is evaporating - real(r8) fracp ! fraction of cloud water converted to precip - real(r8) gafrac ! fraction of tracer in gas phasea - real(r8) hconst ! henry's law solubility constant when equation is expressed - ! in terms of mixing ratios - real(r8) mpla ! moles / liter H2O entering the layer from above - real(r8) mplb ! moles / liter H2O leaving the layer below - real(r8) omsm ! 1 - (a small number) - real(r8) part ! partial pressure of tracer in atmospheres - real(r8) patm ! total pressure in atmospheres - real(r8) pdog ! work variable (pdel/gravit) - real(r8) precab(pcols) ! precip from above (work array) - real(r8) precbl ! precip work variable - real(r8) precxx ! precip work variable - real(r8) precxx2 ! - real(r8) precic ! precip work variable - real(r8) rat ! ratio of amount available to amount removed - real(r8) scavab(pcols) ! scavenged tracer flux from above (work array) - real(r8) scavabc(pcols) ! scavenged tracer flux from above (work array) - ! real(r8) vfall ! fall speed of precip - real(r8) scavmax ! an estimate of the max tracer avail for removal - real(r8) scavbl ! flux removed at bottom of layer - real(r8) fins ! in cloud fraction removed by strat rain - real(r8) finc ! in cloud fraction removed by conv rain - real(r8) rate ! max removal rate estimate - real(r8) scavlimt ! limiting value 1 - real(r8) scavt1 ! limiting value 2 - real(r8) scavin ! scavenging by incloud processes - real(r8) scavbc ! scavenging by below cloud processes - real(r8) tc - real(r8) weight ! ice fraction - real(r8) wtpl ! work variable - real(r8) cldmabs(pcols) ! maximum cloud at or above this level - real(r8) cldmabc(pcols) ! maximum cloud at or above this level - !----------------------------------------------------------- - - omsm = 1._r8-2*epsilon(1._r8) ! used to prevent roundoff errors below zero - - adjfac = deltat/(max(deltat,cmftau)) ! adjustment factor from hack scheme - - ! assume 4 m/s fall speed currently (should be improved) - ! vfall = 4. - - ! zero accumulators - do i = 1,pcols - precab(i) = 1.e-36_r8 - scavab(i) = 0._r8 - cldmabs(i) = 0._r8 - end do - - do k = 1,pver - do i = 1,ncol - - tc = t(i,k) - tmelt - weight = max(0._r8,min(-tc*0.05_r8,1.0_r8)) ! fraction of condensate that is ice - - cldmabs(i) = max(cldmabs(i),cldt(i,k)) - - ! partitioning coefs for gas and aqueous phase - ! take as a cloud water amount, the sum of the stratiform amount - ! plus the convective rain water amount - - ! convective amnt is just the local precip rate from the hack scheme - ! since there is no storage of water, this ignores that falling from above - ! cwatc = cmfdqr(i,k)*deltat/adjfac - !++mcb -- test cwatc - cwatc = (icwmr1(i,k) + icwmr2(i,k)) * (1._r8-weight) - !--mcb - - ! strat cloud water amount and also ignore the part falling from above - cwats = cwat(i,k) - - ! cloud water as liq - !++mcb -- add cwatc later (in cwatti) - ! cwatl = (1.-weight)*(cwatc+cwats) - cwatl = (1._r8-weight)*cwats - ! cloud water as ice - !*not used cwati = weight*(cwatc+cwats) - - ! total suspended condensate as liquid - cwatt = cwatl + rain(i,k) - - ! incloud version - !++mcb -- add cwatc here - cwatti = cwatt/max(cldv(i,k), 0.00001_r8) + cwatc - - ! partitioning terms - patm = p(i,k)/1.013e5_r8 ! pressure in atmospheres - hconst = molwta*patm*solconst(i,k)*cwatti/rhoh2o - aqfrac = hconst/(1._r8+hconst) - gafrac = 1/(1._r8+hconst) - fracis(i,k) = gafrac - - - ! partial pressure of the tracer in the gridbox in atmospheres - part = patm*gafrac*tracer(i,k)*molwta/molwt - - ! use henrys law to give moles tracer /liter of water - ! in this volume - ! then convert to kg tracer /liter of water (kg tracer / kg water) - mplb = solconst(i,k)*part*molwt/1000._r8 - - - pdog = pdel(i,k)/gravit - - ! this part of precip will be carried downward but at a new molarity of mpl - precic = pdog*(precs(i,k) + cmfdqr(i,k)) - - ! we cant take out more than entered, plus that available in the cloud - ! scavmax = scavab(i)+tracer(i,k)*cldt(i,k)/deltat*pdog - scavmax = scavab(i)+tracer(i,k)*cldv(i,k)/deltat*pdog - - ! flux of tracer by incloud processes - scavin = precic*(1._r8-weight)*mplb - - ! fraction of precip which entered above that leaves below - if (.TRUE.) then - ! Sungsu added evaporation of convective precipitation below. - precxx = precab(i)-pdog*(evaps(i,k)+evapc(i,k)) - else - precxx = precab(i)-pdog*evaps(i,k) - end if - precxx = max (precxx,0.0_r8) - - ! flux of tracer by below cloud processes - !++mcb -- removed wtpl because it is now not assigned and previously - ! when it was assigned it was unnecessary: if(tc.gt.0)wtpl=1 - if (tc.gt.0) then - ! scavbc = precxx*wtpl*mplb ! if liquid - scavbc = precxx*mplb ! if liquid - else - precxx2=max(precxx,1.e-36_r8) - scavbc = scavab(i)*precxx2/(precab(i)) ! if ice - endif - - scavbl = min(scavbc + scavin, scavmax) - - ! first guess assuming that henries law works - scavt1 = (scavab(i)-scavbl)/pdog*omsm - - ! pjr this should not be required, but we put it in to make sure we cant remove too much - ! remember, scavt1 is generally negative (indicating removal) - scavt1 = max(scavt1,-tracer(i,k)*cldv(i,k)/deltat) - - !++mcb -- remove this limitation for gas species - !c use the dana and hales or balkanski limit on scavenging - !c rate = precab(i)*0.1 - ! rate = (precic + precxx)*0.1 - ! scavlimt = -tracer(i,k)*cldv(i,k) - ! $ *rate/(1.+rate*deltat) - - ! scavt(i,k) = max(scavt1, scavlimt) - - ! instead just set scavt to scavt1 - scavt(i,k) = scavt1 - !--mcb - - ! now update the amount leaving the layer - scavbl = scavab(i) - scavt(i,k)*pdog - - ! in cloud amount is that formed locally over the total flux out bottom - fins = scavin/(scavin + scavbc + 1.e-36_r8) - iscavt(i,k) = scavt(i,k)*fins - - scavab(i) = scavbl - precab(i) = max(precxx + precic,1.e-36_r8) - - - - end do - end do - - end subroutine wetdepg - -!############################################################################## - -end module wetdep diff --git a/test/ncar_kernels/CAM5_wetdepa/src/wetdep_orig.f90 b/test/ncar_kernels/CAM5_wetdepa/src/wetdep_orig.f90 deleted file mode 100644 index c130e3044b..0000000000 --- a/test/ncar_kernels/CAM5_wetdepa/src/wetdep_orig.f90 +++ /dev/null @@ -1,1199 +0,0 @@ -!#define GENERATE_DRIVER -module wetdep - -!----------------------------------------------------------------------- -! -! Wet deposition routines for both aerosols and gas phase constituents. -! -!----------------------------------------------------------------------- - -use kinds_mod -use params, only: pcols, pver, gravit, rair, tmelt - - - - - - -implicit none -save -private - -public :: wetdepa_v1 ! scavenging codes for very soluble aerosols -- CAM4 version -public :: wetdepa_v2 ! scavenging codes for very soluble aerosols -- CAM5 version -public :: wetdepg ! scavenging of gas phase constituents by henry's law -public :: clddiag ! calc of cloudy volume and rain mixing ratio - -real(r8), parameter :: cmftau = 3600._r8 -real(r8), parameter :: rhoh2o = 1000._r8 ! density of water -real(r8), parameter :: molwta = 28.97_r8 ! molecular weight dry air gm/mole - - - - -!============================================================================== -contains -!============================================================================== - -subroutine clddiag(t, pmid, pdel, cmfdqr, evapc, & - cldt, cldcu, cldst, cme, evapr, & - prain, cldv, cldvcu, cldvst, rain, & - ncol) - - ! ------------------------------------------------------------------------------------ - ! Estimate the cloudy volume which is occupied by rain or cloud water as - ! the max between the local cloud amount or the - ! sum above of (cloud*positive precip production) sum total precip from above - ! ---------------------------------- x ------------------------ - ! sum above of (positive precip ) sum positive precip from above - ! Author: P. Rasch - ! Sungsu Park. Mar.2010 - ! ------------------------------------------------------------------------------------ - - ! Input arguments: - real(r8), intent(in) :: t(pcols,pver) ! temperature (K) - real(r8), intent(in) :: pmid(pcols,pver) ! pressure at layer midpoints - real(r8), intent(in) :: pdel(pcols,pver) ! pressure difference across layers - real(r8), intent(in) :: cmfdqr(pcols,pver) ! dq/dt due to convective rainout - real(r8), intent(in) :: evapc(pcols,pver) ! Evaporation rate of convective precipitation ( >= 0 ) - real(r8), intent(in) :: cldt(pcols,pver) ! total cloud fraction - real(r8), intent(in) :: cldcu(pcols,pver) ! Cumulus cloud fraction - real(r8), intent(in) :: cldst(pcols,pver) ! Stratus cloud fraction - real(r8), intent(in) :: cme(pcols,pver) ! rate of cond-evap within the cloud - real(r8), intent(in) :: evapr(pcols,pver) ! rate of evaporation of falling precipitation (kg/kg/s) - real(r8), intent(in) :: prain(pcols,pver) ! rate of conversion of condensate to precipitation (kg/kg/s) - integer, intent(in) :: ncol - - ! Output arguments: - real(r8), intent(out) :: cldv(pcols,pver) ! fraction occupied by rain or cloud water - real(r8), intent(out) :: cldvcu(pcols,pver) ! Convective precipitation volume - real(r8), intent(out) :: cldvst(pcols,pver) ! Stratiform precipitation volume - real(r8), intent(out) :: rain(pcols,pver) ! mixing ratio of rain (kg/kg) - - ! Local variables: - integer i, k - real(r8) convfw ! used in fallspeed calculation; taken from findmcnew - real(r8) sumppr(pcols) ! precipitation rate (kg/m2-s) - real(r8) sumpppr(pcols) ! sum of positive precips from above - real(r8) cldv1(pcols) ! precip weighted cloud fraction from above - real(r8) lprec ! local production rate of precip (kg/m2/s) - real(r8) lprecp ! local production rate of precip (kg/m2/s) if positive - real(r8) rho ! air density - real(r8) vfall - real(r8) sumppr_cu(pcols) ! Convective precipitation rate (kg/m2-s) - real(r8) sumpppr_cu(pcols) ! Sum of positive convective precips from above - real(r8) cldv1_cu(pcols) ! Convective precip weighted convective cloud fraction from above - real(r8) lprec_cu ! Local production rate of convective precip (kg/m2/s) - real(r8) lprecp_cu ! Local production rate of convective precip (kg/m2/s) if positive - real(r8) sumppr_st(pcols) ! Stratiform precipitation rate (kg/m2-s) - real(r8) sumpppr_st(pcols) ! Sum of positive stratiform precips from above - real(r8) cldv1_st(pcols) ! Stratiform precip weighted stratiform cloud fraction from above - real(r8) lprec_st ! Local production rate of stratiform precip (kg/m2/s) - real(r8) lprecp_st ! Local production rate of stratiform precip (kg/m2/s) if positive - ! ----------------------------------------------------------------------- - - convfw = 1.94_r8*2.13_r8*sqrt(rhoh2o*gravit*2.7e-4_r8) - do i=1,ncol - sumppr(i) = 0._r8 - cldv1(i) = 0._r8 - sumpppr(i) = 1.e-36_r8 - sumppr_cu(i) = 0._r8 - cldv1_cu(i) = 0._r8 - sumpppr_cu(i) = 1.e-36_r8 - sumppr_st(i) = 0._r8 - cldv1_st(i) = 0._r8 - sumpppr_st(i) = 1.e-36_r8 - end do - - do k = 1,pver - do i = 1,ncol - cldv(i,k) = & - max(min(1._r8, & - cldv1(i)/sumpppr(i) & - )*sumppr(i)/sumpppr(i), & - cldt(i,k) & - ) - lprec = pdel(i,k)/gravit & - *(prain(i,k)+cmfdqr(i,k)-evapr(i,k)) - lprecp = max(lprec,1.e-30_r8) - cldv1(i) = cldv1(i) + cldt(i,k)*lprecp - sumppr(i) = sumppr(i) + lprec - sumpppr(i) = sumpppr(i) + lprecp - - ! For convective precipitation volume at the top interface of each layer. Neglect the current layer. - cldvcu(i,k) = max(min(1._r8,cldv1_cu(i)/sumpppr_cu(i))*(sumppr_cu(i)/sumpppr_cu(i)),0._r8) - lprec_cu = (pdel(i,k)/gravit)*(cmfdqr(i,k)-evapc(i,k)) - lprecp_cu = max(lprec_cu,1.e-30_r8) - cldv1_cu(i) = cldv1_cu(i) + cldcu(i,k)*lprecp_cu - sumppr_cu(i) = sumppr_cu(i) + lprec_cu - sumpppr_cu(i) = sumpppr_cu(i) + lprecp_cu - - ! For stratiform precipitation volume at the top interface of each layer. Neglect the current layer. - cldvst(i,k) = max(min(1._r8,cldv1_st(i)/sumpppr_st(i))*(sumppr_st(i)/sumpppr_st(i)),0._r8) - lprec_st = (pdel(i,k)/gravit)*(prain(i,k)-evapr(i,k)) - lprecp_st = max(lprec_st,1.e-30_r8) - cldv1_st(i) = cldv1_st(i) + cldst(i,k)*lprecp_st - sumppr_st(i) = sumppr_st(i) + lprec_st - sumpppr_st(i) = sumpppr_st(i) + lprecp_st - - rain(i,k) = 0._r8 - if(t(i,k) .gt. tmelt) then - rho = pmid(i,k)/(rair*t(i,k)) - vfall = convfw/sqrt(rho) - rain(i,k) = sumppr(i)/(rho*vfall) - if (rain(i,k).lt.1.e-14_r8) rain(i,k) = 0._r8 - endif - end do - end do - -end subroutine clddiag - -!============================================================================== - -! This is the CAM5 version of wetdepa. - -subroutine wetdepa_v2(t, p, q, pdel, & - cldt, cldc, cmfdqr, evapc, conicw, precs, conds, & - evaps, cwat, tracer, deltat, & - scavt, iscavt, cldv, cldvcu, cldvst, dlf, fracis, sol_fact, ncol, & - scavcoef, is_strat_cloudborne, rate1ord_cw2pr_st, qqcw, f_act_conv, & - icscavt, isscavt, bcscavt, bsscavt, & - sol_facti_in, sol_factbi_in, sol_factii_in, & - sol_factic_in, sol_factiic_in ) - - !----------------------------------------------------------------------- - ! Purpose: - ! scavenging code for very soluble aerosols - ! - ! Author: P. Rasch - ! Modified by T. Bond 3/2003 to track different removals - ! Sungsu Park. Mar.2010 : Impose consistencies with a few changes in physics. - !----------------------------------------------------------------------- - - - - implicit none - - real(r8), intent(in) ::& - t(pcols,pver), &! temperature - p(pcols,pver), &! pressure - q(pcols,pver), &! moisture - pdel(pcols,pver), &! pressure thikness - cldt(pcols,pver), &! total cloud fraction - cldc(pcols,pver), &! convective cloud fraction - cmfdqr(pcols,pver), &! rate of production of convective precip -! Sungsu - evapc(pcols,pver), &! Evaporation rate of convective precipitation -! Sungsu - conicw(pcols,pver), &! convective cloud water - cwat(pcols,pver), &! cloud water amount - precs(pcols,pver), &! rate of production of stratiform precip - conds(pcols,pver), &! rate of production of condensate - evaps(pcols,pver), &! rate of evaporation of precip - cldv(pcols,pver), &! total cloud fraction -! Sungsu - cldvcu(pcols,pver), &! Convective precipitation area at the top interface of each layer - cldvst(pcols,pver), &! Stratiform precipitation area at the top interface of each layer - dlf(pcols,pver), &! Detrainment of convective condensate [kg/kg/s] -! Sungsu - deltat, &! time step - tracer(pcols,pver) ! trace species - - ! If subroutine is called with just sol_fact: - ! sol_fact is used for both in- and below-cloud scavenging - ! If subroutine is called with optional argument sol_facti_in: - ! sol_fact is used for below cloud scavenging - ! sol_facti is used for in cloud scavenging - real(r8), intent(in) :: sol_fact ! solubility factor (fraction of aer scavenged below & in, or just below or sol_facti_in is provided) - integer, intent(in) :: ncol - real(r8), intent(in) :: scavcoef(pcols,pver) ! Dana and Hales coefficient (/mm) (0.1 if not MODAL_AERO) - real(r8), intent(out) ::& - scavt(pcols,pver), &! scavenging tend - iscavt(pcols,pver), &! incloud scavenging tends - fracis(pcols,pver) ! fraction of species not scavenged - ! rce 2010/05/01 - ! is_strat_cloudborne = .true. if tracer is stratiform-cloudborne aerosol; else .false. - logical, intent(in), optional :: is_strat_cloudborne - ! rate1ord_cw2pr_st = 1st order rate for strat cw to precip (1/s) - real(r8), intent(in), optional :: rate1ord_cw2pr_st(pcols,pver) - ! qqcw = strat-cloudborne aerosol corresponding to tracer when is_strat_cloudborne==.false.; else 0.0 - real(r8), intent(in), optional :: qqcw(pcols,pver) - ! f_act_conv = conv-cloud activation fraction when is_strat_cloudborne==.false.; else 0.0 - real(r8), intent(in), optional :: f_act_conv(pcols,pver) - ! end rce 2010/05/01 - - real(r8), intent(in), optional :: sol_facti_in ! solubility factor (frac of aerosol scavenged in cloud) - real(r8), intent(in), optional :: sol_factbi_in ! solubility factor (frac of aerosol scavenged below cloud by ice) - real(r8), intent(in), optional :: sol_factii_in ! solubility factor (frac of aerosol scavenged in cloud by ice) - real(r8), intent(in), optional :: sol_factic_in(pcols,pver) ! sol_facti_in for convective clouds - real(r8), intent(in), optional :: sol_factiic_in ! sol_factii_in for convective clouds - - - real(r8), intent(out), optional :: icscavt(pcols,pver) ! incloud, convective - real(r8), intent(out), optional :: isscavt(pcols,pver) ! incloud, stratiform - real(r8), intent(out), optional :: bcscavt(pcols,pver) ! below cloud, convective - real(r8), intent(out), optional :: bsscavt(pcols,pver) ! below cloud, stratiform - - - - ! local variables - - integer i ! x index - integer k ! z index - - real(r8) adjfac ! factor stolen from cmfmca - real(r8) aqfrac ! fraction of tracer in aqueous phase - real(r8) cwatc ! local convective total water amount - real(r8) cwats ! local stratiform total water amount - real(r8) cwatp ! local water amount falling from above precip - real(r8) fracev(pcols) ! fraction of precip from above that is evaporating -! Sungsu - real(r8) fracev_cu(pcols) ! Fraction of convective precip from above that is evaporating -! Sungsu - real(r8) fracp ! fraction of cloud water converted to precip - real(r8) gafrac ! fraction of tracer in gas phasea - real(r8) hconst ! henry's law solubility constant when equation is expressed - ! in terms of mixing ratios - real(r8) mpla ! moles / liter H2O entering the layer from above - real(r8) mplb ! moles / liter H2O leaving the layer below - real(r8) omsm ! 1 - (a small number) - real(r8) part ! partial pressure of tracer in atmospheres - real(r8) patm ! total pressure in atmospheres - real(r8) pdog ! work variable (pdel/gravit) - real(r8) precabc(pcols) ! conv precip from above (work array) - real(r8) precabs(pcols) ! strat precip from above (work array) - real(r8) precbl ! precip falling out of level (work array) - real(r8) precmin ! minimum convective precip causing scavenging - real(r8) rat(pcols) ! ratio of amount available to amount removed - real(r8) scavab(pcols) ! scavenged tracer flux from above (work array) - real(r8) scavabc(pcols) ! scavenged tracer flux from above (work array) - real(r8) srcc ! tend for convective rain - real(r8) srcs ! tend for stratiform rain - real(r8) srct(pcols) ! work variable - real(r8) tracab(pcols) ! column integrated tracer amount -! real(r8) vfall ! fall speed of precip - real(r8) fins ! fraction of rem. rate by strat rain - real(r8) finc ! fraction of rem. rate by conv. rain - real(r8) srcs1 ! work variable - real(r8) srcs2 ! work variable - real(r8) tc ! temp in celcius - real(r8) weight ! fraction of condensate which is ice - real(r8) cldmabs(pcols) ! maximum cloud at or above this level - real(r8) cldmabc(pcols) ! maximum cloud at or above this level - real(r8) odds ! limit on removal rate (proportional to prec) - real(r8) dblchek(pcols) - logical :: found - - ! Jan.16.2009. Sungsu for wet scavenging below clouds. - ! real(r8) cldovr_cu(pcols) ! Convective precipitation area at the base of each layer - ! real(r8) cldovr_st(pcols) ! Stratiform precipitation area at the base of each layer - - real(r8) tracer_incu - real(r8) tracer_mean - - ! End by Sungsu - - real(r8) sol_facti, sol_factb ! in cloud and below cloud fraction of aerosol scavenged - real(r8) sol_factii, sol_factbi ! in cloud and below cloud fraction of aerosol scavenged by ice - real(r8) sol_factic(pcols,pver) ! sol_facti for convective clouds - real(r8) sol_factiic ! sol_factii for convective clouds - ! sol_factic & solfact_iic added for MODAL_AERO. - ! For stratiform cloud, cloudborne aerosol is treated explicitly, - ! and sol_facti is 1.0 for cloudborne, 0.0 for interstitial. - ! For convective cloud, cloudborne aerosol is not treated explicitly, - ! and sol_factic is 1.0 for both cloudborne and interstitial. - - - - ! ------------------------------------------------------------------------ -! omsm = 1.-1.e-10 ! used to prevent roundoff errors below zero - omsm = 1._r8-2*epsilon(1._r8) ! used to prevent roundoff errors below zero - precmin = 0.1_r8/8.64e4_r8 ! set critical value to 0.1 mm/day in kg/m2/s - - adjfac = deltat/(max(deltat,cmftau)) ! adjustment factor from hack scheme - - ! assume 4 m/s fall speed currently (should be improved) -! vfall = 4. - - ! default (if other sol_facts aren't in call, set all to required sol_fact - sol_facti = sol_fact - sol_factb = sol_fact - sol_factii = sol_fact - sol_factbi = sol_fact - - if ( present(sol_facti_in) ) sol_facti = sol_facti_in - if ( present(sol_factii_in) ) sol_factii = sol_factii_in - if ( present(sol_factbi_in) ) sol_factbi = sol_factbi_in - - sol_factic = sol_facti - sol_factiic = sol_factii - if ( present(sol_factic_in ) ) sol_factic = sol_factic_in - if ( present(sol_factiic_in) ) sol_factiic = sol_factiic_in - - ! this section of code is for highly soluble aerosols, - ! the assumption is that within the cloud that - ! all the tracer is in the cloud water - ! - ! for both convective and stratiform clouds, - ! the fraction of cloud water converted to precip defines - ! the amount of tracer which is pulled out. - ! - - do i = 1,pcols - precabs(i) = 0 - precabc(i) = 0 - scavab(i) = 0 - scavabc(i) = 0 - tracab(i) = 0 - cldmabs(i) = 0 - cldmabc(i) = 0 - - ! Jan.16. Sungsu - ! I added below to compute vertically projected cumulus and stratus fractions from the top to the - ! current model layer by assuming a simple independent maximum overlapping assumption for - ! each cloud. - ! cldovr_cu(i) = 0._r8 - ! cldovr_st(i) = 0._r8 - ! End by Sungsu - - end do - - do k = 1,pver - do i = 1,ncol - tc = t(i,k) - tmelt - weight = max(0._r8,min(-tc*0.05_r8,1.0_r8)) ! fraction of condensate that is ice - weight = 0._r8 ! assume no ice - - pdog = pdel(i,k)/gravit - - ! ****************** Evaporation ************************** - ! calculate the fraction of strat precip from above - ! which evaporates within this layer - fracev(i) = evaps(i,k)*pdel(i,k)/gravit & - /max(1.e-12_r8,precabs(i)) - - ! trap to ensure reasonable ratio bounds - fracev(i) = max(0._r8,min(1._r8,fracev(i))) - -! Sungsu : Same as above but convective precipitation part - fracev_cu(i) = evapc(i,k)*pdel(i,k)/gravit/max(1.e-12_r8,precabc(i)) - fracev_cu(i) = max(0._r8,min(1._r8,fracev_cu(i))) -! Sungsu - ! ****************** Convection *************************** - ! now do the convective scavenging - - ! set odds proportional to fraction of the grid box that is swept by the - ! precipitation =precabc/rhoh20*(area of sphere projected on plane - ! /volume of sphere)*deltat - ! assume the radius of a raindrop is 1 e-3 m from Rogers and Yau, - ! unless the fraction of the area that is cloud is less than odds, in which - ! case use the cloud fraction (assumes precabs is in kg/m2/s) - ! is really: precabs*3/4/1000./1e-3*deltat - ! here I use .1 from Balkanski - ! - ! use a local rate of convective rain production for incloud scav - !odds=max(min(1._r8, & - ! cmfdqr(i,k)*pdel(i,k)/gravit*0.1_r8*deltat),0._r8) - !++mcb -- change cldc to cldt; change cldt to cldv (9/17/96) - ! srcs1 = cldt(i,k)*odds*tracer(i,k)*(1.-weight) & - ! srcs1 = cldv(i,k)*odds*tracer(i,k)*(1.-weight) & - !srcs1 = cldc(i,k)*odds*tracer(i,k)*(1.-weight) & - ! /deltat - - ! fraction of convective cloud water converted to rain - ! Dec.29.2009 : Sungsu multiplied cldc(i,k) to conicw(i,k) below - ! fracp = cmfdqr(i,k)*deltat/max(1.e-8_r8,conicw(i,k)) - ! fracp = cmfdqr(i,k)*deltat/max(1.e-8_r8,cldc(i,k)*conicw(i,k)) - ! Sungsu: Below new formula of 'fracp' is necessary since 'conicw' is a LWC/IWC - ! that has already precipitated out, that is, 'conicw' does not contain - ! precipitation at all ! - fracp = cmfdqr(i,k)*deltat/max(1.e-12_r8,cldc(i,k)*conicw(i,k)+(cmfdqr(i,k)+dlf(i,k))*deltat) ! Sungsu.Mar.19.2010. - ! Dec.29.2009 - ! Note cmfdrq can be negative from evap of rain, so constrain it <-- This is wrong. cmfdqr does not - ! contain evaporation of precipitation. - fracp = max(min(1._r8,fracp),0._r8) - ! remove that amount from within the convective area -! srcs1 = cldc(i,k)*fracp*tracer(i,k)*(1._r8-weight)/deltat ! liquid only -! srcs1 = cldc(i,k)*fracp*tracer(i,k)/deltat ! any condensation -! srcs1 = 0. -! Jan.02.2010. Sungsu : cldt --> cldc below. - ! rce 2010/05/01 - if (present(is_strat_cloudborne)) then ! Tianyi, 2011/03/29 - if ( is_strat_cloudborne ) then - ! only strat in-cloud removal affects strat-cloudborne aerosol - srcs1 = 0._r8 - else - tracer_incu = f_act_conv(i,k)*(tracer(i,k)+& - min(qqcw(i,k),tracer(i,k)*((cldt(i,k)-cldc(i,k))/max(0.01_r8,(1._r8-(cldt(i,k)-cldc(i,k))))))) - srcs1 = sol_factic(i,k)*cldc(i,k)*fracp*tracer_incu*(1._r8-weight)/deltat & ! Liquid - + sol_factiic *cldc(i,k)*fracp*tracer_incu*(weight)/deltat ! Ice - end if - else - srcs1 = sol_factic(i,k)*cldc(i,k)*fracp*tracer(i,k)*(1._r8-weight)/deltat & ! liquid - + sol_factiic*cldc(i,k)*fracp*tracer(i,k)*(weight)/deltat ! ice - end if - - - !--mcb - - ! scavenge below cloud - - ! cldmabc(i) = max(cldc(i,k),cldmabc(i)) - ! cldmabc(i) = max(cldt(i,k),cldmabc(i)) - ! cldmabc(i) = max(cldv(i,k),cldmabc(i)) - ! cldmabc(i) = cldv(i,k) - cldmabc(i) = cldvcu(i,k) - - ! Jan. 16. 2010. Sungsu - ! cldmabc(i) = cldmabc(i) * cldovr_cu(i) / max( 0.01_r8, cldovr_cu(i) + cldovr_st(i) ) - ! End by Sungsu - - ! rce 2010/05/01 - if (present(is_strat_cloudborne)) then ! Tianyi, 2011/03/29 - if ( is_strat_cloudborne ) then - ! only strat in-cloud removal affects strat-cloudborne aerosol - srcs2 = 0._r8 - else - tracer_mean = tracer(i,k)*(1._r8-cldc(i,k)*f_act_conv(i,k))-cldc(i,k)*f_act_conv(i,k)*& - min(qqcw(i,k),tracer(i,k)*((cldt(i,k)-cldc(i,k))/max(0.01_r8,(1._r8-(cldt(i,k)-cldc(i,k)))))) - tracer_mean = max(0._r8,tracer_mean) - odds = max(min(1._r8,precabc(i)/max(cldmabc(i),1.e-5_r8)*scavcoef(i,k)*deltat),0._r8) ! Dana and Hales coefficient (/mm) - srcs2 = sol_factb *cldmabc(i)*odds*tracer_mean*(1._r8-weight)/deltat & ! Liquid - + sol_factbi*cldmabc(i)*odds*tracer_mean*(weight)/deltat ! Ice - end if - else - odds=max( & - min(1._r8,precabc(i)/max(cldmabc(i),1.e-5_r8) & - *scavcoef(i,k)*deltat),0._r8) ! Dana and Hales coefficient (/mm) - srcs2 = sol_factb*cldmabc(i)*odds*tracer(i,k)*(1._r8-weight)/deltat & ! liquid - + sol_factbi*cldmabc(i)*odds*tracer(i,k)*(weight)/deltat !ice - end if - - - !Note that using the temperature-determined weight doesn't make much sense here - - - srcc = srcs1 + srcs2 ! convective tend by both processes - finc = srcs1/(srcc + 1.e-36_r8) ! fraction in-cloud - - ! ****************** Stratiform *********************** - ! now do the stratiform scavenging - - ! incloud scavenging - - ! rce 2010/05/01 - if(present(is_strat_cloudborne)) then ! Tianyi 2011/03/29 - if ( is_strat_cloudborne ) then - ! new code for stratiform incloud scav of cloudborne (modal) aerosol - ! >> use the 1st order cw to precip rate calculated in microphysics routine - ! >> cloudborne aerosol resides in cloudy portion of grid cell, so do not apply "cldt" factor - ! fracp = rate1ord_cw2pr_st(i,k)*deltat - ! fracp = max(0._r8,min(1._r8,fracp)) - fracp = precs(i,k)*deltat/max(cwat(i,k)+precs(i,k)*deltat,1.e-12_r8) ! Sungsu. Mar.19.2010. - fracp = max(0._r8,min(1._r8,fracp)) - srcs1 = sol_facti *fracp*tracer(i,k)/deltat*(1._r8-weight) & ! Liquid - + sol_factii*fracp*tracer(i,k)/deltat*(weight) ! Ice - else - ! strat in-cloud removal only affects strat-cloudborne aerosol - srcs1 = 0._r8 - end if - else - ! fracp is the fraction of cloud water converted to precip - ! Sungsu modified fracp as the convectiv case. - ! Below new formula by Sungsu of 'fracp' is necessary since 'cwat' is a LWC/IWC - ! that has already precipitated out, that is, 'cwat' does not contain - ! precipitation at all ! - ! fracp = precs(i,k)*deltat/max(cwat(i,k),1.e-12_r8) - fracp = precs(i,k)*deltat/max(cwat(i,k)+precs(i,k)*deltat,1.e-12_r8) ! Sungsu. Mar.19.2010. - fracp = max(0._r8,min(1._r8,fracp)) - ! fracp = 0. ! for debug - - ! assume the corresponding amnt of tracer is removed - !++mcb -- remove cldc; change cldt to cldv - ! srcs1 = (cldt(i,k)-cldc(i,k))*fracp*tracer(i,k)/deltat - ! srcs1 = cldv(i,k)*fracp*tracer(i,k)/deltat & - ! srcs1 = cldt(i,k)*fracp*tracer(i,k)/deltat ! all condensate - ! Jan.02.2010. Sungsu : cldt --> cldt - cldc below. - srcs1 = sol_facti*(cldt(i,k)-cldc(i,k))*fracp*tracer(i,k)/deltat*(1._r8-weight) & ! liquid - + sol_factii*(cldt(i,k)-cldc(i,k))*fracp*tracer(i,k)/deltat*(weight) ! ice - end if - ! end rce 2010/05/01 - - - ! below cloud scavenging - -! volume undergoing below cloud scavenging -! cldmabs(i) = cldv(i,k) ! precipitating volume -! cldmabs(i) = cldt(i,k) ! local cloud volume - cldmabs(i) = cldvst(i,k) ! Stratiform precipitation area at the top interface of current layer - - ! Jan. 16. 2010. Sungsu - ! cldmabs(i) = cldmabs(i) * cldovr_st(i) / max( 0.01_r8, cldovr_cu(i) + cldovr_st(i) ) - ! End by Sungsu - - ! rce 2010/05/01 - if (present(is_strat_cloudborne)) then ! Tianyi 2011/03/29 - if ( is_strat_cloudborne ) then - ! only strat in-cloud removal affects strat-cloudborne aerosol - srcs2 = 0._r8 - else - odds = precabs(i)/max(cldmabs(i),1.e-5_r8)*scavcoef(i,k)*deltat - odds = max(min(1._r8,odds),0._r8) - srcs2 = sol_factb *cldmabs(i)*odds*tracer_mean*(1._r8-weight)/deltat & ! Liquid - + sol_factbi*cldmabs(i)*odds*tracer_mean*(weight)/deltat ! Ice - end if - else - odds = precabs(i)/max(cldmabs(i),1.e-5_r8)*scavcoef(i,k)*deltat - odds = max(min(1._r8,odds),0._r8) - srcs2 =sol_factb*(cldmabs(i)*odds) *tracer(i,k)*(1._r8-weight)/deltat & ! liquid - + sol_factbi*(cldmabs(i)*odds) *tracer(i,k)*(weight)/deltat ! ice - end if - - !Note that using the temperature-determined weight doesn't make much sense here - - srcs = srcs1 + srcs2 ! total stratiform scavenging - fins=srcs1/(srcs + 1.e-36_r8) ! fraction taken by incloud processes - - ! make sure we dont take out more than is there - ! ratio of amount available to amount removed - rat(i) = tracer(i,k)/max(deltat*(srcc+srcs),1.e-36_r8) - if (rat(i).lt.1._r8) then - srcs = srcs*rat(i) - srcc = srcc*rat(i) - endif - srct(i) = (srcc+srcs)*omsm - - - ! fraction that is not removed within the cloud - ! (assumed to be interstitial, and subject to convective transport) - fracp = deltat*srct(i)/max(cldmabs(i)*tracer(i,k),1.e-36_r8) ! amount removed - fracp = max(0._r8,min(1._r8,fracp)) - fracis(i,k) = 1._r8 - fracp - - ! tend is all tracer removed by scavenging, plus all re-appearing from evaporation above - ! Sungsu added cumulus contribution in the below 3 blocks - - scavt(i,k) = -srct(i) + (fracev(i)*scavab(i)+fracev_cu(i)*scavabc(i))*gravit/pdel(i,k) - iscavt(i,k) = -(srcc*finc + srcs*fins)*omsm - - if ( present(icscavt) ) icscavt(i,k) = -(srcc*finc) * omsm - if ( present(isscavt) ) isscavt(i,k) = -(srcs*fins) * omsm - if ( present(bcscavt) ) bcscavt(i,k) = -(srcc * (1-finc)) * omsm + & - fracev_cu(i)*scavabc(i)*gravit/pdel(i,k) - if ( present(bsscavt) ) bsscavt(i,k) = -(srcs * (1-fins)) * omsm + & - fracev(i)*scavab(i)*gravit/pdel(i,k) - - dblchek(i) = tracer(i,k) + deltat*scavt(i,k) - - ! now keep track of scavenged mass and precip - scavab(i) = scavab(i)*(1-fracev(i)) + srcs*pdel(i,k)/gravit - precabs(i) = precabs(i) + (precs(i,k) - evaps(i,k))*pdel(i,k)/gravit - scavabc(i) = scavabc(i)*(1-fracev_cu(i)) + srcc*pdel(i,k)/gravit - precabc(i) = precabc(i) + (cmfdqr(i,k) - evapc(i,k))*pdel(i,k)/gravit - tracab(i) = tracab(i) + tracer(i,k)*pdel(i,k)/gravit - - ! Jan.16.2010. Sungsu - ! Compute convective and stratiform precipitation areas at the base interface - ! of current layer. These are for computing 'below cloud scavenging' in the - ! next layer below. - - ! cldovr_cu(i) = max( cldovr_cu(i), cldc(i,k) ) - ! cldovr_st(i) = max( cldovr_st(i), max( 0._r8, cldt(i,k) - cldc(i,k) ) ) - - ! cldovr_cu(i) = max( 0._r8, min ( 1._r8, cldovr_cu(i) ) ) - ! cldovr_st(i) = max( 0._r8, min ( 1._r8, cldovr_st(i) ) ) - - ! End by Sungsu - - end do ! End of i = 1, ncol - - found = .false. - do i = 1,ncol - if ( dblchek(i) < 0._r8 ) then - found = .true. - exit - end if - end do - - if ( found ) then - do i = 1,ncol - if (dblchek(i) .lt. 0._r8) then - write(*,*) ' wetdapa: negative value ', i, k, tracer(i,k), & - dblchek(i), scavt(i,k), srct(i), rat(i), fracev(i) - endif - end do - endif - - end do ! End of k = 1, pver - - - end subroutine wetdepa_v2 - - -!============================================================================== - -! This is the frozen CAM4 version of wetdepa. - - - subroutine wetdepa_v1( t, p, q, pdel, & - cldt, cldc, cmfdqr, conicw, precs, conds, & - evaps, cwat, tracer, deltat, & - scavt, iscavt, cldv, fracis, sol_fact, ncol, & - scavcoef,icscavt, isscavt, bcscavt, bsscavt, & - sol_facti_in, sol_factbi_in, sol_factii_in, & - sol_factic_in, sol_factiic_in ) - - !----------------------------------------------------------------------- - ! Purpose: - ! scavenging code for very soluble aerosols - ! - ! Author: P. Rasch - ! Modified by T. Bond 3/2003 to track different removals - !----------------------------------------------------------------------- - - implicit none - - real(r8), intent(in) ::& - t(pcols,pver), &! temperature - p(pcols,pver), &! pressure - q(pcols,pver), &! moisture - pdel(pcols,pver), &! pressure thikness - cldt(pcols,pver), &! total cloud fraction - cldc(pcols,pver), &! convective cloud fraction - cmfdqr(pcols,pver), &! rate of production of convective precip - conicw(pcols,pver), &! convective cloud water - cwat(pcols,pver), &! cloud water amount - precs(pcols,pver), &! rate of production of stratiform precip - conds(pcols,pver), &! rate of production of condensate - evaps(pcols,pver), &! rate of evaporation of precip - cldv(pcols,pver), &! total cloud fraction - deltat, &! time step - tracer(pcols,pver) ! trace species - ! If subroutine is called with just sol_fact: - ! sol_fact is used for both in- and below-cloud scavenging - ! If subroutine is called with optional argument sol_facti_in: - ! sol_fact is used for below cloud scavenging - ! sol_facti is used for in cloud scavenging - real(r8), intent(in) :: sol_fact ! solubility factor (fraction of aer scavenged below & in, or just below or sol_facti_in is provided) - real(r8), intent(in), optional :: sol_facti_in ! solubility factor (frac of aerosol scavenged in cloud) - real(r8), intent(in), optional :: sol_factbi_in ! solubility factor (frac of aerosol scavenged below cloud by ice) - real(r8), intent(in), optional :: sol_factii_in ! solubility factor (frac of aerosol scavenged in cloud by ice) - real(r8), intent(in), optional :: sol_factic_in(pcols,pver) ! sol_facti_in for convective clouds - real(r8), intent(in), optional :: sol_factiic_in ! sol_factii_in for convective clouds - real(r8), intent(in) :: scavcoef(pcols,pver) ! Dana and Hales coefficient (/mm) (0.1 if not MODAL_AERO) - - integer, intent(in) :: ncol - - real(r8), intent(out) ::& - scavt(pcols,pver), &! scavenging tend - iscavt(pcols,pver), &! incloud scavenging tends - fracis(pcols,pver) ! fraction of species not scavenged - - real(r8), intent(out), optional :: icscavt(pcols,pver) ! incloud, convective - real(r8), intent(out), optional :: isscavt(pcols,pver) ! incloud, stratiform - real(r8), intent(out), optional :: bcscavt(pcols,pver) ! below cloud, convective - real(r8), intent(out), optional :: bsscavt(pcols,pver) ! below cloud, stratiform - - ! local variables - - integer i ! x index - integer k ! z index - - real(r8) adjfac ! factor stolen from cmfmca - real(r8) aqfrac ! fraction of tracer in aqueous phase - real(r8) cwatc ! local convective total water amount - real(r8) cwats ! local stratiform total water amount - real(r8) cwatp ! local water amount falling from above precip - real(r8) fracev(pcols) ! fraction of precip from above that is evaporating - real(r8) fracp ! fraction of cloud water converted to precip - real(r8) gafrac ! fraction of tracer in gas phasea - real(r8) hconst ! henry's law solubility constant when equation is expressed - ! in terms of mixing ratios - real(r8) mpla ! moles / liter H2O entering the layer from above - real(r8) mplb ! moles / liter H2O leaving the layer below - real(r8) omsm ! 1 - (a small number) - real(r8) part ! partial pressure of tracer in atmospheres - real(r8) patm ! total pressure in atmospheres - real(r8) pdog ! work variable (pdel/gravit) - real(r8) precabc(pcols) ! conv precip from above (work array) - real(r8) precabs(pcols) ! strat precip from above (work array) - real(r8) precbl ! precip falling out of level (work array) - real(r8) precmin ! minimum convective precip causing scavenging - real(r8) rat(pcols) ! ratio of amount available to amount removed - real(r8) scavab(pcols) ! scavenged tracer flux from above (work array) - real(r8) scavabc(pcols) ! scavenged tracer flux from above (work array) - real(r8) srcc ! tend for convective rain - real(r8) srcs ! tend for stratiform rain - real(r8) srct(pcols) ! work variable - real(r8) tracab(pcols) ! column integrated tracer amount -! real(r8) vfall ! fall speed of precip - real(r8) fins ! fraction of rem. rate by strat rain - real(r8) finc ! fraction of rem. rate by conv. rain - real(r8) srcs1 ! work variable - real(r8) srcs2 ! work variable - real(r8) tc ! temp in celcius - real(r8) weight ! fraction of condensate which is ice - real(r8) cldmabs(pcols) ! maximum cloud at or above this level - real(r8) cldmabc(pcols) ! maximum cloud at or above this level - real(r8) odds ! limit on removal rate (proportional to prec) - real(r8) dblchek(pcols) - logical :: found - - real(r8) sol_facti, sol_factb ! in cloud and below cloud fraction of aerosol scavenged - real(r8) sol_factii, sol_factbi ! in cloud and below cloud fraction of aerosol scavenged by ice - real(r8) sol_factic(pcols,pver) ! sol_facti for convective clouds - real(r8) sol_factiic ! sol_factii for convective clouds - ! sol_factic & solfact_iic added for MODAL_AERO. - ! For stratiform cloud, cloudborne aerosol is treated explicitly, - ! and sol_facti is 1.0 for cloudborne, 0.0 for interstitial. - ! For convective cloud, cloudborne aerosol is not treated explicitly, - ! and sol_factic is 1.0 for both cloudborne and interstitial. - - ! ------------------------------------------------------------------------ -! omsm = 1.-1.e-10 ! used to prevent roundoff errors below zero - omsm = 1._r8-2*epsilon(1._r8) ! used to prevent roundoff errors below zero - precmin = 0.1_r8/8.64e4_r8 ! set critical value to 0.1 mm/day in kg/m2/s - - adjfac = deltat/(max(deltat,cmftau)) ! adjustment factor from hack scheme - - ! assume 4 m/s fall speed currently (should be improved) -! vfall = 4. - - ! default (if other sol_facts aren't in call, set all to required sol_fact - sol_facti = sol_fact - sol_factb = sol_fact - sol_factii = sol_fact - sol_factbi = sol_fact - - if ( present(sol_facti_in) ) sol_facti = sol_facti_in - if ( present(sol_factii_in) ) sol_factii = sol_factii_in - if ( present(sol_factbi_in) ) sol_factbi = sol_factbi_in - - sol_factic = sol_facti - sol_factiic = sol_factii - if ( present(sol_factic_in ) ) sol_factic = sol_factic_in - if ( present(sol_factiic_in) ) sol_factiic = sol_factiic_in - - ! this section of code is for highly soluble aerosols, - ! the assumption is that within the cloud that - ! all the tracer is in the cloud water - ! - ! for both convective and stratiform clouds, - ! the fraction of cloud water converted to precip defines - ! the amount of tracer which is pulled out. - ! - - do i = 1,pcols - precabs(i) = 0 - precabc(i) = 0 - scavab(i) = 0 - scavabc(i) = 0 - tracab(i) = 0 - cldmabs(i) = 0 - cldmabc(i) = 0 - end do - - do k = 1,pver - do i = 1,ncol - tc = t(i,k) - tmelt - weight = max(0._r8,min(-tc*0.05_r8,1.0_r8)) ! fraction of condensate that is ice - weight = 0._r8 ! assume no ice - - pdog = pdel(i,k)/gravit - - ! ****************** Evaporation ************************** - ! calculate the fraction of strat precip from above - ! which evaporates within this layer - fracev(i) = evaps(i,k)*pdel(i,k)/gravit & - /max(1.e-12_r8,precabs(i)) - - ! trap to ensure reasonable ratio bounds - fracev(i) = max(0._r8,min(1._r8,fracev(i))) - - ! ****************** Convection *************************** - ! now do the convective scavenging - - ! set odds proportional to fraction of the grid box that is swept by the - ! precipitation =precabc/rhoh20*(area of sphere projected on plane - ! /volume of sphere)*deltat - ! assume the radius of a raindrop is 1 e-3 m from Rogers and Yau, - ! unless the fraction of the area that is cloud is less than odds, in which - ! case use the cloud fraction (assumes precabs is in kg/m2/s) - ! is really: precabs*3/4/1000./1e-3*deltat - ! here I use .1 from Balkanski - ! - ! use a local rate of convective rain production for incloud scav - !odds=max(min(1._r8, & - ! cmfdqr(i,k)*pdel(i,k)/gravit*0.1_r8*deltat),0._r8) - !++mcb -- change cldc to cldt; change cldt to cldv (9/17/96) - ! srcs1 = cldt(i,k)*odds*tracer(i,k)*(1.-weight) & - ! srcs1 = cldv(i,k)*odds*tracer(i,k)*(1.-weight) & - !srcs1 = cldc(i,k)*odds*tracer(i,k)*(1.-weight) & - ! /deltat - - ! fraction of convective cloud water converted to rain - fracp = cmfdqr(i,k)*deltat/max(1.e-8_r8,conicw(i,k)) - ! note cmfdrq can be negative from evap of rain, so constrain it - fracp = max(min(1._r8,fracp),0._r8) - ! remove that amount from within the convective area -! srcs1 = cldc(i,k)*fracp*tracer(i,k)*(1._r8-weight)/deltat ! liquid only -! srcs1 = cldc(i,k)*fracp*tracer(i,k)/deltat ! any condensation -! srcs1 = 0. - srcs1 = sol_factic(i,k)*cldt(i,k)*fracp*tracer(i,k)*(1._r8-weight)/deltat & ! liquid - + sol_factiic*cldt(i,k)*fracp*tracer(i,k)*(weight)/deltat ! ice - - - !--mcb - - ! scavenge below cloud - - ! cldmabc(i) = max(cldc(i,k),cldmabc(i)) - ! cldmabc(i) = max(cldt(i,k),cldmabc(i)) - cldmabc(i) = max(cldv(i,k),cldmabc(i)) - cldmabc(i) = cldv(i,k) - - odds=max( & - min(1._r8,precabc(i)/max(cldmabc(i),1.e-5_r8) & - *scavcoef(i,k)*deltat),0._r8) ! Dana and Hales coefficient (/mm) - srcs2 = sol_factb*cldmabc(i)*odds*tracer(i,k)*(1._r8-weight)/deltat & ! liquid - + sol_factbi*cldmabc(i)*odds*tracer(i,k)*(weight)/deltat !ice - !Note that using the temperature-determined weight doesn't make much sense here - - - srcc = srcs1 + srcs2 ! convective tend by both processes - finc = srcs1/(srcc + 1.e-36_r8) ! fraction in-cloud - - ! ****************** Stratiform *********************** - ! now do the stratiform scavenging - - ! incloud scavenging - - ! fracp is the fraction of cloud water converted to precip - fracp = precs(i,k)*deltat/max(cwat(i,k),1.e-12_r8) - fracp = max(0._r8,min(1._r8,fracp)) -! fracp = 0. ! for debug - - ! assume the corresponding amnt of tracer is removed - !++mcb -- remove cldc; change cldt to cldv - ! srcs1 = (cldt(i,k)-cldc(i,k))*fracp*tracer(i,k)/deltat - ! srcs1 = cldv(i,k)*fracp*tracer(i,k)/deltat & -! srcs1 = cldt(i,k)*fracp*tracer(i,k)/deltat ! all condensate - srcs1 = sol_facti*cldt(i,k)*fracp*tracer(i,k)/deltat*(1._r8-weight) & ! liquid - + sol_factii*cldt(i,k)*fracp*tracer(i,k)/deltat*(weight) ! ice - - - ! below cloud scavenging - -! volume undergoing below cloud scavenging - cldmabs(i) = cldv(i,k) ! precipitating volume -! cldmabs(i) = cldt(i,k) ! local cloud volume - - odds = precabs(i)/max(cldmabs(i),1.e-5_r8)*scavcoef(i,k)*deltat - odds = max(min(1._r8,odds),0._r8) - srcs2 =sol_factb*(cldmabs(i)*odds) *tracer(i,k)*(1._r8-weight)/deltat & ! liquid - + sol_factbi*(cldmabs(i)*odds) *tracer(i,k)*(weight)/deltat ! ice - !Note that using the temperature-determined weight doesn't make much sense here - - - srcs = srcs1 + srcs2 ! total stratiform scavenging - fins=srcs1/(srcs + 1.e-36_r8) ! fraction taken by incloud processes - - ! make sure we dont take out more than is there - ! ratio of amount available to amount removed - rat(i) = tracer(i,k)/max(deltat*(srcc+srcs),1.e-36_r8) - if (rat(i).lt.1._r8) then - srcs = srcs*rat(i) - srcc = srcc*rat(i) - endif - srct(i) = (srcc+srcs)*omsm - - - ! fraction that is not removed within the cloud - ! (assumed to be interstitial, and subject to convective transport) - fracp = deltat*srct(i)/max(cldmabs(i)*tracer(i,k),1.e-36_r8) ! amount removed - fracp = max(0._r8,min(1._r8,fracp)) - fracis(i,k) = 1._r8 - fracp - - ! tend is all tracer removed by scavenging, plus all re-appearing from evaporation above - scavt(i,k) = -srct(i) + fracev(i)*scavab(i)*gravit/pdel(i,k) - iscavt(i,k) = -(srcc*finc + srcs*fins)*omsm - - if ( present(icscavt) ) icscavt(i,k) = -(srcc*finc) * omsm - if ( present(isscavt) ) isscavt(i,k) = -(srcs*fins) * omsm - if ( present(bcscavt) ) bcscavt(i,k) = -(srcc * (1-finc)) * omsm - if ( present(bsscavt) ) bsscavt(i,k) = -(srcs * (1-fins)) * omsm + & - fracev(i)*scavab(i)*gravit/pdel(i,k) - - dblchek(i) = tracer(i,k) + deltat*scavt(i,k) - - ! now keep track of scavenged mass and precip - scavab(i) = scavab(i)*(1-fracev(i)) + srcs*pdel(i,k)/gravit - precabs(i) = precabs(i) + (precs(i,k) - evaps(i,k))*pdel(i,k)/gravit - scavabc(i) = scavabc(i) + srcc*pdel(i,k)/gravit - precabc(i) = precabc(i) + (cmfdqr(i,k))*pdel(i,k)/gravit - tracab(i) = tracab(i) + tracer(i,k)*pdel(i,k)/gravit - - end do - - found = .false. - do i = 1,ncol - if ( dblchek(i) < 0._r8 ) then - found = .true. - exit - end if - end do - - if ( found ) then - do i = 1,ncol - if (dblchek(i) .lt. 0._r8) then - write(*,*) ' wetdapa: negative value ', i, k, tracer(i,k), & - dblchek(i), scavt(i,k), srct(i), rat(i), fracev(i) - endif - end do - endif - - end do - - end subroutine wetdepa_v1 - -!============================================================================== - -! wetdepg is currently being used for both CAM4 and CAM5 by making use of the -! cam_physpkg_is method. - - subroutine wetdepg( t, p, q, pdel, & - cldt, cldc, cmfdqr, evapc, precs, evaps, & - rain, cwat, tracer, deltat, molwt, & - solconst, scavt, iscavt, cldv, icwmr1, & - icwmr2, fracis, ncol ) - - !----------------------------------------------------------------------- - ! Purpose: - ! scavenging of gas phase constituents by henry's law - ! - ! Author: P. Rasch - !----------------------------------------------------------------------- - - real(r8), intent(in) ::& - t(pcols,pver), &! temperature - p(pcols,pver), &! pressure - q(pcols,pver), &! moisture - pdel(pcols,pver), &! pressure thikness - cldt(pcols,pver), &! total cloud fraction - cldc(pcols,pver), &! convective cloud fraction - cmfdqr(pcols,pver), &! rate of production of convective precip - rain (pcols,pver), &! total rainwater mixing ratio - cwat(pcols,pver), &! cloud water amount - precs(pcols,pver), &! rate of production of stratiform precip - evaps(pcols,pver), &! rate of evaporation of precip -! Sungsu - evapc(pcols,pver), &! Rate of evaporation of convective precipitation -! Sungsu - cldv(pcols,pver), &! estimate of local volume occupied by clouds - icwmr1 (pcols,pver), &! in cloud water mixing ration for zhang scheme - icwmr2 (pcols,pver), &! in cloud water mixing ration for hack scheme - deltat, &! time step - tracer(pcols,pver), &! trace species - molwt ! molecular weights - - integer, intent(in) :: ncol - - real(r8) & - solconst(pcols,pver) ! Henry's law coefficient - - real(r8), intent(out) ::& - scavt(pcols,pver), &! scavenging tend - iscavt(pcols,pver), &! incloud scavenging tends - fracis(pcols, pver) ! fraction of constituent that is insoluble - - ! local variables - - integer i ! x index - integer k ! z index - - real(r8) adjfac ! factor stolen from cmfmca - real(r8) aqfrac ! fraction of tracer in aqueous phase - real(r8) cwatc ! local convective total water amount - real(r8) cwats ! local stratiform total water amount - real(r8) cwatl ! local cloud liq water amount - real(r8) cwatp ! local water amount falling from above precip - real(r8) cwatpl ! local water amount falling from above precip (liq) - real(r8) cwatt ! local sum of strat + conv total water amount - real(r8) cwatti ! cwatt/cldv = cloudy grid volume mixing ratio - real(r8) fracev ! fraction of precip from above that is evaporating - real(r8) fracp ! fraction of cloud water converted to precip - real(r8) gafrac ! fraction of tracer in gas phasea - real(r8) hconst ! henry's law solubility constant when equation is expressed - ! in terms of mixing ratios - real(r8) mpla ! moles / liter H2O entering the layer from above - real(r8) mplb ! moles / liter H2O leaving the layer below - real(r8) omsm ! 1 - (a small number) - real(r8) part ! partial pressure of tracer in atmospheres - real(r8) patm ! total pressure in atmospheres - real(r8) pdog ! work variable (pdel/gravit) - real(r8) precab(pcols) ! precip from above (work array) - real(r8) precbl ! precip work variable - real(r8) precxx ! precip work variable - real(r8) precxx2 ! - real(r8) precic ! precip work variable - real(r8) rat ! ratio of amount available to amount removed - real(r8) scavab(pcols) ! scavenged tracer flux from above (work array) - real(r8) scavabc(pcols) ! scavenged tracer flux from above (work array) - ! real(r8) vfall ! fall speed of precip - real(r8) scavmax ! an estimate of the max tracer avail for removal - real(r8) scavbl ! flux removed at bottom of layer - real(r8) fins ! in cloud fraction removed by strat rain - real(r8) finc ! in cloud fraction removed by conv rain - real(r8) rate ! max removal rate estimate - real(r8) scavlimt ! limiting value 1 - real(r8) scavt1 ! limiting value 2 - real(r8) scavin ! scavenging by incloud processes - real(r8) scavbc ! scavenging by below cloud processes - real(r8) tc - real(r8) weight ! ice fraction - real(r8) wtpl ! work variable - real(r8) cldmabs(pcols) ! maximum cloud at or above this level - real(r8) cldmabc(pcols) ! maximum cloud at or above this level - !----------------------------------------------------------- - - omsm = 1._r8-2*epsilon(1._r8) ! used to prevent roundoff errors below zero - - adjfac = deltat/(max(deltat,cmftau)) ! adjustment factor from hack scheme - - ! assume 4 m/s fall speed currently (should be improved) - ! vfall = 4. - - ! zero accumulators - do i = 1,pcols - precab(i) = 1.e-36_r8 - scavab(i) = 0._r8 - cldmabs(i) = 0._r8 - end do - - do k = 1,pver - do i = 1,ncol - - tc = t(i,k) - tmelt - weight = max(0._r8,min(-tc*0.05_r8,1.0_r8)) ! fraction of condensate that is ice - - cldmabs(i) = max(cldmabs(i),cldt(i,k)) - - ! partitioning coefs for gas and aqueous phase - ! take as a cloud water amount, the sum of the stratiform amount - ! plus the convective rain water amount - - ! convective amnt is just the local precip rate from the hack scheme - ! since there is no storage of water, this ignores that falling from above - ! cwatc = cmfdqr(i,k)*deltat/adjfac - !++mcb -- test cwatc - cwatc = (icwmr1(i,k) + icwmr2(i,k)) * (1._r8-weight) - !--mcb - - ! strat cloud water amount and also ignore the part falling from above - cwats = cwat(i,k) - - ! cloud water as liq - !++mcb -- add cwatc later (in cwatti) - ! cwatl = (1.-weight)*(cwatc+cwats) - cwatl = (1._r8-weight)*cwats - ! cloud water as ice - !*not used cwati = weight*(cwatc+cwats) - - ! total suspended condensate as liquid - cwatt = cwatl + rain(i,k) - - ! incloud version - !++mcb -- add cwatc here - cwatti = cwatt/max(cldv(i,k), 0.00001_r8) + cwatc - - ! partitioning terms - patm = p(i,k)/1.013e5_r8 ! pressure in atmospheres - hconst = molwta*patm*solconst(i,k)*cwatti/rhoh2o - aqfrac = hconst/(1._r8+hconst) - gafrac = 1/(1._r8+hconst) - fracis(i,k) = gafrac - - - ! partial pressure of the tracer in the gridbox in atmospheres - part = patm*gafrac*tracer(i,k)*molwta/molwt - - ! use henrys law to give moles tracer /liter of water - ! in this volume - ! then convert to kg tracer /liter of water (kg tracer / kg water) - mplb = solconst(i,k)*part*molwt/1000._r8 - - - pdog = pdel(i,k)/gravit - - ! this part of precip will be carried downward but at a new molarity of mpl - precic = pdog*(precs(i,k) + cmfdqr(i,k)) - - ! we cant take out more than entered, plus that available in the cloud - ! scavmax = scavab(i)+tracer(i,k)*cldt(i,k)/deltat*pdog - scavmax = scavab(i)+tracer(i,k)*cldv(i,k)/deltat*pdog - - ! flux of tracer by incloud processes - scavin = precic*(1._r8-weight)*mplb - - ! fraction of precip which entered above that leaves below - if (.TRUE.) then - ! Sungsu added evaporation of convective precipitation below. - precxx = precab(i)-pdog*(evaps(i,k)+evapc(i,k)) - else - precxx = precab(i)-pdog*evaps(i,k) - end if - precxx = max (precxx,0.0_r8) - - ! flux of tracer by below cloud processes - !++mcb -- removed wtpl because it is now not assigned and previously - ! when it was assigned it was unnecessary: if(tc.gt.0)wtpl=1 - if (tc.gt.0) then - ! scavbc = precxx*wtpl*mplb ! if liquid - scavbc = precxx*mplb ! if liquid - else - precxx2=max(precxx,1.e-36_r8) - scavbc = scavab(i)*precxx2/(precab(i)) ! if ice - endif - - scavbl = min(scavbc + scavin, scavmax) - - ! first guess assuming that henries law works - scavt1 = (scavab(i)-scavbl)/pdog*omsm - - ! pjr this should not be required, but we put it in to make sure we cant remove too much - ! remember, scavt1 is generally negative (indicating removal) - scavt1 = max(scavt1,-tracer(i,k)*cldv(i,k)/deltat) - - !++mcb -- remove this limitation for gas species - !c use the dana and hales or balkanski limit on scavenging - !c rate = precab(i)*0.1 - ! rate = (precic + precxx)*0.1 - ! scavlimt = -tracer(i,k)*cldv(i,k) - ! $ *rate/(1.+rate*deltat) - - ! scavt(i,k) = max(scavt1, scavlimt) - - ! instead just set scavt to scavt1 - scavt(i,k) = scavt1 - !--mcb - - ! now update the amount leaving the layer - scavbl = scavab(i) - scavt(i,k)*pdog - - ! in cloud amount is that formed locally over the total flux out bottom - fins = scavin/(scavin + scavbc + 1.e-36_r8) - iscavt(i,k) = scavt(i,k)*fins - - scavab(i) = scavbl - precab(i) = max(precxx + precic,1.e-36_r8) - - - - end do - end do - - end subroutine wetdepg - -!############################################################################## - -end module wetdep diff --git a/test/ncar_kernels/CAM5_wetdepa/src/wetdepa_driver.F90 b/test/ncar_kernels/CAM5_wetdepa/src/wetdepa_driver.F90 deleted file mode 100644 index 3ff6db4694..0000000000 --- a/test/ncar_kernels/CAM5_wetdepa/src/wetdepa_driver.F90 +++ /dev/null @@ -1,262 +0,0 @@ - ! Generating file: wetdepa_v2.spo - program wetdepa_v2_driver - - use wetdep - - implicit none - integer :: i,j,k,n1,n2,n3 - integer :: it - integer, parameter :: i4 = selected_int_kind ( 6) ! 4 byte integer - integer, parameter :: r4 = selected_real_kind ( 6) ! 4 byte real - integer, parameter :: r8 = selected_real_kind (12) ! 8 byte real - integer(i4) :: val1_i4,val2_i4 - real(r4) :: val1_r4,val2_r4 - real(r8) :: val1_r8,val2_r8, rel_r8 - real(r8), parameter :: eps = 1.E-14 - real(r8), parameter :: Infinity_t = 290.00_r8 - real(r8), parameter :: Infinity_p = 53174.1653037401_r8 - real(r8), parameter :: Infinity_q = 1.092586539789276E-002 - real(r8), parameter :: Infinity_pdel = 2318.55362653732_r8 - real(r8), parameter :: Underflow = 0.0 - logical :: errorDetected - real(r8) start_time, stop_time - integer :: start_clock,stop_clock,rate_clock - - real(r8), dimension( 16 , 30 ) :: t -!DIR$ ATTRIBUTES ALIGN: 64 :: t - real(r8), dimension( 16 , 30 ) :: p - real(r8), dimension( 16 , 30 ) :: q - real(r8), dimension( 16 , 30 ) :: pdel - real(r8), dimension( 16 , 30 ) :: cldt - real(r8), dimension( 16 , 30 ) :: cldc - real(r8), dimension( 16 , 30 ) :: cmfdqr - real(r8), dimension( 16 , 30 ) :: evapc - real(r8), dimension( 16 , 30 ) :: conicw - real(r8), dimension( 16 , 30 ) :: cwat - real(r8), dimension( 16 , 30 ) :: precs - real(r8), dimension( 16 , 30 ) :: conds - real(r8), dimension( 16 , 30 ) :: evaps - real(r8), dimension( 16 , 30 ) :: cldv - real(r8), dimension( 16 , 30 ) :: cldvcu - real(r8), dimension( 16 , 30 ) :: cldvst - real(r8), dimension( 16 , 30 ) :: dlf - real(r8) :: deltat - real(r8), dimension( 16 , 30 ) :: tracer - real(r8) :: sol_fact - real(r8), dimension( 16 , 30 ) :: scavcoef - real(r8), dimension( 16 , 30 ) :: rate1ord_cw2pr_st - real(r8), dimension( 16 , 30 ) :: qqcw - real(r8), dimension( 16 , 30 ) :: f_act_conv - real(r8) :: sol_facti_in - real(r8) :: sol_factbi_in - real(r8) :: sol_factii_in - real(r8), dimension( 16 , 30 ) :: sol_factic_in - real(r8) :: sol_factiic_in - logical :: is_strat_cloudborne - - integer, parameter :: ntrials = 10000 - - real(r8), dimension( 16 , 30 ) :: scavt, scavt_out - real(r8), dimension( 16 , 30 ) :: iscavt, iscavt_out - real(r8), dimension( 16 , 30 ) :: fracis, fracis_out - real(r8), dimension( 16 , 30 ) :: icscavt, icscavt_out - real(r8), dimension( 16 , 30 ) :: isscavt, isscavt_out - real(r8), dimension( 16 , 30 ) :: bcscavt, bcscavt_out - real(r8), dimension( 16 , 30 ) :: bsscavt, bsscavt_out - integer(i4) :: ncol - - - t( : , : )= 249.034386263986_r8 - p( : , : )= 364.346569404006_r8 - q( : , : )= 2.461868225941993E-006 - pdel( : , : )= 277.645234018564_r8 - cldt( : , : )= 0.626255763599366_r8 - cldc( : , : )= 5.880468503166033E-004 - cmfdqr( : , : )= 1.241832531064138E-009 - evapc( : , : )= 1.060404526009187E-009 - conicw( : , : )= 5.185935053792856E-004 - cwat( : , : )= 5.877465715111163E-012 - precs( : , : )= 1.085056588888535E-008 - conds( : , : )= -1.292209588098710E-009 - evaps( : , : )= 1.317921505262640E-008 - cldv( : , : )= 0.989423625165677_r8 - cldvcu( : , : )= 0.226541172855994_r8 - cldvst( :, : )= 0.961717478206716_r8 - dlf( : , : )= 1.344445793338103E-007 - - errorDetected = .false. - ! real(r8) :: deltat - deltat = 1800.00000000000 - ! real(r8), dimension( 16 , 30 ) :: tracer - tracer( : , : )= 6067770.36711884_r8 - - sol_fact = 0.100000000000000 - ! integer(i4) :: ncol - ncol = 14 - scavcoef( : , : )= 1.024901244576826E-003 - - is_strat_cloudborne = .FALSE. - ! real(r8), dimension( 16 , 30 ) :: rate1ord_cw2pr_st - - rate1ord_cw2pr_st( : , : )= 0.000000000000000E+000 - - ! real(r8), dimension( 16 , 30 ) :: qqcw - qqcw( : , : )= 32847851.8054793_r8 - - ! real(r8), dimension( 16 , 30 ) :: f_act_conv - - f_act_conv( : , : )= 0.800000000000000_r8 - - ! real(r8) :: sol_facti_in - sol_facti_in = 0.000000000000000E+000 - ! real(r8) :: sol_factbi_in - sol_factbi_in = 0.100000000000000_r8 - ! real(r8) :: sol_factii_in - sol_factii_in = 0.000000000000000E+000 - ! real(r8), dimension( 16 , 30 ) :: sol_factic_in - - sol_factic_in( : , : )= 0.400000000000000_r8 - - ! real(r8) :: sol_factiic_in - sol_factiic_in = 0.400000000000000_r8 - ! - ! Insert your call to subroutine here - ! call wetdepa_v2() - ! - call system_clock(start_clock,rate_clock) - call cpu_time(start_time) - do it=1,ntrials - call wetdepa_v2(t, p, q, pdel, & - cldt, cldc, cmfdqr, evapc, conicw, precs, conds, & - evaps, cwat, tracer, deltat, & - scavt_out, iscavt_out, cldv, cldvcu, cldvst, dlf, fracis_out, sol_fact, ncol, & - scavcoef, is_strat_cloudborne, rate1ord_cw2pr_st, qqcw, f_act_conv, & - icscavt_out, isscavt_out, bcscavt_out, bsscavt_out, & - sol_facti_in, sol_factbi_in, sol_factii_in, & - sol_factic_in, sol_factiic_in ) - - ! real(r8), dimension( 16 , 30 ) :: scavt_out - scavt( : , : )= -0.015489807056568383_r8 - iscavt( : , : )= -0.015489807056568383_r8 - isscavt( : , : )= 0.000000000000000E+000 - icscavt(:,:) = -0.015489807056568383_r8 - bcscavt( : , :)= 0.000000000000000E+000 - fracis( : , : )= 0.999995222047063_r8 - enddo - call cpu_time(stop_time) -call system_clock(stop_clock,rate_clock) - - n1=SIZE(scavt,dim=1) - n2=SIZE(scavt,dim=2) - do i=1,1 - do j=1,1 - val1_r8 = scavt(i,j) - val2_r8 = scavt_out(i,j) - rel_r8 = (val1_r8-val2_r8)/val1_r8 - if(abs(rel_r8) > eps) then - errorDetected=.TRUE. - write(*,80) 'scavt:', val1_r8,val2_r8 - print *, 'relerror: scavt(',i,',',j,'): ',rel_r8 - endif - enddo - enddo - 80 format(A, f25.18, f25.18) - ! real(r8), dimension( 16 , 30 ) :: iscavt_out - n1=SIZE(iscavt,dim=1) - n2=SIZE(iscavt,dim=2) - do i=1,1 - do j=1,1 - val1_r8 = iscavt(i,j) - val2_r8 = iscavt_out(i,j) - rel_r8 = (val1_r8-val2_r8)/val1_r8 - if(abs(rel_r8) > eps) then - errorDetected=.TRUE. -! print *, 'error: iscavt(',i,',',j,'): ',val1_r8,' != ',val2_r8 - print *, 'relerror: iscavt(',i,',',j,'): ',rel_r8 - endif - enddo - enddo - ! real(r8), dimension( 16 , 30 ) :: fracis_out - - - n1=SIZE(fracis,dim=1) - n2=SIZE(fracis,dim=2) - do i=1,1 - do j=1,1 - val1_r8 = fracis(i,j) - val2_r8 = fracis_out(i,j) - rel_r8 = (val1_r8-val2_r8)/val1_r8 - if(abs(rel_r8) > eps) then - errorDetected=.TRUE. - print *, 'error: fracis(',i,',',j,'): ',val1_r8,' != ',val2_r8 - print *, 'relerror: fracis(',i,',',j,'): ',rel_r8 - endif - enddo - enddo - ! real(r8), dimension( 16 , 30 ) :: icscavt_out - n1=SIZE(icscavt,dim=1) - n2=SIZE(icscavt,dim=2) - do i=1,1 - do j=1,1 - val1_r8 = icscavt(i,j) - val2_r8 = icscavt_out(i,j) - rel_r8 = (val1_r8-val2_r8)/val1_r8 - if(abs(rel_r8) > eps) then - errorDetected=.TRUE. -! print *, 'error: icscavt(',i,',',j,'): ',val1_r8,' != ',val2_r8 - print *, 'relerror: icscavt(',i,',',j,'): ',rel_r8 - endif - enddo - enddo - ! real(r8), dimension( 16 , 30 ) :: isscavt_out - n1=SIZE(isscavt,dim=1) - n2=SIZE(isscavt,dim=2) - do i=1,1 - do j=1,1 - if(isscavt(i,j) .ne. isscavt_out(i,j)) then - val1_r8 = isscavt(i,j) - val2_r8 = isscavt_out(i,j) - errorDetected=.TRUE. - print *, 'error: isscavt(',i,',',j,'): ',val1_r8,' != ',val2_r8 - endif - enddo - enddo - ! real(r8), dimension( 16 , 30 ) :: bcscavt_out - n1=SIZE(bcscavt,dim=1) - n2=SIZE(bcscavt,dim=2) - do i=1,1 - do j=1,1 - if(bcscavt(i,j) .ne. bcscavt_out(i,j)) then - val1_r8 = bcscavt(i,j) - val2_r8 = bcscavt_out(i,j) - errorDetected=.TRUE. - print *, 'error: bcscavt(',i,',',j,'): ',val1_r8,' != ',val2_r8 - endif - enddo - enddo - ! real(r8), dimension( 16 , 30 ) :: bsscavt_out - n1=SIZE(bsscavt,dim=1) - n2=SIZE(bsscavt,dim=2) - do i=1,1 - do j=1,1 - if(bsscavt(i,j) .ne. bsscavt_out(i,j)) then - val1_r8 = bsscavt(i,j) - val2_r8 = bsscavt_out(i,j) - rel_r8 = (bsscavt(i,j) - bsscavt_out(i,j))/bsscavt(i,j) - print *, 'error: bsscavt(',i,',',j,') =',val1_r8, val2_r8 - errorDetected=.TRUE. -! print *, 'relerror: bsscavt(',i,',',j,'): ',rel_r8 - endif - enddo - enddo - if(errorDetected) then - print *,'Detected error' - print *, 'FAILED' - else - print *,'Correct exection' - print *,'PASSED' -! write(*,'(a,f10.3,a)') ' completed in ', 1.0E6*(real(stop_clock-start_clock,kind=r8)/real(rate_clock,kind=r8)), ' usec' - write(*,'(a,f10.7)') 'total time(sec): ', (stop_time-start_time) - write(*,'(a,f10.3)') 'time per call (usec): ',1e6*(stop_time-start_time)/dble(ntrials) - endif - end program wetdepa_v2_driver diff --git a/test/ncar_kernels/HOMME_div_sphere/CESM_license.txt b/test/ncar_kernels/HOMME_div_sphere/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/HOMME_div_sphere/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/HOMME_div_sphere/inc/t1.mk b/test/ncar_kernels/HOMME_div_sphere/inc/t1.mk deleted file mode 100644 index 2da7171700..0000000000 --- a/test/ncar_kernels/HOMME_div_sphere/inc/t1.mk +++ /dev/null @@ -1,51 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# - -# -# PGI -# -#FC := pgf95 -#FFLAGS := -O3 -# -# Intel -# -# FC := pgfortran -# FFLAGS := -O3 -mmic -qopt-report=5 -fp-model fast -# FFLAGS := -O3 -xCORE-AVX2 -qopt-report=5 -fp-model fast -# FFLAGS := -O3 -xAVX -qopt-report=5 -fp-model fast -# -# GFORTRAN -# -# FC :=gfortran -# FFLAGS := -O3 -ffree-form -ffree-line-length-none -D__GFORTRAN__ -I./ -# # -# -# Cray -# -# FC := ftn -# FFLAGS := -O2 -# - -FC_FLAGS := $(OPT) - -ALL_OBJS := kernel_divergence_sphere.o - -all: build run verify - -verify: - @echo "nothing to be done for verify" - -run: - mkdir rundir; cd rundir; ../kernel.exe - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_divergence_sphere.o: $(SRC_DIR)/kernel_divergence_sphere.F90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f *.exe *.optrpt *.o *.oo *.mod diff --git a/test/ncar_kernels/HOMME_div_sphere/lit/runmake b/test/ncar_kernels/HOMME_div_sphere/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/HOMME_div_sphere/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/HOMME_div_sphere/makefile b/test/ncar_kernels/HOMME_div_sphere/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/HOMME_div_sphere/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/HOMME_div_sphere/src/kernel_divergence_sphere.F90 b/test/ncar_kernels/HOMME_div_sphere/src/kernel_divergence_sphere.F90 deleted file mode 100644 index 635474e7b3..0000000000 --- a/test/ncar_kernels/HOMME_div_sphere/src/kernel_divergence_sphere.F90 +++ /dev/null @@ -1,477 +0,0 @@ - program kgen_kernel_divergence_sphere - - INTEGER , PARAMETER :: np = 4 - - INTEGER(KIND=4) , PARAMETER :: real_kind = 8 - - REAL(KIND=real_kind) , PARAMETER :: rearth = 6.376d6 - - REAL(KIND=real_kind) , PARAMETER :: rrearth = 1.0_real_kind/rearth - - INTEGER , PARAMETER :: nc = 4 - - INTEGER , PARAMETER :: nelem = 64*30 - - INTEGER , PARAMETER :: nip = 3 - - INTEGER , PARAMETER :: nipm = nip-1 - - INTEGER , PARAMETER :: nep = nipm*nc+1 - - TYPE :: derivative_t - REAL(KIND=real_kind) dvv(np,np) - REAL(KIND=real_kind) dvv_diag(np,np) - REAL(KIND=real_kind) dvv_twt(np,np) - REAL(KIND=real_kind) mvv_twt(np,np) - ! diagonal matrix of GLL weights - REAL(KIND=real_kind) mfvm(np,nc+1) - REAL(KIND=real_kind) cfvm(np,nc) - REAL(KIND=real_kind) sfvm(np,nep) - REAL(KIND=real_kind) legdg(np,np) - END TYPE derivative_t - - INTEGER(KIND=4) , PARAMETER :: int_kind = 4 - - INTEGER , PARAMETER :: npsq = np*np - - TYPE :: index_t - INTEGER(KIND=int_kind) ia(npsq), ja(npsq) - INTEGER(KIND=int_kind) is, ie - INTEGER(KIND=int_kind) numuniquepts - INTEGER(KIND=int_kind) uniqueptoffset - END TYPE index_t - - INTEGER(KIND=4) , PARAMETER :: long_kind = 8 - - INTEGER , PARAMETER :: nlev = 20 - - TYPE :: elem_accum_t - REAL(KIND=real_kind) u(np,np,nlev) - REAL(KIND=real_kind) t(np,np,nlev) - REAL(KIND=real_kind) ke(np,np,nlev) - END TYPE elem_accum_t - - TYPE :: derived_state_t - REAL(KIND=real_kind) dummmy - REAL(KIND=real_kind) vstar(np,np,2,nlev) - END TYPE derived_state_t - - INTEGER , PARAMETER :: timelevels = 3 - - TYPE :: elem_state_t - REAL(KIND=real_kind) p(np,np,nlev,timelevels) - REAL(KIND=real_kind) phis(np,np) - REAL(KIND=real_kind) gradps(np,np,2) - REAL(KIND=real_kind) v(np,np,2,nlev,timelevels) - REAL(KIND=real_kind) couv(np,np,2,nlev) - REAL(KIND=real_kind) uv(np,np,2,nlev) - REAL(KIND=real_kind) uv0(np,np,2,nlev) - REAL(KIND=real_kind) pgrads(np,np,2,nlev) - REAL(KIND=real_kind) psi(np,np,nlev) - REAL(KIND=real_kind) phi(np,np,nlev) - REAL(KIND=real_kind) ht(np,np,nlev) - REAL(KIND=real_kind) t(np,np,nlev,timelevels) - REAL(KIND=real_kind) q(np,np,nlev,timelevels) - REAL(KIND=real_kind) pt3d(np,np,nlev) - REAL(KIND=real_kind) qt3d(np,np,nlev) - REAL(KIND=real_kind) peta(np,np,nlev) - REAL(KIND=real_kind) dp3d(np,np,nlev) - REAL(KIND=real_kind) zeta(np,np,nlev) - REAL(KIND=real_kind) pr3d(np,np,nlev+1) - REAL(KIND=real_kind) pr3d_ref(np,np,nlev+1) - REAL(KIND=real_kind) gp3d(np,np,nlev+1) - REAL(KIND=real_kind) ptop(np,np) - REAL(KIND=real_kind) sgp(np,np) - REAL(KIND=real_kind) tbar(nlev) - END TYPE elem_state_t - - TYPE :: rotation_t - INTEGER nbr - INTEGER reverse - REAL(KIND=real_kind), dimension(:,:,:), pointer :: r => null() - END TYPE rotation_t - - INTEGER(KIND=4) , PARAMETER :: log_kind = 4 - - TYPE :: cartesian3d_t - REAL(KIND=real_kind) x - REAL(KIND=real_kind) y - REAL(KIND=real_kind) z - END TYPE cartesian3d_t - - TYPE :: edgedescriptor_t - INTEGER(KIND=int_kind) use_rotation - INTEGER(KIND=int_kind) padding - INTEGER(KIND=int_kind), pointer :: putmapp(:) => null() - INTEGER(KIND=int_kind), pointer :: getmapp(:) => null() - INTEGER(KIND=int_kind), pointer :: putmapp_ghost(:) => null() - INTEGER(KIND=int_kind), pointer :: getmapp_ghost(:) => null() - INTEGER(KIND=int_kind), pointer :: globalid(:) => null() - INTEGER(KIND=int_kind), pointer :: loc2buf(:) => null() - TYPE(cartesian3d_t), pointer :: neigh_corners(:,:) => null() - INTEGER actual_neigh_edges - LOGICAL(KIND=log_kind), pointer :: reverse(:) => null() - TYPE(rotation_t), dimension(:), pointer :: rot => null() - END TYPE edgedescriptor_t - - INTEGER , PARAMETER :: num_neighbors = 8 - - TYPE :: gridvertex_t - INTEGER, pointer :: nbrs(:) => null() - INTEGER, pointer :: nbrs_face(:) => null() - INTEGER, pointer :: nbrs_wgt(:) => null() - INTEGER, pointer :: nbrs_wgt_ghost(:) => null() - INTEGER nbrs_ptr(num_neighbors + 1) - INTEGER face_number - INTEGER number - INTEGER processor_number - INTEGER spacecurve - END TYPE gridvertex_t - - TYPE :: cartesian2d_t - REAL(KIND=real_kind) x - REAL(KIND=real_kind) y - END TYPE cartesian2d_t - - TYPE :: spherical_polar_t - REAL(KIND=real_kind) r - REAL(KIND=real_kind) lon - REAL(KIND=real_kind) lat - END TYPE spherical_polar_t - - TYPE :: element_t - INTEGER(KIND=int_kind) localid - INTEGER(KIND=int_kind) globalid - TYPE(spherical_polar_t) spherep(np,np) - TYPE(cartesian2d_t) cartp(np,np) - TYPE(cartesian2d_t) corners(4) - REAL(KIND=real_kind) u2qmap(4,2) - TYPE(cartesian3d_t) corners3d(4) - REAL(KIND=real_kind) area - REAL(KIND=real_kind) max_eig - REAL(KIND=real_kind) min_eig - REAL(KIND=real_kind) max_eig_ratio - REAL(KIND=real_kind) dx_short - REAL(KIND=real_kind) dx_long - REAL(KIND=real_kind) variable_hyperviscosity(np,np) - REAL(KIND=real_kind) hv_courant - REAL(KIND=real_kind) tensorvisc(2,2,np,np) - INTEGER(KIND=int_kind) node_numbers(4) - INTEGER(KIND=int_kind) node_multiplicity(4) - TYPE(gridvertex_t) vertex - TYPE(edgedescriptor_t) desc - TYPE(elem_state_t) state - TYPE(derived_state_t) derived - TYPE(elem_accum_t) accum - REAL(KIND=real_kind) met(2,2,np,np) - REAL(KIND=real_kind) metinv(2,2,np,np) - REAL(KIND=real_kind) metdet(np,np) - REAL(KIND=real_kind) rmetdet(np,np) - REAL(KIND=real_kind) d(2,2,np,np) - REAL(KIND=real_kind) dinv(2,2,np,np) - REAL(KIND=real_kind) vec_sphere2cart(np,np,3,2) - REAL(KIND=real_kind) dinv2(np,np,2,2) - REAL(KIND=real_kind) mp(np,np) - REAL(KIND=real_kind) rmp(np,np) - REAL(KIND=real_kind) spheremp(np,np) - REAL(KIND=real_kind) rspheremp(np,np) - INTEGER(KIND=long_kind) gdofp(np,np) - REAL(KIND=real_kind) fcor(np,np) - TYPE(index_t) idxp - TYPE(index_t), pointer :: idxv - INTEGER facenum - INTEGER dummy - END TYPE element_t - - - REAL(KIND=real_kind) v(np, np, 2) -!JMD !dir$ attributes align : 64 :: v - - - - TYPE(derivative_t) deriv - - - TYPE(element_t) elem - !JMD manual timer additions - integer*8 c1,c2,cr,cm - integer*8 c12,c22,cr2 - real*8 dt, dt2 - integer :: itmax=10000 - character(len=80), parameter :: kname='[kernel_divergence_sphere]' - character(len=80), parameter :: kname2='[kernel_divergence_sphere_v2]' - integer :: it - !JMD - - REAL(KIND=real_kind) :: DinvTemp(np,np,2,2) - REAL(KIND=real_kind) :: DvvTemp(np,np) - - - REAL(KIND=real_kind) KGEN_RESULT_div(np, np,nelem) - REAL(KIND=real_kind) KGEN_RESULT_div_v2(np, np,nelem) - REAL(KIND=real_kind) KGEN_div(np, np) - - - ! populate dummy initial values - do j=1,np - do i=1,np - elem%metdet(i,j) = 0.1_real_kind * i - elem%Dinv(1,1,i,j) = 0.2_real_kind * j - elem%Dinv(1,2,i,j) = 0.3_real_kind * i*j - elem%Dinv(2,1,i,j) = 0.4_real_kind * i - elem%Dinv(2,2,i,j) = 0.5_real_kind * j - v(i,j,1) = 0.6_real_kind * i*j - v(i,j,2) = 0.7_real_kind * i - deriv%Dvv(i,j) = 0.8_real_kind * j - elem%rmetdet(i,j) = 1.0_real_kind / elem%metdet(i,j) - elem%Dinv2(i,j,1,1) = elem%Dinv(1,1,i,j) - elem%Dinv2(i,j,1,2) = elem%Dinv(1,2,i,j) - elem%Dinv2(i,j,2,1) = elem%Dinv(2,1,i,j) - elem%Dinv2(i,j,2,2) = elem%Dinv(2,2,i,j) - end do - end do - DinvTemp(:,:,1,1) = elem%Dinv(1,1,:,:) - DinvTemp(:,:,1,2) = elem%Dinv(1,2,:,:) - DinvTemp(:,:,2,1) = elem%Dinv(2,1,:,:) - DinvTemp(:,:,2,2) = elem%Dinv(2,2,:,:) - - ! reference result - KGEN_div = divergence_sphere_ref(v,deriv,elem) - - dvvTemp(:,:) = deriv%dvv(:,:) - call system_clock(c12,cr2,cm) - ! modified result - do it=1,itmax - do ie=1,nelem -!JMD KGEN_RESULT_div = divergence_sphere_v2(v,deriv,elem,DinvTemp) - KGEN_RESULT_div(:,:,ie) = divergence_sphere_v2(v,dvvTemp,elem,DinvTemp) - enddo - enddo - call system_clock(c22,cr2,cm) - dt2 = dble(c22-c12)/dble(cr2) - print *, TRIM(kname2), ' total time (sec): ',dt2 - print *, TRIM(kname2), ' time per call (usec): ',1.e6*dt2/dble(itmax) - - ! populate dummy initial values - do j=1,np - do i=1,np - elem%metdet(i,j) = 0.1_real_kind * i - elem%Dinv(1,1,i,j) = 0.2_real_kind * j - elem%Dinv(1,2,i,j) = 0.3_real_kind * i*j - elem%Dinv(2,1,i,j) = 0.4_real_kind * i - elem%Dinv(2,2,i,j) = 0.5_real_kind * j - v(i,j,1) = 0.6_real_kind * i*j - v(i,j,2) = 0.7_real_kind * i - deriv%Dvv(i,j) = 0.8_real_kind * j - elem%rmetdet(i,j) = 1.0_real_kind / elem%metdet(i,j) - elem%Dinv2(i,j,1,1) = elem%Dinv(1,1,i,j) - elem%Dinv2(i,j,1,2) = elem%Dinv(1,2,i,j) - elem%Dinv2(i,j,2,1) = elem%Dinv(2,1,i,j) - elem%Dinv2(i,j,2,2) = elem%Dinv(2,2,i,j) - end do - end do - DinvTemp(:,:,1,1) = elem%Dinv(1,1,:,:) - DinvTemp(:,:,1,2) = elem%Dinv(1,2,:,:) - DinvTemp(:,:,2,1) = elem%Dinv(2,1,:,:) - DinvTemp(:,:,2,2) = elem%Dinv(2,2,:,:) - - - call system_clock(c1,cr,cm) - ! modified result - do it=1,itmax - do ie=1,nelem - KGEN_RESULT_div(:,:,ie) = divergence_sphere(v,deriv,elem) - enddo - enddo - call system_clock(c2,cr,cm) - dt = dble(c2-c1)/dble(cr) - print *, TRIM(kname), ' total time (sec): ',dt - print *, TRIM(kname), ' time per call (usec): ',1.e6*dt/dble(itmax) - - - IF ( ALL( KGEN_div == KGEN_RESULT_div(:,:,1) ) ) THEN - WRITE(*,*) "div is identical. Test PASSED" - WRITE(*,*) "Modified: ", KGEN_div - WRITE(*,*) "Reference: ", KGEN_RESULT_div(:,:,1) - ELSE - WRITE(*,*) "div is NOT identical. Test FAILED" - WRITE(*,*) COUNT( KGEN_div /= KGEN_RESULT_div(:,:,1)), " of ", SIZE( KGEN_RESULT_div ), " elements are different." - WRITE(*,*) "RMS of difference is ", SQRT(SUM((KGEN_div - KGEN_RESULT_div(:,:,1))**2)/SIZE(KGEN_div)) - WRITE(*,*) "Minimum difference is ", MINVAL(ABS(KGEN_div - KGEN_RESULT_div(:,:,1))) - WRITE(*,*) "Maximum difference is ", MAXVAL(ABS(KGEN_div - KGEN_RESULT_div(:,:,1))) - WRITE(*,*) "Mean value of kernel-generated div is ", SUM(KGEN_RESULT_div(:,:,1))/SIZE(KGEN_RESULT_div(:,:,1)) - WRITE(*,*) "Mean value of original div is ", SUM(KGEN_div)/SIZE(KGEN_div) - WRITE(*,*) "" - STOP - END IF - - contains - - function divergence_sphere_ref(v,deriv,elem) result(div) - ! - ! input: v = velocity in lat-lon coordinates - ! ouput: div(v) spherical divergence of v - ! - real(kind=real_kind), intent(in) :: v(np,np,2) - ! in lat-lon coordinates - type (derivative_t), intent(in) :: deriv - type (element_t), intent(in) :: elem - real(kind=real_kind) :: div(np,np) - - ! Local - - integer i - integer j - integer l - - real(kind=real_kind) :: dudx00 - real(kind=real_kind) :: dvdy00 - real(kind=real_kind) :: gv(np,np,2),vvtemp(np,np) - - ! convert to contra variant form and multiply by g - do j=1,np - do i=1,np - gv(i,j,1)=elem%metdet(i,j)*(elem%Dinv(1,1,i,j)*v(i,j,1) + elem%Dinv(1,2,i,j)*v(i,j,2)) - gv(i,j,2)=elem%metdet(i,j)*(elem%Dinv(2,1,i,j)*v(i,j,1) + elem%Dinv(2,2,i,j)*v(i,j,2)) - enddo - enddo - - ! compute d/dx and d/dy - do j=1,np - do l=1,np - dudx00=0.0d0 - dvdy00=0.0d0 - do i=1,np - dudx00 = dudx00 + deriv%Dvv(i,l )*gv(i,j ,1) - dvdy00 = dvdy00 + deriv%Dvv(i,l )*gv(j ,i,2) - end do - div(l ,j ) = dudx00 - vvtemp(j ,l ) = dvdy00 - end do - end do - - - do j=1,np - do i=1,np - div(i,j)=(div(i,j)+vvtemp(i,j))*(elem%rmetdet(i,j)*rrearth) - end do - end do - - end function divergence_sphere_ref - - function divergence_sphere(v,deriv,elem) result(div) - ! - ! input: v = velocity in lat-lon coordinates - ! ouput: div(v) spherical divergence of v - ! - real(kind=real_kind), intent(in) :: v(np,np,2) - ! in lat-lon coordinates - type (derivative_t), intent(in) :: deriv - type (element_t), intent(in) :: elem - real(kind=real_kind) :: div(np,np) - - ! Local - - integer i - integer j - integer l - - real(kind=real_kind) :: dudx00 - real(kind=real_kind) :: dvdy00 - real(kind=real_kind) :: gv(np,np,2) - real(kind=real_kind) :: vvtemp(np,np) - - ! convert to contra variant form and multiply by g - do j=1,np - do i=1,np - gv(i,j,1)=elem%metdet(i,j)*(elem%Dinv(1,1,i,j)*v(i,j,1) + elem%Dinv(1,2,i,j)*v(i,j,2)) - gv(i,j,2)=elem%metdet(i,j)*(elem%Dinv(2,1,i,j)*v(i,j,1) + elem%Dinv(2,2,i,j)*v(i,j,2)) - enddo - enddo - - ! compute d/dx and d/dy - do j=1,np - do l=1,np - dudx00=0.0d0 - dvdy00=0.0d0 - do i=1,np - dudx00 = dudx00 + deriv%Dvv(i,l )*gv(i,j ,1) - dvdy00 = dvdy00 + deriv%Dvv(i,l )*gv(j ,i,2) - end do - div(l ,j ) = dudx00 - vvtemp(j ,l ) = dvdy00 - end do - end do - - - do j=1,np - do i=1,np - div(i,j)=(div(i,j)+vvtemp(i,j))*(elem%rmetdet(i,j)*rrearth) - end do - end do - - end function divergence_sphere - -!DIR$ ATTRIBUTES FORCEINLINE :: divergence_sphere_v2 - function divergence_sphere_v2(v,dvv,elem,Dinv2) result(div) - ! - ! input: v = velocity in lat-lon coordinates - ! ouput: div(v) spherical divergence of v - ! - real(kind=real_kind), intent(in) :: v(np,np,2) - ! in lat-lon coordinates - !JMD type (derivative_t), intent(in) :: deriv - type (element_t), intent(in) :: elem - real(kind=real_kind), intent(in) :: Dinv2(np,np,2,2) - real(kind=real_kind), intent(in) :: dvv(np,np) - real(kind=real_kind) :: div(np,np) - - ! Local - - integer i - integer j - integer l - - real(kind=real_kind) :: dudx00 - real(kind=real_kind) :: dvdy00 - real(kind=real_kind) :: gv1(np,np),gv2(np,np) - real(kind=real_kind) :: vvtemp(np,np) - - ! convert to contra variant form and multiply by g - do j=1,np - do i=1,np -!JMD gv1(i,j)=metdet(i,j)*(Dinv(1,1,i,j)*v(i,j,1) + Dinv(1,2,i,j)*v(i,j,2)) -!JMD gv2(i,j)=metdet(i,j)*(Dinv(2,1,i,j)*v(i,j,1) + Dinv(2,2,i,j)*v(i,j,2)) - gv1(i,j)=elem%metdet(i,j)*(elem%Dinv2(i,j,1,1)*v(i,j,1) + elem%Dinv2(i,j,1,2)*v(i,j,2)) - gv2(i,j)=elem%metdet(i,j)*(elem%Dinv2(i,j,2,1)*v(i,j,1) + elem%Dinv2(i,j,2,2)*v(i,j,2)) - enddo - enddo - - ! compute d/dx and d/dy - do j=1,np - do l=1,np - dudx00=0.0d0 - dvdy00=0.0d0 -!DIR$ UNROLL(4) - do i=1,np - dudx00 = Dvv(i,l )*gv1(i,j ) - dvdy00 = Dvv(i,l )*gv2(j ,i) - - end do - div(l ,j ) = dudx00 - vvtemp(j ,l ) = dvdy00 - end do - end do - - - do j=1,np - do i=1,np - div(i,j)=(div(i,j)+vvtemp(i,j))*(elem%rmetdet(i,j)*rrearth) - end do - end do - - end function divergence_sphere_v2 - - - - end program kgen_kernel_divergence_sphere diff --git a/test/ncar_kernels/HOMME_grad_sphere/CESM_license.txt b/test/ncar_kernels/HOMME_grad_sphere/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/HOMME_grad_sphere/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/HOMME_grad_sphere/inc/t1.mk b/test/ncar_kernels/HOMME_grad_sphere/inc/t1.mk deleted file mode 100644 index 6dfc006c6d..0000000000 --- a/test/ncar_kernels/HOMME_grad_sphere/inc/t1.mk +++ /dev/null @@ -1,61 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# -# PGI default flags -# -# FC := pgf95 -# FC_FLAGS := -O3 -# -# Intel default flags -# -# FC := pgfortran -# FFLAGS := -O3 -xCORE-AVX2 -qopt-report=5 -fp-model fast -# FFLAGS := -O3 -align array64byte -xCORE-AVX2 -qopt-report=5 -fp-model fast=2 -# FFLAGS := -O3 -xCORE-AVX2 -qopt-report=5 -fp-model fast=2 -# FFLAGS := -O3 -align array64byte -xAVX -fp-model fast=2 -# FFLAGS := -O3 -align array64byte -mmic -qopt-report=5 -fp-model fast=2 -# FFLAGS := -O3 -xAVX -qopt-report=5 -fp-model fast=2 -# -# GFORTRAN -# -# FC :=gfortran -# FFLAGS := -O3 -ffree-form -ffree-line-length-none -D__GFORTRAN__ -I./ -# -# -# Makefile for KGEN-generated kernel -FC_FLAGS := $(OPT) - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - - -ALL_OBJS := kernel_gradient_sphere.o - -verify: - @echo "nothing to be done for verify" - -run: build - ./kernel.exe - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_gradient_sphere.o: $(SRC_DIR)/kernel_gradient_sphere.F90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.rslt diff --git a/test/ncar_kernels/HOMME_grad_sphere/lit/runmake b/test/ncar_kernels/HOMME_grad_sphere/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/HOMME_grad_sphere/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/HOMME_grad_sphere/makefile b/test/ncar_kernels/HOMME_grad_sphere/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/HOMME_grad_sphere/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/HOMME_grad_sphere/src/grad_sphere.edison.pbs b/test/ncar_kernels/HOMME_grad_sphere/src/grad_sphere.edison.pbs deleted file mode 100644 index 0aa9e62460..0000000000 --- a/test/ncar_kernels/HOMME_grad_sphere/src/grad_sphere.edison.pbs +++ /dev/null @@ -1,14 +0,0 @@ -#PBS -q debug -#PBS -l mppwidth=1 -#PBS -l walltime=00:10:00 -#PBS -N my_job -#PBS -e my_job.$PBS_JOBID.err -#PBS -o my_job.$PBS_JOBID.out -#PBS -V - -cd $PBS_O_WORKDIR -#export KMP_AFFINITY=balanced -#export I_MPI_PIN_MODE=mpd -#get_micfile -aprun -n 1 ./kernel_gradient_sphere.exe - diff --git a/test/ncar_kernels/HOMME_grad_sphere/src/kernel_gradient_sphere.F90 b/test/ncar_kernels/HOMME_grad_sphere/src/kernel_gradient_sphere.F90 deleted file mode 100644 index 1777c3534c..0000000000 --- a/test/ncar_kernels/HOMME_grad_sphere/src/kernel_gradient_sphere.F90 +++ /dev/null @@ -1,356 +0,0 @@ - program kgen_kernel_gradient_sphere - - INTEGER(KIND=4) , PARAMETER :: real_kind = 8 - - REAL(KIND=real_kind) , PARAMETER :: rearth = 6.376d6 - - REAL(KIND=real_kind) , PARAMETER :: rrearth = 1.0_real_kind/rearth - - INTEGER , PARAMETER :: np = 4 - - INTEGER , Parameter :: nelem = 30*64 - - INTEGER , PARAMETER :: nc = 4 - - INTEGER , PARAMETER :: nip = 3 - - INTEGER , PARAMETER :: nipm = nip-1 - - INTEGER , PARAMETER :: nep = nipm*nc+1 - - TYPE :: derivative_t - REAL(KIND=real_kind) dvv(np,np) - REAL(KIND=real_kind) dvv_diag(np,np) - REAL(KIND=real_kind) dvv_twt(np,np) - REAL(KIND=real_kind) mvv_twt(np,np) - ! diagonal matrix of GLL weights - REAL(KIND=real_kind) mfvm(np,nc+1) - REAL(KIND=real_kind) cfvm(np,nc) - REAL(KIND=real_kind) sfvm(np,nep) - REAL(KIND=real_kind) legdg(np,np) - END TYPE derivative_t - - TYPE :: element_t - REAL(KIND=real_kind) dinv(2,2,np,np) - END TYPE element_t - - TYPE :: element_t2 - REAL(KIND=real_kind) dinv2(np,np,2,2) - REAL(KIND=real_kind) ds(np,np,2) - END TYPE element_t2 - - type (element_t), allocatable :: elem(:) - type (element_t2), allocatable :: elem2(:) - - - REAL(KIND=real_kind) s(np, np,nelem) - TYPE(derivative_t) deriv - REAL(KIND=real_kind), DIMENSION(2, 2, np, np,nelem) :: dinv - REAL(KIND=real_kind), DIMENSION(np,np,2,2) :: dinv2b - REAL(KIND=real_kind), dimension(np,np,2,2,nelem) :: dinv2 - REAL(KIND=real_kind) KGEN_RESULT_ds(np, np, 2,nelem) - REAL(KIND=real_kind), dimension(np,np,2) :: KGEN_RESULT_ds2b - REAL(KIND=real_kind) KGEN_ds(np, np, 2) - - !JMD manual timer additions - integer*8 c1,c2,cr,cm - real*8 dt - real*8 flops - integer :: itmax - character(len=80), parameter :: kname1='[kernel_gradient_sphere_v1]' - character(len=80), parameter :: kname2a='[kernel_gradient_sphere_v2a]' - character(len=80), parameter :: kname2b='[kernel_gradient_sphere_v2b]' - character(len=80), parameter :: kname2c='[kernel_gradient_sphere_v2c]' - character(len=80), parameter :: kname2d='[kernel_gradient_sphere_v2d]' - character(len=80), parameter :: kname2e='[kernel_gradient_sphere_v2e]' - character(len=80), parameter :: kname2f='[kernel_gradient_sphere_v2f]' - integer :: it - !JMD -!DIR$ ATTRIBUTES ALIGN:64 :: element_t2 -!DIR$ ATTRIBUTES align:64 :: elem, elem2 -!DIR$ ATTRIBUTES ALIGN:64 :: KGEN_RESULT_ds - - allocate(elem(nelem)) - allocate(elem2(nelem)) - itmax = ceiling(real(10000000,kind=real_kind)/real(nelem,kind=real_kind)) - - - ! populate dummy initial values - do j=1,np - do i=1,np - s(i,j,:) = 0.6_real_kind * i*j - deriv%Dvv(i,j) = 0.8_real_kind * j - - Dinv(1,1,i,j,:) = 0.2_real_kind * j - Dinv(2,1,i,j,:) = 0.3_real_kind * i*j - Dinv(2,1,i,j,:) = 0.4_real_kind * i - Dinv(2,2,i,j,:) = 0.5_real_kind * j - Dinv2(i,j,1,1,:) = Dinv(1,1,i,j,:) - Dinv2(i,j,1,2,:) = Dinv(1,2,i,j,:) - Dinv2(i,j,2,1,:) = Dinv(2,1,i,j,:) - Dinv2(i,j,2,2,:) = Dinv(2,2,i,j,:) - end do - end do - do ie=1,nelem - elem(ie)%dinv = Dinv(:,:,:,:,ie) - elem2(ie)%dinv2 = Dinv2(:,:,:,:,ie) - enddo - dinv2b = Dinv2(:,:,:,:,1) - - ! reference result - ! KGEN_ds = gradient_sphere_ref(s,deriv,dinv(:,:,:,:,1)) - KGEN_ds = gradient_sphere_ref(s,deriv,elem(1)%dinv) - - call system_clock(c1,cr,cm) - ! modified result - do it=1,itmax - do ie=1,nelem -! KGEN_RESULT_ds(:,:,:,ie) = gradient_sphere_v1(s(:,:,ie),deriv,dinv(:,:,:,:,ie)) - KGEN_RESULT_ds(:,:,:,ie)= gradient_sphere_v1(s(:,:,ie),deriv,elem(ie)%dinv) - enddo - enddo - call system_clock(c2,cr,cm) - dt = dble(c2-c1)/dble(cr) -! flops = real(nelem,kind=real_kind)*real(4*np*np*np + 5*np*np,kind=real_kind)*real(itmax,kind=real_kind) - print *, TRIM(kname1), ' total time (sec): ',dt - print *, TRIM(kname1), ' time per call (usec): ',1.e6*dt/dble(itmax) - -#if 0 - call system_clock(c1,cr,cm) - ! modified result - do it=1,itmax - do ie=1,nelem - KGEN_RESULT_ds(:,:,:,ie) = gradient_sphere_v2(s(:,:,ie),deriv,dinv2(:,:,:,:,ie)) - enddo - enddo - call system_clock(c2,cr,cm) - dt = dble(c2-c1)/dble(cr) - print *, TRIM(kname2a), ' total time (sec): ',dt - print *, TRIM(kname2a), ' time per call (usec): ',1.e6*dt/dble(itmax) -#endif - - if(nelem==1) then - call system_clock(c1,cr,cm) - ! modified result - do it=1,itmax - do ie=1,nelem - KGEN_RESULT_ds2b = gradient_sphere_v2(s(:,:,ie),deriv,elem2(ie)%dinv2) - enddo - enddo - call system_clock(c2,cr,cm) - dt = dble(c2-c1)/dble(cr) - print *, TRIM(kname2b), ' total time (sec): ',dt - print *, TRIM(kname2b), ' time per call (usec): ',1.e6*dt/dble(itmax) - endif - -#if 0 - call system_clock(c1,cr,cm) - ! modified result - do it=1,itmax - do ie=1,nelem - elem2(ie)%ds = gradient_sphere_v2(s(:,:,ie),deriv,elem2(ie)%dinv2) - enddo - enddo - call system_clock(c2,cr,cm) - dt = dble(c2-c1)/dble(cr) - print *, TRIM(kname2c), ' total time (sec): ',dt - print *, TRIM(kname2c), ' time per call (usec): ',1.e6*dt/dble(itmax) -#endif - - call system_clock(c1,cr,cm) - ! modified result - do it=1,itmax - do ie=1,nelem - elem2(ie)%ds = gradient_sphere_v2(s(:,:,ie),deriv,elem2(ie)%dinv2) - enddo - enddo - call system_clock(c2,cr,cm) - dt = dble(c2-c1)/dble(cr) - print *, TRIM(kname2d), ' total time (sec): ',dt - print *, TRIM(kname2d), ' time per call (usec): ',1.e6*dt/dble(itmax) - - if (nelem == 1) then - call system_clock(c1,cr,cm) - ! modified result - do it=1,itmax - do ie=1,nelem - KGEN_RESULT_ds2b = gradient_sphere_v2(s(:,:,ie),deriv,dinv2(:,:,:,:,ie)) - enddo - enddo - call system_clock(c2,cr,cm) - dt = dble(c2-c1)/dble(cr) - print *, TRIM(kname2e), ' total time (sec): ',dt - print *, TRIM(kname2e), ' time per call (usec): ',1.e6*dt/dble(itmax) - endif - -#if 0 - call system_clock(c1,cr,cm) - ! modified result - do it=1,itmax - do ie=1,nelem - KGEN_RESULT_ds(:,:,:,ie) = gradient_sphere_v2(s(:,:,ie),deriv,dinv2(:,:,:,:,ie)) - enddo - enddo - call system_clock(c2,cr,cm) - dt = dble(c2-c1)/dble(cr) - print *, TRIM(kname2f), ' total time (sec): ',dt - print *, TRIM(kname2f), ' time per call (usec): ',1.e6*dt/dble(itmax) -#endif - - - - - - - IF ( ALL( KGEN_ds == KGEN_RESULT_ds(:,:,:,1) ) ) THEN - WRITE(*,*) "ds is identical." - WRITE(*,*) "PASSED" -! WRITE(*,*) "Modified: ", KGEN_ds -! WRITE(*,*) "Reference: ", KGEN_RESULT_ds(:,:,:,1) - ELSE - WRITE(*,*) "ds is NOT identical." - WRITE(*,*) "FAILED" - WRITE(*,*) COUNT( KGEN_ds /= KGEN_RESULT_ds(:,:,:,1)), " of ", SIZE( KGEN_RESULT_ds(:,:,:,1) ), " elements are different." - WRITE(*,*) "RMS of difference is ", SQRT(SUM((KGEN_ds - KGEN_RESULT_ds(:,:,:,1))**2)/SIZE(KGEN_ds)) - WRITE(*,*) "Minimum difference is ", MINVAL(ABS(KGEN_ds - KGEN_RESULT_ds(:,:,:,1))) - WRITE(*,*) "Maximum difference is ", MAXVAL(ABS(KGEN_ds - KGEN_RESULT_ds(:,:,:,1))) - WRITE(*,*) "Mean value of kernel-generated ds is ", SUM(KGEN_RESULT_ds(:,:,:,1))/SIZE(KGEN_RESULT_ds(:,:,:,1)) - WRITE(*,*) "Mean value of original ds is ", SUM(KGEN_ds)/SIZE(KGEN_ds) - WRITE(*,*) "" - STOP - END IF - - contains - - function gradient_sphere_ref(s,deriv,Dinv) result(ds) - ! - ! input s: scalar - ! output ds: spherical gradient of s, lat-lon coordinates - ! - - type (derivative_t), intent(in) :: deriv - real(kind=real_kind), intent(in), dimension(2,2,np,np) :: Dinv - real(kind=real_kind), intent(in) :: s(np,np) - - real(kind=real_kind) :: ds(np,np,2) - - integer i - integer j - integer l - - real(kind=real_kind) :: dsdx00 - real(kind=real_kind) :: dsdy00 - real(kind=real_kind) :: v1(np,np),v2(np,np) - - do j=1,np - do l=1,np - dsdx00=0.0d0 - dsdy00=0.0d0 - do i=1,np - dsdx00 = dsdx00 + deriv%Dvv(i,l )*s(i,j ) - dsdy00 = dsdy00 + deriv%Dvv(i,l )*s(j ,i) - end do - v1(l ,j ) = dsdx00*rrearth - v2(j ,l ) = dsdy00*rrearth - end do - end do - ! convert covarient to latlon - do j=1,np - do i=1,np - ds(i,j,1)=Dinv(1,1,i,j)*v1(i,j) + Dinv(2,1,i,j)*v2(i,j) - ds(i,j,2)=Dinv(1,2,i,j)*v1(i,j) + Dinv(2,2,i,j)*v2(i,j) - enddo - enddo - - end function gradient_sphere_ref - -!DIR$ ATTRIBUTES FORCEINLINE :: gradient_sphere_v1 - function gradient_sphere_v1(s,deriv,Dinv) result(ds) - ! - ! input s: scalar - ! output ds: spherical gradient of s, lat-lon coordinates - ! - - type (derivative_t), intent(in) :: deriv - real(kind=real_kind), intent(in), dimension(2,2,np,np) :: Dinv - real(kind=real_kind), intent(in) :: s(np,np) - - real(kind=real_kind) :: ds(np,np,2) - - integer i - integer j - integer l - - real(kind=real_kind) :: dsdx00 - real(kind=real_kind) :: dsdy00 - real(kind=real_kind) :: v1(np,np),v2(np,np) - - do j=1,np - do l=1,np - dsdx00=0.0d0 - dsdy00=0.0d0 - do i=1,np - dsdx00 = dsdx00 + deriv%Dvv(i,l )*s(i,j ) - dsdy00 = dsdy00 + deriv%Dvv(i,l )*s(j ,i) - end do - v1(l ,j ) = dsdx00*rrearth - v2(j ,l ) = dsdy00*rrearth - end do - end do - ! convert covarient to latlon - do j=1,np - do i=1,np - ds(i,j,1)=Dinv(1,1,i,j)*v1(i,j) + Dinv(2,1,i,j)*v2(i,j) - ds(i,j,2)=Dinv(1,2,i,j)*v1(i,j) + Dinv(2,2,i,j)*v2(i,j) - enddo - enddo - - end function gradient_sphere_v1 - -!DIR$ ATTRIBUTES FORCEINLINE :: gradient_sphere_v2 - function gradient_sphere_v2(s,deriv,Dinv) result(ds) - ! - ! input s: scalar - ! output ds: spherical gradient of s, lat-lon coordinates - ! - - type (derivative_t), intent(in) :: deriv - real(kind=real_kind), intent(in), dimension(np,np,2,2) :: Dinv - real(kind=real_kind), intent(in) :: s(np,np) - - real(kind=real_kind) :: ds(np,np,2) -!DIR$ ATTRIBUTES ALIGN:64 :: ds - - integer i - integer j - integer l - - real(kind=real_kind) :: dsdx00 - real(kind=real_kind) :: dsdy00 - real(kind=real_kind) :: v1(np,np),v2(np,np) - - do j=1,np - do l=1,np - dsdx00=0.0d0 - dsdy00=0.0d0 -!DIR$ UNROLL(4) - do i=1,np - dsdx00 = dsdx00 + deriv%Dvv(i,l )*s(i,j ) - dsdy00 = dsdy00 + deriv%Dvv(i,l )*s(j ,i) - end do - v1(l ,j ) = dsdx00*rrearth - v2(j ,l ) = dsdy00*rrearth - end do - end do - ! convert covarient to latlon - do j=1,np - do i=1,np - ds(i,j,1)=Dinv(i,j,1,1)*v1(i,j) + Dinv(i,j,2,1)*v2(i,j) - ds(i,j,2)=Dinv(i,j,1,2)*v1(i,j) + Dinv(i,j,2,2)*v2(i,j) - enddo - enddo - - end function gradient_sphere_v2 - - - end program kgen_kernel_gradient_sphere diff --git a/test/ncar_kernels/HOMME_limiter_optim_iter_full/CESM_license.txt b/test/ncar_kernels/HOMME_limiter_optim_iter_full/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/HOMME_limiter_optim_iter_full/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/HOMME_limiter_optim_iter_full/data/limiter_optim_iter_full.1.0 b/test/ncar_kernels/HOMME_limiter_optim_iter_full/data/limiter_optim_iter_full.1.0 deleted file mode 100644 index 85e10410f9..0000000000 Binary files a/test/ncar_kernels/HOMME_limiter_optim_iter_full/data/limiter_optim_iter_full.1.0 and /dev/null differ diff --git a/test/ncar_kernels/HOMME_limiter_optim_iter_full/data/limiter_optim_iter_full.10.0 b/test/ncar_kernels/HOMME_limiter_optim_iter_full/data/limiter_optim_iter_full.10.0 deleted file mode 100644 index 1e8b429a3b..0000000000 Binary files a/test/ncar_kernels/HOMME_limiter_optim_iter_full/data/limiter_optim_iter_full.10.0 and /dev/null differ diff --git a/test/ncar_kernels/HOMME_limiter_optim_iter_full/data/limiter_optim_iter_full.20.0 b/test/ncar_kernels/HOMME_limiter_optim_iter_full/data/limiter_optim_iter_full.20.0 deleted file mode 100644 index 5f8a865898..0000000000 Binary files a/test/ncar_kernels/HOMME_limiter_optim_iter_full/data/limiter_optim_iter_full.20.0 and /dev/null differ diff --git a/test/ncar_kernels/HOMME_limiter_optim_iter_full/inc/t1.mk b/test/ncar_kernels/HOMME_limiter_optim_iter_full/inc/t1.mk deleted file mode 100644 index 568dba02f8..0000000000 --- a/test/ncar_kernels/HOMME_limiter_optim_iter_full/inc/t1.mk +++ /dev/null @@ -1,60 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# Intel default flags -# -# FC_FLAGS := -assume byterecl -fp-model precise -ftz -O3 -g -openmp -# -# Makefile for KGEN-generated kernel -FC_FLAGS := $(OPT) - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - - -ALL_OBJS := kernel_driver.o prim_advection_mod.o dimensions_mod.o kinds.o - -verify: - @(grep "verification.FAIL" $(TEST).rslt && echo "FAILED") || (grep "verification.PASS" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 prim_advection_mod.o dimensions_mod.o kinds.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -prim_advection_mod.o: $(SRC_DIR)/prim_advection_mod.F90 kinds.o dimensions_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -dimensions_mod.o: $(SRC_DIR)/dimensions_mod.F90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -kinds.o: $(SRC_DIR)/kinds.F90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.rslt diff --git a/test/ncar_kernels/HOMME_limiter_optim_iter_full/lit/runmake b/test/ncar_kernels/HOMME_limiter_optim_iter_full/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/HOMME_limiter_optim_iter_full/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/HOMME_limiter_optim_iter_full/makefile b/test/ncar_kernels/HOMME_limiter_optim_iter_full/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/HOMME_limiter_optim_iter_full/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/HOMME_limiter_optim_iter_full/readme.txt b/test/ncar_kernels/HOMME_limiter_optim_iter_full/readme.txt deleted file mode 100644 index 1400c3637b..0000000000 --- a/test/ncar_kernels/HOMME_limiter_optim_iter_full/readme.txt +++ /dev/null @@ -1,20 +0,0 @@ -Limiter_optim_iter_full Kernel -Edited 03/03/2015 -Amogh Simha - -*kernel and supporting files - -the limiter_optim_iter_full subroutine is located in the prim_advection_mod.F90 file - -subroutine call is in the same file in the euler_step subroutine - -*compilation and execution - -Just download the enclosing directory - -Run make - -*verification - -The make command will trigger the verification of the kernel. - -It is considered to have passed verification if the tolerance for normalized RMS is less than 9.999999824516700E-015 - -Input data is provided by limiter_optim_iter_full.1.0, limiter_optim_iter_full.10.0, and limiter_optim_iter_full.20.0 - -*performance measurement - -The elapsed time in seconds is printed to stdout for each input file specified - diff --git a/test/ncar_kernels/HOMME_limiter_optim_iter_full/src/dimensions_mod.F90 b/test/ncar_kernels/HOMME_limiter_optim_iter_full/src/dimensions_mod.F90 deleted file mode 100644 index 497f70cd2a..0000000000 --- a/test/ncar_kernels/HOMME_limiter_optim_iter_full/src/dimensions_mod.F90 +++ /dev/null @@ -1,48 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : dimensions_mod.F90 -! Generated at: 2015-03-03 13:07:29 -! KGEN version: 0.4.4 - - - - MODULE dimensions_mod - IMPLICIT NONE - PRIVATE - ! set MAX number of tracers. actual number of tracers is a run time argument - ! SE tracers: default is 4 - ! fvm tracers - ! FI # dependent variables - INTEGER, parameter, public :: np = 4 - ! fvm dimensions: - !number of Gausspoints for the fvm integral approximation - !Max. Courant number - !halo width needed for reconstruction - phl - !total halo width where reconstruction is needed (nht<=nc) - phl - !(different from halo needed for elements on edges and corners - ! integer, parameter, public :: ns=3 !quadratic halo interpolation - recommended setting for nc=3 - ! integer, parameter, public :: ns=4 !cubic halo interpolation - recommended setting for nc=4 - !nhc determines width of halo exchanged with neighboring elements - ! - ! constants for SPELT - ! - !number of interpolation values, works only for this - ! number of points in an element - ! dg degree for hybrid cg/dg element 0=disabled - INTEGER, parameter, public :: nlev=26 - ! params for a mesh - ! integer, public, parameter :: max_elements_attached_to_node = 7 - ! integer, public, parameter :: s_nv = 2*max_elements_attached_to_node - !default for non-refined mesh (note that these are *not* parameters now) - !max_elements_attached_to_node-3 - !4 + 4*max_corner_elem - ! total number of elements - ! number of elements per MPI task - ! max number of elements on any MPI task - ! This is the number of physics processors/ per dynamics processor - CONTAINS - - ! read subroutines - - END MODULE dimensions_mod diff --git a/test/ncar_kernels/HOMME_limiter_optim_iter_full/src/kernel_driver.f90 b/test/ncar_kernels/HOMME_limiter_optim_iter_full/src/kernel_driver.f90 deleted file mode 100644 index a32304cff1..0000000000 --- a/test/ncar_kernels/HOMME_limiter_optim_iter_full/src/kernel_driver.f90 +++ /dev/null @@ -1,74 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-03-03 13:07:29 -! KGEN version: 0.4.4 - - -PROGRAM kernel_driver - USE prim_advection_mod, only : euler_step - USE prim_advection_mod, only : read_externs_prim_advection_mod - - IMPLICIT NONE - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(1), PARAMETER :: kgen_mpi_rank_at = (/ 0 /) - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_counter_at = (/ 1, 10, 20 /) - CHARACTER(LEN=1024) :: kgen_filepath - - DO kgen_repeat_counter = 0, 2 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 1)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - kgen_filepath = "../data/limiter_optim_iter_full." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "************ Verification against '" // trim(adjustl(kgen_filepath)) // "' ************" - - call read_externs_prim_advection_mod(kgen_unit) - - ! driver variables - call euler_step(kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! read subroutines - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/HOMME_limiter_optim_iter_full/src/kinds.F90 b/test/ncar_kernels/HOMME_limiter_optim_iter_full/src/kinds.F90 deleted file mode 100644 index 722035c4f5..0000000000 --- a/test/ncar_kernels/HOMME_limiter_optim_iter_full/src/kinds.F90 +++ /dev/null @@ -1,22 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kinds.F90 -! Generated at: 2015-03-03 13:07:29 -! KGEN version: 0.4.4 - - - - MODULE kinds - IMPLICIT NONE - PRIVATE - ! - ! most floating point variables should be of type real_kind = real*8 - ! For higher precision, we also have quad_kind = real*16, but this - ! is only supported on IBM systems - ! - INTEGER(KIND=4), public, parameter :: real_kind = 8 - ! stderr file handle - - ! read subroutines - END MODULE kinds diff --git a/test/ncar_kernels/HOMME_limiter_optim_iter_full/src/prim_advection_mod.F90 b/test/ncar_kernels/HOMME_limiter_optim_iter_full/src/prim_advection_mod.F90 deleted file mode 100644 index 6b5f523658..0000000000 --- a/test/ncar_kernels/HOMME_limiter_optim_iter_full/src/prim_advection_mod.F90 +++ /dev/null @@ -1,703 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : prim_advection_mod.F90 -! Generated at: 2015-03-03 13:07:29 -! KGEN version: 0.4.4 - - - - - - - - - - - - MODULE prim_advection_mod - ! - ! two formulations. both are conservative - ! u grad Q formulation: - ! - ! d/dt[ Q] + U grad Q + eta_dot dp/dn dQ/dp = 0 - ! ( eta_dot dQ/dn ) - ! - ! d/dt[ dp/dn ] = div( dp/dn U ) + d/dn ( eta_dot dp/dn ) - ! - ! total divergence formulation: - ! d/dt[dp/dn Q] + div( U dp/dn Q ) + d/dn ( eta_dot dp/dn Q ) = 0 - ! - ! for convience, rewrite this as dp Q: (since dn does not depend on time or the horizonal): - ! equation is now: - ! d/dt[dp Q] + div( U dp Q ) + d( eta_dot_dpdn Q ) = 0 - ! - ! - USE kinds, ONLY: real_kind - ! _EXTERNAL - IMPLICIT NONE - PRIVATE - PUBLIC read_externs_prim_advection_mod - INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - PUBLIC euler_step - type, public :: check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - end type check_t - REAL(KIND=real_kind), allocatable :: qmin(:,:,:) - REAL(KIND=real_kind), allocatable :: qmax(:,:,:) - ! derivative struct (nthreads) - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_prim_advection_mod(kgen_unit) - integer, intent(in) :: kgen_unit - call read_var_real_real_kind_dim3(qmin, kgen_unit) - call read_var_real_real_kind_dim3(qmax, kgen_unit) - - CONTAINS - subroutine read_var_real_real_kind_dim3(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=real_kind), intent(out), dimension(:,:,:), allocatable :: var - integer, dimension(2,3) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END SUBROUTINE read_externs_prim_advection_mod - - subroutine kgen_init_check(check,tolerance) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.E-14 - endif - end subroutine kgen_init_check - subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif - end subroutine kgen_print_check - - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! fvm driver - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !=================================================================================================! - - - - - - ! ----------------------------------------------------------------------------------! - !SUBROUTINE ALE_RKDSS-----------------------------------------------CE-for FVM! - ! AUTHOR: CHRISTOPH ERATH, MARK TAYLOR, 06. December 2012 - ! - ! DESCRIPTION: ! create a runge kutta taylor serios mixture to calculate the departure grid - ! - ! CALLS: - ! INPUT: - ! - ! OUTPUT: - !-----------------------------------------------------------------------------------! - ! this will calculate the velocity at time t+1/2 along the trajectory s(t) given the velocities - ! at the GLL points at time t and t+1 using a second order time accurate formulation. - - ! ----------------------------------------------------------------------------------! - !SUBROUTINE FVM_DEP_FROM_GLL----------------------------------------------CE-for FVM! - ! AUTHOR: CHRISTOPH ERATH, MARK TAYLOR 14. December 2011 ! - ! DESCRIPTION: calculates the deparute grid for fvm coming from the gll points ! - ! ! - ! CALLS: - ! INPUT: - ! - ! OUTPUT: - !-----------------------------------------------------------------------------------! - - - - - - - - - - - !----------------------------------------------------------------------------- - !----------------------------------------------------------------------------- - ! forward-in-time 2 level vertically lagrangian step - ! this code takes a lagrangian step in the horizontal - ! (complete with DSS), and then applies a vertical remap - ! - ! This routine may use dynamics fields at timelevel np1 - ! In addition, other fields are required, which have to be - ! explicitly saved by the dynamics: (in elem(ie)%derived struct) - ! - ! Fields required from dynamics: (in - ! omega_p it will be DSS'd here, for later use by CAM physics - ! we DSS omega here because it can be done for "free" - ! Consistent mass/tracer-mass advection (used if subcycling turned on) - ! dp() dp at timelevel n0 - ! vn0() mean flux < U dp > going from n0 to np1 - ! - ! 3 stage - ! Euler step from t -> t+.5 - ! Euler step from t+.5 -> t+1.0 - ! Euler step from t+1.0 -> t+1.5 - ! u(t) = u(t)/3 + u(t+2)*2/3 - ! - !----------------------------------------------------------------------------- - !----------------------------------------------------------------------------- - - !----------------------------------------------------------------------------- - !----------------------------------------------------------------------------- - - !----------------------------------------------------------------------------- - !----------------------------------------------------------------------------- - - SUBROUTINE euler_step(kgen_unit) - ! =================================== - ! This routine is the basic foward - ! euler component used to construct RK SSP methods - ! - ! u(np1) = u(n0) + dt2*DSS[ RHS(u(n0)) ] - ! - ! n0 can be the same as np1. - ! - ! DSSopt = DSSeta or DSSomega: also DSS eta_dot_dpdn or omega - ! - ! =================================== - USE kinds, ONLY: real_kind - USE dimensions_mod, ONLY: np - USE dimensions_mod, ONLY: nlev - IMPLICIT NONE - integer, intent(in) :: kgen_unit - - ! read interface - !interface kgen_read_var - ! procedure read_var_real_real_kind_dim3 - ! procedure read_var_real_real_kind_dim2 - !end interface kgen_read_var - - - - ! verification interface - interface kgen_verify_var - procedure verify_var_logical - procedure verify_var_integer - procedure verify_var_real - procedure verify_var_character - procedure verify_var_real_real_kind_dim3 - procedure verify_var_real_real_kind_dim2 - end interface kgen_verify_var - - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - ! local - REAL(KIND=real_kind), dimension(np,np ,nlev) :: qtens - REAL(KIND=real_kind), allocatable :: ref_qtens(:,:,:) - REAL(KIND=real_kind), dimension(np,np ,nlev) :: dp_star - REAL(KIND=real_kind), dimension(np,np) :: smaug - INTEGER :: ie - INTEGER :: ref_ie - INTEGER :: q - INTEGER :: ref_q - ! call t_barrierf('sync_euler_step', hybrid%par%comm) - ! call t_startf('euler_step') - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! compute Q min/max values for lim8 - ! compute biharmonic mixing term f - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! compute biharmonic mixing term and qmin/qmax - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! 2D Advection step - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - tolerance = 1.E-14 - CALL kgen_init_check(check_status, tolerance) - READ(UNIT=kgen_unit) qtens - READ(UNIT=kgen_unit) dp_star - READ(UNIT=kgen_unit) smaug - READ(UNIT=kgen_unit) ie - READ(UNIT=kgen_unit) q - call read_var_real_real_kind_dim3(ref_qtens, kgen_unit) - READ(UNIT=kgen_unit) ref_ie - READ(UNIT=kgen_unit) ref_q - ! call to kernel - CALL limiter_optim_iter_full(qtens(:, :, :), smaug(:, :), qmin(:, q, ie), qmax(:, q, ie), dp_star(:, :, :)) - ! kernel verification for output variables - call kgen_verify_var("qtens", check_status, qtens, ref_qtens) - call kgen_verify_var("ie", check_status, ie, ref_ie) - call kgen_verify_var("q", check_status, q, ref_q) - CALL kgen_print_check("limiter_optim_iter_full", check_status) - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,10 - CALL limiter_optim_iter_full(qtens(:, :, :), smaug(:, :), qmin(:, q, ie), qmax(:, q, ie), dp_star(:, :, :)) - END DO - CALL system_clock(stop_clock, rate_clock) - WRITE(*,*) - PRINT *, "Elapsed time (sec): ", (stop_clock - start_clock)/REAL(rate_clock*10) - ! call t_stopf('euler_step') - CONTAINS - - ! read subroutines - subroutine read_var_real_real_kind_dim3(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=real_kind), intent(out), dimension(:,:,:), allocatable :: var - integer, dimension(2,3) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_real_kind_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=real_kind), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - - subroutine verify_var_logical(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - logical, intent(in) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - IF ( var .eqv. ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - endif - endif - check_status%numFatal = check_status%numFatal + 1 - END IF - end subroutine - - subroutine verify_var_integer(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - endif - endif - check_status%numFatal = check_status%numFatal + 1 - END IF - end subroutine - - subroutine verify_var_real(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real, intent(in) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - endif - endif - check_status%numFatal = check_status%numFatal + 1 - END IF - end subroutine - - subroutine verify_var_character(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - character(*), intent(in) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - end subroutine - - subroutine verify_var_real_real_kind_dim3(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(kind=real_kind), intent(in), dimension(:,:,:) :: var - real(kind=real_kind), intent(in), allocatable, dimension(:,:,:) :: ref_var - real(kind=real_kind) :: nrmsdiff, rmsdiff - real(kind=real_kind), allocatable :: temp(:,:,:), temp2(:,:,:) - integer :: n - - - IF ( ALLOCATED(ref_var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - IF ( ALL( var == ref_var ) ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - n = count(var/=ref_var) - where(ref_var .NE. 0) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - END IF - deallocate(temp,temp2) - END IF - end subroutine - - subroutine verify_var_real_real_kind_dim2(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(kind=real_kind), intent(in), dimension(:,:) :: var - real(kind=real_kind), intent(in), allocatable, dimension(:,:) :: ref_var - real(kind=real_kind) :: nrmsdiff, rmsdiff - real(kind=real_kind), allocatable :: temp(:,:), temp2(:,:) - integer :: n - - - IF ( ALLOCATED(ref_var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - IF ( ALL( var == ref_var ) ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - n = count(var/=ref_var) - where(ref_var .NE. 0) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - END IF - deallocate(temp,temp2) - END IF - end subroutine - - END SUBROUTINE euler_step - !----------------------------------------------------------------------------- - !----------------------------------------------------------------------------- - !----------------------------------------------------------------------------- - !----------------------------------------------------------------------------- - !----------------------------------------------------------------------------- - - !----------------------------------------------------------------------------- - !----------------------------------------------------------------------------- - !----------------------------------------------------------------------------- - - SUBROUTINE limiter_optim_iter_full(ptens, sphweights, minp, maxp, dpmass) - !THIS IS A NEW VERSION OF LIM8, POTENTIALLY FASTER BECAUSE INCORPORATES KNOWLEDGE FROM - !PREVIOUS ITERATIONS - !The idea here is the following: We need to find a grid field which is closest - !to the initial field (in terms of weighted sum), but satisfies the min/max constraints. - !So, first we find values which do not satisfy constraints and bring these values - !to a closest constraint. This way we introduce some mass change (addmass), - !so, we redistribute addmass in the way that l2 error is smallest. - !This redistribution might violate constraints thus, we do a few iterations. - USE kinds, ONLY: real_kind - USE dimensions_mod, ONLY: np, np, nlev - REAL(KIND=real_kind), dimension(np*np,nlev), intent(inout) :: ptens - REAL(KIND=real_kind), dimension(np*np), intent(in ) :: sphweights - REAL(KIND=real_kind), dimension( nlev), intent(inout) :: minp - REAL(KIND=real_kind), dimension( nlev), intent(inout) :: maxp - REAL(KIND=real_kind), dimension(np*np,nlev), intent(in ), optional :: dpmass - REAL(KIND=real_kind), dimension(np*np,nlev) :: weights - INTEGER :: k1, k, i, j, iter, i1, i2 - INTEGER :: whois_neg(np*np), whois_pos(np*np), neg_counter, pos_counter - REAL(KIND=real_kind) :: addmass, weightssum, mass - REAL(KIND=real_kind) :: x(np*np), c(np*np) - REAL(KIND=real_kind) :: al_neg(np*np), al_pos(np*np), howmuch - REAL(KIND=real_kind) :: tol_limiter = 1e-15 - INTEGER, parameter :: maxiter = 5 - DO k = 1 , nlev - weights(:,k) = sphweights(:) * dpmass(:,k) - ptens(:,k) = ptens(:,k) / dpmass(:,k) - END DO - DO k = 1 , nlev - c = weights(:,k) - x = ptens(:,k) - mass = sum(c*x) - ! relax constraints to ensure limiter has a solution: - ! This is only needed if runnign with the SSP CFL>1 or - ! due to roundoff errors - IF ((mass / sum(c)) < minp(k)) THEN - minp(k) = mass / sum(c) - END IF - IF ((mass / sum(c)) > maxp(k)) THEN - maxp(k) = mass / sum(c) - END IF - addmass = 0.0d0 - pos_counter = 0 - neg_counter = 0 - ! apply constraints, compute change in mass caused by constraints - DO k1 = 1 , np*np - IF (( x(k1) >= maxp(k) )) THEN - addmass = addmass + (x(k1) - maxp(k)) * c(k1) - x(k1) = maxp(k) - whois_pos(k1) = -1 - ELSE - pos_counter = pos_counter+1 - whois_pos(pos_counter) = k1 - END IF - IF (( x(k1) <= minp(k) )) THEN - addmass = addmass - (minp(k) - x(k1)) * c(k1) - x(k1) = minp(k) - whois_neg(k1) = -1 - ELSE - neg_counter = neg_counter+1 - whois_neg(neg_counter) = k1 - END IF - END DO - ! iterate to find field that satifies constraints and is l2-norm closest to original - weightssum = 0.0d0 - IF (addmass > 0) THEN - DO i2 = 1 , maxiter - weightssum = 0.0 - DO k1 = 1 , pos_counter - i1 = whois_pos(k1) - weightssum = weightssum + c(i1) - al_pos(i1) = maxp(k) - x(i1) - END DO - IF (( pos_counter > 0 ) .and. ( addmass > tol_limiter * abs(mass) )) THEN - DO k1 = 1 , pos_counter - i1 = whois_pos(k1) - howmuch = addmass / weightssum - IF (howmuch > al_pos(i1)) THEN - howmuch = al_pos(i1) - whois_pos(k1) = -1 - END IF - addmass = addmass - howmuch * c(i1) - weightssum = weightssum - c(i1) - x(i1) = x(i1) + howmuch - END DO - !now sort whois_pos and get a new number for pos_counter - !here neg_counter and whois_neg serve as temp vars - neg_counter = pos_counter - whois_neg = whois_pos - whois_pos = -1 - pos_counter = 0 - DO k1 = 1 , neg_counter - IF (whois_neg(k1) .ne. -1) THEN - pos_counter = pos_counter+1 - whois_pos(pos_counter) = whois_neg(k1) - END IF - END DO - ELSE - EXIT - END IF - END DO - ELSE - DO i2 = 1 , maxiter - weightssum = 0.0 - DO k1 = 1 , neg_counter - i1 = whois_neg(k1) - weightssum = weightssum + c(i1) - al_neg(i1) = x(i1) - minp(k) - END DO - IF (( neg_counter > 0 ) .and. ( (-addmass) > tol_limiter * abs(mass) )) THEN - DO k1 = 1 , neg_counter - i1 = whois_neg(k1) - howmuch = -addmass / weightssum - IF (howmuch > al_neg(i1)) THEN - howmuch = al_neg(i1) - whois_neg(k1) = -1 - END IF - addmass = addmass + howmuch * c(i1) - weightssum = weightssum - c(i1) - x(i1) = x(i1) - howmuch - END DO - !now sort whois_pos and get a new number for pos_counter - !here pos_counter and whois_pos serve as temp vars - pos_counter = neg_counter - whois_pos = whois_neg - whois_neg = -1 - neg_counter = 0 - DO k1 = 1 , pos_counter - IF (whois_pos(k1) .ne. -1) THEN - neg_counter = neg_counter+1 - whois_neg(neg_counter) = whois_pos(k1) - END IF - END DO - ELSE - EXIT - END IF - END DO - END IF - ptens(:,k) = x - END DO - DO k = 1 , nlev - ptens(:,k) = ptens(:,k) * dpmass(:,k) - END DO - END SUBROUTINE limiter_optim_iter_full - !----------------------------------------------------------------------------- - !----------------------------------------------------------------------------- - - !----------------------------------------------------------------------------- - !----------------------------------------------------------------------------- - - !----------------------------------------------------------------------------- - !----------------------------------------------------------------------------- - - - END MODULE prim_advection_mod diff --git a/test/ncar_kernels/HOMME_preq_hydrostatic/CESM_license.txt b/test/ncar_kernels/HOMME_preq_hydrostatic/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/HOMME_preq_hydrostatic/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/HOMME_preq_hydrostatic/data/preq_hydrostatic.1.0 b/test/ncar_kernels/HOMME_preq_hydrostatic/data/preq_hydrostatic.1.0 deleted file mode 100644 index 5db394fa1f..0000000000 Binary files a/test/ncar_kernels/HOMME_preq_hydrostatic/data/preq_hydrostatic.1.0 and /dev/null differ diff --git a/test/ncar_kernels/HOMME_preq_hydrostatic/inc/t1.mk b/test/ncar_kernels/HOMME_preq_hydrostatic/inc/t1.mk deleted file mode 100644 index 86be0b7eb0..0000000000 --- a/test/ncar_kernels/HOMME_preq_hydrostatic/inc/t1.mk +++ /dev/null @@ -1,93 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# Intel default flags -# -# FC_FLAGS := -fp-model source -convert big_endian -assume byterecl -# -ftz -traceback -assume realloc_lhs -xHost -O2 -# -# Makefile for KGEN-generated kernel -FC_FLAGS := $(OPT) - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - -ALL_OBJS := kernel_driver.o prim_advance_mod.o kgen_utils.o kinds.o shr_const_mod.o physical_constants.o shr_kind_mod.o prim_si_mod.o element_mod.o physconst.o coordinate_systems_mod.o gridgraph_mod.o edge_mod.o dimensions_mod.o constituents.o - -verify: - @(grep "verification.FAIL" $(TEST).rslt && echo "FAILED") || (grep "verification.PASS" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 prim_advance_mod.o kgen_utils.o kinds.o shr_const_mod.o physical_constants.o shr_kind_mod.o prim_si_mod.o element_mod.o physconst.o coordinate_systems_mod.o gridgraph_mod.o edge_mod.o dimensions_mod.o constituents.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -prim_advance_mod.o: $(SRC_DIR)/prim_advance_mod.F90 kgen_utils.o prim_si_mod.o kinds.o dimensions_mod.o element_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -kinds.o: $(SRC_DIR)/kinds.F90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_const_mod.o: $(SRC_DIR)/shr_const_mod.F90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -physical_constants.o: $(SRC_DIR)/physical_constants.F90 kgen_utils.o physconst.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_kind_mod.o: $(SRC_DIR)/shr_kind_mod.F90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -prim_si_mod.o: $(SRC_DIR)/prim_si_mod.F90 kgen_utils.o kinds.o dimensions_mod.o physical_constants.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -element_mod.o: $(SRC_DIR)/element_mod.F90 kgen_utils.o kinds.o coordinate_systems_mod.o dimensions_mod.o gridgraph_mod.o edge_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -physconst.o: $(SRC_DIR)/physconst.F90 kgen_utils.o shr_kind_mod.o shr_const_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -coordinate_systems_mod.o: $(SRC_DIR)/coordinate_systems_mod.F90 kgen_utils.o kinds.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -gridgraph_mod.o: $(SRC_DIR)/gridgraph_mod.F90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -edge_mod.o: $(SRC_DIR)/edge_mod.F90 kgen_utils.o kinds.o coordinate_systems_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -dimensions_mod.o: $(SRC_DIR)/dimensions_mod.F90 kgen_utils.o constituents.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -constituents.o: $(SRC_DIR)/constituents.F90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -kgen_utils.o: $(SRC_DIR)/kgen_utils.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.rslt diff --git a/test/ncar_kernels/HOMME_preq_hydrostatic/lit/runmake b/test/ncar_kernels/HOMME_preq_hydrostatic/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/HOMME_preq_hydrostatic/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/HOMME_preq_hydrostatic/makefile b/test/ncar_kernels/HOMME_preq_hydrostatic/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/HOMME_preq_hydrostatic/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/HOMME_preq_hydrostatic/src/README b/test/ncar_kernels/HOMME_preq_hydrostatic/src/README deleted file mode 100644 index 9a201ae3e6..0000000000 --- a/test/ncar_kernels/HOMME_preq_hydrostatic/src/README +++ /dev/null @@ -1,12 +0,0 @@ -preq_hydrostatic kernel ------------------ - -* how to use the kernel -run "make" in this folder will initiate building and running the kernel. - -* entry of program execution -"kernel_driver.f90" has a Fortran Program statement for execution entry - -Questions: -Youngsung Kim -youngsun@ucar.edu diff --git a/test/ncar_kernels/HOMME_preq_hydrostatic/src/constituents.F90 b/test/ncar_kernels/HOMME_preq_hydrostatic/src/constituents.F90 deleted file mode 100644 index f161d67d30..0000000000 --- a/test/ncar_kernels/HOMME_preq_hydrostatic/src/constituents.F90 +++ /dev/null @@ -1,101 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : constituents.F90 -! Generated at: 2015-04-12 19:37:50 -! KGEN version: 0.4.9 - - - - MODULE constituents - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !---------------------------------------------------------------------------------------------- - ! - ! Purpose: Contains data and functions for manipulating advected and non-advected constituents. - ! - ! Revision history: - ! B.A. Boville Original version - ! June 2003 P. Rasch Add wet/dry m.r. specifier - ! 2004-08-28 B. Eaton Add query function to allow turning off the default 1 output of - ! constituents so that chemistry module can make the outfld calls. - ! Allow cnst_get_ind to return without aborting when constituent not - ! found. - ! 2006-10-31 B. Eaton Remove 'non-advected' constituent functionality. - !---------------------------------------------------------------------------------------------- - IMPLICIT NONE - PRIVATE - ! - ! Public interfaces - ! - ! add a constituent to the list of advected constituents - ! returns the number of available slots in the constituent array - ! get the index of a constituent - ! get the type of a constituent - ! get the type of a constituent - ! get the molecular diffusion type of a constituent - ! query whether constituent initial values are read from initial file - ! check that number of constituents added equals dimensions (pcnst) - ! Returns true if default 1 output was specified in the cnst_add calls. - ! Public data - INTEGER, parameter, public :: pcnst = 29 ! number of advected constituents (including water vapor) - ! constituent names - ! long name of constituents - ! Namelist variables - ! true => obtain initial tracer data from IC file - ! - ! Constants for each tracer - ! specific heat at constant pressure (J/kg/K) - ! specific heat at constant volume (J/kg/K) - ! molecular weight (kg/kmole) - ! wet or dry mixing ratio - ! major or minor species molecular diffusion - ! gas constant () - ! minimum permitted constituent concentration (kg/kg) - ! for backward compatibility only - ! upper bndy condition = fixed ? - ! upper boundary non-zero fixed constituent flux - ! convective transport : phase 1 or phase 2? - !++bee - temporary... These names should be declared in the module that makes the addfld and outfld calls. - ! Lists of tracer names and diagnostics - ! constituents after physics (FV core only) - ! constituents before physics (FV core only) - ! names of horizontal advection tendencies - ! names of vertical advection tendencies - ! names of convection tendencies - ! names of species slt fixer tendencies - ! names of total tendencies of species - ! names of total physics tendencies of species - ! names of dme adjusted tracers (FV) - ! names of surface fluxes of species - ! names for horz + vert + fixer tendencies - ! Private data - ! index pointer to last advected tracer - ! true => read initial values from initial file - ! true => default 1 output of constituents in kg/kg - ! false => chemistry is responsible for making outfld - ! calls for constituents - !============================================================================================== - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !============================================================================================== - - !============================================================================== - - !============================================================================== - - !============================================================================================== - - !============================================================================================== - - - !============================================================================== - - !============================================================================== - - !============================================================================== - - !============================================================================== - END MODULE constituents diff --git a/test/ncar_kernels/HOMME_preq_hydrostatic/src/coordinate_systems_mod.F90 b/test/ncar_kernels/HOMME_preq_hydrostatic/src/coordinate_systems_mod.F90 deleted file mode 100644 index 83934bd240..0000000000 --- a/test/ncar_kernels/HOMME_preq_hydrostatic/src/coordinate_systems_mod.F90 +++ /dev/null @@ -1,294 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : coordinate_systems_mod.F90 -! Generated at: 2015-04-12 19:37:50 -! KGEN version: 0.4.9 - - - - MODULE coordinate_systems_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! WARNING: When using this class be sure that you know if the - ! cubic coordinates are on the unit cube or the [-\pi/4,\pi/4] cube - ! and if the spherical longitude is in [0,2\pi] or [-\pi,\pi] - USE kinds, ONLY: real_kind - IMPLICIT NONE - PRIVATE - TYPE, public :: cartesian2d_t - REAL(KIND=real_kind) :: x ! x coordinate - REAL(KIND=real_kind) :: y ! y coordinate - END TYPE cartesian2d_t - TYPE, public :: cartesian3d_t - REAL(KIND=real_kind) :: x ! x coordinate - REAL(KIND=real_kind) :: y ! y coordinate - REAL(KIND=real_kind) :: z ! z coordinate - END TYPE cartesian3d_t - TYPE, public :: spherical_polar_t - REAL(KIND=real_kind) :: r ! radius - REAL(KIND=real_kind) :: lon ! longitude - REAL(KIND=real_kind) :: lat ! latitude - END TYPE spherical_polar_t - - - - - ! ========================================== - ! Public Interfaces - ! ========================================== - ! (x,y,z) -> equal-angle (x,y) - ! (lat,lon) -> (x,y,z) - ! equal-angle (x,y) -> (lat,lon) - ! should be called cubedsphere2spherical - ! equal-angle (x,y) -> (x,y,z) - ! (lat,lon) -> equal-angle (x,y) - ! CE - ! (x,y,z) -> gnomonic (x,y) - ! gnominic (x,y) -> (lat,lon) - !private :: spherical_to_cart - - ! read interface - PUBLIC kgen_read - INTERFACE kgen_read - MODULE PROCEDURE kgen_read_cartesian2d_t - MODULE PROCEDURE kgen_read_cartesian3d_t - MODULE PROCEDURE kgen_read_spherical_polar_t - END INTERFACE kgen_read - - PUBLIC kgen_verify - INTERFACE kgen_verify - MODULE PROCEDURE kgen_verify_cartesian2d_t - MODULE PROCEDURE kgen_verify_cartesian3d_t - MODULE PROCEDURE kgen_verify_spherical_polar_t - END INTERFACE kgen_verify - - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - SUBROUTINE kgen_read_cartesian2d_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(cartesian2d_t), INTENT(out) :: var - READ(UNIT=kgen_unit) var%x - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%x **", var%x - END IF - READ(UNIT=kgen_unit) var%y - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%y **", var%y - END IF - END SUBROUTINE - SUBROUTINE kgen_read_cartesian3d_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(cartesian3d_t), INTENT(out) :: var - READ(UNIT=kgen_unit) var%x - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%x **", var%x - END IF - READ(UNIT=kgen_unit) var%y - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%y **", var%y - END IF - READ(UNIT=kgen_unit) var%z - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%z **", var%z - END IF - END SUBROUTINE - SUBROUTINE kgen_read_spherical_polar_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(spherical_polar_t), INTENT(out) :: var - READ(UNIT=kgen_unit) var%r - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%r **", var%r - END IF - READ(UNIT=kgen_unit) var%lon - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%lon **", var%lon - END IF - READ(UNIT=kgen_unit) var%lat - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%lat **", var%lat - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_cartesian2d_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(cartesian2d_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_real_real_kind("x", dtype_check_status, var%x, ref_var%x) - CALL kgen_verify_real_real_kind("y", dtype_check_status, var%y, ref_var%y) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_cartesian3d_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(cartesian3d_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_real_real_kind("x", dtype_check_status, var%x, ref_var%x) - CALL kgen_verify_real_real_kind("y", dtype_check_status, var%y, ref_var%y) - CALL kgen_verify_real_real_kind("z", dtype_check_status, var%z, ref_var%z) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_spherical_polar_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(spherical_polar_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_real_real_kind("r", dtype_check_status, var%r, ref_var%r) - CALL kgen_verify_real_real_kind("lon", dtype_check_status, var%lon, ref_var%lon) - CALL kgen_verify_real_real_kind("lat", dtype_check_status, var%lat, ref_var%lat) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_real_real_kind( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=real_kind), intent(in) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - END SUBROUTINE kgen_verify_real_real_kind - - ! ============================================ - ! copy_cart2d: - ! - ! Overload assignment operator for cartesian2D_t - ! ============================================ - - ! ============================================ - ! eq_cart2d: - ! - ! Overload == operator for cartesian2D_t - ! ============================================ - - ! =================================================== - ! distance_cart2D : scalar version - ! distance_cart2D_v: vector version - ! - ! computes distance between cartesian 2D coordinates - ! =================================================== - - - ! =================================================== - ! distance_cart3D : scalar version - ! distance_cart3D_v: vector version - ! =================================================== - - - ! =================================================================== - ! spherical_to_cart: - ! converts spherical polar {lon,lat} to 3D cartesian {x,y,z} - ! on unit sphere. Note: spherical longitude is [0,2\pi] - ! =================================================================== - - ! =================================================================== - ! spherical_to_cart_v: - ! converts spherical polar {lon,lat} to 3D cartesian {x,y,z} - ! on unit sphere. Note: spherical longitude is [0,2\pi] - ! =================================================================== - - ! ========================================================================== - ! cart_to_spherical: - ! - ! converts 3D cartesian {x,y,z} to spherical polar {lon,lat} - ! on unit sphere. Note: spherical longitude is [0,2\pi] - ! ========================================================================== - ! scalar version - - - - - - ! Note: Output spherical longitude is [-pi,pi] - - ! takes a 2D point on a face of the cube of size [-\pi/4, \pi/4] and projects it - ! onto a 3D point on a cube of size [-1,1] in R^3 - - ! onto a cube of size [-\pi/2,\pi/2] in R^3 - ! the spherical longitude can be either in [0,2\pi] or [-\pi,\pi] - - ! Go from an arbitrary sized cube in 3D - ! to a [-\pi/4,\pi/4] sized cube with (face,2d) coordinates. - ! - ! Z - ! | - ! | - ! | - ! | - ! ---------------Y - ! / - ! / - ! / - ! / - ! X - ! - ! NOTE: Face 1 => X positive constant face of cube - ! Face 2 => Y positive constant face of cube - ! Face 3 => X negative constant face of cube - ! Face 4 => Y negative constant face of cube - ! Face 5 => Z negative constant face of cube - ! Face 6 => Z positive constant face of cube - - ! This function divides three dimentional space up into - ! six sectors. These sectors are then considered as the - ! faces of the cube. It should work for any (x,y,z) coordinate - ! if on a sphere or on a cube. - - ! This could be done directly by using the lon, lat coordinates, - ! but call cube_face_number_from_cart just so that there is one place - ! to do the conversions and they are all consistant. - - ! CE, need real (cartesian) xy coordinates on the cubed sphere - - ! CE END - - !CE, 5.May 2011 - !INPUT: Points in xy cubed sphere coordinates, counterclockwise - !OUTPUT: corresponding area on the sphere - - END MODULE coordinate_systems_mod diff --git a/test/ncar_kernels/HOMME_preq_hydrostatic/src/dimensions_mod.F90 b/test/ncar_kernels/HOMME_preq_hydrostatic/src/dimensions_mod.F90 deleted file mode 100644 index 4a9ec73ed1..0000000000 --- a/test/ncar_kernels/HOMME_preq_hydrostatic/src/dimensions_mod.F90 +++ /dev/null @@ -1,54 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : dimensions_mod.F90 -! Generated at: 2015-04-12 19:37:50 -! KGEN version: 0.4.9 - - - - MODULE dimensions_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE constituents, ONLY: qsize_d => pcnst ! _EXTERNAL - IMPLICIT NONE - PRIVATE - ! set MAX number of tracers. actual number of tracers is a run time argument - ! fvm tracers - ! FI # dependent variables - INTEGER, parameter, public :: np = 4 - ! fvm dimensions: - !number of Gausspoints for the fvm integral approximation - !Max. Courant number - !halo width needed for reconstruction - phl - !total halo width where reconstruction is needed (nht<=nc) - phl - !(different from halo needed for elements on edges and corners - ! integer, parameter, public :: ns=3 !quadratic halo interpolation - recommended setting for nc=3 - ! integer, parameter, public :: ns=4 !cubic halo interpolation - recommended setting for nc=4 - !nhc determines width of halo exchanged with neighboring elements - ! - ! constants for SPELT - ! - !number of interpolation values, works only for this - ! number of points in an element - ! dg degree for hybrid cg/dg element 0=disabled - INTEGER, parameter, public :: npsq = np*np - INTEGER, parameter, public :: nlev=30 - INTEGER, parameter, public :: nlevp=nlev+1 - ! params for a mesh - ! integer, public, parameter :: max_elements_attached_to_node = 7 - ! integer, public, parameter :: s_nv = 2*max_elements_attached_to_node - !default for non-refined mesh (note that these are *not* parameters now) - !max_elements_attached_to_node-3 - !4 + 4*max_corner_elem - PUBLIC qsize_d - ! total number of elements - ! number of elements per MPI task - ! max number of elements on any MPI task - ! This is the number of physics processors/ per dynamics processor - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - - END MODULE dimensions_mod diff --git a/test/ncar_kernels/HOMME_preq_hydrostatic/src/edge_mod.F90 b/test/ncar_kernels/HOMME_preq_hydrostatic/src/edge_mod.F90 deleted file mode 100644 index da98978a8a..0000000000 --- a/test/ncar_kernels/HOMME_preq_hydrostatic/src/edge_mod.F90 +++ /dev/null @@ -1,919 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : edge_mod.F90 -! Generated at: 2015-04-12 19:37:50 -! KGEN version: 0.4.9 - - - - MODULE edge_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE coordinate_systems_mod, ONLY : kgen_read_mod10 => kgen_read - USE coordinate_systems_mod, ONLY : kgen_verify_mod10 => kgen_verify - USE kinds, ONLY: int_kind - USE kinds, ONLY: log_kind - USE kinds, ONLY: real_kind - ! _EXTERNAL - USE coordinate_systems_mod, ONLY: cartesian3d_t - IMPLICIT NONE - PRIVATE - TYPE, public :: rotation_t - INTEGER :: nbr ! nbr direction: north south east west - INTEGER :: reverse ! 0 = do not reverse order - ! 1 = reverse order - REAL(KIND=real_kind), dimension(:,:,:), pointer :: r => null() ! rotation matrix - END TYPE rotation_t - TYPE, public :: edgedescriptor_t - INTEGER(KIND=int_kind) :: use_rotation - INTEGER(KIND=int_kind) :: padding - INTEGER(KIND=int_kind), pointer :: putmapp(:) => null() - INTEGER(KIND=int_kind), pointer :: getmapp(:) => null() - INTEGER(KIND=int_kind), pointer :: putmapp_ghost(:) => null() - INTEGER(KIND=int_kind), pointer :: getmapp_ghost(:) => null() - INTEGER(KIND=int_kind), pointer :: globalid(:) => null() - INTEGER(KIND=int_kind), pointer :: loc2buf(:) => null() - TYPE(cartesian3d_t), pointer :: neigh_corners(:,:) => null() - INTEGER :: actual_neigh_edges - LOGICAL(KIND=log_kind), pointer :: reverse(:) => null() - TYPE(rotation_t), dimension(:), pointer :: rot => null() ! Identifies list of edges - ! that must be rotated, and how - END TYPE edgedescriptor_t - ! NOTE ON ELEMENT ORIENTATION - ! - ! Element orientation: index V(i,j) - ! - ! (1,np) NWEST (np,np) NEAST - ! - ! (1,1) SWEST (np,1) SEAST - ! - ! - ! for the edge neighbors: - ! we set the "reverse" flag if two elements who share an edge use a - ! reverse orientation. The data is reversed during the *pack* stage - ! For corner neighbors: - ! for edge buffers, there is no orientation because two corner neighbors - ! only share a single point. - ! For ghost cell data, there is a again two posible orientations. For - ! this case, we set the "reverse" flag if the corner element is using - ! the reverse orientation. In this case, the data is reversed during the - ! *unpack* stage (not sure why) - ! - ! The edge orientation is set at startup. The corner orientation is computed - ! at run time, via the call to compute_ghost_corner_orientation() - ! This routine only works for meshes with at most 1 corner element. It's - ! not called and the corner orientation flag is not set for unstructured meshes - ! - ! - ! Mark Taylor - ! pack/unpack full element of data of size (nx,nx) - ! user specifies the size when creating the buffer - ! input/output arrays are cartesian, and will only unpack 1 corner element - ! (even if there are more when running with an unstructured grid) - ! This routine is used mostly for testing and to compute the orientation of - ! an elements corner neighbors - ! - ! init/free buffers used by pack/unpack full and 3D - ! same as above, except orientation of element data is preserved - ! (so boundary data for two adjacent element may not match up) - ! - ! James Overfelt - ! pack/unpack user specifed halo region "nhc". - ! Does not include element edge data (assumes element edge data is C0) - ! (appropriate for continuous GLL data where the edge data does not need to be sent) - ! support for unstructed meshes via extra output arrays: sw,se,ne,nw - ! This routine is currently used by surfaces_mod.F90 to construct the GLL dual grid - ! - ! pack/unpack specifed halo size (up to 1 element) - ! should be identical to ghostVpack2d except for - ! shape of input array - ! returns v including populating halo region of v - ! "extra" corner elements are returned in arrays - ! sw,se,ne,nw - ! MT TODO: this routine works for unstructed data (where the corner orientation flag is - ! not set). So why dont we remove all the "reverse" checks in unpack? - ! - ! Christoph Erath - ! pack/unpack partial element of data of size (nx,nx) with user specifed halo size nh - ! user specifies the sizes when creating the buffer - ! buffer has 1 extra dimension (as compared to subroutines above) for multiple tracers - ! input/output arrays are cartesian, and thus assume at most 1 element at each corner - ! hence currently only supports cube-sphere grids. - ! - ! TODO: GhostBufferTR (init and type) should be removed - we only need GhostBuffer3D, - ! if we can fix - ! ghostVpack2d below to pass vlyr*ntrac_d instead of two seperate arguments - ! - ! ghostbufferTR_t - ! ghostbufferTR_t - ! routines which including element edge data - ! (used for FVM arrays where edge data is not shared by neighboring elements) - ! these routines pack/unpack element data with user specified halo size - ! - ! THESE ROUTINES SHOULD BE MERGED - ! - ! input/output: - ! v(1-nhc:npoints+nhc,1-nhc:npoints+nhc,vlyr,ntrac_d,timelevels) - ! used to pack/unpack SPELT "Rp". What's this? - ! v(1-nhc:npoints+nhc,1-nhc:npoints+nhc,vlyr,ntrac_d) - ! routines which do NOT include element edge data - ! (used for SPELT arrays and GLL point arrays, where edge data is shared and does not need - ! to be sent/received. - ! these routines pack/unpack element data with user specifed halo size - ! - ! THESE ROUTINES CAN ALL BE REPLACED BY ghostVpack3D (if we make extra corner data arrays - ! an optional argument). Or at least these should be merged to 1 routine - ! input/output: - ! v(1-nhc:npoints+nhc,1-nhc:npoints+nhc, vlyr, ntrac_d,timelevels) - ! used to pack/unpack SPELT%sga. what's this? - ! input/output - ! v(1-nhc:npoints+nhc,1-nhc:npoints+nhc) - ! used to pack/unpack FV vertex data (velocity/grid) - ! input/output - ! v(1-nhc:npoints+nhc,1-nhc:npoints+nhc, vlyr) - ! Wrap pointer so we can make an array of them. - - ! read interface - PUBLIC kgen_read - INTERFACE kgen_read - MODULE PROCEDURE kgen_read_rotation_t - MODULE PROCEDURE kgen_read_edgedescriptor_t - END INTERFACE kgen_read - - PUBLIC kgen_verify - INTERFACE kgen_verify - MODULE PROCEDURE kgen_verify_rotation_t - MODULE PROCEDURE kgen_verify_edgedescriptor_t - END INTERFACE kgen_verify - - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_real_kind_dim3_ptr(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=real_kind), INTENT(OUT), POINTER, DIMENSION(:,:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2,idx3 - INTEGER, DIMENSION(2,3) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_real_kind_dim3_ptr - - SUBROUTINE kgen_read_integer_int_kind_dim1_ptr(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - integer(KIND=int_kind), INTENT(OUT), POINTER, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_integer_int_kind_dim1_ptr - - SUBROUTINE kgen_read_logical_log_kind_dim1_ptr(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - logical(KIND=log_kind), INTENT(OUT), POINTER, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_logical_log_kind_dim1_ptr - - SUBROUTINE kgen_read_cartesian3d_t_dim2_ptr(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(cartesian3d_t), INTENT(OUT), POINTER, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - DO idx1=kgen_bound(1,1), kgen_bound(2, 1) - DO idx2=kgen_bound(1,2), kgen_bound(2, 2) - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_mod10(var(idx1,idx2), kgen_unit, printvar=printvar) - ELSE - CALL kgen_read_mod10(var(idx1,idx2), kgen_unit) - END IF - END DO - END DO - END IF - END SUBROUTINE kgen_read_cartesian3d_t_dim2_ptr - - SUBROUTINE kgen_read_rotation_t_dim1_ptr(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(rotation_t), INTENT(OUT), POINTER, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - DO idx1=kgen_bound(1,1), kgen_bound(2, 1) - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_rotation_t(var(idx1), kgen_unit, printvar=printvar) - ELSE - CALL kgen_read_rotation_t(var(idx1), kgen_unit) - END IF - END DO - END IF - END SUBROUTINE kgen_read_rotation_t_dim1_ptr - - ! No module extern variables - SUBROUTINE kgen_read_rotation_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(rotation_t), INTENT(out) :: var - READ(UNIT=kgen_unit) var%nbr - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%nbr **", var%nbr - END IF - READ(UNIT=kgen_unit) var%reverse - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%reverse **", var%reverse - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_real_kind_dim3_ptr(var%r, kgen_unit, printvar=printvar//"%r") - ELSE - CALL kgen_read_real_real_kind_dim3_ptr(var%r, kgen_unit) - END IF - END SUBROUTINE - SUBROUTINE kgen_read_edgedescriptor_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(edgedescriptor_t), INTENT(out) :: var - READ(UNIT=kgen_unit) var%use_rotation - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%use_rotation **", var%use_rotation - END IF - READ(UNIT=kgen_unit) var%padding - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%padding **", var%padding - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_integer_int_kind_dim1_ptr(var%putmapp, kgen_unit, printvar=printvar//"%putmapp") - ELSE - CALL kgen_read_integer_int_kind_dim1_ptr(var%putmapp, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_integer_int_kind_dim1_ptr(var%getmapp, kgen_unit, printvar=printvar//"%getmapp") - ELSE - CALL kgen_read_integer_int_kind_dim1_ptr(var%getmapp, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_integer_int_kind_dim1_ptr(var%putmapp_ghost, kgen_unit, printvar=printvar//"%putmapp_ghost") - ELSE - CALL kgen_read_integer_int_kind_dim1_ptr(var%putmapp_ghost, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_integer_int_kind_dim1_ptr(var%getmapp_ghost, kgen_unit, printvar=printvar//"%getmapp_ghost") - ELSE - CALL kgen_read_integer_int_kind_dim1_ptr(var%getmapp_ghost, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_integer_int_kind_dim1_ptr(var%globalid, kgen_unit, printvar=printvar//"%globalid") - ELSE - CALL kgen_read_integer_int_kind_dim1_ptr(var%globalid, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_integer_int_kind_dim1_ptr(var%loc2buf, kgen_unit, printvar=printvar//"%loc2buf") - ELSE - CALL kgen_read_integer_int_kind_dim1_ptr(var%loc2buf, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_cartesian3d_t_dim2_ptr(var%neigh_corners, kgen_unit, printvar=printvar//"%neigh_corners") - ELSE - CALL kgen_read_cartesian3d_t_dim2_ptr(var%neigh_corners, kgen_unit) - END IF - READ(UNIT=kgen_unit) var%actual_neigh_edges - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%actual_neigh_edges **", var%actual_neigh_edges - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_logical_log_kind_dim1_ptr(var%reverse, kgen_unit, printvar=printvar//"%reverse") - ELSE - CALL kgen_read_logical_log_kind_dim1_ptr(var%reverse, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_rotation_t_dim1_ptr(var%rot, kgen_unit, printvar=printvar//"%rot") - ELSE - CALL kgen_read_rotation_t_dim1_ptr(var%rot, kgen_unit) - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_rotation_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(rotation_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_integer("nbr", dtype_check_status, var%nbr, ref_var%nbr) - CALL kgen_verify_integer("reverse", dtype_check_status, var%reverse, ref_var%reverse) - CALL kgen_verify_real_real_kind_dim3_ptr("r", dtype_check_status, var%r, ref_var%r) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_edgedescriptor_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(edgedescriptor_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_integer_int_kind("use_rotation", dtype_check_status, var%use_rotation, ref_var%use_rotation) - CALL kgen_verify_integer_int_kind("padding", dtype_check_status, var%padding, ref_var%padding) - CALL kgen_verify_integer_int_kind_dim1_ptr("putmapp", dtype_check_status, var%putmapp, ref_var%putmapp) - CALL kgen_verify_integer_int_kind_dim1_ptr("getmapp", dtype_check_status, var%getmapp, ref_var%getmapp) - CALL kgen_verify_integer_int_kind_dim1_ptr("putmapp_ghost", dtype_check_status, var%putmapp_ghost, ref_var%putmapp_ghost) - CALL kgen_verify_integer_int_kind_dim1_ptr("getmapp_ghost", dtype_check_status, var%getmapp_ghost, ref_var%getmapp_ghost) - CALL kgen_verify_integer_int_kind_dim1_ptr("globalid", dtype_check_status, var%globalid, ref_var%globalid) - CALL kgen_verify_integer_int_kind_dim1_ptr("loc2buf", dtype_check_status, var%loc2buf, ref_var%loc2buf) - CALL kgen_verify_cartesian3d_t_dim2_ptr("neigh_corners", dtype_check_status, var%neigh_corners, ref_var%neigh_corners) - CALL kgen_verify_integer("actual_neigh_edges", dtype_check_status, var%actual_neigh_edges, ref_var%actual_neigh_edges) - CALL kgen_verify_logical_log_kind_dim1_ptr("reverse", dtype_check_status, var%reverse, ref_var%reverse) - CALL kgen_verify_rotation_t_dim1_ptr("rot", dtype_check_status, var%rot, ref_var%rot) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_integer( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - END SUBROUTINE kgen_verify_integer - - SUBROUTINE kgen_verify_real_real_kind_dim3_ptr( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=real_kind), intent(in), DIMENSION(:,:,:), POINTER :: var, ref_var - real(KIND=real_kind) :: nrmsdiff, rmsdiff - real(KIND=real_kind), allocatable, DIMENSION(:,:,:) :: temp, temp2 - integer :: n - IF ( ASSOCIATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END IF - END SUBROUTINE kgen_verify_real_real_kind_dim3_ptr - - SUBROUTINE kgen_verify_integer_int_kind( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer(KIND=int_kind), intent(in) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - END SUBROUTINE kgen_verify_integer_int_kind - - SUBROUTINE kgen_verify_integer_int_kind_dim1_ptr( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer(KIND=int_kind), intent(in), DIMENSION(:), POINTER :: var, ref_var - IF ( ASSOCIATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - end if - - check_status%numFatal = check_status%numFatal+1 - END IF - END IF - END SUBROUTINE kgen_verify_integer_int_kind_dim1_ptr - - SUBROUTINE kgen_verify_cartesian3d_t_dim2_ptr( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - type(check_t) :: dtype_check_status - TYPE(cartesian3d_t), intent(in), DIMENSION(:,:), POINTER :: var, ref_var - integer :: idx1,idx2 - IF ( ASSOCIATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - DO idx1=LBOUND(var,1), UBOUND(var,1) - DO idx2=LBOUND(var,2), UBOUND(var,2) - CALL kgen_verify_mod10(varname, dtype_check_status, var(idx1,idx2), ref_var(idx1,idx2)) - END DO - END DO - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END IF - END SUBROUTINE kgen_verify_cartesian3d_t_dim2_ptr - - SUBROUTINE kgen_verify_logical_log_kind_dim1_ptr( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - logical(KIND=log_kind), intent(in), DIMENSION(:), POINTER :: var, ref_var - IF ( ASSOCIATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var .EQV. ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - end if - - check_status%numFatal = check_status%numFatal+1 - END IF - END IF - END SUBROUTINE kgen_verify_logical_log_kind_dim1_ptr - - SUBROUTINE kgen_verify_rotation_t_dim1_ptr( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - type(check_t) :: dtype_check_status - TYPE(rotation_t), intent(in), DIMENSION(:), POINTER :: var, ref_var - integer :: idx1 - IF ( ASSOCIATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - DO idx1=LBOUND(var,1), UBOUND(var,1) - CALL kgen_verify_rotation_t("rotation_t", dtype_check_status, var(idx1), ref_var(idx1)) - END DO - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END IF - END SUBROUTINE kgen_verify_rotation_t_dim1_ptr - - ! ========================================= - ! initEdgeBuffer: - ! - ! create an Real based communication buffer - ! ========================================= - - ! ========================================= - ! initLongEdgeBuffer: - ! - ! create an Integer based communication buffer - ! ========================================= - - ! ========================================= - ! edgeDGVpack: - ! - ! Pack edges of v into buf for DG stencil - ! ========================================= - - ! =========================================== - ! FreeEdgeBuffer: - ! - ! Freed an edge communication buffer - ! ========================================= - - - ! =========================================== - ! FreeLongEdgeBuffer: - ! - ! Freed an edge communication buffer - ! ========================================= - - ! ========================================= - ! - !> @brief Pack edges of v into an edge buffer for boundary exchange. - ! - !> This subroutine packs for one or more vertical layers into an edge - !! buffer. If the buffer associated with edge is not large enough to - !! hold all vertical layers you intent to pack, the method will - !! halt the program with a call to parallel_mod::haltmp(). - !! @param[in] edge Edge Buffer into which the data will be packed. - !! This buffer must be previously allocated with initEdgeBuffer(). - !! @param[in] v The data to be packed. - !! @param[in] vlyr Number of vertical level coming into the subroutine - !! for packing for input v. - !! @param[in] kptr Vertical pointer to the place in the edge buffer where - !! data will be located. - ! ========================================= - - ! ========================================= - ! LongEdgeVpack: - ! - ! Pack edges of v into buf... - ! ========================================= - - ! ======================================== - ! edgeVunpack: - ! - ! Unpack edges from edge buffer into v... - ! ======================================== - - - ! ======================================== - ! edgeDGVunpack: - ! - ! Unpack edges from edge buffer into v... - ! ======================================== - - ! ======================================== - ! edgeVunpackMIN/MAX: - ! - ! Finds the Min/Max edges from edge buffer into v... - ! ======================================== - - - ! ======================================== - ! LongEdgeVunpackMIN: - ! - ! Finds the Min edges from edge buffer into v... - ! ======================================== - - ! ============================= - ! edgerotate: - ! - ! Rotate edges in buffer... - ! ============================= - - ! ============================================= - ! buffermap: - ! - ! buffermap translates element number, inum and - ! element edge/corner, facet, into an edge buffer - ! memory location, loc. - ! ============================================= - - ! =========================================== - ! FreeGhostBuffer: - ! Author: Christoph Erath, Mark Taylor - ! Freed an ghostpoints communication buffer - ! ========================================= - - ! ========================================= - ! ========================================= - ! - !> @brief Pack edges of v into an edge buffer for boundary exchange. - ! - !> This subroutine packs for one or more vertical layers into an edge - !! buffer. If the buffer associated with edge is not large enough to - !! hold all vertical layers you intent to pack, the method will - !! halt the program with a call to parallel_mod::haltmp(). - !! @param[in] edge Ghost Buffer into which the data will be packed. - !! This buffer must be previously allocated with initghostbufferfull(). - !! @param[in] v The data to be packed. - !! @param[in] vlyr Number of vertical level coming into the subroutine - !! for packing for input v. - !! @param[in] kptr Vertical pointer to the place in the edge buffer where - !! data will be located. - ! ========================================= - - ! ======================================== - ! edgeVunpack: - ! - ! Unpack edges from edge buffer into v... - ! ======================================== - - ! ========================================= - ! - !> @brief Pack edges of v into an edge buffer for boundary exchange. - ! - !> This subroutine packs for one or more vertical layers into an edge - !! buffer. If the buffer associated with edge is not large enough to - !! hold all vertical layers you intent to pack, the method will - !! halt the program with a call to parallel_mod::haltmp(). - !! @param[in] edge Ghost Buffer into which the data will be packed. - !! This buffer must be previously allocated with initghostbuffer(). - !! @param[in] v The data to be packed. - !! @param[in] vlyr Number of vertical level coming into the subroutine - !! for packing for input v. - !! @param[in] kptr Vertical pointer to the place in the edge buffer where - !! data will be located. - ! ========================================= - - ! ======================================== - ! edgeVunpack: - ! - ! Unpack edges from edge buffer into v... - ! ======================================== - - ! ========================================= - ! initGhostBuffer: - ! Author: Christoph Erath - ! create an Real based communication buffer - ! npoints is the number of points on one side - ! nhc is the deep of the ghost/halo zone - ! ========================================= - - ! ========================================= - ! Christoph Erath - !> Packs the halo zone from v - ! ========================================= - - ! ========================================= - ! Christoph Erath - !> Packs the halo zone from v - ! ========================================= - ! NOTE: I have to give timelevels as argument, because element_mod is not compiled first - ! and the array call has to be done in this way because of performance reasons!!! - - ! ======================================== - ! Christoph Erath - ! - ! Unpack the halo zone into v - ! ======================================== - - ! ======================================== - ! Christoph Erath - ! - ! Unpack the halo zone into v - ! ======================================== - ! NOTE: I have to give timelevels as argument, because element_mod is not compiled first - ! and the array call has to be done in this way because of performance reasons!!! - - ! ================================================================================= - ! GHOSTVPACK2D - ! AUTHOR: Christoph Erath - ! Pack edges of v into an ghost buffer for boundary exchange. - ! - ! This subroutine packs for one vertical layers into an ghost - ! buffer. It is for cartesian points (v is only two dimensional). - ! If the buffer associated with edge is not large enough to - ! hold all vertical layers you intent to pack, the method will - ! halt the program with a call to parallel_mod::haltmp(). - ! INPUT: - ! - ghost Buffer into which the data will be packed. - ! This buffer must be previously allocated with initGhostBuffer(). - ! - v The data to be packed. - ! - nhc deep of ghost/halo zone - ! - npoints number of points on on side - ! - kptr Vertical pointer to the place in the edge buffer where - ! data will be located. - ! ================================================================================= - - ! ================================================================================= - ! GHOSTVUNPACK2D - ! AUTHOR: Christoph Erath - ! Unpack ghost points from ghost buffer into v... - ! It is for cartesian points (v is only two dimensional). - ! INPUT SAME arguments as for GHOSTVPACK2d - ! ================================================================================= - - ! ================================================================================= - ! GHOSTVPACK2D - ! AUTHOR: Christoph Erath - ! Pack edges of v into an ghost buffer for boundary exchange. - ! - ! This subroutine packs for one vertical layers into an ghost - ! buffer. It is for cartesian points (v is only two dimensional). - ! If the buffer associated with edge is not large enough to - ! hold all vertical layers you intent to pack, the method will - ! halt the program with a call to parallel_mod::haltmp(). - ! INPUT: - ! - ghost Buffer into which the data will be packed. - ! This buffer must be previously allocated with initGhostBuffer(). - ! - v The data to be packed. - ! - nhc deep of ghost/halo zone - ! - npoints number of points on on side - ! - kptr Vertical pointer to the place in the edge buffer where - ! data will be located. - ! ================================================================================= - - ! ================================================================================= - ! GHOSTVUNPACK2D - ! AUTHOR: Christoph Erath - ! Unpack ghost points from ghost buffer into v... - ! It is for cartesian points (v is only two dimensional). - ! INPUT SAME arguments as for GHOSTVPACK2d - ! ================================================================================= - - ! ================================================================================= - ! GHOSTVPACK2D - ! AUTHOR: Christoph Erath - ! Pack edges of v into an ghost buffer for boundary exchange. - ! - ! This subroutine packs for one vertical layers into an ghost - ! buffer. It is for cartesian points (v is only two dimensional). - ! If the buffer associated with edge is not large enough to - ! hold all vertical layers you intent to pack, the method will - ! halt the program with a call to parallel_mod::haltmp(). - ! INPUT: - ! - ghost Buffer into which the data will be packed. - ! This buffer must be previously allocated with initGhostBuffer(). - ! - v The data to be packed. - ! - nhc deep of ghost/halo zone - ! - npoints number of points on on side - ! - kptr Vertical pointer to the place in the edge buffer where - ! data will be located. - ! ================================================================================= - - ! ================================================================================= - ! GHOSTVUNPACK2D - ! AUTHOR: Christoph Erath - ! Unpack ghost points from ghost buffer into v... - ! It is for cartesian points (v is only two dimensional). - ! INPUT SAME arguments as for GHOSTVPACK2d - ! ================================================================================= - - ! ========================================= - ! initGhostBuffer3d: - ! Author: James Overfelt - ! create an Real based communication buffer - ! npoints is the number of points on one side - ! nhc is the deep of the ghost/halo zone - ! ========================================= - - ! ================================================================================= - ! GHOSTVPACK3D - ! AUTHOR: James Overfelt (from a subroutine of Christoph Erath, ghostvpack2D) - ! Pack edges of v into an ghost buffer for boundary exchange. - ! - ! This subroutine packs for many vertical layers into an ghost - ! buffer. - ! If the buffer associated with edge is not large enough to - ! hold all vertical layers you intent to pack, the method will - ! halt the program with a call to parallel_mod::haltmp(). - ! INPUT: - ! - ghost Buffer into which the data will be packed. - ! This buffer must be previously allocated with initGhostBuffer(). - ! - v The data to be packed. - ! - nhc deep of ghost/halo zone - ! - npoints number of points on on side - ! - kptr Vertical pointer to the place in the edge buffer where - ! data will be located. - ! ================================================================================= - - ! ================================================================================= - ! GHOSTVUNPACK3D - ! AUTHOR: James Overfelt (from a subroutine of Christoph Erath, ghostVunpack2d) - ! Unpack ghost points from ghost buffer into v... - ! It is for cartesian points (v is only two dimensional). - ! INPUT SAME arguments as for GHOSTVPACK - ! ================================================================================= - - END MODULE edge_mod diff --git a/test/ncar_kernels/HOMME_preq_hydrostatic/src/element_mod.F90 b/test/ncar_kernels/HOMME_preq_hydrostatic/src/element_mod.F90 deleted file mode 100644 index 9b3e197b7f..0000000000 --- a/test/ncar_kernels/HOMME_preq_hydrostatic/src/element_mod.F90 +++ /dev/null @@ -1,1290 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : element_mod.F90 -! Generated at: 2015-04-12 19:37:50 -! KGEN version: 0.4.9 - - - - MODULE element_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE coordinate_systems_mod, ONLY : kgen_read_mod10 => kgen_read - USE coordinate_systems_mod, ONLY : kgen_verify_mod10 => kgen_verify - USE gridgraph_mod, ONLY : kgen_read_mod11 => kgen_read - USE gridgraph_mod, ONLY : kgen_verify_mod11 => kgen_verify - USE edge_mod, ONLY : kgen_read_mod12 => kgen_read - USE edge_mod, ONLY : kgen_verify_mod12 => kgen_verify - USE kinds, ONLY: int_kind - USE kinds, ONLY: real_kind - USE kinds, ONLY: long_kind - USE coordinate_systems_mod, ONLY: spherical_polar_t - USE coordinate_systems_mod, ONLY: cartesian2d_t - USE coordinate_systems_mod, ONLY: cartesian3d_t - USE dimensions_mod, ONLY: np - USE dimensions_mod, ONLY: nlev - USE dimensions_mod, ONLY: qsize_d - USE dimensions_mod, ONLY: nlevp - USE dimensions_mod, ONLY: npsq - USE edge_mod, ONLY: edgedescriptor_t - USE gridgraph_mod, ONLY: gridvertex_t - IMPLICIT NONE - PRIVATE - INTEGER, public, parameter :: timelevels = 3 - ! =========== PRIMITIVE-EQUATION DATA-STRUCTURES ===================== - TYPE, public :: elem_state_t - ! prognostic variables for preqx solver - ! prognostics must match those in prim_restart_mod.F90 - ! vertically-lagrangian code advects dp3d instead of ps_v - ! tracers Q, Qdp always use 2 level time scheme - REAL(KIND=real_kind) :: v (np,np,2,nlev,timelevels) ! velocity 1 - REAL(KIND=real_kind) :: t (np,np,nlev,timelevels) ! temperature 2 - REAL(KIND=real_kind) :: dp3d(np,np,nlev,timelevels) ! delta p on levels 8 - REAL(KIND=real_kind) :: lnps(np,np,timelevels) ! log surface pressure 3 - REAL(KIND=real_kind) :: ps_v(np,np,timelevels) ! surface pressure 4 - REAL(KIND=real_kind) :: phis(np,np) ! surface geopotential (prescribed) 5 - REAL(KIND=real_kind) :: q (np,np,nlev,qsize_d) ! Tracer concentration 6 - REAL(KIND=real_kind) :: qdp (np,np,nlev,qsize_d,2) ! Tracer mass 7 - END TYPE elem_state_t - ! num prognistics variables (for prim_restart_mod.F90) - !___________________________________________________________________ - TYPE, public :: derived_state_t - ! diagnostic variables for preqx solver - ! storage for subcycling tracers/dynamics - ! if (compute_mean_flux==1) vn0=time_avg(U*dp) else vn0=U at tracer-time t - REAL(KIND=real_kind) :: vn0 (np,np,2,nlev) ! velocity for SE tracer advection - REAL(KIND=real_kind) :: vstar(np,np,2,nlev) ! velocity on Lagrangian surfaces - REAL(KIND=real_kind) :: dpdiss_biharmonic(np,np,nlev) ! mean dp dissipation tendency, if nu_p>0 - REAL(KIND=real_kind) :: dpdiss_ave(np,np,nlev) ! mean dp used to compute psdiss_tens - ! diagnostics for explicit timestep - REAL(KIND=real_kind) :: phi(np,np,nlev) ! geopotential - REAL(KIND=real_kind) :: omega_p(np,np,nlev) ! vertical tendency (derived) - REAL(KIND=real_kind) :: eta_dot_dpdn(np,np,nlevp) ! mean vertical flux from dynamics - ! semi-implicit diagnostics: computed in explict-component, reused in Helmholtz-component. - REAL(KIND=real_kind) :: grad_lnps(np,np,2) ! gradient of log surface pressure - REAL(KIND=real_kind) :: zeta(np,np,nlev) ! relative vorticity - REAL(KIND=real_kind) :: div(np,np,nlev,timelevels) ! divergence - ! tracer advection fields used for consistency and limiters - REAL(KIND=real_kind) :: dp(np,np,nlev) ! for dp_tracers at physics timestep - REAL(KIND=real_kind) :: divdp(np,np,nlev) ! divergence of dp - REAL(KIND=real_kind) :: divdp_proj(np,np,nlev) ! DSSed divdp - ! forcing terms for 1 - REAL(KIND=real_kind) :: fq(np,np,nlev,qsize_d, 1) ! tracer forcing - REAL(KIND=real_kind) :: fm(np,np,2,nlev, 1) ! momentum forcing - REAL(KIND=real_kind) :: ft(np,np,nlev, 1) ! temperature forcing - REAL(KIND=real_kind) :: omega_prescribed(np,np,nlev) ! prescribed vertical tendency - ! forcing terms for both 1 and HOMME - ! FQps for conserving dry mass in the presence of precipitation - REAL(KIND=real_kind) :: pecnd(np,np,nlev) ! pressure perturbation from condensate - REAL(KIND=real_kind) :: fqps(np,np,timelevels) ! forcing of FQ on ps_v - END TYPE derived_state_t - !___________________________________________________________________ - TYPE, public :: elem_accum_t - ! the "4" timelevels represents data computed at: - ! 1 t-.5 - ! 2 t+.5 after dynamics - ! 3 t+.5 after forcing - ! 4 t+.5 after Robert - ! after calling TimeLevelUpdate, all times above decrease by 1.0 - REAL(KIND=real_kind) :: kener(np,np,4) - REAL(KIND=real_kind) :: pener(np,np,4) - REAL(KIND=real_kind) :: iener(np,np,4) - REAL(KIND=real_kind) :: iener_wet(np,np,4) - REAL(KIND=real_kind) :: qvar(np,np,qsize_d,4) ! Q variance at half time levels - REAL(KIND=real_kind) :: qmass(np,np,qsize_d,4) ! Q mass at half time levels - REAL(KIND=real_kind) :: q1mass(np,np,qsize_d) ! Q mass at full time levels - END TYPE elem_accum_t - ! ============= DATA-STRUCTURES COMMON TO ALL SOLVERS ================ - TYPE, public :: index_t - INTEGER(KIND=int_kind) :: ia(npsq), ja(npsq) - INTEGER(KIND=int_kind) :: is, ie - INTEGER(KIND=int_kind) :: numuniquepts - INTEGER(KIND=int_kind) :: uniqueptoffset - END TYPE index_t - !___________________________________________________________________ - TYPE, public :: element_t - INTEGER(KIND=int_kind) :: localid - INTEGER(KIND=int_kind) :: globalid - ! Coordinate values of element points - TYPE(spherical_polar_t) :: spherep(np,np) ! Spherical coords of GLL points - ! Equ-angular gnomonic projection coordinates - TYPE(cartesian2d_t) :: cartp(np,np) ! gnomonic coords of GLL points - TYPE(cartesian2d_t) :: corners(4) ! gnomonic coords of element corners - REAL(KIND=real_kind) :: u2qmap(4,2) ! bilinear map from ref element to quad in cubedsphere coordinates - ! SHOULD BE REMOVED - ! 3D cartesian coordinates - TYPE(cartesian3d_t) :: corners3d(4) - ! Element diagnostics - REAL(KIND=real_kind) :: area ! Area of element - REAL(KIND=real_kind) :: normdinv ! some type of norm of Dinv used for CFL - REAL(KIND=real_kind) :: dx_short ! short length scale in km - REAL(KIND=real_kind) :: dx_long ! long length scale in km - REAL(KIND=real_kind) :: variable_hyperviscosity(np,np) ! hyperviscosity based on above - REAL(KIND=real_kind) :: hv_courant ! hyperviscosity courant number - REAL(KIND=real_kind) :: tensorvisc(2,2,np,np) !og, matrix V for tensor viscosity - ! Edge connectivity information - ! integer(kind=int_kind) :: node_numbers(4) - ! integer(kind=int_kind) :: node_multiplicity(4) ! number of elements sharing corner node - TYPE(gridvertex_t) :: vertex ! element grid vertex information - TYPE(edgedescriptor_t) :: desc - TYPE(elem_state_t) :: state - TYPE(derived_state_t) :: derived - TYPE(elem_accum_t) :: accum - ! Metric terms - REAL(KIND=real_kind) :: met(2,2,np,np) ! metric tensor on velocity and pressure grid - REAL(KIND=real_kind) :: metinv(2,2,np,np) ! metric tensor on velocity and pressure grid - REAL(KIND=real_kind) :: metdet(np,np) ! g = SQRT(det(g_ij)) on velocity and pressure grid - REAL(KIND=real_kind) :: rmetdet(np,np) ! 1/metdet on velocity pressure grid - REAL(KIND=real_kind) :: d(2,2,np,np) ! Map covariant field on cube to vector field on the sphere - REAL(KIND=real_kind) :: dinv(2,2,np,np) ! Map vector field on the sphere to covariant v on cube - ! Convert vector fields from spherical to rectangular components - ! The transpose of this operation is its pseudoinverse. - REAL(KIND=real_kind) :: vec_sphere2cart(np,np,3,2) - ! Mass matrix terms for an element on a cube face - REAL(KIND=real_kind) :: mp(np,np) ! mass matrix on v and p grid - REAL(KIND=real_kind) :: rmp(np,np) ! inverse mass matrix on v and p grid - ! Mass matrix terms for an element on the sphere - ! This mass matrix is used when solving the equations in weak form - ! with the natural (surface area of the sphere) inner product - REAL(KIND=real_kind) :: spheremp(np,np) ! mass matrix on v and p grid - REAL(KIND=real_kind) :: rspheremp(np,np) ! inverse mass matrix on v and p grid - INTEGER(KIND=long_kind) :: gdofp(np,np) ! global degree of freedom (P-grid) - REAL(KIND=real_kind) :: fcor(np,np) ! Coreolis term - TYPE(index_t) :: idxp - TYPE(index_t), pointer :: idxv - INTEGER :: facenum - ! force element_t to be a multiple of 8 bytes. - ! on BGP, code will crash (signal 7, or signal 15) if 8 byte alignment is off - ! check core file for: - ! core.63:Generated by interrupt..(Alignment Exception DEAR=0xa1ef671c ESR=0x01800000 CCR0=0x4800a002) - INTEGER :: dummy - END TYPE element_t - !___________________________________________________________________ - - ! read interface - PUBLIC kgen_read - INTERFACE kgen_read - MODULE PROCEDURE kgen_read_elem_state_t - MODULE PROCEDURE kgen_read_derived_state_t - MODULE PROCEDURE kgen_read_elem_accum_t - MODULE PROCEDURE kgen_read_index_t - MODULE PROCEDURE kgen_read_element_t - END INTERFACE kgen_read - - PUBLIC kgen_verify - INTERFACE kgen_verify - MODULE PROCEDURE kgen_verify_elem_state_t - MODULE PROCEDURE kgen_verify_derived_state_t - MODULE PROCEDURE kgen_verify_elem_accum_t - MODULE PROCEDURE kgen_verify_index_t - MODULE PROCEDURE kgen_verify_element_t - END INTERFACE kgen_verify - - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_index_t_ptr(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(index_t), INTENT(OUT), POINTER :: var - LOGICAL :: is_true - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - ALLOCATE(var) - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_index_t(var, kgen_unit, printvar=printvar//"%index_t") - ELSE - CALL kgen_read_index_t(var, kgen_unit) - END IF - END IF - END SUBROUTINE kgen_read_index_t_ptr - - SUBROUTINE kgen_read_cartesian2d_t_dim2(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(cartesian2d_t), INTENT(OUT), DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - DO idx1=kgen_bound(1,1), kgen_bound(2, 1) - DO idx2=kgen_bound(1,2), kgen_bound(2, 2) - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_mod10(var(idx1,idx2), kgen_unit, printvar=printvar) - ELSE - CALL kgen_read_mod10(var(idx1,idx2), kgen_unit) - END IF - END DO - END DO - END IF - END SUBROUTINE kgen_read_cartesian2d_t_dim2 - - SUBROUTINE kgen_read_cartesian3d_t_dim1(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(cartesian3d_t), INTENT(OUT), DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - DO idx1=kgen_bound(1,1), kgen_bound(2, 1) - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_mod10(var(idx1), kgen_unit, printvar=printvar) - ELSE - CALL kgen_read_mod10(var(idx1), kgen_unit) - END IF - END DO - END IF - END SUBROUTINE kgen_read_cartesian3d_t_dim1 - - SUBROUTINE kgen_read_cartesian2d_t_dim1(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(cartesian2d_t), INTENT(OUT), DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - DO idx1=kgen_bound(1,1), kgen_bound(2, 1) - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_mod10(var(idx1), kgen_unit, printvar=printvar) - ELSE - CALL kgen_read_mod10(var(idx1), kgen_unit) - END IF - END DO - END IF - END SUBROUTINE kgen_read_cartesian2d_t_dim1 - - SUBROUTINE kgen_read_spherical_polar_t_dim2(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(spherical_polar_t), INTENT(OUT), DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - DO idx1=kgen_bound(1,1), kgen_bound(2, 1) - DO idx2=kgen_bound(1,2), kgen_bound(2, 2) - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_mod10(var(idx1,idx2), kgen_unit, printvar=printvar) - ELSE - CALL kgen_read_mod10(var(idx1,idx2), kgen_unit) - END IF - END DO - END DO - END IF - END SUBROUTINE kgen_read_spherical_polar_t_dim2 - - ! No module extern variables - SUBROUTINE kgen_read_elem_state_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(elem_state_t), INTENT(out) :: var - READ(UNIT=kgen_unit) var%v - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%v **", var%v - END IF - READ(UNIT=kgen_unit) var%t - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%t **", var%t - END IF - READ(UNIT=kgen_unit) var%dp3d - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dp3d **", var%dp3d - END IF - READ(UNIT=kgen_unit) var%lnps - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%lnps **", var%lnps - END IF - READ(UNIT=kgen_unit) var%ps_v - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%ps_v **", var%ps_v - END IF - READ(UNIT=kgen_unit) var%phis - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%phis **", var%phis - END IF - READ(UNIT=kgen_unit) var%q - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%q **", var%q - END IF - READ(UNIT=kgen_unit) var%qdp - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%qdp **", var%qdp - END IF - END SUBROUTINE - SUBROUTINE kgen_read_derived_state_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(derived_state_t), INTENT(out) :: var - READ(UNIT=kgen_unit) var%vn0 - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%vn0 **", var%vn0 - END IF - READ(UNIT=kgen_unit) var%vstar - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%vstar **", var%vstar - END IF - READ(UNIT=kgen_unit) var%dpdiss_biharmonic - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dpdiss_biharmonic **", var%dpdiss_biharmonic - END IF - READ(UNIT=kgen_unit) var%dpdiss_ave - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dpdiss_ave **", var%dpdiss_ave - END IF - READ(UNIT=kgen_unit) var%phi - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%phi **", var%phi - END IF - READ(UNIT=kgen_unit) var%omega_p - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%omega_p **", var%omega_p - END IF - READ(UNIT=kgen_unit) var%eta_dot_dpdn - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%eta_dot_dpdn **", var%eta_dot_dpdn - END IF - READ(UNIT=kgen_unit) var%grad_lnps - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%grad_lnps **", var%grad_lnps - END IF - READ(UNIT=kgen_unit) var%zeta - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%zeta **", var%zeta - END IF - READ(UNIT=kgen_unit) var%div - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%div **", var%div - END IF - READ(UNIT=kgen_unit) var%dp - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dp **", var%dp - END IF - READ(UNIT=kgen_unit) var%divdp - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%divdp **", var%divdp - END IF - READ(UNIT=kgen_unit) var%divdp_proj - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%divdp_proj **", var%divdp_proj - END IF - READ(UNIT=kgen_unit) var%fq - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%fq **", var%fq - END IF - READ(UNIT=kgen_unit) var%fm - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%fm **", var%fm - END IF - READ(UNIT=kgen_unit) var%ft - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%ft **", var%ft - END IF - READ(UNIT=kgen_unit) var%omega_prescribed - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%omega_prescribed **", var%omega_prescribed - END IF - READ(UNIT=kgen_unit) var%pecnd - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%pecnd **", var%pecnd - END IF - READ(UNIT=kgen_unit) var%fqps - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%fqps **", var%fqps - END IF - END SUBROUTINE - SUBROUTINE kgen_read_elem_accum_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(elem_accum_t), INTENT(out) :: var - READ(UNIT=kgen_unit) var%kener - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%kener **", var%kener - END IF - READ(UNIT=kgen_unit) var%pener - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%pener **", var%pener - END IF - READ(UNIT=kgen_unit) var%iener - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%iener **", var%iener - END IF - READ(UNIT=kgen_unit) var%iener_wet - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%iener_wet **", var%iener_wet - END IF - READ(UNIT=kgen_unit) var%qvar - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%qvar **", var%qvar - END IF - READ(UNIT=kgen_unit) var%qmass - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%qmass **", var%qmass - END IF - READ(UNIT=kgen_unit) var%q1mass - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%q1mass **", var%q1mass - END IF - END SUBROUTINE - SUBROUTINE kgen_read_index_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(index_t), INTENT(out) :: var - READ(UNIT=kgen_unit) var%ia - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%ia **", var%ia - END IF - READ(UNIT=kgen_unit) var%ja - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%ja **", var%ja - END IF - READ(UNIT=kgen_unit) var%is - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%is **", var%is - END IF - READ(UNIT=kgen_unit) var%ie - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%ie **", var%ie - END IF - READ(UNIT=kgen_unit) var%numuniquepts - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%numuniquepts **", var%numuniquepts - END IF - READ(UNIT=kgen_unit) var%uniqueptoffset - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%uniqueptoffset **", var%uniqueptoffset - END IF - END SUBROUTINE - SUBROUTINE kgen_read_element_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(element_t), INTENT(out) :: var - READ(UNIT=kgen_unit) var%localid - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%localid **", var%localid - END IF - READ(UNIT=kgen_unit) var%globalid - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%globalid **", var%globalid - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_spherical_polar_t_dim2(var%spherep, kgen_unit, printvar=printvar//"%spherep") - ELSE - CALL kgen_read_spherical_polar_t_dim2(var%spherep, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_cartesian2d_t_dim2(var%cartp, kgen_unit, printvar=printvar//"%cartp") - ELSE - CALL kgen_read_cartesian2d_t_dim2(var%cartp, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_cartesian2d_t_dim1(var%corners, kgen_unit, printvar=printvar//"%corners") - ELSE - CALL kgen_read_cartesian2d_t_dim1(var%corners, kgen_unit) - END IF - READ(UNIT=kgen_unit) var%u2qmap - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%u2qmap **", var%u2qmap - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_cartesian3d_t_dim1(var%corners3d, kgen_unit, printvar=printvar//"%corners3d") - ELSE - CALL kgen_read_cartesian3d_t_dim1(var%corners3d, kgen_unit) - END IF - READ(UNIT=kgen_unit) var%area - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%area **", var%area - END IF - READ(UNIT=kgen_unit) var%normdinv - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%normdinv **", var%normdinv - END IF - READ(UNIT=kgen_unit) var%dx_short - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dx_short **", var%dx_short - END IF - READ(UNIT=kgen_unit) var%dx_long - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dx_long **", var%dx_long - END IF - READ(UNIT=kgen_unit) var%variable_hyperviscosity - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%variable_hyperviscosity **", var%variable_hyperviscosity - END IF - READ(UNIT=kgen_unit) var%hv_courant - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%hv_courant **", var%hv_courant - END IF - READ(UNIT=kgen_unit) var%tensorvisc - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%tensorvisc **", var%tensorvisc - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_mod11(var%vertex, kgen_unit, printvar=printvar//"%vertex") - ELSE - CALL kgen_read_mod11(var%vertex, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_mod12(var%desc, kgen_unit, printvar=printvar//"%desc") - ELSE - CALL kgen_read_mod12(var%desc, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_elem_state_t(var%state, kgen_unit, printvar=printvar//"%state") - ELSE - CALL kgen_read_elem_state_t(var%state, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_derived_state_t(var%derived, kgen_unit, printvar=printvar//"%derived") - ELSE - CALL kgen_read_derived_state_t(var%derived, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_elem_accum_t(var%accum, kgen_unit, printvar=printvar//"%accum") - ELSE - CALL kgen_read_elem_accum_t(var%accum, kgen_unit) - END IF - READ(UNIT=kgen_unit) var%met - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%met **", var%met - END IF - READ(UNIT=kgen_unit) var%metinv - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%metinv **", var%metinv - END IF - READ(UNIT=kgen_unit) var%metdet - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%metdet **", var%metdet - END IF - READ(UNIT=kgen_unit) var%rmetdet - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%rmetdet **", var%rmetdet - END IF - READ(UNIT=kgen_unit) var%d - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%d **", var%d - END IF - READ(UNIT=kgen_unit) var%dinv - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dinv **", var%dinv - END IF - READ(UNIT=kgen_unit) var%vec_sphere2cart - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%vec_sphere2cart **", var%vec_sphere2cart - END IF - READ(UNIT=kgen_unit) var%mp - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%mp **", var%mp - END IF - READ(UNIT=kgen_unit) var%rmp - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%rmp **", var%rmp - END IF - READ(UNIT=kgen_unit) var%spheremp - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%spheremp **", var%spheremp - END IF - READ(UNIT=kgen_unit) var%rspheremp - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%rspheremp **", var%rspheremp - END IF - READ(UNIT=kgen_unit) var%gdofp - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%gdofp **", var%gdofp - END IF - READ(UNIT=kgen_unit) var%fcor - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%fcor **", var%fcor - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_index_t(var%idxp, kgen_unit, printvar=printvar//"%idxp") - ELSE - CALL kgen_read_index_t(var%idxp, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_index_t_ptr(var%idxv, kgen_unit, printvar=printvar//"%idxv") - ELSE - CALL kgen_read_index_t_ptr(var%idxv, kgen_unit) - END IF - READ(UNIT=kgen_unit) var%facenum - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%facenum **", var%facenum - END IF - READ(UNIT=kgen_unit) var%dummy - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dummy **", var%dummy - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_elem_state_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(elem_state_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_real_real_kind_dim5("v", dtype_check_status, var%v, ref_var%v) - CALL kgen_verify_real_real_kind_dim4("t", dtype_check_status, var%t, ref_var%t) - CALL kgen_verify_real_real_kind_dim4("dp3d", dtype_check_status, var%dp3d, ref_var%dp3d) - CALL kgen_verify_real_real_kind_dim3("lnps", dtype_check_status, var%lnps, ref_var%lnps) - CALL kgen_verify_real_real_kind_dim3("ps_v", dtype_check_status, var%ps_v, ref_var%ps_v) - CALL kgen_verify_real_real_kind_dim2("phis", dtype_check_status, var%phis, ref_var%phis) - CALL kgen_verify_real_real_kind_dim4("q", dtype_check_status, var%q, ref_var%q) - CALL kgen_verify_real_real_kind_dim5("qdp", dtype_check_status, var%qdp, ref_var%qdp) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_derived_state_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(derived_state_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_real_real_kind_dim4("vn0", dtype_check_status, var%vn0, ref_var%vn0) - CALL kgen_verify_real_real_kind_dim4("vstar", dtype_check_status, var%vstar, ref_var%vstar) - CALL kgen_verify_real_real_kind_dim3("dpdiss_biharmonic", dtype_check_status, var%dpdiss_biharmonic, ref_var%dpdiss_biharmonic) - CALL kgen_verify_real_real_kind_dim3("dpdiss_ave", dtype_check_status, var%dpdiss_ave, ref_var%dpdiss_ave) - CALL kgen_verify_real_real_kind_dim3("phi", dtype_check_status, var%phi, ref_var%phi) - CALL kgen_verify_real_real_kind_dim3("omega_p", dtype_check_status, var%omega_p, ref_var%omega_p) - CALL kgen_verify_real_real_kind_dim3("eta_dot_dpdn", dtype_check_status, var%eta_dot_dpdn, ref_var%eta_dot_dpdn) - CALL kgen_verify_real_real_kind_dim3("grad_lnps", dtype_check_status, var%grad_lnps, ref_var%grad_lnps) - CALL kgen_verify_real_real_kind_dim3("zeta", dtype_check_status, var%zeta, ref_var%zeta) - CALL kgen_verify_real_real_kind_dim4("div", dtype_check_status, var%div, ref_var%div) - CALL kgen_verify_real_real_kind_dim3("dp", dtype_check_status, var%dp, ref_var%dp) - CALL kgen_verify_real_real_kind_dim3("divdp", dtype_check_status, var%divdp, ref_var%divdp) - CALL kgen_verify_real_real_kind_dim3("divdp_proj", dtype_check_status, var%divdp_proj, ref_var%divdp_proj) - CALL kgen_verify_real_real_kind_dim5("fq", dtype_check_status, var%fq, ref_var%fq) - CALL kgen_verify_real_real_kind_dim5("fm", dtype_check_status, var%fm, ref_var%fm) - CALL kgen_verify_real_real_kind_dim4("ft", dtype_check_status, var%ft, ref_var%ft) - CALL kgen_verify_real_real_kind_dim3("omega_prescribed", dtype_check_status, var%omega_prescribed, ref_var%omega_prescribed) - CALL kgen_verify_real_real_kind_dim3("pecnd", dtype_check_status, var%pecnd, ref_var%pecnd) - CALL kgen_verify_real_real_kind_dim3("fqps", dtype_check_status, var%fqps, ref_var%fqps) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_elem_accum_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(elem_accum_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_real_real_kind_dim3("kener", dtype_check_status, var%kener, ref_var%kener) - CALL kgen_verify_real_real_kind_dim3("pener", dtype_check_status, var%pener, ref_var%pener) - CALL kgen_verify_real_real_kind_dim3("iener", dtype_check_status, var%iener, ref_var%iener) - CALL kgen_verify_real_real_kind_dim3("iener_wet", dtype_check_status, var%iener_wet, ref_var%iener_wet) - CALL kgen_verify_real_real_kind_dim4("qvar", dtype_check_status, var%qvar, ref_var%qvar) - CALL kgen_verify_real_real_kind_dim4("qmass", dtype_check_status, var%qmass, ref_var%qmass) - CALL kgen_verify_real_real_kind_dim3("q1mass", dtype_check_status, var%q1mass, ref_var%q1mass) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_index_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(index_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_integer_int_kind_dim1("ia", dtype_check_status, var%ia, ref_var%ia) - CALL kgen_verify_integer_int_kind_dim1("ja", dtype_check_status, var%ja, ref_var%ja) - CALL kgen_verify_integer_int_kind("is", dtype_check_status, var%is, ref_var%is) - CALL kgen_verify_integer_int_kind("ie", dtype_check_status, var%ie, ref_var%ie) - CALL kgen_verify_integer_int_kind("numuniquepts", dtype_check_status, var%numuniquepts, ref_var%numuniquepts) - CALL kgen_verify_integer_int_kind("uniqueptoffset", dtype_check_status, var%uniqueptoffset, ref_var%uniqueptoffset) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_element_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(element_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_integer_int_kind("localid", dtype_check_status, var%localid, ref_var%localid) - CALL kgen_verify_integer_int_kind("globalid", dtype_check_status, var%globalid, ref_var%globalid) - CALL kgen_verify_spherical_polar_t_dim2("spherep", dtype_check_status, var%spherep, ref_var%spherep) - CALL kgen_verify_cartesian2d_t_dim2("cartp", dtype_check_status, var%cartp, ref_var%cartp) - CALL kgen_verify_cartesian2d_t_dim1("corners", dtype_check_status, var%corners, ref_var%corners) - CALL kgen_verify_real_real_kind_dim2("u2qmap", dtype_check_status, var%u2qmap, ref_var%u2qmap) - CALL kgen_verify_cartesian3d_t_dim1("corners3d", dtype_check_status, var%corners3d, ref_var%corners3d) - CALL kgen_verify_real_real_kind("area", dtype_check_status, var%area, ref_var%area) - CALL kgen_verify_real_real_kind("normdinv", dtype_check_status, var%normdinv, ref_var%normdinv) - CALL kgen_verify_real_real_kind("dx_short", dtype_check_status, var%dx_short, ref_var%dx_short) - CALL kgen_verify_real_real_kind("dx_long", dtype_check_status, var%dx_long, ref_var%dx_long) - CALL kgen_verify_real_real_kind_dim2("variable_hyperviscosity", dtype_check_status, var%variable_hyperviscosity, ref_var%variable_hyperviscosity) - CALL kgen_verify_real_real_kind("hv_courant", dtype_check_status, var%hv_courant, ref_var%hv_courant) - CALL kgen_verify_real_real_kind_dim4("tensorvisc", dtype_check_status, var%tensorvisc, ref_var%tensorvisc) - CALL kgen_verify_mod11("vertex", dtype_check_status, var%vertex, ref_var%vertex) - CALL kgen_verify_mod12("desc", dtype_check_status, var%desc, ref_var%desc) - CALL kgen_verify_elem_state_t("state", dtype_check_status, var%state, ref_var%state) - CALL kgen_verify_derived_state_t("derived", dtype_check_status, var%derived, ref_var%derived) - CALL kgen_verify_elem_accum_t("accum", dtype_check_status, var%accum, ref_var%accum) - CALL kgen_verify_real_real_kind_dim4("met", dtype_check_status, var%met, ref_var%met) - CALL kgen_verify_real_real_kind_dim4("metinv", dtype_check_status, var%metinv, ref_var%metinv) - CALL kgen_verify_real_real_kind_dim2("metdet", dtype_check_status, var%metdet, ref_var%metdet) - CALL kgen_verify_real_real_kind_dim2("rmetdet", dtype_check_status, var%rmetdet, ref_var%rmetdet) - CALL kgen_verify_real_real_kind_dim4("d", dtype_check_status, var%d, ref_var%d) - CALL kgen_verify_real_real_kind_dim4("dinv", dtype_check_status, var%dinv, ref_var%dinv) - CALL kgen_verify_real_real_kind_dim4("vec_sphere2cart", dtype_check_status, var%vec_sphere2cart, ref_var%vec_sphere2cart) - CALL kgen_verify_real_real_kind_dim2("mp", dtype_check_status, var%mp, ref_var%mp) - CALL kgen_verify_real_real_kind_dim2("rmp", dtype_check_status, var%rmp, ref_var%rmp) - CALL kgen_verify_real_real_kind_dim2("spheremp", dtype_check_status, var%spheremp, ref_var%spheremp) - CALL kgen_verify_real_real_kind_dim2("rspheremp", dtype_check_status, var%rspheremp, ref_var%rspheremp) - CALL kgen_verify_integer_long_kind_dim2("gdofp", dtype_check_status, var%gdofp, ref_var%gdofp) - CALL kgen_verify_real_real_kind_dim2("fcor", dtype_check_status, var%fcor, ref_var%fcor) - CALL kgen_verify_index_t("idxp", dtype_check_status, var%idxp, ref_var%idxp) - CALL kgen_verify_index_t_ptr("idxv", dtype_check_status, var%idxv, ref_var%idxv) - CALL kgen_verify_integer("facenum", dtype_check_status, var%facenum, ref_var%facenum) - CALL kgen_verify_integer("dummy", dtype_check_status, var%dummy, ref_var%dummy) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_real_real_kind_dim5( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=real_kind), intent(in), DIMENSION(:,:,:,:,:) :: var, ref_var - real(KIND=real_kind) :: nrmsdiff, rmsdiff - real(KIND=real_kind), allocatable, DIMENSION(:,:,:,:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3),SIZE(var,dim=4),SIZE(var,dim=5))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3),SIZE(var,dim=4),SIZE(var,dim=5))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_real_kind_dim5 - - SUBROUTINE kgen_verify_real_real_kind_dim4( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=real_kind), intent(in), DIMENSION(:,:,:,:) :: var, ref_var - real(KIND=real_kind) :: nrmsdiff, rmsdiff - real(KIND=real_kind), allocatable, DIMENSION(:,:,:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3),SIZE(var,dim=4))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3),SIZE(var,dim=4))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_real_kind_dim4 - - SUBROUTINE kgen_verify_real_real_kind_dim3( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=real_kind), intent(in), DIMENSION(:,:,:) :: var, ref_var - real(KIND=real_kind) :: nrmsdiff, rmsdiff - real(KIND=real_kind), allocatable, DIMENSION(:,:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_real_kind_dim3 - - SUBROUTINE kgen_verify_real_real_kind_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=real_kind), intent(in), DIMENSION(:,:) :: var, ref_var - real(KIND=real_kind) :: nrmsdiff, rmsdiff - real(KIND=real_kind), allocatable, DIMENSION(:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_real_kind_dim2 - - SUBROUTINE kgen_verify_integer_int_kind_dim1( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer(KIND=int_kind), intent(in), DIMENSION(:) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - end if - - check_status%numFatal = check_status%numFatal+1 - END IF - END SUBROUTINE kgen_verify_integer_int_kind_dim1 - - SUBROUTINE kgen_verify_integer_int_kind( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer(KIND=int_kind), intent(in) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - END SUBROUTINE kgen_verify_integer_int_kind - - SUBROUTINE kgen_verify_spherical_polar_t_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - type(check_t) :: dtype_check_status - TYPE(spherical_polar_t), intent(in), DIMENSION(:,:) :: var, ref_var - integer :: idx1,idx2 - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - DO idx1=LBOUND(var,1), UBOUND(var,1) - DO idx2=LBOUND(var,2), UBOUND(var,2) - CALL kgen_verify_mod10(varname, dtype_check_status, var(idx1,idx2), ref_var(idx1,idx2)) - END DO - END DO - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE kgen_verify_spherical_polar_t_dim2 - - SUBROUTINE kgen_verify_cartesian2d_t_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - type(check_t) :: dtype_check_status - TYPE(cartesian2d_t), intent(in), DIMENSION(:,:) :: var, ref_var - integer :: idx1,idx2 - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - DO idx1=LBOUND(var,1), UBOUND(var,1) - DO idx2=LBOUND(var,2), UBOUND(var,2) - CALL kgen_verify_mod10(varname, dtype_check_status, var(idx1,idx2), ref_var(idx1,idx2)) - END DO - END DO - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE kgen_verify_cartesian2d_t_dim2 - - SUBROUTINE kgen_verify_cartesian2d_t_dim1( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - type(check_t) :: dtype_check_status - TYPE(cartesian2d_t), intent(in), DIMENSION(:) :: var, ref_var - integer :: idx1 - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - DO idx1=LBOUND(var,1), UBOUND(var,1) - CALL kgen_verify_mod10(varname, dtype_check_status, var(idx1), ref_var(idx1)) - END DO - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE kgen_verify_cartesian2d_t_dim1 - - SUBROUTINE kgen_verify_cartesian3d_t_dim1( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - type(check_t) :: dtype_check_status - TYPE(cartesian3d_t), intent(in), DIMENSION(:) :: var, ref_var - integer :: idx1 - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - DO idx1=LBOUND(var,1), UBOUND(var,1) - CALL kgen_verify_mod10(varname, dtype_check_status, var(idx1), ref_var(idx1)) - END DO - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE kgen_verify_cartesian3d_t_dim1 - - SUBROUTINE kgen_verify_real_real_kind( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=real_kind), intent(in) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - END SUBROUTINE kgen_verify_real_real_kind - - SUBROUTINE kgen_verify_integer_long_kind_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer(KIND=long_kind), intent(in), DIMENSION(:,:) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - end if - - check_status%numFatal = check_status%numFatal+1 - END IF - END SUBROUTINE kgen_verify_integer_long_kind_dim2 - - SUBROUTINE kgen_verify_index_t_ptr( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - type(check_t) :: dtype_check_status - TYPE(index_t), intent(in), POINTER :: var, ref_var - IF ( ASSOCIATED(var) ) THEN - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_integer_int_kind_dim1("ia", dtype_check_status, var%ia, ref_var%ia) - CALL kgen_verify_integer_int_kind_dim1("ja", dtype_check_status, var%ja, ref_var%ja) - CALL kgen_verify_integer_int_kind("is", dtype_check_status, var%is, ref_var%is) - CALL kgen_verify_integer_int_kind("ie", dtype_check_status, var%ie, ref_var%ie) - CALL kgen_verify_integer_int_kind("numuniquepts", dtype_check_status, var%numuniquepts, ref_var%numuniquepts) - CALL kgen_verify_integer_int_kind("uniqueptoffset", dtype_check_status, var%uniqueptoffset, ref_var%uniqueptoffset) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END IF - END SUBROUTINE kgen_verify_index_t_ptr - - SUBROUTINE kgen_verify_integer( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - END SUBROUTINE kgen_verify_integer - - ! ===================== ELEMENT_MOD METHODS ========================== - - !___________________________________________________________________ - - !___________________________________________________________________ - - !___________________________________________________________________ - - !___________________________________________________________________ - - !___________________________________________________________________ - - END MODULE element_mod diff --git a/test/ncar_kernels/HOMME_preq_hydrostatic/src/gridgraph_mod.F90 b/test/ncar_kernels/HOMME_preq_hydrostatic/src/gridgraph_mod.F90 deleted file mode 100644 index 5d35246785..0000000000 --- a/test/ncar_kernels/HOMME_preq_hydrostatic/src/gridgraph_mod.F90 +++ /dev/null @@ -1,272 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : gridgraph_mod.F90 -! Generated at: 2015-04-12 19:37:50 -! KGEN version: 0.4.9 - - - - MODULE gridgraph_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !------------------------- - !------------------------------- - !------------------------- - !----- - IMPLICIT NONE - PRIVATE - INTEGER, public, parameter :: num_neighbors=8 ! for north, south, east, west, neast, nwest, seast, swest - TYPE, public :: gridvertex_t - INTEGER, pointer :: nbrs(:) => null() ! The numbers of the neighbor elements - INTEGER, pointer :: nbrs_face(:) => null() ! The cube face number of the neighbor element (nbrs array) - INTEGER, pointer :: nbrs_wgt(:) => null() ! The weights for edges defined by nbrs array - INTEGER, pointer :: nbrs_wgt_ghost(:) => null() ! The weights for edges defined by nbrs array - INTEGER :: nbrs_ptr(num_neighbors + 1) !index into the nbrs array for each neighbor direction - INTEGER :: face_number ! which face of the cube this vertex is on - INTEGER :: number ! element number - INTEGER :: processor_number ! processor number - INTEGER :: spacecurve ! index in Space-Filling curve - END TYPE gridvertex_t - ! ========================================== - ! Public Interfaces - ! ========================================== - - - ! read interface - PUBLIC kgen_read - INTERFACE kgen_read - MODULE PROCEDURE kgen_read_gridvertex_t - END INTERFACE kgen_read - - PUBLIC kgen_verify - INTERFACE kgen_verify - MODULE PROCEDURE kgen_verify_gridvertex_t - END INTERFACE kgen_verify - - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_integer_4_dim1_ptr(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - integer(KIND=4), INTENT(OUT), POINTER, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_integer_4_dim1_ptr - - ! No module extern variables - SUBROUTINE kgen_read_gridvertex_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(gridvertex_t), INTENT(out) :: var - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_integer_4_dim1_ptr(var%nbrs, kgen_unit, printvar=printvar//"%nbrs") - ELSE - CALL kgen_read_integer_4_dim1_ptr(var%nbrs, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_integer_4_dim1_ptr(var%nbrs_face, kgen_unit, printvar=printvar//"%nbrs_face") - ELSE - CALL kgen_read_integer_4_dim1_ptr(var%nbrs_face, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_integer_4_dim1_ptr(var%nbrs_wgt, kgen_unit, printvar=printvar//"%nbrs_wgt") - ELSE - CALL kgen_read_integer_4_dim1_ptr(var%nbrs_wgt, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_integer_4_dim1_ptr(var%nbrs_wgt_ghost, kgen_unit, printvar=printvar//"%nbrs_wgt_ghost") - ELSE - CALL kgen_read_integer_4_dim1_ptr(var%nbrs_wgt_ghost, kgen_unit) - END IF - READ(UNIT=kgen_unit) var%nbrs_ptr - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%nbrs_ptr **", var%nbrs_ptr - END IF - READ(UNIT=kgen_unit) var%face_number - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%face_number **", var%face_number - END IF - READ(UNIT=kgen_unit) var%number - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%number **", var%number - END IF - READ(UNIT=kgen_unit) var%processor_number - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%processor_number **", var%processor_number - END IF - READ(UNIT=kgen_unit) var%spacecurve - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%spacecurve **", var%spacecurve - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_gridvertex_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(gridvertex_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_integer_4_dim1_ptr("nbrs", dtype_check_status, var%nbrs, ref_var%nbrs) - CALL kgen_verify_integer_4_dim1_ptr("nbrs_face", dtype_check_status, var%nbrs_face, ref_var%nbrs_face) - CALL kgen_verify_integer_4_dim1_ptr("nbrs_wgt", dtype_check_status, var%nbrs_wgt, ref_var%nbrs_wgt) - CALL kgen_verify_integer_4_dim1_ptr("nbrs_wgt_ghost", dtype_check_status, var%nbrs_wgt_ghost, ref_var%nbrs_wgt_ghost) - CALL kgen_verify_integer_4_dim1("nbrs_ptr", dtype_check_status, var%nbrs_ptr, ref_var%nbrs_ptr) - CALL kgen_verify_integer("face_number", dtype_check_status, var%face_number, ref_var%face_number) - CALL kgen_verify_integer("number", dtype_check_status, var%number, ref_var%number) - CALL kgen_verify_integer("processor_number", dtype_check_status, var%processor_number, ref_var%processor_number) - CALL kgen_verify_integer("spacecurve", dtype_check_status, var%spacecurve, ref_var%spacecurve) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_integer_4_dim1_ptr( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in), DIMENSION(:), POINTER :: var, ref_var - IF ( ASSOCIATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - end if - - check_status%numFatal = check_status%numFatal+1 - END IF - END IF - END SUBROUTINE kgen_verify_integer_4_dim1_ptr - - SUBROUTINE kgen_verify_integer_4_dim1( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in), DIMENSION(:) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - end if - - check_status%numFatal = check_status%numFatal+1 - END IF - END SUBROUTINE kgen_verify_integer_4_dim1 - - SUBROUTINE kgen_verify_integer( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - END SUBROUTINE kgen_verify_integer - - !====================================================================== - - !====================================================================== - - !====================================================================== - ! ===================================== - ! copy edge: - ! copy device for overloading = sign. - ! ===================================== - - !====================================================================== - - !====================================================================== - - !====================================================================== - - !====================================================================== - !=========================== - ! search edge list for match - !=========================== - - !====================================================================== - - !====================================================================== - - !====================================================================== - - !====================================================================== - - !====================================================================== - - !====================================================================== - ! ========================================== - ! set_GridVertex_neighbors: - ! - ! Set global element number for element elem - ! ========================================== - - !====================================================================== - - !====================================================================== - - !====================================================================== - - !====================================================================== - END MODULE gridgraph_mod diff --git a/test/ncar_kernels/HOMME_preq_hydrostatic/src/kernel_driver.f90 b/test/ncar_kernels/HOMME_preq_hydrostatic/src/kernel_driver.f90 deleted file mode 100644 index 0212a471e1..0000000000 --- a/test/ncar_kernels/HOMME_preq_hydrostatic/src/kernel_driver.f90 +++ /dev/null @@ -1,105 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-04-12 19:37:49 -! KGEN version: 0.4.9 - - -PROGRAM kernel_driver - USE prim_advance_mod, ONLY : compute_and_apply_rhs - USE element_mod, ONLY: element_t - USE physconst, ONLY : kgen_read_externs_physconst - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE element_mod, ONLY : kgen_read_mod9 => kgen_read - USE element_mod, ONLY : kgen_verify_mod9 => kgen_verify - - IMPLICIT NONE - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(1), PARAMETER :: kgen_mpi_rank_at = (/ 0 /) - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(1), PARAMETER :: kgen_counter_at = (/ 1 /) - CHARACTER(LEN=1024) :: kgen_filepath - TYPE(element_t), target, allocatable :: elem(:) - - DO kgen_repeat_counter = 0, 0 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 1)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 1)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - kgen_filepath = "../data/preq_hydrostatic." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "** Verification against '" // trim(adjustl(kgen_filepath)) // "' **" - - CALL kgen_read_externs_physconst(kgen_unit) - - ! driver variables - CALL kgen_read_element_t_dim1(elem, kgen_unit) - - call compute_and_apply_rhs(elem, kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_element_t_dim1(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(element_t), INTENT(OUT), ALLOCATABLE, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - DO idx1=kgen_bound(1,1), kgen_bound(2, 1) - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_mod9(var(idx1), kgen_unit, printvar=printvar) - ELSE - CALL kgen_read_mod9(var(idx1), kgen_unit) - END IF - END DO - END IF - END SUBROUTINE kgen_read_element_t_dim1 - - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/HOMME_preq_hydrostatic/src/kgen_utils.f90 b/test/ncar_kernels/HOMME_preq_hydrostatic/src/kgen_utils.f90 deleted file mode 100644 index cfa8d114e0..0000000000 --- a/test/ncar_kernels/HOMME_preq_hydrostatic/src/kgen_utils.f90 +++ /dev/null @@ -1,61 +0,0 @@ -module kgen_utils_mod - -INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - -type check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - real(kind=kgen_dp) :: minvalue -end type check_t - -public kgen_dp, check_t, kgen_init_check, kgen_print_check - -contains - -subroutine kgen_init_check(check, tolerance, minvalue) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - real(kind=kgen_dp), intent(in), optional :: minvalue - - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.0D-15 - endif - if(present(minvalue)) then - check%minvalue = minvalue - else - check%minvalue = 1.0D-15 - endif -end subroutine kgen_init_check - -subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif -end subroutine kgen_print_check - -end module diff --git a/test/ncar_kernels/HOMME_preq_hydrostatic/src/kinds.F90 b/test/ncar_kernels/HOMME_preq_hydrostatic/src/kinds.F90 deleted file mode 100644 index 72f600879b..0000000000 --- a/test/ncar_kernels/HOMME_preq_hydrostatic/src/kinds.F90 +++ /dev/null @@ -1,31 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kinds.F90 -! Generated at: 2015-04-12 19:37:49 -! KGEN version: 0.4.9 - - - - MODULE kinds - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: shr_kind_i4 - USE shr_kind_mod, ONLY: shr_kind_i8 - USE shr_kind_mod, ONLY: shr_kind_r8 - ! _EXTERNAL - IMPLICIT NONE - PRIVATE - ! - ! most floating point variables should be of type real_kind = real*8 - ! For higher precision, we also have quad_kind = real*16, but this - ! is only supported on IBM systems - ! - INTEGER(KIND=4), public, parameter :: real_kind = shr_kind_r8 - INTEGER(KIND=4), public, parameter :: int_kind = shr_kind_i4 - INTEGER(KIND=4), public, parameter :: log_kind = kind(.true.) - INTEGER(KIND=4), public, parameter :: long_kind = shr_kind_i8 - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE kinds diff --git a/test/ncar_kernels/HOMME_preq_hydrostatic/src/physconst.F90 b/test/ncar_kernels/HOMME_preq_hydrostatic/src/physconst.F90 deleted file mode 100644 index 64942559f9..0000000000 --- a/test/ncar_kernels/HOMME_preq_hydrostatic/src/physconst.F90 +++ /dev/null @@ -1,92 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : physconst.F90 -! Generated at: 2015-04-12 19:37:50 -! KGEN version: 0.4.9 - - - - MODULE physconst - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! Physical constants. Use CCSM shared values whenever available. - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - USE shr_const_mod, ONLY: shr_const_rdair - ! Dimensions and chunk bounds - IMPLICIT NONE - PRIVATE - ! Constants based off share code or defined in physconst - ! Avogadro's number (molecules/kmole) - ! Boltzman's constant (J/K/molecule) - ! sec in calendar day ~ sec - ! specific heat of dry air (J/K/kg) - ! specific heat of fresh h2o (J/K/kg) - ! Von Karman constant - ! Latent heat of fusion (J/kg) - ! Latent heat of vaporization (J/kg) - ! 3.14... - ! Standard pressure (Pascals) - ! Universal gas constant (J/K/kmol) - ! Density of liquid water (STP) - !special value - ! Stefan-Boltzmann's constant (W/m^2/K^4) - ! Triple point temperature of water (K) - ! Speed of light in a vacuum (m/s) - ! Planck's constant (J.s) - ! Molecular weights - ! molecular weight co2 - ! molecular weight n2o - ! molecular weight ch4 - ! molecular weight cfc11 - ! molecular weight cfc12 - ! molecular weight O3 - ! modifiable physical constants for aquaplanet - ! gravitational acceleration (m/s**2) - ! sec in siderial day ~ sec - ! molecular weight h2o - ! specific heat of water vapor (J/K/kg) - ! molecular weight dry air - ! radius of earth (m) - ! Freezing point of water (K) - !--------------- Variables below here are derived from those above ----------------------- - ! reciprocal of gravit - ! reciprocal of earth radius - ! earth rot ~ rad/sec - ! Water vapor gas constant ~ J/K/kg - REAL(KIND=r8), public :: rair = shr_const_rdair ! Dry air gas constant ~ J/K/kg - ! ratio of h2o to dry air molecular weights - ! (rh2o/rair) - 1 - ! CPWV/CPDAIR - 1.0 - ! density of dry air at STP ~ kg/m^3 - ! R/Cp - ! Coriolis expansion coeff -> omega/sqrt(0.375) - !--------------- Variables below here are for WACCM-X ----------------------- - ! composition dependent specific heat at constant pressure - ! composition dependent gas "constant" - ! rairv/cpairv - ! composition dependent atmosphere mean mass - ! molecular viscosity kg/m/s - ! molecular conductivity J/m/s/K - !--------------- Variables below here are for turbulent mountain stress ----------------------- - !================================================================================================ - PUBLIC kgen_read_externs_physconst - CONTAINS - - ! write subroutines - ! No subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_physconst(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) rair - END SUBROUTINE kgen_read_externs_physconst - - !================================================================================================ - - !============================================================================== - ! Read namelist variables. - - !=============================================================================== - - END MODULE physconst diff --git a/test/ncar_kernels/HOMME_preq_hydrostatic/src/physical_constants.F90 b/test/ncar_kernels/HOMME_preq_hydrostatic/src/physical_constants.F90 deleted file mode 100644 index 038558fa59..0000000000 --- a/test/ncar_kernels/HOMME_preq_hydrostatic/src/physical_constants.F90 +++ /dev/null @@ -1,27 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : physical_constants.F90 -! Generated at: 2015-04-12 19:37:49 -! KGEN version: 0.4.9 - - - - MODULE physical_constants - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! ------------------------------ - USE physconst, ONLY: rgas => rair ! _EXTERNAL - ! ----------------------------- - IMPLICIT NONE - PRIVATE - ! m s^-2 - ! m - ! s^-1 - PUBLIC rgas - ! Pa - ! m - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE physical_constants diff --git a/test/ncar_kernels/HOMME_preq_hydrostatic/src/prim_advance_mod.F90 b/test/ncar_kernels/HOMME_preq_hydrostatic/src/prim_advance_mod.F90 deleted file mode 100644 index 137b78cd4c..0000000000 --- a/test/ncar_kernels/HOMME_preq_hydrostatic/src/prim_advance_mod.F90 +++ /dev/null @@ -1,220 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : prim_advance_mod.F90 -! Generated at: 2015-04-12 19:37:49 -! KGEN version: 0.4.9 - - - - MODULE prim_advance_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE element_mod, ONLY : kgen_read_mod9 => kgen_read - USE element_mod, ONLY : kgen_verify_mod9 => kgen_verify - ! _EXTERNAL - IMPLICIT NONE - PRIVATE - PUBLIC compute_and_apply_rhs - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - - - - - - - - - - ! - ! phl notes: output is stored in first argument. Advances from 2nd argument using tendencies evaluated at 3rd rgument: - ! phl: for offline winds use time at 3rd argument (same as rhs currently) - ! - - SUBROUTINE compute_and_apply_rhs(elem, kgen_unit) - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! =================================== - ! compute the RHS, accumulate into u(np1) and apply DSS - ! - ! u(np1) = u(nm1) + dt2*DSS[ RHS(u(n0)) ] - ! - ! This subroutine is normally called to compute a leapfrog timestep - ! but by adjusting np1,nm1,n0 and dt2, many other timesteps can be - ! accomodated. For example, setting nm1=np1=n0 this routine will - ! take a forward euler step, overwriting the input with the output. - ! - ! qn0 = timelevel used to access Qdp() in order to compute virtual Temperature - ! qn0=-1 for the dry case - ! - ! if dt2<0, then the DSS'd RHS is returned in timelevel np1 - ! - ! Combining the RHS and DSS pack operation in one routine - ! allows us to fuse these two loops for more cache reuse - ! - ! Combining the dt advance and DSS unpack operation in one routine - ! allows us to fuse these two loops for more cache reuse - ! - ! note: for prescribed velocity case, velocity will be computed at - ! "real_time", which should be the time of timelevel n0. - ! - ! - ! =================================== - USE kinds, ONLY: real_kind - USE dimensions_mod, ONLY: np - USE dimensions_mod, ONLY: nlev - USE element_mod, ONLY: element_t - USE prim_si_mod, ONLY: preq_hydrostatic - IMPLICIT NONE - integer, intent(in) :: kgen_unit - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - TYPE(element_t), intent(inout), target :: elem(:) - ! weighting for eta_dot_dpdn mean flux - ! local - ! surface pressure for current tiime level - REAL(KIND=real_kind), pointer, dimension(:,:,:) :: phi - REAL(KIND=real_kind), pointer :: ref_phi(:,:,:) => NULL() - REAL(KIND=real_kind), dimension(np,np,nlev) :: t_v - ! half level vertical velocity on p-grid - ! temporary field - ! generic gradient storage - ! v.grad(T) - ! kinetic energy + PHI term - ! lat-lon coord version - ! vorticity - REAL(KIND=real_kind), dimension(np,np,nlev) :: p ! pressure - REAL(KIND=real_kind), dimension(np,np,nlev) :: dp ! delta pressure - ! inverse of delta pressure - ! temperature vertical advection - ! v.grad(p) - ! half level pressures on p-grid - ! velocity vertical advection - INTEGER :: ie - !JMD call t_barrierf('sync_compute_and_apply_rhs', hybrid%par%comm) - tolerance = 1.E-14 - CALL kgen_init_check(check_status, tolerance) - CALL kgen_read_real_real_kind_dim3_ptr(phi, kgen_unit) - READ(UNIT=kgen_unit) t_v - READ(UNIT=kgen_unit) p - READ(UNIT=kgen_unit) dp - READ(UNIT=kgen_unit) ie - - CALL kgen_read_real_real_kind_dim3_ptr(ref_phi, kgen_unit) - - - ! call to kernel - CALL preq_hydrostatic(phi, elem(ie)%state%phis, t_v, p, dp) - ! kernel verification for output variables - CALL kgen_verify_real_real_kind_dim3_ptr( "phi", check_status, phi, ref_phi) - CALL kgen_print_check("preq_hydrostatic", check_status) - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,10 - CALL preq_hydrostatic(phi, elem(ie) % state % phis, t_v, p, dp) - END DO - CALL system_clock(stop_clock, rate_clock) - WRITE(*,*) - PRINT *, "Elapsed time (sec): ", (stop_clock - start_clock)/REAL(rate_clock*10) - ! ============================================================= - ! Insert communications here: for shared memory, just a single - ! sync is required - ! ============================================================= - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_real_kind_dim3_ptr(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=real_kind), INTENT(OUT), POINTER, DIMENSION(:,:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2,idx3 - INTEGER, DIMENSION(2,3) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_real_kind_dim3_ptr - - - ! verify subroutines - SUBROUTINE kgen_verify_real_real_kind_dim3_ptr( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=real_kind), intent(in), DIMENSION(:,:,:), POINTER :: var, ref_var - real(KIND=real_kind) :: nrmsdiff, rmsdiff - real(KIND=real_kind), allocatable, DIMENSION(:,:,:) :: temp, temp2 - integer :: n - IF ( ASSOCIATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END IF - END SUBROUTINE kgen_verify_real_real_kind_dim3_ptr - - END SUBROUTINE compute_and_apply_rhs - !TRILINOS - - - END MODULE prim_advance_mod diff --git a/test/ncar_kernels/HOMME_preq_hydrostatic/src/prim_si_mod.F90 b/test/ncar_kernels/HOMME_preq_hydrostatic/src/prim_si_mod.F90 deleted file mode 100644 index 01f4e8b889..0000000000 --- a/test/ncar_kernels/HOMME_preq_hydrostatic/src/prim_si_mod.F90 +++ /dev/null @@ -1,124 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : prim_si_mod.F90 -! Generated at: 2015-04-12 19:37:50 -! KGEN version: 0.4.9 - - - - MODULE prim_si_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - IMPLICIT NONE - PRIVATE - PUBLIC preq_hydrostatic - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - ! ========================================================== - ! Implicit system for semi-implicit primitive equations. - ! ========================================================== - - !----------------------------------------------------------------------- - ! preq_omegap: - ! Purpose: - ! Calculate (omega/p) needed for the Thermodynamics Equation - ! - ! Method: - ! Simplified version in CAM2 for clarity - ! - ! Author: Modified by Rich Loft for use in HOMME. - ! - !----------------------------------------------------------------------- - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1 - ! - ! compute omega/p using ps, modeled after CCM3 formulas - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1 - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1 - ! - ! compute omega/p using lnps - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1 - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1 - ! - ! CCM3 hydrostatic integral - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1 - - SUBROUTINE preq_hydrostatic(phi, phis, t_v, p, dp) - USE kinds, ONLY: real_kind - USE dimensions_mod, ONLY: np - USE dimensions_mod, ONLY: nlev - USE physical_constants, ONLY: rgas - ! use hybvcoord_mod, only : hvcoord_t - IMPLICIT NONE - !------------------------------Arguments--------------------------------------------------------------- - REAL(KIND=real_kind), intent(out) :: phi(np,np,nlev) - REAL(KIND=real_kind), intent(in) :: phis(np,np) - REAL(KIND=real_kind), intent(in) :: t_v(np,np,nlev) - REAL(KIND=real_kind), intent(in) :: p(np,np,nlev) - REAL(KIND=real_kind), intent(in) :: dp(np,np,nlev) - ! type (hvcoord_t), intent(in) :: hvcoord - !------------------------------------------------------------------------------------------------------ - !---------------------------Local workspace----------------------------- - INTEGER :: j - INTEGER :: i - INTEGER :: k ! longitude, level indices - REAL(KIND=real_kind) :: hkk - REAL(KIND=real_kind) :: hkl ! diagonal term of energy conversion matrix - REAL(KIND=real_kind), dimension(np,np,nlev) :: phii ! Geopotential at interfaces - !----------------------------------------------------------------------- - DO j=1,np ! Loop inversion (AAM) - DO i=1,np - hkk = dp(i,j,nlev)*0.5d0/p(i,j,nlev) - hkl = 2*hkk - phii(i,j,nlev) = rgas*t_v(i,j,nlev)*hkl - phi(i,j,nlev) = phis(i,j) + rgas*t_v(i,j,nlev)*hkk - END DO - DO k=nlev-1,2,-1 - DO i=1,np - ! hkk = dp*ckk - hkk = dp(i,j,k)*0.5d0/p(i,j,k) - hkl = 2*hkk - phii(i,j,k) = phii(i,j,k+1) + rgas*t_v(i,j,k)*hkl - phi(i,j,k) = phis(i,j) + phii(i,j,k+1) + rgas*t_v(i,j,k)*hkk - END DO - END DO - DO i=1,np - ! hkk = dp*ckk - hkk = 0.5d0*dp(i,j,1)/p(i,j,1) - phi(i,j,1) = phis(i,j) + phii(i,j,2) + rgas*t_v(i,j,1)*hkk - END DO - END DO - END SUBROUTINE preq_hydrostatic - ! - ! The hydrostatic routine from 1 physics. - ! (FV stuff removed) - ! t,q input changed to take t_v - ! removed gravit, so this routine returns PHI, not zm - - !----------------------------------------------------------------------- - ! preq_pressure: - ! - ! Purpose: - ! Define the pressures of the interfaces and midpoints from the - ! coordinate definitions and the surface pressure. Originally plevs0! - ! - ! Method: - ! - ! Author: B. Boville/ Adapted for HOMME by Rich Loft - ! - !----------------------------------------------------------------------- - ! - ! $Id: prim_si_mod.F90,v 2.10 2005/10/14 20:17:22 jedwards Exp $ - ! $Author: jedwards $ - ! - !----------------------------------------------------------------------- - - END MODULE prim_si_mod diff --git a/test/ncar_kernels/HOMME_preq_hydrostatic/src/shr_const_mod.F90 b/test/ncar_kernels/HOMME_preq_hydrostatic/src/shr_const_mod.F90 deleted file mode 100644 index 23f7803c1e..0000000000 --- a/test/ncar_kernels/HOMME_preq_hydrostatic/src/shr_const_mod.F90 +++ /dev/null @@ -1,66 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : shr_const_mod.F90 -! Generated at: 2015-04-12 19:37:49 -! KGEN version: 0.4.9 - - - - MODULE shr_const_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, only : shr_kind_in - USE shr_kind_mod, only : shr_kind_r8 - INTEGER(KIND=shr_kind_in), parameter, private :: r8 = shr_kind_r8 ! rename for local readability only - !---------------------------------------------------------------------------- - ! physical constants (all data public) - !---------------------------------------------------------------------------- - PUBLIC - ! pi - ! sec in calendar day ~ sec - ! sec in siderial day ~ sec - ! earth rot ~ rad/sec - ! radius of earth ~ m - ! acceleration of gravity ~ m/s^2 - ! Stefan-Boltzmann constant ~ W/m^2/K^4 - REAL(KIND=r8), parameter :: shr_const_boltz = 1.38065e-23_r8 ! Boltzmann's constant ~ J/K/molecule - REAL(KIND=r8), parameter :: shr_const_avogad = 6.02214e26_r8 ! Avogadro's number ~ molecules/kmole - REAL(KIND=r8), parameter :: shr_const_rgas = shr_const_avogad*shr_const_boltz ! Universal gas constant ~ J/K/kmole - REAL(KIND=r8), parameter :: shr_const_mwdair = 28.966_r8 ! molecular weight dry air ~ kg/kmole - ! molecular weight water vapor - REAL(KIND=r8), parameter :: shr_const_rdair = shr_const_rgas/shr_const_mwdair ! Dry air gas constant ~ J/K/kg - ! Water vapor gas constant ~ J/K/kg - ! RWV/RDAIR - 1.0 - ! Von Karman constant - ! standard pressure ~ pascals - ! ratio of 13C/12C in Pee Dee Belemnite (C isotope standard) - ! triple point of fresh water ~ K - ! freezing T of fresh water ~ K - ! freezing T of salt water ~ K - ! density of dry air at STP ~ kg/m^3 - ! density of fresh water ~ kg/m^3 - ! density of sea water ~ kg/m^3 - ! density of ice ~ kg/m^3 - ! specific heat of dry air ~ J/kg/K - ! specific heat of water vap ~ J/kg/K - ! CPWV/CPDAIR - 1.0 - ! specific heat of fresh h2o ~ J/kg/K - ! specific heat of sea h2o ~ J/kg/K - ! specific heat of fresh ice ~ J/kg/K - ! latent heat of fusion ~ J/kg - ! latent heat of evaporation ~ J/kg - ! latent heat of sublimation ~ J/kg - ! ocn ref salinity (psu) - ! ice ref salinity (psu) - ! special missing value - ! min spval tolerance - ! max spval tolerance - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !----------------------------------------------------------------------------- - - !----------------------------------------------------------------------------- - END MODULE shr_const_mod diff --git a/test/ncar_kernels/HOMME_preq_hydrostatic/src/shr_kind_mod.F90 b/test/ncar_kernels/HOMME_preq_hydrostatic/src/shr_kind_mod.F90 deleted file mode 100644 index dd456df48c..0000000000 --- a/test/ncar_kernels/HOMME_preq_hydrostatic/src/shr_kind_mod.F90 +++ /dev/null @@ -1,31 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : shr_kind_mod.F90 -! Generated at: 2015-04-12 19:37:49 -! KGEN version: 0.4.9 - - - - MODULE shr_kind_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - PUBLIC - INTEGER, parameter :: shr_kind_r8 = selected_real_kind(12) ! 8 byte real - ! 4 byte real - ! native real - INTEGER, parameter :: shr_kind_i8 = selected_int_kind (13) ! 8 byte integer - INTEGER, parameter :: shr_kind_i4 = selected_int_kind ( 6) ! 4 byte integer - INTEGER, parameter :: shr_kind_in = kind(1) ! native integer - ! short char - ! mid-sized char - ! long char - ! extra-long char - ! extra-extra-long char - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE shr_kind_mod diff --git a/test/ncar_kernels/HOMME_preq_omega_ps/CESM_license.txt b/test/ncar_kernels/HOMME_preq_omega_ps/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/HOMME_preq_omega_ps/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/HOMME_preq_omega_ps/data/preq_omega_ps.1.0 b/test/ncar_kernels/HOMME_preq_omega_ps/data/preq_omega_ps.1.0 deleted file mode 100644 index 7d7d0f721d..0000000000 Binary files a/test/ncar_kernels/HOMME_preq_omega_ps/data/preq_omega_ps.1.0 and /dev/null differ diff --git a/test/ncar_kernels/HOMME_preq_omega_ps/data/preq_omega_ps.10.0 b/test/ncar_kernels/HOMME_preq_omega_ps/data/preq_omega_ps.10.0 deleted file mode 100644 index 8dbf5d9500..0000000000 Binary files a/test/ncar_kernels/HOMME_preq_omega_ps/data/preq_omega_ps.10.0 and /dev/null differ diff --git a/test/ncar_kernels/HOMME_preq_omega_ps/data/preq_omega_ps.20.0 b/test/ncar_kernels/HOMME_preq_omega_ps/data/preq_omega_ps.20.0 deleted file mode 100644 index 37a5b72c86..0000000000 Binary files a/test/ncar_kernels/HOMME_preq_omega_ps/data/preq_omega_ps.20.0 and /dev/null differ diff --git a/test/ncar_kernels/HOMME_preq_omega_ps/inc/t1.mk b/test/ncar_kernels/HOMME_preq_omega_ps/inc/t1.mk deleted file mode 100644 index b51fd7fb1b..0000000000 --- a/test/ncar_kernels/HOMME_preq_omega_ps/inc/t1.mk +++ /dev/null @@ -1,66 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# Intel default flags -# -# FC_FLAGS := -O2 -fp-model source -convert big_endian -assume byterecl -# -ftz -traceback -assume realloc_lhs -xAVX -# -# Makefile for KGEN-generated kernel -FC_FLAGS := $(OPT) - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - -ALL_OBJS := kernel_driver.o prim_advance_mod.o hybvcoord_mod.o prim_si_mod.o dimensions_mod.o kinds.o - -verify: - @(grep "verification.FAIL" $(TEST).rslt && echo "FAILED") || (grep "verification.PASS" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 prim_advance_mod.o hybvcoord_mod.o prim_si_mod.o dimensions_mod.o kinds.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -prim_advance_mod.o: $(SRC_DIR)/prim_advance_mod.F90 prim_si_mod.o kinds.o dimensions_mod.o hybvcoord_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -hybvcoord_mod.o: $(SRC_DIR)/hybvcoord_mod.F90 kinds.o dimensions_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -prim_si_mod.o: $(SRC_DIR)/prim_si_mod.F90 kinds.o dimensions_mod.o hybvcoord_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -dimensions_mod.o: $(SRC_DIR)/dimensions_mod.F90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -kinds.o: $(SRC_DIR)/kinds.F90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.rslt diff --git a/test/ncar_kernels/HOMME_preq_omega_ps/lit/runmake b/test/ncar_kernels/HOMME_preq_omega_ps/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/HOMME_preq_omega_ps/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/HOMME_preq_omega_ps/makefile b/test/ncar_kernels/HOMME_preq_omega_ps/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/HOMME_preq_omega_ps/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/HOMME_preq_omega_ps/readme.txt b/test/ncar_kernels/HOMME_preq_omega_ps/readme.txt deleted file mode 100644 index 6ac56cb46f..0000000000 --- a/test/ncar_kernels/HOMME_preq_omega_ps/readme.txt +++ /dev/null @@ -1,20 +0,0 @@ -preq_omega_ps kernel -Edited 03/18/2015 -Amogh Simha - -*kernel and supporting files - -the preq_omega_ps subroutine is located in the prim_si_mod.F90 file - -subroutine call is in the compute_and_apply_rhs subroutine in the prim_advance_mod.F90 file - -*compilation and execution - -Just download the enclosing directory - -Run make - -*verification - -The make command will trigger the verification of the kernel. - -It is considered to have passed verification if the tolerance for normalized RMS is less than 9.999999824516700E-015 - -Input data is provided by preq_omega_ps.1.0 preq_omega_ps.10.0, and preq_omega_ps.20.0 - -*performance measurement - -The elapsed time in seconds is printed to stdout for each input file specified - diff --git a/test/ncar_kernels/HOMME_preq_omega_ps/src/dimensions_mod.F90 b/test/ncar_kernels/HOMME_preq_omega_ps/src/dimensions_mod.F90 deleted file mode 100644 index a0bd4e12a1..0000000000 --- a/test/ncar_kernels/HOMME_preq_omega_ps/src/dimensions_mod.F90 +++ /dev/null @@ -1,51 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : dimensions_mod.F90 -! Generated at: 2015-03-16 09:25:32 -! KGEN version: 0.4.5 - - - - MODULE dimensions_mod - IMPLICIT NONE - PRIVATE - ! set MAX number of tracers. actual number of tracers is a run time argument - ! SE tracers: default is 4 - ! fvm tracers - ! FI # dependent variables - INTEGER, parameter, public :: np = 4 - ! fvm dimensions: - !number of Gausspoints for the fvm integral approximation - !Max. Courant number - !halo width needed for reconstruction - phl - !total halo width where reconstruction is needed (nht<=nc) - phl - !(different from halo needed for elements on edges and corners - ! integer, parameter, public :: ns=3 !quadratic halo interpolation - recommended setting for nc=3 - ! integer, parameter, public :: ns=4 !cubic halo interpolation - recommended setting for nc=4 - !nhc determines width of halo exchanged with neighboring elements - ! - ! constants for SPELT - ! - !number of interpolation values, works only for this - ! number of points in an element - ! dg degree for hybrid cg/dg element 0=disabled - INTEGER, parameter, public :: nlev=26 - INTEGER, parameter, public :: nlevp=nlev+1 - ! params for a mesh - ! integer, public, parameter :: max_elements_attached_to_node = 7 - ! integer, public, parameter :: s_nv = 2*max_elements_attached_to_node - !default for non-refined mesh (note that these are *not* parameters now) - !max_elements_attached_to_node-3 - !4 + 4*max_corner_elem - ! total number of elements - ! number of elements per MPI task - ! max number of elements on any MPI task - ! This is the number of physics processors/ per dynamics processor - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - - END MODULE dimensions_mod diff --git a/test/ncar_kernels/HOMME_preq_omega_ps/src/hybvcoord_mod.F90 b/test/ncar_kernels/HOMME_preq_omega_ps/src/hybvcoord_mod.F90 deleted file mode 100644 index 0c002c5c37..0000000000 --- a/test/ncar_kernels/HOMME_preq_omega_ps/src/hybvcoord_mod.F90 +++ /dev/null @@ -1,64 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : hybvcoord_mod.F90 -! Generated at: 2015-03-16 09:25:31 -! KGEN version: 0.4.5 - - - - MODULE hybvcoord_mod - USE kinds, ONLY: r8 => real_kind - USE dimensions_mod, ONLY: plevp => nlevp - USE dimensions_mod, ONLY: plev => nlev - IMPLICIT NONE - PRIVATE - !----------------------------------------------------------------------- - ! hvcoord_t: Hybrid level definitions: p = a*p0 + b*ps - ! interfaces p(k) = hyai(k)*ps0 + hybi(k)*ps - ! midpoints p(k) = hyam(k)*ps0 + hybm(k)*ps - !----------------------------------------------------------------------- - TYPE, public :: hvcoord_t - REAL(KIND=r8) :: ps0 ! base state surface-pressure for level definitions - REAL(KIND=r8) :: hyai(plevp) ! ps0 component of hybrid coordinate - interfaces - REAL(KIND=r8) :: hyam(plev) ! ps0 component of hybrid coordinate - midpoints - REAL(KIND=r8) :: hybi(plevp) ! ps component of hybrid coordinate - interfaces - REAL(KIND=r8) :: hybm(plev) ! ps component of hybrid coordinate - midpoints - REAL(KIND=r8) :: hybd(plev) ! difference in b (hybi) across layers - REAL(KIND=r8) :: prsfac ! log pressure extrapolation factor (time, space independent) - REAL(KIND=r8) :: etam(plev) ! eta-levels at midpoints - REAL(KIND=r8) :: etai(plevp) ! eta-levels at interfaces - INTEGER :: nprlev ! number of pure pressure levels at top - INTEGER :: pad - END TYPE hvcoord_t - - ! read interface - PUBLIC kgen_read - INTERFACE kgen_read - MODULE PROCEDURE kgen_read_hvcoord_t - END INTERFACE kgen_read - - CONTAINS - - ! write subroutines - ! No module extern variables - SUBROUTINE kgen_read_hvcoord_t(var, kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - TYPE(hvcoord_t), INTENT(out) :: var - READ(UNIT=kgen_unit) var%ps0 - READ(UNIT=kgen_unit) var%hyai - READ(UNIT=kgen_unit) var%hyam - READ(UNIT=kgen_unit) var%hybi - READ(UNIT=kgen_unit) var%hybm - READ(UNIT=kgen_unit) var%hybd - READ(UNIT=kgen_unit) var%prsfac - READ(UNIT=kgen_unit) var%etam - READ(UNIT=kgen_unit) var%etai - READ(UNIT=kgen_unit) var%nprlev - READ(UNIT=kgen_unit) var%pad - END SUBROUTINE - !_____________________________________________________________________ - - !_______________________________________________________________________ - - END MODULE hybvcoord_mod diff --git a/test/ncar_kernels/HOMME_preq_omega_ps/src/kernel_driver.f90 b/test/ncar_kernels/HOMME_preq_omega_ps/src/kernel_driver.f90 deleted file mode 100644 index 469410fe3f..0000000000 --- a/test/ncar_kernels/HOMME_preq_omega_ps/src/kernel_driver.f90 +++ /dev/null @@ -1,77 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-03-16 09:25:31 -! KGEN version: 0.4.5 - - -PROGRAM kernel_driver - USE prim_advance_mod, ONLY : compute_and_apply_rhs - USE hybvcoord_mod, ONLY: hvcoord_t - USE hybvcoord_mod, ONLY : kgen_read_mod5 => kgen_read - - IMPLICIT NONE - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(1), PARAMETER :: kgen_mpi_rank_at = (/ 0 /) - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_counter_at = (/ 1, 10, 20 /) - CHARACTER(LEN=1024) :: kgen_filepath - TYPE(hvcoord_t) :: hvcoord - - DO kgen_repeat_counter = 0, 2 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 1)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - kgen_filepath = "../data/preq_omega_ps." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "************ Verification against '" // trim(adjustl(kgen_filepath)) // "' ************" - - - ! driver variables - CALL kgen_read_mod5(hvcoord, kgen_unit) - - call compute_and_apply_rhs(hvcoord, kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! write subroutines - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/HOMME_preq_omega_ps/src/kinds.F90 b/test/ncar_kernels/HOMME_preq_omega_ps/src/kinds.F90 deleted file mode 100644 index 3a0649a997..0000000000 --- a/test/ncar_kernels/HOMME_preq_omega_ps/src/kinds.F90 +++ /dev/null @@ -1,24 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kinds.F90 -! Generated at: 2015-03-16 09:25:32 -! KGEN version: 0.4.5 - - - - MODULE kinds - IMPLICIT NONE - PRIVATE - ! - ! most floating point variables should be of type real_kind = real*8 - ! For higher precision, we also have quad_kind = real*16, but this - ! is only supported on IBM systems - ! - INTEGER(KIND=4), public, parameter :: real_kind = 8 - ! stderr file handle - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE kinds diff --git a/test/ncar_kernels/HOMME_preq_omega_ps/src/prim_advance_mod.F90 b/test/ncar_kernels/HOMME_preq_omega_ps/src/prim_advance_mod.F90 deleted file mode 100644 index 56de857c73..0000000000 --- a/test/ncar_kernels/HOMME_preq_omega_ps/src/prim_advance_mod.F90 +++ /dev/null @@ -1,353 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : prim_advance_mod.F90 -! Generated at: 2015-03-16 09:25:31 -! KGEN version: 0.4.5 - - - - MODULE prim_advance_mod - USE hybvcoord_mod, ONLY : kgen_read_mod5 => kgen_read - ! _EXTERNAL - IMPLICIT NONE - PRIVATE - INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - PUBLIC compute_and_apply_rhs - type, public :: check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - end type check_t - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - subroutine kgen_init_check(check,tolerance) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.E-14 - endif - end subroutine kgen_init_check - subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif - end subroutine kgen_print_check - - - - - - - - - - ! - ! phl notes: output is stored in first argument. Advances from 2nd argument using tendencies evaluated at 3rd rgument: - ! phl: for offline winds use time at 3rd argument (same as rhs currently) - ! - - SUBROUTINE compute_and_apply_rhs(hvcoord, kgen_unit) - ! =================================== - ! compute the RHS, accumulate into u(np1) and apply DSS - ! - ! u(np1) = u(nm1) + dt2*DSS[ RHS(u(n0)) ] - ! - ! This subroutine is normally called to compute a leapfrog timestep - ! but by adjusting np1,nm1,n0 and dt2, many other timesteps can be - ! accomodated. For example, setting nm1=np1=n0 this routine will - ! take a forward euler step, overwriting the input with the output. - ! - ! qn0 = timelevel used to access Qdp() in order to compute virtual Temperature - ! qn0=-1 for the dry case - ! - ! if dt2<0, then the DSS'd RHS is returned in timelevel np1 - ! - ! Combining the RHS and DSS pack operation in one routine - ! allows us to fuse these two loops for more cache reuse - ! - ! Combining the dt advance and DSS unpack operation in one routine - ! allows us to fuse these two loops for more cache reuse - ! - ! note: for prescribed velocity case, velocity will be computed at - ! "real_time", which should be the time of timelevel n0. - ! - ! - ! =================================== - USE kinds, ONLY: real_kind - USE dimensions_mod, ONLY: np - USE dimensions_mod, ONLY: nlev - USE hybvcoord_mod, ONLY: hvcoord_t - USE prim_si_mod, ONLY: preq_omega_ps - IMPLICIT NONE - integer, intent(in) :: kgen_unit - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - TYPE(hvcoord_t), intent(in) :: hvcoord - ! weighting for eta_dot_dpdn mean flux - ! local - ! surface pressure for current tiime level - REAL(KIND=real_kind), dimension(np,np,nlev) :: omega_p - REAL(KIND=real_kind) :: ref_omega_p(np,np,nlev) - REAL(KIND=real_kind), dimension(np,np,nlev) :: divdp - ! half level vertical velocity on p-grid - ! temporary field - ! generic gradient storage - ! - ! - ! v.grad(T) - ! kinetic energy + PHI term - ! lat-lon coord version - ! gradient(p - p_met) - ! vorticity - REAL(KIND=real_kind), dimension(np,np,nlev) :: p ! pressure - ! delta pressure - ! inverse of delta pressure - ! temperature vertical advection - REAL(KIND=real_kind), dimension(np,np,nlev) :: vgrad_p ! v.grad(p) - ! half level pressures on p-grid - ! velocity vertical advection - !JMD call t_barrierf('sync_compute_and_apply_rhs', hybrid%par%comm) - tolerance = 1.E-14 - CALL kgen_init_check(check_status, tolerance) - READ(UNIT=kgen_unit) omega_p - READ(UNIT=kgen_unit) divdp - READ(UNIT=kgen_unit) p - READ(UNIT=kgen_unit) vgrad_p - - READ(UNIT=kgen_unit) ref_omega_p - - ! call to kernel - CALL preq_omega_ps(omega_p, hvcoord, p, vgrad_p, divdp) - ! kernel verification for output variables - CALL kgen_verify_real_real_kind_dim3( "omega_p", check_status, omega_p, ref_omega_p) - CALL kgen_print_check("preq_omega_ps", check_status) - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,10 - CALL preq_omega_ps(omega_p, hvcoord, p, vgrad_p, divdp) - END DO - CALL system_clock(stop_clock, rate_clock) - WRITE(*,*) - PRINT *, "Elapsed time (sec): ", (stop_clock - start_clock)/REAL(rate_clock*10) - ! ============================================================= - ! Insert communications here: for shared memory, just a single - ! sync is required - ! ============================================================= - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_real_kind_dim3(var, kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - real(KIND=real_kind), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2,idx3 - INTEGER, DIMENSION(2,3) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - END IF - END SUBROUTINE kgen_read_real_real_kind_dim3 - - - subroutine kgen_verify_logical(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - logical, intent(in) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - IF ( var .eqv. ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - endif - endif - check_status%numFatal = check_status%numFatal + 1 - END IF - end subroutine - - subroutine kgen_verify_integer(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - endif - endif - check_status%numFatal = check_status%numFatal + 1 - END IF - end subroutine - - subroutine kgen_verify_real(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real, intent(in) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - endif - endif - check_status%numFatal = check_status%numFatal + 1 - END IF - end subroutine - - subroutine kgen_verify_character(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - character(*), intent(in) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - end subroutine - - subroutine kgen_verify_real_real_kind_dim3(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(kind=real_kind), intent(in), dimension(:,:,:) :: var, ref_var - !real(kind=real_kind), intent(in), dimension(:,:,:) :: ref_var - real(kind=real_kind) :: nrmsdiff, rmsdiff - real(kind=real_kind), allocatable :: temp(:,:,:), temp2(:,:,:) - integer :: n - - - IF ( .TRUE. ) THEN - check_status%numTotal = check_status%numTotal + 1 - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - IF ( ALL( var == ref_var ) ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - n = count(var/=ref_var) - where(ref_var .NE. 0) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - END IF - deallocate(temp,temp2) - END IF - end subroutine - - END SUBROUTINE compute_and_apply_rhs - - !TRILINOS - - - END MODULE prim_advance_mod diff --git a/test/ncar_kernels/HOMME_preq_omega_ps/src/prim_si_mod.F90 b/test/ncar_kernels/HOMME_preq_omega_ps/src/prim_si_mod.F90 deleted file mode 100644 index 3d750c902d..0000000000 --- a/test/ncar_kernels/HOMME_preq_omega_ps/src/prim_si_mod.F90 +++ /dev/null @@ -1,129 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : prim_si_mod.F90 -! Generated at: 2015-03-16 09:25:31 -! KGEN version: 0.4.5 - - - - MODULE prim_si_mod - IMPLICIT NONE - PRIVATE - PUBLIC preq_omega_ps - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - ! ========================================================== - ! Implicit system for semi-implicit primitive equations. - ! ========================================================== - - !----------------------------------------------------------------------- - ! preq_omegap: - ! Purpose: - ! Calculate (omega/p) needed for the Thermodynamics Equation - ! - ! Method: - ! Simplified version in CAM2 for clarity - ! - ! Author: Modified by Rich Loft for use in HOMME. - ! - !----------------------------------------------------------------------- - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1 - ! - ! compute omega/p using ps, modeled after CCM3 formulas - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1 - - SUBROUTINE preq_omega_ps(omega_p, hvcoord, p, vgrad_p, divdp) - USE kinds, ONLY: real_kind - USE dimensions_mod, ONLY: np - USE dimensions_mod, ONLY: nlev - USE hybvcoord_mod, ONLY: hvcoord_t - IMPLICIT NONE - !------------------------------Arguments--------------------------------------------------------------- - REAL(KIND=real_kind), intent(in) :: divdp(np,np,nlev) ! divergence - REAL(KIND=real_kind), intent(in) :: vgrad_p(np,np,nlev) ! v.grad(p) - REAL(KIND=real_kind), intent(in) :: p(np,np,nlev) ! layer thicknesses (pressure) - TYPE(hvcoord_t), intent(in) :: hvcoord - REAL(KIND=real_kind), intent(out) :: omega_p(np,np,nlev) ! vertical pressure velocity - !------------------------------------------------------------------------------------------------------ - !---------------------------Local workspace----------------------------- - INTEGER :: j - INTEGER :: i - INTEGER :: k ! longitude, level indices - REAL(KIND=real_kind) :: term ! one half of basic term in omega/p summation - REAL(KIND=real_kind) :: ckk - REAL(KIND=real_kind) :: ckl ! diagonal term of energy conversion matrix - REAL(KIND=real_kind) :: suml(np,np) ! partial sum over l = (1, k-1) - !----------------------------------------------------------------------- - DO j=1,np ! Loop inversion (AAM) - DO i=1,np - ckk = 0.5d0/p(i,j,1) - term = divdp(i,j,1) - ! omega_p(i,j,1) = hvcoord%hybm(1)*vgrad_ps(i,j,1)/p(i,j,1) - omega_p(i,j,1) = vgrad_p(i,j,1)/p(i,j,1) - omega_p(i,j,1) = omega_p(i,j,1) - ckk*term - suml(i,j) = term - END DO - DO k=2,nlev-1 - DO i=1,np - ckk = 0.5d0/p(i,j,k) - ckl = 2*ckk - term = divdp(i,j,k) - ! omega_p(i,j,k) = hvcoord%hybm(k)*vgrad_ps(i,j,k)/p(i,j,k) - omega_p(i,j,k) = vgrad_p(i,j,k)/p(i,j,k) - omega_p(i,j,k) = omega_p(i,j,k) - ckl*suml(i,j) - ckk*term - suml(i,j) = suml(i,j) + term - END DO - END DO - DO i=1,np - ckk = 0.5d0/p(i,j,nlev) - ckl = 2*ckk - term = divdp(i,j,nlev) - ! omega_p(i,j,nlev) = hvcoord%hybm(nlev)*vgrad_ps(i,j,nlev)/p(i,j,nlev) - omega_p(i,j,nlev) = vgrad_p(i,j,nlev)/p(i,j,nlev) - omega_p(i,j,nlev) = omega_p(i,j,nlev) - ckl*suml(i,j) - ckk*term - END DO - END DO - END SUBROUTINE preq_omega_ps - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1 - ! - ! compute omega/p using lnps - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1 - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1 - ! - ! CCM3 hydrostatic integral - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1 - - ! - ! The hydrostatic routine from CAM physics. - ! (FV stuff removed) - ! t,q input changed to take t_v - ! removed gravit, so this routine returns PHI, not zm - - !----------------------------------------------------------------------- - ! preq_pressure: - ! - ! Purpose: - ! Define the pressures of the interfaces and midpoints from the - ! coordinate definitions and the surface pressure. Originally plevs0! - ! - ! Method: - ! - ! Author: B. Boville/ Adapted for HOMME by Rich Loft - ! - !----------------------------------------------------------------------- - ! - ! $Id: prim_si_mod.F90,v 2.10 2005/10/14 20:17:22 jedwards Exp $ - ! $Author: jedwards $ - ! - !----------------------------------------------------------------------- - - END MODULE prim_si_mod diff --git a/test/ncar_kernels/HOMME_remap_q_ppm/CESM_license.txt b/test/ncar_kernels/HOMME_remap_q_ppm/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/HOMME_remap_q_ppm/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/HOMME_remap_q_ppm/data/remap_q_ppm.1.0 b/test/ncar_kernels/HOMME_remap_q_ppm/data/remap_q_ppm.1.0 deleted file mode 100644 index e752097d50..0000000000 Binary files a/test/ncar_kernels/HOMME_remap_q_ppm/data/remap_q_ppm.1.0 and /dev/null differ diff --git a/test/ncar_kernels/HOMME_remap_q_ppm/data/remap_q_ppm.10.0 b/test/ncar_kernels/HOMME_remap_q_ppm/data/remap_q_ppm.10.0 deleted file mode 100644 index bcb80b4d07..0000000000 Binary files a/test/ncar_kernels/HOMME_remap_q_ppm/data/remap_q_ppm.10.0 and /dev/null differ diff --git a/test/ncar_kernels/HOMME_remap_q_ppm/data/remap_q_ppm.20.0 b/test/ncar_kernels/HOMME_remap_q_ppm/data/remap_q_ppm.20.0 deleted file mode 100644 index fc6abb63e7..0000000000 Binary files a/test/ncar_kernels/HOMME_remap_q_ppm/data/remap_q_ppm.20.0 and /dev/null differ diff --git a/test/ncar_kernels/HOMME_remap_q_ppm/inc/t1.mk b/test/ncar_kernels/HOMME_remap_q_ppm/inc/t1.mk deleted file mode 100644 index 6eeeebda80..0000000000 --- a/test/ncar_kernels/HOMME_remap_q_ppm/inc/t1.mk +++ /dev/null @@ -1,68 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# Intel default flags -# -# FC_FLAGS := -assume byterecl -fp-model precise -ftz -O3 -g -openmp -# -# Makefile for KGEN-generated kernel -FC_FLAGS := $(OPT) - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - -ALL_OBJS := kernel_driver.o prim_advection_mod.o dimensions_mod.o kinds.o perf_utils.o perf_mod.o control_mod.o - -verify: - @(grep "verification.FAIL" $(TEST).rslt && echo "FAILED") || (grep "verification.PASS" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 prim_advection_mod.o dimensions_mod.o kinds.o perf_utils.o perf_mod.o control_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -prim_advection_mod.o: $(SRC_DIR)/prim_advection_mod.F90 kinds.o dimensions_mod.o perf_mod.o control_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -dimensions_mod.o: $(SRC_DIR)/dimensions_mod.F90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -kinds.o: $(SRC_DIR)/kinds.F90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -perf_utils.o: $(SRC_DIR)/perf_utils.F90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -perf_mod.o: $(SRC_DIR)/perf_mod.F90 perf_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -control_mod.o: $(SRC_DIR)/control_mod.F90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.rslt diff --git a/test/ncar_kernels/HOMME_remap_q_ppm/lit/runmake b/test/ncar_kernels/HOMME_remap_q_ppm/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/HOMME_remap_q_ppm/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/HOMME_remap_q_ppm/makefile b/test/ncar_kernels/HOMME_remap_q_ppm/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/HOMME_remap_q_ppm/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/HOMME_remap_q_ppm/readme.txt b/test/ncar_kernels/HOMME_remap_q_ppm/readme.txt deleted file mode 100644 index 901bfb554b..0000000000 --- a/test/ncar_kernels/HOMME_remap_q_ppm/readme.txt +++ /dev/null @@ -1,20 +0,0 @@ -Remap_q_ppm Kernel -Edited 02/24/2015 -Amogh Simha - -*kernel and supporting files - -the remap_q_ppm subroutine is located in the prim_advection_mod.F90 file - -subroutine call is in the same file at line 150 under the remap1 subroutine - -*compilation and execution - -Just download the enclosing directory - -Run make - -*verification - -The make command will trigger the verification of the kernel. - -It is considered to have passed verification if the tolerance for normalized RMS is less than 9.999999824516700E-015 - -Input data is provided by remap_q_ppm.1.0, remap_q_ppm.10.0, and remap_q_ppm.20.0 - -*performance measurement - -The elapsed time in seconds is printed to stdout for each input file specified - diff --git a/test/ncar_kernels/HOMME_remap_q_ppm/src/control_mod.F90 b/test/ncar_kernels/HOMME_remap_q_ppm/src/control_mod.F90 deleted file mode 100644 index f3778f8d56..0000000000 --- a/test/ncar_kernels/HOMME_remap_q_ppm/src/control_mod.F90 +++ /dev/null @@ -1,126 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : control_mod.F90 -! Generated at: 2015-02-24 15:34:48 -! KGEN version: 0.4.4 - - - - MODULE control_mod - ! time integration (explicit, semi_imp, or full imp) - ! none of this is used anymore: - ! u grad(Q) formulation - ! div(u dp/dn Q ) formulation - ! Tracer transport type - ! We potentially have five types of tracer advection. However, not all of them - ! may be chosen at runtime due to compile-type restrictions on arrays - !shallow water advection tests: - !kmass points to a level with density. other levels contain test tracers - ! m s^-2 - ! 0 = leapfrog - ! 1 = RK (foward-in-time) - ! number of RK stages to use - ! Forcing Type - ! ftype = 0 HOMME ApplyColumn() type forcing process split - ! ftype = -1 ignore forcing (used for testing energy balance) - ! use cp or cp* in T equation - ! -1: No fixer, use non-staggered formula - ! 0: No Fixer, use staggered in time formula - ! (only for leapfrog) - ! 1 or 4: Enable fixer, non-staggered formula - ! ratio of dynamics tsteps to tracer tsteps - ! for vertically lagrangian dynamics, apply remap - ! every rsplit tracer timesteps - ! Defines if the program is to use its own physics (HOMME standalone), valid values 1,2,3 - ! physics = 0, no physics - ! physics = 1, Use physics - ! leapfrog-trapazoidal frequency - ! interspace a lf-trapazoidal step every LFTfreq leapfrogs - ! 0 = disabled - ! compute_mean_flux: obsolete, not used - ! vert_remap_q_alg: 0 default value, Zerroukat monotonic splines - ! 1 PPM vertical remap with mirroring at the boundaries - ! (solid wall bc's, high-order throughout) - ! 2 PPM vertical remap without mirroring at the boundaries - ! (no bc's enforced, first-order at two cells bordering top and bottom boundaries) - INTEGER, public :: vert_remap_q_alg = 0 - ! -1 = chosen at run time - ! 0 = equi-angle Gnomonic (default) - ! 1 = equi-spaced Gnomonic (not yet coded) - ! 2 = element-local projection (for var-res) - ! 3 = parametric (not yet coded) - !tolerance to define smth small, was introduced for lim 8 in 2d and 3d - ! if semi_implicit, type of preconditioner: - ! choices block_jacobi or identity - ! partition methods - ! options: "cube" is supported - ! options: if cube: "swtc1","swtc2",or "swtc6" - ! generic test case param - ! remap frequency of synopsis of system state (steps) - ! selected remapping option - ! output frequency of synopsis of system state (steps) - ! frequency in steps of field accumulation - ! model day to start accumulation - ! model day to stop accumulation - ! max iterations of solver - ! solver tolerance (convergence criteria) - ! debug level of CG solver - ! Boyd Vandeven filter Transfer fn parameters - ! Fischer-Mullen filter Transfer fn parameters - ! vertical formulation (ecmwf,ccm1) - ! vertical grid spacing (equal,unequal) - ! vertical coordinate system (sigma,hybrid) - ! set for refined exodus meshes (variable viscosity) - ! upper bound for Courant number - ! (only used for variable viscosity, recommend 1.9 in namelist) - ! viscosity (momentum equ) - ! viscsoity (momentum equ, div component) - ! default = nu T equ. viscosity - ! default = nu tracer viscosity - ! default = 0 ps equ. viscosity - ! top-of-the-model viscosity - ! number of subcycles for hyper viscsosity timestep - ! number of subcycles for hyper viscsosity timestep on TRACERS - ! laplace**hypervis_order. 0=not used 1=regular viscosity, 2=grad**4 - ! 0 = use laplace on eta surfaces - ! 1 = use (approx.) laplace on p surfaces - ! if not 0, use variable hyperviscosity based on element area - ! use tensor hyperviscosity - ! - !three types of hyper viscosity are supported right now: - ! (1) const hv: nu * del^2 del^2 - ! (2) scalar hv: nu(lat,lon) * del^2 del^2 - ! (3) tensor hv, nu * ( \div * tensor * \grad ) * del^2 - ! - ! (1) default: hypervis_power=0, hypervis_scaling=0 - ! (2) Original version for var-res grids. (M. Levy) - ! scalar coefficient within each element - ! hypervisc_scaling=0 - ! set hypervis_power>0 and set fine_ne, max_hypervis_courant - ! (3) tensor HV var-res grids - ! tensor within each element: - ! set hypervis_scaling > 0 (typical values would be 3.2 or 4.0) - ! hypervis_power=0 - ! (\div * tensor * \grad) operator uses cartesian laplace - ! - ! hyperviscosity parameters used for smoothing topography - ! 0 = disable - ! 0 = disabled - ! fix the velocities? - ! initial perturbation in JW test case - ! initial perturbation in JW test case - !pertibation to temperature [like CESM] - PUBLIC read_externs_control_mod - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_control_mod(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) vert_remap_q_alg - END SUBROUTINE read_externs_control_mod - - - ! read subroutines - END MODULE control_mod diff --git a/test/ncar_kernels/HOMME_remap_q_ppm/src/dimensions_mod.F90 b/test/ncar_kernels/HOMME_remap_q_ppm/src/dimensions_mod.F90 deleted file mode 100644 index ea03b99b87..0000000000 --- a/test/ncar_kernels/HOMME_remap_q_ppm/src/dimensions_mod.F90 +++ /dev/null @@ -1,47 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : dimensions_mod.F90 -! Generated at: 2015-02-24 15:34:48 -! KGEN version: 0.4.4 - - - - MODULE dimensions_mod - IMPLICIT NONE - PRIVATE - ! set MAX number of tracers. actual number of tracers is a run time argument - ! SE tracers: default is 4 - ! fvm tracers - ! FI # dependent variables - ! fvm dimensions: - !number of Gausspoints for the fvm integral approximation - !Max. Courant number - !halo width needed for reconstruction - phl - !total halo width where reconstruction is needed (nht<=nc) - phl - !(different from halo needed for elements on edges and corners - ! integer, parameter, public :: ns=3 !quadratic halo interpolation - recommended setting for nc=3 - ! integer, parameter, public :: ns=4 !cubic halo interpolation - recommended setting for nc=4 - !nhc determines width of halo exchanged with neighboring elements - ! - ! constants for SPELT - ! - !number of interpolation values, works only for this - ! number of points in an element - ! dg degree for hybrid cg/dg element 0=disabled - INTEGER, parameter, public :: nlev=26 - ! params for a mesh - ! integer, public, parameter :: max_elements_attached_to_node = 7 - ! integer, public, parameter :: s_nv = 2*max_elements_attached_to_node - !default for non-refined mesh (note that these are *not* parameters now) - !max_elements_attached_to_node-3 - !4 + 4*max_corner_elem - ! total number of elements - ! number of elements per MPI task - ! max number of elements on any MPI task - ! This is the number of physics processors/ per dynamics processor - CONTAINS - - ! read subroutines - - END MODULE dimensions_mod diff --git a/test/ncar_kernels/HOMME_remap_q_ppm/src/kernel_driver.f90 b/test/ncar_kernels/HOMME_remap_q_ppm/src/kernel_driver.f90 deleted file mode 100644 index 6819d26d54..0000000000 --- a/test/ncar_kernels/HOMME_remap_q_ppm/src/kernel_driver.f90 +++ /dev/null @@ -1,133 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-02-24 15:34:48 -! KGEN version: 0.4.4 - - -PROGRAM kernel_driver - USE vertremap_mod, only : remap1 - USE kinds, ONLY: real_kind - USE dimensions_mod, ONLY: nlev - USE perf_mod, only : read_externs_perf_mod - USE control_mod, only : read_externs_control_mod - - IMPLICIT NONE - - ! read interface - interface kgen_read_var - procedure read_var_real_real_kind_dim4 - procedure read_var_real_real_kind_dim3 - end interface kgen_read_var - - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(1), PARAMETER :: kgen_mpi_rank_at = (/ 0 /) - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_counter_at = (/ 1, 10, 20 /) - CHARACTER(LEN=1024) :: kgen_filepath - INTEGER :: nx - INTEGER :: qsize - REAL(KIND=real_kind), allocatable :: qdp(:,:,:,:) - REAL(KIND=real_kind), allocatable :: dp2(:,:,:) - REAL(KIND=real_kind), allocatable :: dp1(:,:,:) - - DO kgen_repeat_counter = 0, 2 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 1)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - kgen_filepath = "../data/remap_q_ppm." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "************ Verification against '" // trim(adjustl(kgen_filepath)) // "' ************" - - call read_externs_perf_mod(kgen_unit) - call read_externs_control_mod(kgen_unit) - - ! driver variables - READ(UNIT=kgen_unit) nx - READ(UNIT=kgen_unit) qsize - call kgen_read_var(qdp, kgen_unit) - call kgen_read_var(dp1, kgen_unit) - call kgen_read_var(dp2, kgen_unit) - call remap1(nx, qsize, qdp, dp1, dp2, kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! read subroutines - subroutine read_var_real_real_kind_dim4(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=real_kind), intent(out), dimension(:,:,:,:), allocatable :: var - integer, dimension(2,4) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - READ(UNIT = kgen_unit) kgen_bound(1, 4) - READ(UNIT = kgen_unit) kgen_bound(2, 4) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1, kgen_bound(2, 4) - kgen_bound(1, 4) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_real_kind_dim3(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=real_kind), intent(out), dimension(:,:,:), allocatable :: var - integer, dimension(2,3) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/HOMME_remap_q_ppm/src/kinds.F90 b/test/ncar_kernels/HOMME_remap_q_ppm/src/kinds.F90 deleted file mode 100644 index eb7bf61281..0000000000 --- a/test/ncar_kernels/HOMME_remap_q_ppm/src/kinds.F90 +++ /dev/null @@ -1,22 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kinds.F90 -! Generated at: 2015-02-24 15:34:48 -! KGEN version: 0.4.4 - - - - MODULE kinds - IMPLICIT NONE - PRIVATE - ! - ! most floating point variables should be of type real_kind = real*8 - ! For higher precision, we also have quad_kind = real*16, but this - ! is only supported on IBM systems - ! - INTEGER(KIND=4), public, parameter :: real_kind = 8 - ! stderr file handle - - ! read subroutines - END MODULE kinds diff --git a/test/ncar_kernels/HOMME_remap_q_ppm/src/perf_mod.F90 b/test/ncar_kernels/HOMME_remap_q_ppm/src/perf_mod.F90 deleted file mode 100644 index 769c3945f0..0000000000 --- a/test/ncar_kernels/HOMME_remap_q_ppm/src/perf_mod.F90 +++ /dev/null @@ -1,341 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : perf_mod.F90 -! Generated at: 2015-02-24 15:34:48 -! KGEN version: 0.4.4 - - - - MODULE perf_mod - !----------------------------------------------------------------------- - ! - ! Purpose: This module is responsible for controlling the performance - ! timer logic. - ! - ! Author: P. Worley, January 2007 - ! - ! $Id$ - ! - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - !- Uses ---------------------------------------------------------------- - !----------------------------------------------------------------------- - USE perf_utils, only : shr_kind_i8 - !----------------------------------------------------------------------- - !- module boilerplate -------------------------------------------------- - !----------------------------------------------------------------------- - IMPLICIT NONE - PRIVATE ! Make the default access private - ! - ! Copyright (C) 2003-2014 Intel Corporation. All Rights Reserved. - ! - ! The source code contained or described herein and all documents - ! related to the source code ("Material") are owned by Intel Corporation - ! or its suppliers or licensors. Title to the Material remains with - ! Intel Corporation or its suppliers and licensors. The Material is - ! protected by worldwide copyright and trade secret laws and treaty - ! provisions. No part of the Material may be used, copied, reproduced, - ! modified, published, uploaded, posted, transmitted, distributed, or - ! disclosed in any way without Intel's prior express written permission. - ! - ! No license under any patent, copyright, trade secret or other - ! intellectual property right is granted to or conferred upon you by - ! disclosure or delivery of the Materials, either expressly, by - ! implication, inducement, estoppel or otherwise. Any license under - ! such intellectual property rights must be express and approved by - ! Intel in writing. - ! /* -*- Mode: Fortran; -*- */ - ! - ! (C) 2001 by Argonne National Laboratory. - ! - ! MPICH2 COPYRIGHT - ! - ! The following is a notice of limited availability of the code, and disclaimer - ! which must be included in the prologue of the code and in all source listings - ! of the code. - ! - ! Copyright Notice - ! + 2002 University of Chicago - ! - ! Permission is hereby granted to use, reproduce, prepare derivative works, and - ! to redistribute to others. This software was authored by: - ! - ! Mathematics and Computer Science Division - ! Argonne National Laboratory, Argonne IL 60439 - ! - ! (and) - ! - ! Department of Computer Science - ! University of Illinois at Urbana-Champaign - ! - ! - ! GOVERNMENT LICENSE - ! - ! Portions of this material resulted from work developed under a U.S. - ! Government Contract and are subject to the following license: the Government - ! is granted for itself and others acting on its behalf a paid-up, nonexclusive, - ! irrevocable worldwide license in this computer software to reproduce, prepare - ! derivative works, and perform publicly and display publicly. - ! - ! DISCLAIMER - ! - ! This computer code material was prepared, in part, as an account of work - ! sponsored by an agency of the United States Government. Neither the United - ! States, nor the University of Chicago, nor any of their employees, makes any - ! warranty express or implied, or assumes any legal liability or responsibility - ! for the accuracy, completeness, or usefulness of any information, apparatus, - ! product, or process disclosed, or represents that its use would not infringe - ! privately owned rights. - ! - ! Portions of this code were written by Microsoft. Those portions are - ! Copyright (c) 2007 Microsoft Corporation. Microsoft grants permission to - ! use, reproduce, prepare derivative works, and to redistribute to - ! others. The code is licensed "as is." The User bears the risk of using - ! it. Microsoft gives no express warranties, guarantees or - ! conditions. To the extent permitted by law, Microsoft excludes the - ! implied warranties of merchantability, fitness for a particular - ! purpose and non-infringement. - ! - ! - ! - ! - ! - ! DO NOT EDIT - ! This file created by buildiface - ! - !----------------------------------------------------------------------- - ! Public interfaces ---------------------------------------------------- - !----------------------------------------------------------------------- - PUBLIC t_startf - PUBLIC t_stopf - !----------------------------------------------------------------------- - ! Private interfaces (local) ------------------------------------------- - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - !- include statements -------------------------------------------------- - !----------------------------------------------------------------------- - ! - ! $Id: gptl.inc,v 1.44 2011-03-28 20:55:19 rosinski Exp $ - ! - ! Author: Jim Rosinski - ! - ! GPTL header file to be included in user code. Values match - ! their counterparts in gptl.h. See that file or man pages - ! or web-based documenation for descriptions of each value - ! - ! Externals - !----------------------------------------------------------------------- - ! Private data --------------------------------------------------------- - !----------------------------------------------------------------------- - !---------------------------------------------------------------------------- - ! perf_mod options - !---------------------------------------------------------------------------- - ! default - ! unit number for log output - LOGICAL, parameter :: def_timing_initialized = .false. ! default - LOGICAL, private :: timing_initialized = def_timing_initialized - ! flag indicating whether timing library has - ! been initialized - ! default - ! flag indicating whether timers are disabled - ! default - ! flag indicating whether the mpi_barrier in - ! t_barrierf should be called - ! default - ! integer indicating maximum number of levels of - ! timer nesting - INTEGER, parameter :: def_timing_detail_limit = 1 ! default - INTEGER, private :: timing_detail_limit = def_timing_detail_limit - ! integer indicating maximum detail level to - ! profile - INTEGER, parameter :: init_timing_disable_depth = 0 ! init - INTEGER, private :: timing_disable_depth = init_timing_disable_depth - ! integer indicating depth of t_disablef calls - INTEGER, parameter :: init_timing_detail = 0 ! init - INTEGER, private :: cur_timing_detail = init_timing_detail - ! current timing detail level - ! default - ! flag indicating whether the performance timer - ! output should be written to a single file - ! (per component communicator) or to a - ! separate file for each process - ! default - ! maximum number of processes writing out - ! timing data (for this component communicator) - ! default - ! separation between process ids for processes - ! that are writing out timing data - ! (for this component communicator) - ! default - ! collect and print out global performance statistics - ! (for this component communicator) - ! default - ! integer indicating which timer to use - ! (as defined in gptl.inc) - ! default - ! flag indicating whether the PAPI namelist - ! should be read and HW performance counters - ! used in profiling - ! PAPI counter ids - ! default - ! default - ! default - ! default - !======================================================================= - PUBLIC read_externs_perf_mod - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_perf_mod(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) timing_initialized - READ(UNIT=kgen_unit) timing_detail_limit - READ(UNIT=kgen_unit) timing_disable_depth - READ(UNIT=kgen_unit) cur_timing_detail - END SUBROUTINE read_externs_perf_mod - - - ! read subroutines - !======================================================================= - ! - !======================================================================== - ! - - ! - !======================================================================== - ! - - ! - !======================================================================== - ! - - ! - !======================================================================== - ! - - ! - !======================================================================== - ! - - ! - !======================================================================== - ! - - ! - !======================================================================== - ! - - ! - !======================================================================== - ! - - ! - !======================================================================== - ! - - ! - !======================================================================== - ! - - ! - !======================================================================== - ! - - SUBROUTINE t_startf(event, handle) - !----------------------------------------------------------------------- - ! Purpose: Start an event timer - ! Author: P. Worley - !----------------------------------------------------------------------- - !---------------------------Input arguments----------------------------- - ! - ! performance timer event name - CHARACTER(LEN=*), intent(in) :: event - ! - !---------------------------Input/Output arguments---------------------- - ! - ! GPTL event handle - INTEGER(KIND=shr_kind_i8), optional :: handle - ! - !---------------------------Local workspace----------------------------- - ! - INTEGER :: ierr ! GPTL error return - ! - !----------------------------------------------------------------------- - ! - IF ((timing_initialized) .and. (timing_disable_depth .eq. 0) .and. (cur_timing_detail .le. & - timing_detail_limit)) THEN - IF (present (handle)) THEN - !kgen_excluded ierr = gptlstart_handle(event, handle) - ELSE - !kgen_excluded ierr = gptlstart(event) - END IF - END IF - RETURN - END SUBROUTINE t_startf - ! - !======================================================================== - ! - - SUBROUTINE t_stopf(event, handle) - !----------------------------------------------------------------------- - ! Purpose: Stop an event timer - ! Author: P. Worley - !----------------------------------------------------------------------- - !---------------------------Input arguments----------------------------- - ! - ! performance timer event name - CHARACTER(LEN=*), intent(in) :: event - ! - !---------------------------Input/Output arguments---------------------- - ! - ! GPTL event handle - INTEGER(KIND=shr_kind_i8), optional :: handle - ! - !---------------------------Local workspace----------------------------- - ! - INTEGER :: ierr ! GPTL error return - ! - !----------------------------------------------------------------------- - ! - IF ((timing_initialized) .and. (timing_disable_depth .eq. 0) .and. (cur_timing_detail .le. & - timing_detail_limit)) THEN - IF (present (handle)) THEN - !kgen_excluded ierr = gptlstop_handle(event, handle) - ELSE - !kgen_excluded ierr = gptlstop(event) - END IF - END IF - RETURN - END SUBROUTINE t_stopf - ! - !======================================================================== - ! - - ! - !======================================================================== - ! - - ! - !======================================================================== - ! - - ! - !======================================================================== - ! - - ! - !======================================================================== - ! - - ! - !======================================================================== - ! - - ! - !======================================================================== - ! - - !=============================================================================== - END MODULE perf_mod diff --git a/test/ncar_kernels/HOMME_remap_q_ppm/src/perf_utils.F90 b/test/ncar_kernels/HOMME_remap_q_ppm/src/perf_utils.F90 deleted file mode 100644 index f865826e36..0000000000 --- a/test/ncar_kernels/HOMME_remap_q_ppm/src/perf_utils.F90 +++ /dev/null @@ -1,209 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : perf_utils.F90 -! Generated at: 2015-02-24 15:34:48 -! KGEN version: 0.4.4 - - - - MODULE perf_utils - !----------------------------------------------------------------------- - ! - ! Purpose: This module supplies the csm_share and CAM utilities - ! needed by perf_mod.F90 (when the csm_share and CAM utilities - ! are not available). - ! - ! Author: P. Worley, October 2007 - ! - ! $Id$ - ! - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - !- module boilerplate -------------------------------------------------- - !----------------------------------------------------------------------- - IMPLICIT NONE - PRIVATE ! Make the default access private - ! - ! Copyright (C) 2003-2014 Intel Corporation. All Rights Reserved. - ! - ! The source code contained or described herein and all documents - ! related to the source code ("Material") are owned by Intel Corporation - ! or its suppliers or licensors. Title to the Material remains with - ! Intel Corporation or its suppliers and licensors. The Material is - ! protected by worldwide copyright and trade secret laws and treaty - ! provisions. No part of the Material may be used, copied, reproduced, - ! modified, published, uploaded, posted, transmitted, distributed, or - ! disclosed in any way without Intel's prior express written permission. - ! - ! No license under any patent, copyright, trade secret or other - ! intellectual property right is granted to or conferred upon you by - ! disclosure or delivery of the Materials, either expressly, by - ! implication, inducement, estoppel or otherwise. Any license under - ! such intellectual property rights must be express and approved by - ! Intel in writing. - ! /* -*- Mode: Fortran; -*- */ - ! - ! (C) 2001 by Argonne National Laboratory. - ! - ! MPICH2 COPYRIGHT - ! - ! The following is a notice of limited availability of the code, and disclaimer - ! which must be included in the prologue of the code and in all source listings - ! of the code. - ! - ! Copyright Notice - ! + 2002 University of Chicago - ! - ! Permission is hereby granted to use, reproduce, prepare derivative works, and - ! to redistribute to others. This software was authored by: - ! - ! Mathematics and Computer Science Division - ! Argonne National Laboratory, Argonne IL 60439 - ! - ! (and) - ! - ! Department of Computer Science - ! University of Illinois at Urbana-Champaign - ! - ! - ! GOVERNMENT LICENSE - ! - ! Portions of this material resulted from work developed under a U.S. - ! Government Contract and are subject to the following license: the Government - ! is granted for itself and others acting on its behalf a paid-up, nonexclusive, - ! irrevocable worldwide license in this computer software to reproduce, prepare - ! derivative works, and perform publicly and display publicly. - ! - ! DISCLAIMER - ! - ! This computer code material was prepared, in part, as an account of work - ! sponsored by an agency of the United States Government. Neither the United - ! States, nor the University of Chicago, nor any of their employees, makes any - ! warranty express or implied, or assumes any legal liability or responsibility - ! for the accuracy, completeness, or usefulness of any information, apparatus, - ! product, or process disclosed, or represents that its use would not infringe - ! privately owned rights. - ! - ! Portions of this code were written by Microsoft. Those portions are - ! Copyright (c) 2007 Microsoft Corporation. Microsoft grants permission to - ! use, reproduce, prepare derivative works, and to redistribute to - ! others. The code is licensed "as is." The User bears the risk of using - ! it. Microsoft gives no express warranties, guarantees or - ! conditions. To the extent permitted by law, Microsoft excludes the - ! implied warranties of merchantability, fitness for a particular - ! purpose and non-infringement. - ! - ! - ! - ! - ! - ! DO NOT EDIT - ! This file created by buildiface - ! - !----------------------------------------------------------------------- - ! Public interfaces ---------------------------------------------------- - !----------------------------------------------------------------------- - - !----------------------------------------------------------------------- - ! Private interfaces --------------------------------------------------- - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - !- include statements -------------------------------------------------- - !----------------------------------------------------------------------- - ! - ! $Id: gptl.inc,v 1.44 2011-03-28 20:55:19 rosinski Exp $ - ! - ! Author: Jim Rosinski - ! - ! GPTL header file to be included in user code. Values match - ! their counterparts in gptl.h. See that file or man pages - ! or web-based documenation for descriptions of each value - ! - ! Externals - !----------------------------------------------------------------------- - ! Public data --------------------------------------------------------- - !----------------------------------------------------------------------- - !---------------------------------------------------------------------------- - ! precision/kind constants (from csm_share/shr/shr_kind_mod.F90) - !---------------------------------------------------------------------------- - ! 8 byte real - INTEGER, parameter, public :: shr_kind_i8 = selected_int_kind (13) ! 8 byte integer - ! native integer - ! long char - ! extra-long char - !----------------------------------------------------------------------- - ! Private data --------------------------------------------------------- - !----------------------------------------------------------------------- - ! default - ! unit number for log output - !======================================================================= - CONTAINS - - ! read subroutines - !======================================================================= - ! - !======================================================================== - ! - - !============== Routines from csm_share/shr/shr_sys_mod.F90 ============ - !======================================================================= - - !=============================================================================== - !=============================================================================== - - !=============================================================================== - !================== Routines from csm_share/shr/shr_mpi_mod.F90 =============== - !=============================================================================== - - !=============================================================================== - !=============================================================================== - - !=============================================================================== - !=============================================================================== - - !=============================================================================== - !=============================================================================== - - !=============================================================================== - !=============================================================================== - - !=============================================================================== - !================== Routines from csm_share/shr/shr_file_mod.F90 =============== - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_file_getUnit -- Get a free FORTRAN unit number - ! - ! !DESCRIPTION: Get the next free FORTRAN unit number. - ! - ! !REVISION HISTORY: - ! 2005-Dec-14 - E. Kluzek - creation - ! 2007-Oct-21 - P. Worley - dumbed down for use in perf_mod - ! - ! !INTERFACE: ------------------------------------------------------------------ - - !=============================================================================== - !=============================================================================== - !BOP =========================================================================== - ! - ! !IROUTINE: shr_file_freeUnit -- Free up a FORTRAN unit number - ! - ! !DESCRIPTION: Free up the given unit number - ! - ! !REVISION HISTORY: - ! 2005-Dec-14 - E. Kluzek - creation - ! 2007-Oct-21 - P. Worley - dumbed down for use in perf_mod - ! - ! !INTERFACE: ------------------------------------------------------------------ - - !=============================================================================== - !============= Routines from atm/cam/src/utils/namelist_utils.F90 ============== - !=============================================================================== - - !=============================================================================== - !================ Routines from atm/cam/src/utils/string_utils.F90 ============= - !=============================================================================== - - !=============================================================================== - END MODULE perf_utils diff --git a/test/ncar_kernels/HOMME_remap_q_ppm/src/prim_advection_mod.F90 b/test/ncar_kernels/HOMME_remap_q_ppm/src/prim_advection_mod.F90 deleted file mode 100644 index f936d433e6..0000000000 --- a/test/ncar_kernels/HOMME_remap_q_ppm/src/prim_advection_mod.F90 +++ /dev/null @@ -1,593 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : prim_advection_mod.F90 -! Generated at: 2015-02-24 15:34:48 -! KGEN version: 0.4.4 - - - - MODULE vertremap_mod - !************************************************************************************** - ! - ! Purpose: - ! Construct sub-grid-scale polynomials using piecewise spline method with - ! monotone filters. - ! - ! References: PCM - Zerroukat et al., Q.J.R. Meteorol. Soc., 2005. (ZWS2005QJR) - ! PSM - Zerroukat et al., Int. J. Numer. Meth. Fluids, 2005. (ZWS2005IJMF) - ! - !************************************************************************************** - USE kinds, ONLY: real_kind - USE dimensions_mod, ONLY: nlev - USE perf_mod, ONLY: t_startf - USE perf_mod, ONLY: t_stopf ! _EXTERNAL - INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - PUBLIC remap1 - type, public :: check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - end type check_t - ! remap any field, splines, monotone - ! remap any field, splines, no filter - ! todo: tweak interface to match remap1 above, rename remap1_ppm: - PUBLIC remap_q_ppm ! remap state%Q, PPM, monotone - CONTAINS - subroutine kgen_init_check(check,tolerance) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.E-14 - endif - end subroutine kgen_init_check - subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif - end subroutine kgen_print_check - !=======================================================================================================! - !remap_calc_grids computes the vertical pressures and pressure differences for one vertical column for the reference grid - !and for the deformed Lagrangian grid. This was pulled out of each routine since it was a repeated task. - - !=======================================================================================================! - - SUBROUTINE remap1(nx, qsize, qdp, dp1, dp2, kgen_unit) - ! remap 1 field - ! input: Qdp field to be remapped (NOTE: MASS, not MIXING RATIO) - ! dp1 layer thickness (source) - ! dp2 layer thickness (target) - ! - ! output: remaped Qdp, conserving mass, monotone on Q=Qdp/dp - ! - IMPLICIT NONE - integer, intent(in) :: kgen_unit - - ! read interface - interface kgen_read_var - procedure read_var_real_real_kind_dim4 - end interface kgen_read_var - - - - ! verification interface - interface kgen_verify_var - procedure verify_var_logical - procedure verify_var_integer - procedure verify_var_real - procedure verify_var_character - procedure verify_var_real_real_kind_dim4 - end interface kgen_verify_var - - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - INTEGER, intent(in) :: nx - INTEGER, intent(in) :: qsize - REAL(KIND=real_kind), intent(inout) :: qdp(nx,nx,nlev,qsize) - REAL(KIND=real_kind), allocatable :: ref_qdp(:,:,:,:) - REAL(KIND=real_kind), intent(in) :: dp1(nx,nx,nlev) - REAL(KIND=real_kind), intent(in) :: dp2(nx,nx,nlev) - ! ======================== - ! Local Variables - ! ======================== - tolerance = 1.E-14 - CALL kgen_init_check(check_status, tolerance) - ! None - call kgen_read_var(ref_qdp, kgen_unit) - ! call to kernel - CALL remap_q_ppm(qdp, nx, qsize, dp1, dp2) - ! kernel verification for output variables - call kgen_verify_var("qdp", check_status, qdp, ref_qdp) - CALL kgen_print_check("remap_q_ppm", check_status) - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,10 - CALL remap_q_ppm(qdp, nx, qsize, dp1, dp2) - END DO - CALL system_clock(stop_clock, rate_clock) - WRITE(*,*) - PRINT *, "Elapsed time (sec): ", (stop_clock - start_clock)/REAL(rate_clock*10) - ! q loop - CONTAINS - - ! read subroutines - subroutine read_var_real_real_kind_dim4(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=real_kind), intent(out), dimension(:,:,:,:), allocatable :: var - integer, dimension(2,4) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - READ(UNIT = kgen_unit) kgen_bound(1, 4) - READ(UNIT = kgen_unit) kgen_bound(2, 4) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1, kgen_bound(2, 4) - kgen_bound(1, 4) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - - subroutine verify_var_logical(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - logical, intent(in) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - IF ( var .eqv. ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - endif - endif - check_status%numFatal = check_status%numFatal + 1 - END IF - end subroutine - - subroutine verify_var_integer(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - endif - endif - check_status%numFatal = check_status%numFatal + 1 - END IF - end subroutine - - subroutine verify_var_real(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real, intent(in) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - endif - endif - check_status%numFatal = check_status%numFatal + 1 - END IF - end subroutine - - subroutine verify_var_character(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - character(*), intent(in) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - end subroutine - - subroutine verify_var_real_real_kind_dim4(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(kind=real_kind), intent(in), dimension(:,:,:,:) :: var - real(kind=real_kind), intent(in), allocatable, dimension(:,:,:,:) :: ref_var - real(kind=real_kind) :: nrmsdiff, rmsdiff - real(kind=real_kind), allocatable :: temp(:,:,:,:), temp2(:,:,:,:) - integer :: n - - - IF ( ALLOCATED(ref_var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3),SIZE(var,dim=4))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3),SIZE(var,dim=4))) - IF ( ALL( var == ref_var ) ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - n = count(var/=ref_var) - where(ref_var .NE. 0) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - END IF - deallocate(temp,temp2) - END IF - end subroutine - - END SUBROUTINE remap1 - - !=======================================================================================================! - !This uses the exact same model and reference grids and data as remap_Q, but it interpolates - !using PPM instead of splines. - - SUBROUTINE remap_q_ppm(qdp, nx, qsize, dp1, dp2) - ! remap 1 field - ! input: Qdp field to be remapped (NOTE: MASS, not MIXING RATIO) - ! dp1 layer thickness (source) - ! dp2 layer thickness (target) - ! - ! output: remaped Qdp, conserving mass - ! - USE control_mod, ONLY: vert_remap_q_alg - IMPLICIT NONE - INTEGER, intent(in) :: nx, qsize - REAL(KIND=real_kind), intent(inout) :: qdp(nx,nx,nlev,qsize) - REAL(KIND=real_kind), intent(in) :: dp1(nx,nx,nlev), dp2(nx,nx,nlev) - ! Local Variables - INTEGER, parameter :: gs = 2 !Number of cells to place in the ghost region - REAL(KIND=real_kind), dimension(nlev+2) :: pio !Pressure at interfaces for old grid - REAL(KIND=real_kind), dimension(nlev+1) :: pin !Pressure at interfaces for new grid - REAL(KIND=real_kind), dimension(nlev+1) :: masso !Accumulate mass up to each interface - REAL(KIND=real_kind), dimension(1-gs:nlev+gs) :: ao !Tracer value on old grid - REAL(KIND=real_kind), dimension(1-gs:nlev+gs) :: dpo !change in pressure over a cell for old grid - REAL(KIND=real_kind), dimension(1-gs:nlev+gs) :: dpn !change in pressure over a cell for old grid - REAL(KIND=real_kind), dimension(3, nlev) :: coefs !PPM coefficients within each cell - REAL(KIND=real_kind), dimension( nlev ) :: z1, z2 - REAL(KIND=real_kind) :: ppmdx(10,0:nlev+1) !grid spacings - REAL(KIND=real_kind) :: mymass, massn1, massn2 - INTEGER :: i, j, k, q, kk, kid(nlev) - CALL t_startf('remap_Q_ppm') - DO j = 1 , nx - DO i = 1 , nx - pin(1) = 0 - pio(1) = 0 - DO k=1,nlev - dpn(k) = dp2(i,j,k) - dpo(k) = dp1(i,j,k) - pin(k+1) = pin(k)+dpn(k) - pio(k+1) = pio(k)+dpo(k) - END DO - pio(nlev+2) = pio(nlev+1) + 1. !This is here to allow an entire block of k threads to run in the remapping phase. - !It makes sure there's an old interface value below the domain that is larger. - pin(nlev+1) = pio(nlev+1) !The total mass in a column does not change. - !Therefore, the pressure of that mass cannot either. - !Fill in the ghost regions with mirrored values. if vert_remap_q_alg is defined, this is of no consequence. - DO k = 1 , gs - dpo(1 -k) = dpo( k) - dpo(nlev+k) = dpo(nlev+1-k) - END DO - !Compute remapping intervals once for all tracers. Find the old grid cell index in which the - !k-th new cell interface resides. Then integrate from the bottom of that old cell to the new - !interface location. In practice, the grid never deforms past one cell, so the search can be - !simplified by this. Also, the interval of integration is usually of magnitude close to zero - !or close to dpo because of minimial deformation. - !Numerous tests confirmed that the bottom and top of the grids match to machine precision, so - !I set them equal to each other. - DO k = 1 , nlev - kk = k !Keep from an order n^2 search operation by assuming the old cell index is close. - !Find the index of the old grid cell in which this new cell's bottom interface resides. - DO while (pio(kk) <= pin(k+1)) - kk = kk + 1 - END DO - kk = kk - 1 !kk is now the cell index we're integrating over. - IF (kk == nlev+1) kk = nlev !This is to keep the indices in bounds. - !Top bounds match anyway, so doesn't matter what coefficients are used - kid(k) = kk !Save for reuse - z1(k) = -0.5d0 !This remapping assumes we're starting from the left interface of an old grid cell - !In fact, we're usually integrating very little or almost all of the cell in question - z2(k) = (pin(k+1) - ( pio(kk) + pio(kk+1) ) * 0.5) / dpo(kk) !PPM interpolants are normalized to an independent - !coordinate domain [-0.5,0.5]. - END DO - !This turned out a big optimization, remembering that only parts of the PPM algorithm depends on the data, - ! namely the - !limiting. So anything that depends only on the grid is pre-computed outside the tracer loop. - ppmdx(:,:) = compute_ppm_grids( dpo ) - !From here, we loop over tracers for only those portions which depend on tracer data, which includes PPM - ! limiting and - !mass accumulation - DO q = 1 , qsize - !Accumulate the old mass up to old grid cell interface locations to simplify integration - !during remapping. Also, divide out the grid spacing so we're working with actual tracer - !values and can conserve mass. The option for ifndef ZEROHORZ I believe is there to ensure - !tracer consistency for an initially uniform field. I copied it from the old remap routine. - masso(1) = 0. - DO k = 1 , nlev - ao(k) = qdp(i,j,k,q) - masso(k+1) = masso(k) + ao(k) !Accumulate the old mass. This will simplify the remapping - ao(k) = ao(k) / dpo(k) !Divide out the old grid spacing because we want the tracer mixing ratio, not mass. - END DO - !Fill in ghost values. Ignored if vert_remap_q_alg == 2 - DO k = 1 , gs - ao(1 -k) = ao( k) - ao(nlev+k) = ao(nlev+1-k) - END DO - !Compute monotonic and conservative PPM reconstruction over every cell - coefs(:,:) = compute_ppm(ao , ppmdx) - !Compute tracer values on the new grid by integrating from the old cell bottom to the new - !cell interface to form a new grid mass accumulation. Taking the difference between - !accumulation at successive interfaces gives the mass inside each cell. Since Qdp is - !supposed to hold the full mass this needs no normalization. - massn1 = 0. - DO k = 1 , nlev - kk = kid(k) - massn2 = masso(kk) + integrate_parabola(coefs(:,kk) , z1(k) , z2(k)) * dpo(kk) - qdp(i,j,k,q) = massn2 - massn1 - massn1 = massn2 - END DO - END DO - END DO - END DO - CALL t_stopf('remap_Q_ppm') - END SUBROUTINE remap_q_ppm - !=======================================================================================================! - !THis compute grid-based coefficients from Collela & Woodward 1984. - - FUNCTION compute_ppm_grids(dx) RESULT ( rslt ) - USE control_mod, ONLY: vert_remap_q_alg - IMPLICIT NONE - REAL(KIND=real_kind), intent(in) :: dx(-1:nlev+2) !grid spacings - REAL(KIND=real_kind) :: rslt(10,0:nlev+1) !grid spacings - INTEGER :: j - INTEGER :: indb, inde - !Calculate grid-based coefficients for stage 1 of compute_ppm - IF (vert_remap_q_alg == 2) THEN - indb = 2 - inde = nlev-1 - ELSE - indb = 0 - inde = nlev+1 - END IF - DO j = indb , inde - rslt(1,j) = dx(j) / (dx(j-1) + dx(j) + dx(j+1)) - rslt(2,j) = (2.*dx(j-1) + dx(j)) / (dx(j+1) + dx(j)) - rslt(3,j) = (dx(j) + 2.*dx(j+1)) / (dx(j-1) + dx(j)) - END DO - !Caculate grid-based coefficients for stage 2 of compute_ppm - IF (vert_remap_q_alg == 2) THEN - indb = 2 - inde = nlev-2 - ELSE - indb = 0 - inde = nlev - END IF - DO j = indb , inde - rslt(4,j) = dx(j) / (dx(j) + dx(j+1)) - rslt(5,j) = 1. / sum(dx(j-1:j+2)) - rslt(6,j) = (2. * dx(j+1) * dx(j)) / (dx(j) + dx(j+1 )) - rslt(7,j) = (dx(j-1) + dx(j )) / (2. * dx(j ) + dx(j+1)) - rslt(8,j) = (dx(j+2) + dx(j+1)) / (2. * dx(j+1) + dx(j )) - rslt(9,j) = dx(j ) * (dx(j-1) + dx(j )) / (2.*dx(j ) + dx(j+1)) - rslt(10,j) = dx(j+1) * (dx(j+1) + dx(j+2)) / (dx(j ) + 2.*dx(j+1)) - END DO - END FUNCTION compute_ppm_grids - !=======================================================================================================! - !This computes a limited parabolic interpolant using a net 5-cell stencil, but the stages of computation are broken up - ! into 3 stages - - FUNCTION compute_ppm(a, dx) RESULT ( coefs ) - USE control_mod, ONLY: vert_remap_q_alg - IMPLICIT NONE - REAL(KIND=real_kind), intent(in) :: a (-1:nlev+2) !Cell-mean values - REAL(KIND=real_kind), intent(in) :: dx (10, 0:nlev+1) !grid spacings - REAL(KIND=real_kind) :: coefs(0:2, nlev) !PPM coefficients (for parabola) - REAL(KIND=real_kind) :: ai (0:nlev) !fourth-order accurate, then limited interface values - REAL(KIND=real_kind) :: dma(0:nlev+1) !An expression from Collela's '84 publication - REAL(KIND=real_kind) :: da !Ditto - ! Hold expressions based on the grid (which are cumbersome). - REAL(KIND=real_kind) :: dx1, dx2, dx3, dx4, dx5, dx6, dx7, dx8, dx9, dx10 - REAL(KIND=real_kind) :: al, ar !Left and right interface values for cell-local limiting - INTEGER :: j - INTEGER :: indb, inde - ! Stage 1: Compute dma for each cell, allowing a 1-cell ghost stencil below and above the domain - IF (vert_remap_q_alg == 2) THEN - indb = 2 - inde = nlev-1 - ELSE - indb = 0 - inde = nlev+1 - END IF - DO j = indb , inde - da = dx(1,j) * (dx(2,j) * ( a(j+1) - a(j) ) + dx(3,j) * ( a(j) - a(j-1) )) - dma(j) = minval((/ abs(da) , 2. * abs( a(j) - a(j-1) ) , 2. * abs( a(j+1) - a(j) ) /)) * sign(1.d0,da) - IF (( a(j+1) - a(j) ) * ( a(j) - a(j-1) ) <= 0.) dma(j) = 0. - END DO - ! Stage 2: Compute ai for each cell interface in the physical domain (dimension nlev+1) - IF (vert_remap_q_alg == 2) THEN - indb = 2 - inde = nlev-2 - ELSE - indb = 0 - inde = nlev - END IF - DO j = indb , inde - ai(j) = a(j) + dx(4,j) * (a(j+1) - a(j)) + dx(5,j) * (dx(6,j) * ( dx(7,j) - dx(8,j) ) * ( a(j+1) - a(j) )& - - dx(9,j) * dma(j+1) + dx(10,j) * dma(j)) - END DO - ! Stage 3: Compute limited PPM interpolant over each cell in the physical domain - ! (dimension nlev) using ai on either side and ao within the cell. - IF (vert_remap_q_alg == 2) THEN - indb = 3 - inde = nlev-2 - ELSE - indb = 1 - inde = nlev - END IF - DO j = indb , inde - al = ai(j-1) - ar = ai(j ) - IF ((ar - a(j)) * (a(j) - al) <= 0.) THEN - al = a(j) - ar = a(j) - END IF - IF ((ar - al) * (a(j) - (al + ar)/2.) > (ar - al)**2/6.) al = 3.*a(j) - 2. * ar - IF ((ar - al) * (a(j) - (al + ar)/2.) < -(ar - al)**2/6.) ar = 3.*a(j) - 2. * al - !Computed these coefficients from the edge values and cell mean in Maple. Assumes normalized coordinates: xi=( - ! x-x0)/dx - coefs(0,j) = 1.5 * a(j) - (al + ar) / 4. - coefs(1,j) = ar - al - coefs(2,j) = -6. * a(j) + 3. * (al + ar) - END DO - !If we're not using a mirrored boundary condition, then make the two cells bordering the top and bottom - !material boundaries piecewise constant. Zeroing out the first and second moments, and setting the zeroth - !moment to the cell mean is sufficient to maintain conservation. - IF (vert_remap_q_alg == 2) THEN - coefs(0,1:2) = a(1:2) - coefs(1:2,1:2) = 0. - coefs(0,nlev-1:nlev) = a(nlev-1:nlev) - coefs(1:2,nlev-1:nlev) = 0.d0 - END IF - END FUNCTION compute_ppm - !=======================================================================================================! - !Simple function computes the definite integral of a parabola in normalized coordinates, xi=(x-x0)/dx, - !given two bounds. Make sure this gets inlined during compilation. - - FUNCTION integrate_parabola(a, x1, x2) RESULT ( mass ) - IMPLICIT NONE - REAL(KIND=real_kind), intent(in) :: a(0:2) !Coefficients of the parabola - REAL(KIND=real_kind), intent(in) :: x1 !lower domain bound for integration - REAL(KIND=real_kind), intent(in) :: x2 !upper domain bound for integration - REAL(KIND=real_kind) :: mass - mass = a(0) * (x2 - x1) + a(1) * (x2 ** 2 - x1 ** 2) / 0.2d1 + a(2) * (x2 ** 3 - x1 ** 3) / 0.3d1 - END FUNCTION integrate_parabola - !=============================================================================================! - END MODULE vertremap_mod - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/CESM_license.txt b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/README b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/README deleted file mode 100644 index ac3ddbdb9c..0000000000 --- a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/README +++ /dev/null @@ -1,12 +0,0 @@ -vlaplace_sphere_wk kernel ------------------ - -* how to use the kernel -run "make" in this folder will initiate building and running the kernel. - -* entry of program execution -"kernel_driver.f90" has a Fortran Program statement for execution entry - -Questions: -Youngsung Kim -youngsun@ucar.edu diff --git a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/data/vlaplace_sphere_wk.1.0 b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/data/vlaplace_sphere_wk.1.0 deleted file mode 100644 index 2120525984..0000000000 Binary files a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/data/vlaplace_sphere_wk.1.0 and /dev/null differ diff --git a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/inc/t1.mk b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/inc/t1.mk deleted file mode 100644 index 1be4dd3326..0000000000 --- a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/inc/t1.mk +++ /dev/null @@ -1,101 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# Intel default flags -# -# FC_FLAGS := -O2 -fp-model source -convert big_endian -assume byterecl -# -ftz -traceback -assume realloc_lhs -xAVX -# -# Makefile for KGEN-generated kernel - -FC_FLAGS := $(OPT) -FC_FLAGS += -Mnofma - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - -ALL_OBJS := kernel_driver.o viscosity_mod.o kgen_utils.o kinds.o shr_const_mod.o control_mod.o physical_constants.o parallel_mod.o shr_kind_mod.o element_mod.o gridgraph_mod.o derivative_mod.o coordinate_systems_mod.o physconst.o edge_mod.o dimensions_mod.o constituents.o - -verify: - @(grep "verification.FAIL" $(TEST).rslt && echo "FAILED") || (grep "verification.PASS" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 viscosity_mod.o kgen_utils.o kinds.o shr_const_mod.o control_mod.o physical_constants.o parallel_mod.o shr_kind_mod.o element_mod.o gridgraph_mod.o derivative_mod.o coordinate_systems_mod.o physconst.o edge_mod.o dimensions_mod.o constituents.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -viscosity_mod.o: $(SRC_DIR)/viscosity_mod.F90 kgen_utils.o derivative_mod.o element_mod.o kinds.o dimensions_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -kinds.o: $(SRC_DIR)/kinds.F90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_const_mod.o: $(SRC_DIR)/shr_const_mod.F90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -control_mod.o: $(SRC_DIR)/control_mod.F90 kgen_utils.o kinds.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -physical_constants.o: $(SRC_DIR)/physical_constants.F90 kgen_utils.o physconst.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -parallel_mod.o: $(SRC_DIR)/parallel_mod.F90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_kind_mod.o: $(SRC_DIR)/shr_kind_mod.F90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -element_mod.o: $(SRC_DIR)/element_mod.F90 kgen_utils.o kinds.o coordinate_systems_mod.o dimensions_mod.o gridgraph_mod.o edge_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -gridgraph_mod.o: $(SRC_DIR)/gridgraph_mod.F90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -derivative_mod.o: $(SRC_DIR)/derivative_mod.F90 kgen_utils.o element_mod.o kinds.o dimensions_mod.o control_mod.o parallel_mod.o physical_constants.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -coordinate_systems_mod.o: $(SRC_DIR)/coordinate_systems_mod.F90 kgen_utils.o kinds.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -physconst.o: $(SRC_DIR)/physconst.F90 kgen_utils.o shr_kind_mod.o shr_const_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -edge_mod.o: $(SRC_DIR)/edge_mod.F90 kgen_utils.o kinds.o coordinate_systems_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -dimensions_mod.o: $(SRC_DIR)/dimensions_mod.F90 kgen_utils.o constituents.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -constituents.o: $(SRC_DIR)/constituents.F90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -kgen_utils.o: $(SRC_DIR)/kgen_utils.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.rslt diff --git a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/lit/runmake b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/makefile b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/constituents.F90 b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/constituents.F90 deleted file mode 100644 index ef709a0101..0000000000 --- a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/constituents.F90 +++ /dev/null @@ -1,101 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : constituents.F90 -! Generated at: 2015-04-12 19:17:35 -! KGEN version: 0.4.9 - - - - MODULE constituents - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !---------------------------------------------------------------------------------------------- - ! - ! Purpose: Contains data and functions for manipulating advected and non-advected constituents. - ! - ! Revision history: - ! B.A. Boville Original version - ! June 2003 P. Rasch Add wet/dry m.r. specifier - ! 2004-08-28 B. Eaton Add query function to allow turning off the default 1 output of - ! constituents so that chemistry module can make the outfld calls. - ! Allow cnst_get_ind to return without aborting when constituent not - ! found. - ! 2006-10-31 B. Eaton Remove 'non-advected' constituent functionality. - !---------------------------------------------------------------------------------------------- - IMPLICIT NONE - PRIVATE - ! - ! Public interfaces - ! - ! add a constituent to the list of advected constituents - ! returns the number of available slots in the constituent array - ! get the index of a constituent - ! get the type of a constituent - ! get the type of a constituent - ! get the molecular diffusion type of a constituent - ! query whether constituent initial values are read from initial file - ! check that number of constituents added equals dimensions (pcnst) - ! Returns true if default 1 output was specified in the cnst_add calls. - ! Public data - INTEGER, parameter, public :: pcnst = 29 ! number of advected constituents (including water vapor) - ! constituent names - ! long name of constituents - ! Namelist variables - ! true => obtain initial tracer data from IC file - ! - ! Constants for each tracer - ! specific heat at constant pressure (J/kg/K) - ! specific heat at constant volume (J/kg/K) - ! molecular weight (kg/kmole) - ! wet or dry mixing ratio - ! major or minor species molecular diffusion - ! gas constant () - ! minimum permitted constituent concentration (kg/kg) - ! for backward compatibility only - ! upper bndy condition = fixed ? - ! upper boundary non-zero fixed constituent flux - ! convective transport : phase 1 or phase 2? - !++bee - temporary... These names should be declared in the module that makes the addfld and outfld calls. - ! Lists of tracer names and diagnostics - ! constituents after physics (FV core only) - ! constituents before physics (FV core only) - ! names of horizontal advection tendencies - ! names of vertical advection tendencies - ! names of convection tendencies - ! names of species slt fixer tendencies - ! names of total tendencies of species - ! names of total physics tendencies of species - ! names of dme adjusted tracers (FV) - ! names of surface fluxes of species - ! names for horz + vert + fixer tendencies - ! Private data - ! index pointer to last advected tracer - ! true => read initial values from initial file - ! true => default 1 output of constituents in kg/kg - ! false => chemistry is responsible for making outfld - ! calls for constituents - !============================================================================================== - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !============================================================================================== - - !============================================================================== - - !============================================================================== - - !============================================================================================== - - !============================================================================================== - - - !============================================================================== - - !============================================================================== - - !============================================================================== - - !============================================================================== - END MODULE constituents diff --git a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/control_mod.F90 b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/control_mod.F90 deleted file mode 100644 index 9dcf88dc2f..0000000000 --- a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/control_mod.F90 +++ /dev/null @@ -1,128 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : control_mod.F90 -! Generated at: 2015-04-12 19:17:34 -! KGEN version: 0.4.9 - - - - MODULE control_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE kinds, ONLY: real_kind - ! time integration (explicit, semi_imp, or full imp) - ! none of this is used anymore: - ! u grad(Q) formulation - ! div(u dp/dn Q ) formulation - ! Tracer transport type - ! We potentially have five types of tracer advection. However, not all of them - ! may be chosen at runtime due to compile-type restrictions on arrays - !shallow water advection tests: - !kmass points to a level with density. other levels contain test tracers - ! m s^-2 - ! 0 = leapfrog - ! 1 = RK (foward-in-time) - ! number of RK stages to use - ! Forcing Type - ! ftype = 0 HOMME ApplyColumn() type forcing process split - ! ftype = -1 ignore forcing (used for testing energy balance) - ! use cp or cp* in T equation - ! -1: No fixer, use non-staggered formula - ! 0: No Fixer, use staggered in time formula - ! (only for leapfrog) - ! 1 or 4: Enable fixer, non-staggered formula - ! ratio of dynamics tsteps to tracer tsteps - ! for vertically lagrangian dynamics, apply remap - ! every rsplit tracer timesteps - ! Defines if the program is to use its own physics (HOMME standalone), valid values 1,2,3 - ! physics = 0, no physics - ! physics = 1, Use physics - ! leapfrog-trapazoidal frequency - ! interspace a lf-trapazoidal step every LFTfreq leapfrogs - ! 0 = disabled - ! compute_mean_flux: obsolete, not used - ! vert_remap_q_alg: 0 default value, Zerroukat monotonic splines - ! 1 PPM vertical remap with mirroring at the boundaries - ! (solid wall bc's, high-order throughout) - ! 2 PPM vertical remap without mirroring at the boundaries - ! (no bc's enforced, first-order at two cells bordering top and bottom boundaries) - ! -1 = chosen at run time - ! 0 = equi-angle Gnomonic (default) - ! 1 = equi-spaced Gnomonic (not yet coded) - ! 2 = element-local projection (for var-res) - ! 3 = parametric (not yet coded) - !tolerance to define smth small, was introduced for lim 8 in 2d and 3d - ! if semi_implicit, type of preconditioner: - ! choices block_jacobi or identity - ! partition methods - ! options: "cube" is supported - ! options: if cube: "swtc1","swtc2",or "swtc6" - ! generic test case param - ! remap frequency of synopsis of system state (steps) - ! selected remapping option - ! output frequency of synopsis of system state (steps) - ! frequency in steps of field accumulation - ! model day to start accumulation - ! model day to stop accumulation - ! max iterations of solver - ! solver tolerance (convergence criteria) - ! debug level of CG solver - ! Boyd Vandeven filter Transfer fn parameters - ! Fischer-Mullen filter Transfer fn parameters - ! vertical formulation (ecmwf,ccm1) - ! vertical grid spacing (equal,unequal) - ! vertical coordinate system (sigma,hybrid) - ! set for refined exodus meshes (variable viscosity) - ! upper bound for Courant number - ! (only used for variable viscosity, recommend 1.9 in namelist) - ! viscosity (momentum equ) - ! viscsoity (momentum equ, div component) - ! default = nu T equ. viscosity - ! default = nu tracer viscosity - ! default = 0 ps equ. viscosity - ! top-of-the-model viscosity - ! number of subcycles for hyper viscsosity timestep - ! number of subcycles for hyper viscsosity timestep on TRACERS - ! laplace**hypervis_order. 0=not used 1=regular viscosity, 2=grad**4 - ! 0 = use laplace on eta surfaces - ! 1 = use (approx.) laplace on p surfaces - REAL(KIND=real_kind), public :: hypervis_power=0 ! if not 0, use variable hyperviscosity based on element area - REAL(KIND=real_kind), public :: hypervis_scaling=0 ! use tensor hyperviscosity - ! - !three types of hyper viscosity are supported right now: - ! (1) const hv: nu * del^2 del^2 - ! (2) scalar hv: nu(lat,lon) * del^2 del^2 - ! (3) tensor hv, nu * ( \div * tensor * \grad ) * del^2 - ! - ! (1) default: hypervis_power=0, hypervis_scaling=0 - ! (2) Original version for var-res grids. (M. Levy) - ! scalar coefficient within each element - ! hypervisc_scaling=0 - ! set hypervis_power>0 and set fine_ne, max_hypervis_courant - ! (3) tensor HV var-res grids - ! tensor within each element: - ! set hypervis_scaling > 0 (typical values would be 3.2 or 4.0) - ! hypervis_power=0 - ! (\div * tensor * \grad) operator uses cartesian laplace - ! - ! hyperviscosity parameters used for smoothing topography - ! 0 = disable - ! 0 = disabled - ! fix the velocities? - ! initial perturbation in JW test case - ! initial perturbation in JW test case - PUBLIC kgen_read_externs_control_mod - CONTAINS - - ! write subroutines - ! No subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_control_mod(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) hypervis_power - READ(UNIT=kgen_unit) hypervis_scaling - END SUBROUTINE kgen_read_externs_control_mod - - END MODULE control_mod diff --git a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/coordinate_systems_mod.F90 b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/coordinate_systems_mod.F90 deleted file mode 100644 index 0a02dbd504..0000000000 --- a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/coordinate_systems_mod.F90 +++ /dev/null @@ -1,294 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : coordinate_systems_mod.F90 -! Generated at: 2015-04-12 19:17:34 -! KGEN version: 0.4.9 - - - - MODULE coordinate_systems_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! WARNING: When using this class be sure that you know if the - ! cubic coordinates are on the unit cube or the [-\pi/4,\pi/4] cube - ! and if the spherical longitude is in [0,2\pi] or [-\pi,\pi] - USE kinds, ONLY: real_kind - IMPLICIT NONE - PRIVATE - TYPE, public :: cartesian2d_t - REAL(KIND=real_kind) :: x ! x coordinate - REAL(KIND=real_kind) :: y ! y coordinate - END TYPE cartesian2d_t - TYPE, public :: cartesian3d_t - REAL(KIND=real_kind) :: x ! x coordinate - REAL(KIND=real_kind) :: y ! y coordinate - REAL(KIND=real_kind) :: z ! z coordinate - END TYPE cartesian3d_t - TYPE, public :: spherical_polar_t - REAL(KIND=real_kind) :: r ! radius - REAL(KIND=real_kind) :: lon ! longitude - REAL(KIND=real_kind) :: lat ! latitude - END TYPE spherical_polar_t - - - - - ! ========================================== - ! Public Interfaces - ! ========================================== - ! (x,y,z) -> equal-angle (x,y) - ! (lat,lon) -> (x,y,z) - ! equal-angle (x,y) -> (lat,lon) - ! should be called cubedsphere2spherical - ! equal-angle (x,y) -> (x,y,z) - ! (lat,lon) -> equal-angle (x,y) - ! CE - ! (x,y,z) -> gnomonic (x,y) - ! gnominic (x,y) -> (lat,lon) - !private :: spherical_to_cart - - ! read interface - PUBLIC kgen_read - INTERFACE kgen_read - MODULE PROCEDURE kgen_read_cartesian2d_t - MODULE PROCEDURE kgen_read_cartesian3d_t - MODULE PROCEDURE kgen_read_spherical_polar_t - END INTERFACE kgen_read - - PUBLIC kgen_verify - INTERFACE kgen_verify - MODULE PROCEDURE kgen_verify_cartesian2d_t - MODULE PROCEDURE kgen_verify_cartesian3d_t - MODULE PROCEDURE kgen_verify_spherical_polar_t - END INTERFACE kgen_verify - - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - SUBROUTINE kgen_read_cartesian2d_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(cartesian2d_t), INTENT(out) :: var - READ(UNIT=kgen_unit) var%x - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%x **", var%x - END IF - READ(UNIT=kgen_unit) var%y - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%y **", var%y - END IF - END SUBROUTINE - SUBROUTINE kgen_read_cartesian3d_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(cartesian3d_t), INTENT(out) :: var - READ(UNIT=kgen_unit) var%x - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%x **", var%x - END IF - READ(UNIT=kgen_unit) var%y - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%y **", var%y - END IF - READ(UNIT=kgen_unit) var%z - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%z **", var%z - END IF - END SUBROUTINE - SUBROUTINE kgen_read_spherical_polar_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(spherical_polar_t), INTENT(out) :: var - READ(UNIT=kgen_unit) var%r - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%r **", var%r - END IF - READ(UNIT=kgen_unit) var%lon - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%lon **", var%lon - END IF - READ(UNIT=kgen_unit) var%lat - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%lat **", var%lat - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_cartesian2d_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(cartesian2d_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_real_real_kind("x", dtype_check_status, var%x, ref_var%x) - CALL kgen_verify_real_real_kind("y", dtype_check_status, var%y, ref_var%y) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_cartesian3d_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(cartesian3d_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_real_real_kind("x", dtype_check_status, var%x, ref_var%x) - CALL kgen_verify_real_real_kind("y", dtype_check_status, var%y, ref_var%y) - CALL kgen_verify_real_real_kind("z", dtype_check_status, var%z, ref_var%z) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_spherical_polar_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(spherical_polar_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_real_real_kind("r", dtype_check_status, var%r, ref_var%r) - CALL kgen_verify_real_real_kind("lon", dtype_check_status, var%lon, ref_var%lon) - CALL kgen_verify_real_real_kind("lat", dtype_check_status, var%lat, ref_var%lat) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_real_real_kind( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=real_kind), intent(in) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - END SUBROUTINE kgen_verify_real_real_kind - - ! ============================================ - ! copy_cart2d: - ! - ! Overload assignment operator for cartesian2D_t - ! ============================================ - - ! ============================================ - ! eq_cart2d: - ! - ! Overload == operator for cartesian2D_t - ! ============================================ - - ! =================================================== - ! distance_cart2D : scalar version - ! distance_cart2D_v: vector version - ! - ! computes distance between cartesian 2D coordinates - ! =================================================== - - - ! =================================================== - ! distance_cart3D : scalar version - ! distance_cart3D_v: vector version - ! =================================================== - - - ! =================================================================== - ! spherical_to_cart: - ! converts spherical polar {lon,lat} to 3D cartesian {x,y,z} - ! on unit sphere. Note: spherical longitude is [0,2\pi] - ! =================================================================== - - ! =================================================================== - ! spherical_to_cart_v: - ! converts spherical polar {lon,lat} to 3D cartesian {x,y,z} - ! on unit sphere. Note: spherical longitude is [0,2\pi] - ! =================================================================== - - ! ========================================================================== - ! cart_to_spherical: - ! - ! converts 3D cartesian {x,y,z} to spherical polar {lon,lat} - ! on unit sphere. Note: spherical longitude is [0,2\pi] - ! ========================================================================== - ! scalar version - - - - - - ! Note: Output spherical longitude is [-pi,pi] - - ! takes a 2D point on a face of the cube of size [-\pi/4, \pi/4] and projects it - ! onto a 3D point on a cube of size [-1,1] in R^3 - - ! onto a cube of size [-\pi/2,\pi/2] in R^3 - ! the spherical longitude can be either in [0,2\pi] or [-\pi,\pi] - - ! Go from an arbitrary sized cube in 3D - ! to a [-\pi/4,\pi/4] sized cube with (face,2d) coordinates. - ! - ! Z - ! | - ! | - ! | - ! | - ! ---------------Y - ! / - ! / - ! / - ! / - ! X - ! - ! NOTE: Face 1 => X positive constant face of cube - ! Face 2 => Y positive constant face of cube - ! Face 3 => X negative constant face of cube - ! Face 4 => Y negative constant face of cube - ! Face 5 => Z negative constant face of cube - ! Face 6 => Z positive constant face of cube - - ! This function divides three dimentional space up into - ! six sectors. These sectors are then considered as the - ! faces of the cube. It should work for any (x,y,z) coordinate - ! if on a sphere or on a cube. - - ! This could be done directly by using the lon, lat coordinates, - ! but call cube_face_number_from_cart just so that there is one place - ! to do the conversions and they are all consistant. - - ! CE, need real (cartesian) xy coordinates on the cubed sphere - - ! CE END - - !CE, 5.May 2011 - !INPUT: Points in xy cubed sphere coordinates, counterclockwise - !OUTPUT: corresponding area on the sphere - - END MODULE coordinate_systems_mod diff --git a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/derivative_mod.F90 b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/derivative_mod.F90 deleted file mode 100644 index 1030f1084c..0000000000 --- a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/derivative_mod.F90 +++ /dev/null @@ -1,757 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : derivative_mod.F90 -! Generated at: 2015-04-12 19:17:34 -! KGEN version: 0.4.9 - - - - MODULE derivative_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE kinds, ONLY: real_kind - USE dimensions_mod, ONLY: np - USE dimensions_mod, ONLY: nc - USE dimensions_mod, ONLY: nep - USE parallel_mod, ONLY: abortmp - ! needed for spherical differential operators: - USE physical_constants, ONLY: rrearth - USE element_mod, ONLY: element_t - USE control_mod, ONLY: hypervis_scaling - USE control_mod, ONLY: hypervis_power - IMPLICIT NONE - PRIVATE - TYPE, public :: derivative_t - REAL(KIND=real_kind) :: dvv(np,np) - REAL(KIND=real_kind) :: dvv_diag(np,np) - REAL(KIND=real_kind) :: dvv_twt(np,np) - REAL(KIND=real_kind) :: mvv_twt(np,np) ! diagonal matrix of GLL weights - REAL(KIND=real_kind) :: mfvm(np,nc+1) - REAL(KIND=real_kind) :: cfvm(np,nc) - REAL(KIND=real_kind) :: sfvm(np,nep) - REAL(KIND=real_kind) :: legdg(np,np) - END TYPE derivative_t - ! ====================================== - ! Public Interfaces - ! ====================================== - - - - ! these routines compute spherical differential operators as opposed to - ! the gnomonic coordinate operators above. Vectors (input or output) - ! are always expressed in lat-lon coordinates - ! - ! note that weak derivatives (integrated by parts form) can be defined using - ! contra or co-variant test functions, so - ! - PUBLIC gradient_sphere - PUBLIC gradient_sphere_wk_testcov - ! only used for debugging - PUBLIC vorticity_sphere - PUBLIC divergence_sphere - PUBLIC curl_sphere_wk_testcov - ! public :: curl_sphere_wk_testcontra ! not coded - PUBLIC divergence_sphere_wk - PUBLIC laplace_sphere_wk - PUBLIC vlaplace_sphere_wk - - ! read interface - PUBLIC kgen_read - INTERFACE kgen_read - MODULE PROCEDURE kgen_read_derivative_t - END INTERFACE kgen_read - - PUBLIC kgen_verify - INTERFACE kgen_verify - MODULE PROCEDURE kgen_verify_derivative_t - END INTERFACE kgen_verify - - CONTAINS - - ! write subroutines - ! No module extern variables - SUBROUTINE kgen_read_derivative_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(derivative_t), INTENT(out) :: var - READ(UNIT=kgen_unit) var%dvv - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dvv **", var%dvv - END IF - READ(UNIT=kgen_unit) var%dvv_diag - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dvv_diag **", var%dvv_diag - END IF - READ(UNIT=kgen_unit) var%dvv_twt - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dvv_twt **", var%dvv_twt - END IF - READ(UNIT=kgen_unit) var%mvv_twt - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%mvv_twt **", var%mvv_twt - END IF - READ(UNIT=kgen_unit) var%mfvm - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%mfvm **", var%mfvm - END IF - READ(UNIT=kgen_unit) var%cfvm - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%cfvm **", var%cfvm - END IF - READ(UNIT=kgen_unit) var%sfvm - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%sfvm **", var%sfvm - END IF - READ(UNIT=kgen_unit) var%legdg - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%legdg **", var%legdg - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_derivative_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(derivative_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_real_real_kind_dim2("dvv", dtype_check_status, var%dvv, ref_var%dvv) - CALL kgen_verify_real_real_kind_dim2("dvv_diag", dtype_check_status, var%dvv_diag, ref_var%dvv_diag) - CALL kgen_verify_real_real_kind_dim2("dvv_twt", dtype_check_status, var%dvv_twt, ref_var%dvv_twt) - CALL kgen_verify_real_real_kind_dim2("mvv_twt", dtype_check_status, var%mvv_twt, ref_var%mvv_twt) - CALL kgen_verify_real_real_kind_dim2("mfvm", dtype_check_status, var%mfvm, ref_var%mfvm) - CALL kgen_verify_real_real_kind_dim2("cfvm", dtype_check_status, var%cfvm, ref_var%cfvm) - CALL kgen_verify_real_real_kind_dim2("sfvm", dtype_check_status, var%sfvm, ref_var%sfvm) - CALL kgen_verify_real_real_kind_dim2("legdg", dtype_check_status, var%legdg, ref_var%legdg) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_real_real_kind_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=real_kind), intent(in), DIMENSION(:,:) :: var, ref_var - real(KIND=real_kind) :: nrmsdiff, rmsdiff - real(KIND=real_kind), allocatable, DIMENSION(:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_real_kind_dim2 - - ! ========================================== - ! derivinit: - ! - ! Initialize the matrices for taking - ! derivatives and interpolating - ! ========================================== - - - ! ======================================= - ! dmatinit: - ! - ! Compute rectangular v->p - ! derivative matrix (dmat) - ! ======================================= - - ! ======================================= - ! dpvinit: - ! - ! Compute rectangular p->v - ! derivative matrix (dmat) - ! for strong gradients - ! ======================================= - - ! ======================================= - ! v2pinit: - ! Compute interpolation matrix from gll(1:n1) -> gs(1:n2) - ! ======================================= - - ! ======================================= - ! dvvinit: - ! - ! Compute rectangular v->v - ! derivative matrix (dvv) - ! ======================================= - - ! ================================================ - ! divergence_stag: - ! - ! Compute divergence (maps v grid -> p grid) - ! ================================================ - - ! ================================================ - ! divergence_nonstag: - ! - ! Compute divergence (maps v->v) - ! ================================================ - - ! ================================================ - ! gradient_wk_stag: - ! - ! Compute the weak form gradient: - ! maps scalar field on the pressure grid to the - ! velocity grid - ! ================================================ - - ! ================================================ - ! gradient_wk_nonstag: - ! - ! Compute the weak form gradient: - ! maps scalar field on the Gauss-Lobatto grid to the - ! weak gradient on the Gauss-Lobbatto grid - ! ================================================ - - ! ================================================ - ! gradient_str_stag: - ! - ! Compute the *strong* form gradient: - ! maps scalar field on the pressure grid to the - ! velocity grid - ! ================================================ - - ! ================================================ - ! gradient_str_nonstag: - ! - ! Compute the *strong* gradient on the velocity grid - ! of a scalar field on the velocity grid - ! ================================================ - - ! ================================================ - ! vorticity: - ! - ! Compute the vorticity of the velocity field on the - ! velocity grid - ! ================================================ - - ! ================================================ - ! interpolate_gll2fvm_points: - ! - ! shape funtion interpolation from data on GLL grid to cellcenters on physics grid - ! Author: Christoph Erath - ! ================================================ - - ! ================================================ - ! interpolate_gll2spelt_points: - ! - ! shape function interpolation from data on GLL grid the spelt grid - ! Author: Christoph Erath - ! ================================================ - - ! ================================================ - ! interpolate_gll2fvm_corners: - ! - ! shape funtion interpolation from data on GLL grid to physics grid - ! - ! ================================================ - - ! ================================================ - ! remap_phys2gll: - ! - ! interpolate to an equally spaced (in reference element coordinate system) - ! "physics" grid to the GLL grid - ! - ! 1st order, monotone, conservative - ! MT initial version 2013 - ! ================================================ - - !---------------------------------------------------------------- - - FUNCTION gradient_sphere(s, deriv, dinv) RESULT ( ds ) - ! - ! input s: scalar - ! output ds: spherical gradient of s, lat-lon coordinates - ! - TYPE(derivative_t), intent(in) :: deriv - REAL(KIND=real_kind), intent(in), dimension(2,2,np,np) :: dinv - REAL(KIND=real_kind), intent(in) :: s(np,np) - REAL(KIND=real_kind) :: ds(np,np,2) - INTEGER :: i - INTEGER :: j - INTEGER :: l - REAL(KIND=real_kind) :: dsdx00 - REAL(KIND=real_kind) :: dsdy00 - REAL(KIND=real_kind) :: v1(np,np) - REAL(KIND=real_kind) :: v2(np,np) - DO j=1,np - DO l=1,np - dsdx00 = 0.0d0 - dsdy00 = 0.0d0 - DO i=1,np - dsdx00 = dsdx00 + deriv%dvv(i,l)*s(i,j) - dsdy00 = dsdy00 + deriv%dvv(i,l)*s(j ,i) - END DO - v1(l ,j) = dsdx00*rrearth - v2(j ,l) = dsdy00*rrearth - END DO - END DO - ! convert covarient to latlon - DO j=1,np - DO i=1,np - ds(i,j,1) = dinv(1,1,i,j)*v1(i,j) + dinv(2,1,i,j)*v2(i,j) - ds(i,j,2) = dinv(1,2,i,j)*v1(i,j) + dinv(2,2,i,j)*v2(i,j) - END DO - END DO - END FUNCTION gradient_sphere - - FUNCTION curl_sphere_wk_testcov(s, deriv, elem) RESULT ( ds ) - ! - ! integrated-by-parts gradient, w.r.t. COVARIANT test functions - ! input s: scalar (assumed to be s*khat) - ! output ds: weak curl, lat/lon coordinates - ! - ! starting with: - ! PHIcov1 = (PHI,0) covariant vector - ! PHIcov2 = (0,PHI) covariant vector - ! - ! ds1 = integral[ PHIcov1 dot curl(s*khat) ] - ! ds2 = integral[ PHIcov2 dot curl(s*khat) ] - ! integrate by parts: - ! ds1 = integral[ vor(PHIcov1) * s ] - ! ds2 = integral[ vor(PHIcov1) * s ] - ! - ! PHIcov1 = (PHI^mn,0) - ! PHIcov2 = (0,PHI^mn) - ! vorticity() acts on covariant vectors: - ! ds1 = sum wij g s_ij 1/g ( (PHIcov1_2)_x - (PHIcov1_1)_y ) - ! = -sum wij s_ij d/dy (PHI^mn ) - ! for d/dy component, only sum over i=m - ! = -sum w_mj s_mj d( PHI^n)(j) - ! j - ! - ! ds2 = sum wij g s_ij 1/g ( (PHIcov2_2)_x - (PHIcov2_1)_y ) - ! = +sum wij s_ij d/dx (PHI^mn ) - ! for d/dx component, only sum over j=n - ! = +sum w_in s_in d( PHI^m)(i) - ! i - ! - TYPE(derivative_t), intent(in) :: deriv - TYPE(element_t), intent(in) :: elem - REAL(KIND=real_kind), intent(in) :: s(np,np) - REAL(KIND=real_kind) :: ds(np,np,2) - INTEGER :: n - INTEGER :: m - INTEGER :: j - INTEGER :: i - REAL(KIND=real_kind) :: dscontra(np,np,2) - dscontra = 0 - DO n=1,np - DO m=1,np - DO j=1,np - ! phi(n)_y sum over second index, 1st index fixed at m - dscontra(m,n,1) = dscontra(m,n,1)-(elem%mp(m,j)*s(m,j)*deriv%dvv(n,j))*rrearth - ! phi(m)_x sum over first index, second index fixed at n - dscontra(m,n,2) = dscontra(m,n,2)+(elem%mp(j,n)*s(j,n)*deriv%dvv(m,j))*rrearth - END DO - END DO - END DO - ! convert contra -> latlon - DO j=1,np - DO i=1,np - ds(i,j,1) = (elem%d(1,1,i,j)*dscontra(i,j,1) + elem%d(1,2,i,j)*dscontra(i,j,2)) - ds(i,j,2) = (elem%d(2,1,i,j)*dscontra(i,j,1) + elem%d(2,2,i,j)*dscontra(i,j,2)) - END DO - END DO - END FUNCTION curl_sphere_wk_testcov - - FUNCTION gradient_sphere_wk_testcov(s, deriv, elem) RESULT ( ds ) - ! - ! integrated-by-parts gradient, w.r.t. COVARIANT test functions - ! input s: scalar - ! output ds: weak gradient, lat/lon coordinates - ! ds = - integral[ div(PHIcov) s ] - ! - ! PHIcov1 = (PHI^mn,0) - ! PHIcov2 = (0,PHI^mn) - ! div() acts on contra components, so convert test function to contra: - ! PHIcontra1 = metinv PHIcov1 = (a^mn,b^mn)*PHI^mn - ! a = metinv(1,1) b=metinv(2,1) - ! - ! ds1 = sum wij g s_ij 1/g ( g a PHI^mn)_x + ( g b PHI^mn)_y ) - ! = sum wij s_ij ag(m,n) d/dx( PHI^mn ) + bg(m,n) d/dy( PHI^mn) - ! i,j - ! for d/dx component, only sum over j=n - ! = sum w_in s_in ag(m,n) d( PHI^m)(i) - ! i - ! for d/dy component, only sum over i=m - ! = sum w_mj s_mj bg(m,n) d( PHI^n)(j) - ! j - ! - ! - ! This formula is identical to gradient_sphere_wk_testcontra, except that - ! g(m,n) is replaced by a(m,n)*g(m,n) - ! and we have two terms for each componet of ds - ! - ! - TYPE(derivative_t), intent(in) :: deriv - TYPE(element_t), intent(in) :: elem - REAL(KIND=real_kind), intent(in) :: s(np,np) - REAL(KIND=real_kind) :: ds(np,np,2) - INTEGER :: n - INTEGER :: m - INTEGER :: j - INTEGER :: i - REAL(KIND=real_kind) :: dscontra(np,np,2) - dscontra = 0 - DO n=1,np - DO m=1,np - DO j=1,np - dscontra(m,n,1) = dscontra(m,n,1)-((elem%mp(j,n)*elem%metinv(1,1,m,n)*elem%metdet(m,n)*s(j,n)*deriv%dvv(m,& - j) ) + (elem%mp(m,j)*elem%metinv(2,1,m,n)*elem%metdet(m,n)*s(m,j)*deriv%dvv(n,j) )) *rrearth - dscontra(m,n,2) = dscontra(m,n,2)-((elem%mp(j,n)*elem%metinv(1,2,m,n)*elem%metdet(m,n)*s(j,n)*deriv%dvv(m,& - j) ) + (elem%mp(m,j)*elem%metinv(2,2,m,n)*elem%metdet(m,n)*s(m,j)*deriv%dvv(n,j) )) *rrearth - END DO - END DO - END DO - ! convert contra -> latlon - DO j=1,np - DO i=1,np - ds(i,j,1) = (elem%d(1,1,i,j)*dscontra(i,j,1) + elem%d(1,2,i,j)*dscontra(i,j,2)) - ds(i,j,2) = (elem%d(2,1,i,j)*dscontra(i,j,1) + elem%d(2,2,i,j)*dscontra(i,j,2)) - END DO - END DO - END FUNCTION gradient_sphere_wk_testcov - - - - !-------------------------------------------------------------------------- - - FUNCTION divergence_sphere_wk(v, deriv, elem) RESULT ( div ) - ! - ! input: v = velocity in lat-lon coordinates - ! ouput: div(v) spherical divergence of v, integrated by parts - ! - ! Computes -< grad(psi) dot v > - ! (the integrated by parts version of < psi div(v) > ) - ! - ! note: after DSS, divergence_sphere() and divergence_sphere_wk() - ! are identical to roundoff, as theory predicts. - ! - REAL(KIND=real_kind), intent(in) :: v(np,np,2) ! in lat-lon coordinates - TYPE(derivative_t), intent(in) :: deriv - TYPE(element_t), intent(in) :: elem - REAL(KIND=real_kind) :: div(np,np) - ! Local - INTEGER :: j - INTEGER :: i - INTEGER :: n - INTEGER :: m - REAL(KIND=real_kind) :: vtemp(np,np,2) - ! latlon- > contra - DO j=1,np - DO i=1,np - vtemp(i,j,1) = (elem%dinv(1,1,i,j)*v(i,j,1) + elem%dinv(1,2,i,j)*v(i,j,2)) - vtemp(i,j,2) = (elem%dinv(2,1,i,j)*v(i,j,1) + elem%dinv(2,2,i,j)*v(i,j,2)) - END DO - END DO - DO n=1,np - DO m=1,np - div(m,n) = 0 - DO j=1,np - div(m,n) = div(m,n)-(elem%spheremp(j,n)*vtemp(j,n,1)*deriv%dvv(m,j) & - +elem%spheremp(m,j)*vtemp(m,j,2)*deriv%dvv(n,j)) * rrearth - END DO - END DO - END DO - END FUNCTION divergence_sphere_wk - - - - FUNCTION vorticity_sphere(v, deriv, elem) RESULT ( vort ) - ! - ! input: v = velocity in lat-lon coordinates - ! ouput: spherical vorticity of v - ! - TYPE(derivative_t), intent(in) :: deriv - TYPE(element_t), intent(in) :: elem - REAL(KIND=real_kind), intent(in) :: v(np,np,2) - REAL(KIND=real_kind) :: vort(np,np) - INTEGER :: i - INTEGER :: j - INTEGER :: l - REAL(KIND=real_kind) :: dvdx00 - REAL(KIND=real_kind) :: dudy00 - REAL(KIND=real_kind) :: vco(np,np,2) - REAL(KIND=real_kind) :: vtemp(np,np) - ! convert to covariant form - DO j=1,np - DO i=1,np - vco(i,j,1) = (elem%d(1,1,i,j)*v(i,j,1) + elem%d(2,1,i,j)*v(i,j,2)) - vco(i,j,2) = (elem%d(1,2,i,j)*v(i,j,1) + elem%d(2,2,i,j)*v(i,j,2)) - END DO - END DO - DO j=1,np - DO l=1,np - dudy00 = 0.0d0 - dvdx00 = 0.0d0 - DO i=1,np - dvdx00 = dvdx00 + deriv%dvv(i,l)*vco(i,j ,2) - dudy00 = dudy00 + deriv%dvv(i,l)*vco(j ,i,1) - END DO - vort(l ,j) = dvdx00 - vtemp(j ,l) = dudy00 - END DO - END DO - DO j=1,np - DO i=1,np - vort(i,j) = (vort(i,j)-vtemp(i,j))*(elem%rmetdet(i,j)*rrearth) - END DO - END DO - END FUNCTION vorticity_sphere - - - FUNCTION divergence_sphere(v, deriv, elem) RESULT ( div ) - ! - ! input: v = velocity in lat-lon coordinates - ! ouput: div(v) spherical divergence of v - ! - REAL(KIND=real_kind), intent(in) :: v(np,np,2) ! in lat-lon coordinates - TYPE(derivative_t), intent(in) :: deriv - TYPE(element_t), intent(in) :: elem - REAL(KIND=real_kind) :: div(np,np) - ! Local - INTEGER :: i - INTEGER :: j - INTEGER :: l - REAL(KIND=real_kind) :: dudx00 - REAL(KIND=real_kind) :: dvdy00 - REAL(KIND=real_kind) :: gv(np,np,2) - REAL(KIND=real_kind) :: vvtemp(np,np) - ! convert to contra variant form and multiply by g - DO j=1,np - DO i=1,np - gv(i,j,1) = elem%metdet(i,j)*(elem%dinv(1,1,i,j)*v(i,j,1) + elem%dinv(1,2,i,j)*v(i,j,2)) - gv(i,j,2) = elem%metdet(i,j)*(elem%dinv(2,1,i,j)*v(i,j,1) + elem%dinv(2,2,i,j)*v(i,j,2)) - END DO - END DO - ! compute d/dx and d/dy - DO j=1,np - DO l=1,np - dudx00 = 0.0d0 - dvdy00 = 0.0d0 - DO i=1,np - dudx00 = dudx00 + deriv%dvv(i,l)*gv(i,j ,1) - dvdy00 = dvdy00 + deriv%dvv(i,l)*gv(j ,i,2) - END DO - div(l ,j) = dudx00 - vvtemp(j ,l) = dvdy00 - END DO - END DO - DO j=1,np - DO i=1,np - div(i,j) = (div(i,j)+vvtemp(i,j))*(elem%rmetdet(i,j)*rrearth) - END DO - END DO - END FUNCTION divergence_sphere - - FUNCTION laplace_sphere_wk(s, deriv, elem, var_coef) RESULT ( laplace ) - ! - ! input: s = scalar - ! ouput: -< grad(PHI), grad(s) > = weak divergence of grad(s) - ! note: for this form of the operator, grad(s) does not need to be made C0 - ! - REAL(KIND=real_kind), intent(in) :: s(np,np) - LOGICAL, intent(in) :: var_coef - TYPE(derivative_t), intent(in) :: deriv - TYPE(element_t), intent(in) :: elem - REAL(KIND=real_kind) :: laplace(np,np) - INTEGER :: j - INTEGER :: i - ! Local - REAL(KIND=real_kind) :: grads(np,np,2) - REAL(KIND=real_kind) :: oldgrads(np,np,2) - grads = gradient_sphere(s,deriv,elem%dinv) - IF (var_coef) THEN - IF (hypervis_power/=0) THEN - ! scalar viscosity with variable coefficient - grads(:,:,1) = grads(:,:,1)*elem%variable_hyperviscosity(:,:) - grads(:,:,2) = grads(:,:,2)*elem%variable_hyperviscosity(:,:) - ELSE IF (hypervis_scaling /=0) THEN - ! tensor hv, (3) - oldgrads = grads - DO j=1,np - DO i=1,np - grads(i,j,1) = sum(oldgrads(i,j,:)*elem%tensorvisc(1,:,i,j)) - grads(i,j,2) = sum(oldgrads(i,j,:)*elem%tensorvisc(2,:,i,j)) - END DO - END DO - ELSE - ! do nothing: constant coefficient viscsoity - END IF - END IF - ! note: divergnece_sphere and divergence_sphere_wk are identical *after* bndry_exchange - ! if input is C_0. Here input is not C_0, so we should use divergence_sphere_wk(). - laplace = divergence_sphere_wk(grads,deriv,elem) - END FUNCTION laplace_sphere_wk - - FUNCTION vlaplace_sphere_wk(v, deriv, elem, var_coef, nu_ratio) RESULT ( laplace ) - ! - ! input: v = vector in lat-lon coordinates - ! ouput: weak laplacian of v, in lat-lon coordinates - ! - ! logic: - ! tensorHV: requires cartesian - ! nu_div/=nu: requires contra formulatino - ! - ! One combination NOT supported: tensorHV and nu_div/=nu then abort - ! - REAL(KIND=real_kind), intent(in) :: v(np,np,2) - LOGICAL, intent(in) :: var_coef - TYPE(derivative_t), intent(in) :: deriv - TYPE(element_t), intent(in) :: elem - REAL(KIND=real_kind), optional :: nu_ratio - REAL(KIND=real_kind) :: laplace(np,np,2) - IF (hypervis_scaling/=0 .and. var_coef) THEN - ! tensorHV is turned on - requires cartesian formulation - IF (present(nu_ratio)) THEN - IF (nu_ratio /= 1) THEN - CALL abortmp('ERROR: tensorHV can not be used with nu_div/=nu') - END IF - END IF - laplace = vlaplace_sphere_wk_cartesian(v,deriv,elem,var_coef) - ELSE - ! all other cases, use contra formulation: - laplace = vlaplace_sphere_wk_contra(v,deriv,elem,var_coef,nu_ratio) - END IF - END FUNCTION vlaplace_sphere_wk - - FUNCTION vlaplace_sphere_wk_cartesian(v, deriv, elem, var_coef) RESULT ( laplace ) - ! - ! input: v = vector in lat-lon coordinates - ! ouput: weak laplacian of v, in lat-lon coordinates - REAL(KIND=real_kind), intent(in) :: v(np,np,2) - LOGICAL :: var_coef - TYPE(derivative_t), intent(in) :: deriv - TYPE(element_t), intent(in) :: elem - REAL(KIND=real_kind) :: laplace(np,np,2) - ! Local - INTEGER :: component - REAL(KIND=real_kind) :: dum_cart(np,np,3) - ! latlon -> cartesian - DO component=1,3 - dum_cart(:,:,component) = sum(elem%vec_sphere2cart(:,:,component,:)*v(:,:,:) ,3) - END DO - ! Do laplace on cartesian comps - DO component=1,3 - dum_cart(:,:,component) = laplace_sphere_wk(dum_cart(:,:,component),deriv,elem,var_coef) - END DO - ! cartesian -> latlon - DO component=1,2 - ! vec_sphere2cart is its own pseudoinverse. - laplace(:,:,component) = sum(dum_cart(:,:,:)*elem%vec_sphere2cart(:,:,:,component) ,3) - END DO - END FUNCTION vlaplace_sphere_wk_cartesian - - FUNCTION vlaplace_sphere_wk_contra(v, deriv, elem, var_coef, nu_ratio) RESULT ( laplace ) - ! - ! input: v = vector in lat-lon coordinates - ! ouput: weak laplacian of v, in lat-lon coordinates - ! - ! du/dt = laplace(u) = grad(div) - curl(vor) - ! < PHI du/dt > = < PHI laplace(u) > PHI = covariant, u = contravariant - ! = < PHI grad(div) > - < PHI curl(vor) > - ! = grad_wk(div) - curl_wk(vor) - ! - REAL(KIND=real_kind), intent(in) :: v(np,np,2) - LOGICAL, intent(in) :: var_coef - TYPE(derivative_t), intent(in) :: deriv - TYPE(element_t), intent(in) :: elem - REAL(KIND=real_kind) :: laplace(np,np,2) - REAL(KIND=real_kind), optional :: nu_ratio - ! Local - INTEGER :: n - INTEGER :: m - REAL(KIND=real_kind) :: div(np,np) - REAL(KIND=real_kind) :: vor(np,np) - div = divergence_sphere(v,deriv,elem) - vor = vorticity_sphere(v,deriv,elem) - IF (var_coef .and. hypervis_power/=0) THEN - ! scalar viscosity with variable coefficient - div = div*elem%variable_hyperviscosity(:,:) - vor = vor*elem%variable_hyperviscosity(:,:) - END IF - IF (present(nu_ratio)) div = nu_ratio*div - laplace = gradient_sphere_wk_testcov(div,deriv,elem) - curl_sphere_wk_testcov(vor,deriv,elem) - DO n=1,np - DO m=1,np - ! add in correction so we dont damp rigid rotation - laplace(m,n,1) = laplace(m,n,1) + 2*elem%spheremp(m,n)*v(m,n,1)*(rrearth**2) - laplace(m,n,2) = laplace(m,n,2) + 2*elem%spheremp(m,n)*v(m,n,2)*(rrearth**2) - END DO - END DO - END FUNCTION vlaplace_sphere_wk_contra - - - ! Given a field defined on the unit element, [-1,1]x[-1,1] - ! sample values, sampled_val, and integration weights, metdet, - ! at a number, np, of Gauss-Lobatto-Legendre points. Divide - ! the square up into intervals by intervals sub-squares so that - ! there are now intervals**2 sub-cells. Integrate the - ! function defined by sampled_val and metdet over each of these - ! sub-cells and return the integrated values as an - ! intervals by intervals matrix. - ! - ! Efficiency is obtained by computing and caching the appropriate - ! integration matrix the first time the function is called. - - ! Helper subroutine that will fill in a matrix needed to - ! integrate a function defined on the GLL points of a unit - ! square on sub-cells. So np is the number of integration - ! GLL points defined on the unit square (actually [-1,1]x[-1,1]) - ! and intervals is the number to cut it up into, say a 3 by 3 - ! set of uniform sub-cells. This function will fill the - ! subcell_integration matrix with the correct coefficients - ! to integrate over each subcell. - - END MODULE derivative_mod diff --git a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/dimensions_mod.F90 b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/dimensions_mod.F90 deleted file mode 100644 index c4f730078e..0000000000 --- a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/dimensions_mod.F90 +++ /dev/null @@ -1,56 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : dimensions_mod.F90 -! Generated at: 2015-04-12 19:17:35 -! KGEN version: 0.4.9 - - - - MODULE dimensions_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE constituents, ONLY: qsize_d => pcnst ! _EXTERNAL - IMPLICIT NONE - PRIVATE - ! set MAX number of tracers. actual number of tracers is a run time argument - ! fvm tracers - ! FI # dependent variables - INTEGER, parameter, public :: np = 4 - INTEGER, parameter, public :: nc = 4 - ! fvm dimensions: - !number of Gausspoints for the fvm integral approximation - !Max. Courant number - !halo width needed for reconstruction - phl - !total halo width where reconstruction is needed (nht<=nc) - phl - !(different from halo needed for elements on edges and corners - ! integer, parameter, public :: ns=3 !quadratic halo interpolation - recommended setting for nc=3 - ! integer, parameter, public :: ns=4 !cubic halo interpolation - recommended setting for nc=4 - !nhc determines width of halo exchanged with neighboring elements - ! - ! constants for SPELT - ! - INTEGER, parameter, public :: nip=3 !number of interpolation values, works only for this - INTEGER, parameter, public :: nipm=nip-1 - INTEGER, parameter, public :: nep=nipm*nc+1 ! number of points in an element - ! dg degree for hybrid cg/dg element 0=disabled - INTEGER, parameter, public :: npsq = np*np - INTEGER, parameter, public :: nlev=30 - INTEGER, parameter, public :: nlevp=nlev+1 - ! params for a mesh - ! integer, public, parameter :: max_elements_attached_to_node = 7 - ! integer, public, parameter :: s_nv = 2*max_elements_attached_to_node - !default for non-refined mesh (note that these are *not* parameters now) - !max_elements_attached_to_node-3 - !4 + 4*max_corner_elem - PUBLIC qsize_d - ! total number of elements - ! number of elements per MPI task - ! max number of elements on any MPI task - ! This is the number of physics processors/ per dynamics processor - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - - END MODULE dimensions_mod diff --git a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/edge_mod.F90 b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/edge_mod.F90 deleted file mode 100644 index 650d3c23ab..0000000000 --- a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/edge_mod.F90 +++ /dev/null @@ -1,919 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : edge_mod.F90 -! Generated at: 2015-04-12 19:17:34 -! KGEN version: 0.4.9 - - - - MODULE edge_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE coordinate_systems_mod, ONLY : kgen_read_mod6 => kgen_read - USE coordinate_systems_mod, ONLY : kgen_verify_mod6 => kgen_verify - USE kinds, ONLY: int_kind - USE kinds, ONLY: log_kind - USE kinds, ONLY: real_kind - ! _EXTERNAL - USE coordinate_systems_mod, ONLY: cartesian3d_t - IMPLICIT NONE - PRIVATE - TYPE, public :: rotation_t - INTEGER :: nbr ! nbr direction: north south east west - INTEGER :: reverse ! 0 = do not reverse order - ! 1 = reverse order - REAL(KIND=real_kind), dimension(:,:,:), pointer :: r => null() ! rotation matrix - END TYPE rotation_t - TYPE, public :: edgedescriptor_t - INTEGER(KIND=int_kind) :: use_rotation - INTEGER(KIND=int_kind) :: padding - INTEGER(KIND=int_kind), pointer :: putmapp(:) => null() - INTEGER(KIND=int_kind), pointer :: getmapp(:) => null() - INTEGER(KIND=int_kind), pointer :: putmapp_ghost(:) => null() - INTEGER(KIND=int_kind), pointer :: getmapp_ghost(:) => null() - INTEGER(KIND=int_kind), pointer :: globalid(:) => null() - INTEGER(KIND=int_kind), pointer :: loc2buf(:) => null() - TYPE(cartesian3d_t), pointer :: neigh_corners(:,:) => null() - INTEGER :: actual_neigh_edges - LOGICAL(KIND=log_kind), pointer :: reverse(:) => null() - TYPE(rotation_t), dimension(:), pointer :: rot => null() ! Identifies list of edges - ! that must be rotated, and how - END TYPE edgedescriptor_t - ! NOTE ON ELEMENT ORIENTATION - ! - ! Element orientation: index V(i,j) - ! - ! (1,np) NWEST (np,np) NEAST - ! - ! (1,1) SWEST (np,1) SEAST - ! - ! - ! for the edge neighbors: - ! we set the "reverse" flag if two elements who share an edge use a - ! reverse orientation. The data is reversed during the *pack* stage - ! For corner neighbors: - ! for edge buffers, there is no orientation because two corner neighbors - ! only share a single point. - ! For ghost cell data, there is a again two posible orientations. For - ! this case, we set the "reverse" flag if the corner element is using - ! the reverse orientation. In this case, the data is reversed during the - ! *unpack* stage (not sure why) - ! - ! The edge orientation is set at startup. The corner orientation is computed - ! at run time, via the call to compute_ghost_corner_orientation() - ! This routine only works for meshes with at most 1 corner element. It's - ! not called and the corner orientation flag is not set for unstructured meshes - ! - ! - ! Mark Taylor - ! pack/unpack full element of data of size (nx,nx) - ! user specifies the size when creating the buffer - ! input/output arrays are cartesian, and will only unpack 1 corner element - ! (even if there are more when running with an unstructured grid) - ! This routine is used mostly for testing and to compute the orientation of - ! an elements corner neighbors - ! - ! init/free buffers used by pack/unpack full and 3D - ! same as above, except orientation of element data is preserved - ! (so boundary data for two adjacent element may not match up) - ! - ! James Overfelt - ! pack/unpack user specifed halo region "nhc". - ! Does not include element edge data (assumes element edge data is C0) - ! (appropriate for continuous GLL data where the edge data does not need to be sent) - ! support for unstructed meshes via extra output arrays: sw,se,ne,nw - ! This routine is currently used by surfaces_mod.F90 to construct the GLL dual grid - ! - ! pack/unpack specifed halo size (up to 1 element) - ! should be identical to ghostVpack2d except for - ! shape of input array - ! returns v including populating halo region of v - ! "extra" corner elements are returned in arrays - ! sw,se,ne,nw - ! MT TODO: this routine works for unstructed data (where the corner orientation flag is - ! not set). So why dont we remove all the "reverse" checks in unpack? - ! - ! Christoph Erath - ! pack/unpack partial element of data of size (nx,nx) with user specifed halo size nh - ! user specifies the sizes when creating the buffer - ! buffer has 1 extra dimension (as compared to subroutines above) for multiple tracers - ! input/output arrays are cartesian, and thus assume at most 1 element at each corner - ! hence currently only supports cube-sphere grids. - ! - ! TODO: GhostBufferTR (init and type) should be removed - we only need GhostBuffer3D, - ! if we can fix - ! ghostVpack2d below to pass vlyr*ntrac_d instead of two seperate arguments - ! - ! ghostbufferTR_t - ! ghostbufferTR_t - ! routines which including element edge data - ! (used for FVM arrays where edge data is not shared by neighboring elements) - ! these routines pack/unpack element data with user specified halo size - ! - ! THESE ROUTINES SHOULD BE MERGED - ! - ! input/output: - ! v(1-nhc:npoints+nhc,1-nhc:npoints+nhc,vlyr,ntrac_d,timelevels) - ! used to pack/unpack SPELT "Rp". What's this? - ! v(1-nhc:npoints+nhc,1-nhc:npoints+nhc,vlyr,ntrac_d) - ! routines which do NOT include element edge data - ! (used for SPELT arrays and GLL point arrays, where edge data is shared and does not need - ! to be sent/received. - ! these routines pack/unpack element data with user specifed halo size - ! - ! THESE ROUTINES CAN ALL BE REPLACED BY ghostVpack3D (if we make extra corner data arrays - ! an optional argument). Or at least these should be merged to 1 routine - ! input/output: - ! v(1-nhc:npoints+nhc,1-nhc:npoints+nhc, vlyr, ntrac_d,timelevels) - ! used to pack/unpack SPELT%sga. what's this? - ! input/output - ! v(1-nhc:npoints+nhc,1-nhc:npoints+nhc) - ! used to pack/unpack FV vertex data (velocity/grid) - ! input/output - ! v(1-nhc:npoints+nhc,1-nhc:npoints+nhc, vlyr) - ! Wrap pointer so we can make an array of them. - - ! read interface - PUBLIC kgen_read - INTERFACE kgen_read - MODULE PROCEDURE kgen_read_rotation_t - MODULE PROCEDURE kgen_read_edgedescriptor_t - END INTERFACE kgen_read - - PUBLIC kgen_verify - INTERFACE kgen_verify - MODULE PROCEDURE kgen_verify_rotation_t - MODULE PROCEDURE kgen_verify_edgedescriptor_t - END INTERFACE kgen_verify - - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_real_kind_dim3_ptr(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=real_kind), INTENT(OUT), POINTER, DIMENSION(:,:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2,idx3 - INTEGER, DIMENSION(2,3) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_real_kind_dim3_ptr - - SUBROUTINE kgen_read_integer_int_kind_dim1_ptr(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - integer(KIND=int_kind), INTENT(OUT), POINTER, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_integer_int_kind_dim1_ptr - - SUBROUTINE kgen_read_logical_log_kind_dim1_ptr(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - logical(KIND=log_kind), INTENT(OUT), POINTER, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_logical_log_kind_dim1_ptr - - SUBROUTINE kgen_read_cartesian3d_t_dim2_ptr(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(cartesian3d_t), INTENT(OUT), POINTER, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - DO idx1=kgen_bound(1,1), kgen_bound(2, 1) - DO idx2=kgen_bound(1,2), kgen_bound(2, 2) - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_mod6(var(idx1,idx2), kgen_unit, printvar=printvar) - ELSE - CALL kgen_read_mod6(var(idx1,idx2), kgen_unit) - END IF - END DO - END DO - END IF - END SUBROUTINE kgen_read_cartesian3d_t_dim2_ptr - - SUBROUTINE kgen_read_rotation_t_dim1_ptr(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(rotation_t), INTENT(OUT), POINTER, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - DO idx1=kgen_bound(1,1), kgen_bound(2, 1) - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_rotation_t(var(idx1), kgen_unit, printvar=printvar) - ELSE - CALL kgen_read_rotation_t(var(idx1), kgen_unit) - END IF - END DO - END IF - END SUBROUTINE kgen_read_rotation_t_dim1_ptr - - ! No module extern variables - SUBROUTINE kgen_read_rotation_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(rotation_t), INTENT(out) :: var - READ(UNIT=kgen_unit) var%nbr - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%nbr **", var%nbr - END IF - READ(UNIT=kgen_unit) var%reverse - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%reverse **", var%reverse - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_real_kind_dim3_ptr(var%r, kgen_unit, printvar=printvar//"%r") - ELSE - CALL kgen_read_real_real_kind_dim3_ptr(var%r, kgen_unit) - END IF - END SUBROUTINE - SUBROUTINE kgen_read_edgedescriptor_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(edgedescriptor_t), INTENT(out) :: var - READ(UNIT=kgen_unit) var%use_rotation - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%use_rotation **", var%use_rotation - END IF - READ(UNIT=kgen_unit) var%padding - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%padding **", var%padding - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_integer_int_kind_dim1_ptr(var%putmapp, kgen_unit, printvar=printvar//"%putmapp") - ELSE - CALL kgen_read_integer_int_kind_dim1_ptr(var%putmapp, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_integer_int_kind_dim1_ptr(var%getmapp, kgen_unit, printvar=printvar//"%getmapp") - ELSE - CALL kgen_read_integer_int_kind_dim1_ptr(var%getmapp, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_integer_int_kind_dim1_ptr(var%putmapp_ghost, kgen_unit, printvar=printvar//"%putmapp_ghost") - ELSE - CALL kgen_read_integer_int_kind_dim1_ptr(var%putmapp_ghost, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_integer_int_kind_dim1_ptr(var%getmapp_ghost, kgen_unit, printvar=printvar//"%getmapp_ghost") - ELSE - CALL kgen_read_integer_int_kind_dim1_ptr(var%getmapp_ghost, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_integer_int_kind_dim1_ptr(var%globalid, kgen_unit, printvar=printvar//"%globalid") - ELSE - CALL kgen_read_integer_int_kind_dim1_ptr(var%globalid, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_integer_int_kind_dim1_ptr(var%loc2buf, kgen_unit, printvar=printvar//"%loc2buf") - ELSE - CALL kgen_read_integer_int_kind_dim1_ptr(var%loc2buf, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_cartesian3d_t_dim2_ptr(var%neigh_corners, kgen_unit, printvar=printvar//"%neigh_corners") - ELSE - CALL kgen_read_cartesian3d_t_dim2_ptr(var%neigh_corners, kgen_unit) - END IF - READ(UNIT=kgen_unit) var%actual_neigh_edges - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%actual_neigh_edges **", var%actual_neigh_edges - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_logical_log_kind_dim1_ptr(var%reverse, kgen_unit, printvar=printvar//"%reverse") - ELSE - CALL kgen_read_logical_log_kind_dim1_ptr(var%reverse, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_rotation_t_dim1_ptr(var%rot, kgen_unit, printvar=printvar//"%rot") - ELSE - CALL kgen_read_rotation_t_dim1_ptr(var%rot, kgen_unit) - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_rotation_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(rotation_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_integer("nbr", dtype_check_status, var%nbr, ref_var%nbr) - CALL kgen_verify_integer("reverse", dtype_check_status, var%reverse, ref_var%reverse) - CALL kgen_verify_real_real_kind_dim3_ptr("r", dtype_check_status, var%r, ref_var%r) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_edgedescriptor_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(edgedescriptor_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_integer_int_kind("use_rotation", dtype_check_status, var%use_rotation, ref_var%use_rotation) - CALL kgen_verify_integer_int_kind("padding", dtype_check_status, var%padding, ref_var%padding) - CALL kgen_verify_integer_int_kind_dim1_ptr("putmapp", dtype_check_status, var%putmapp, ref_var%putmapp) - CALL kgen_verify_integer_int_kind_dim1_ptr("getmapp", dtype_check_status, var%getmapp, ref_var%getmapp) - CALL kgen_verify_integer_int_kind_dim1_ptr("putmapp_ghost", dtype_check_status, var%putmapp_ghost, ref_var%putmapp_ghost) - CALL kgen_verify_integer_int_kind_dim1_ptr("getmapp_ghost", dtype_check_status, var%getmapp_ghost, ref_var%getmapp_ghost) - CALL kgen_verify_integer_int_kind_dim1_ptr("globalid", dtype_check_status, var%globalid, ref_var%globalid) - CALL kgen_verify_integer_int_kind_dim1_ptr("loc2buf", dtype_check_status, var%loc2buf, ref_var%loc2buf) - CALL kgen_verify_cartesian3d_t_dim2_ptr("neigh_corners", dtype_check_status, var%neigh_corners, ref_var%neigh_corners) - CALL kgen_verify_integer("actual_neigh_edges", dtype_check_status, var%actual_neigh_edges, ref_var%actual_neigh_edges) - CALL kgen_verify_logical_log_kind_dim1_ptr("reverse", dtype_check_status, var%reverse, ref_var%reverse) - CALL kgen_verify_rotation_t_dim1_ptr("rot", dtype_check_status, var%rot, ref_var%rot) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_integer( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - END SUBROUTINE kgen_verify_integer - - SUBROUTINE kgen_verify_real_real_kind_dim3_ptr( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=real_kind), intent(in), DIMENSION(:,:,:), POINTER :: var, ref_var - real(KIND=real_kind) :: nrmsdiff, rmsdiff - real(KIND=real_kind), allocatable, DIMENSION(:,:,:) :: temp, temp2 - integer :: n - IF ( ASSOCIATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END IF - END SUBROUTINE kgen_verify_real_real_kind_dim3_ptr - - SUBROUTINE kgen_verify_integer_int_kind( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer(KIND=int_kind), intent(in) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - END SUBROUTINE kgen_verify_integer_int_kind - - SUBROUTINE kgen_verify_integer_int_kind_dim1_ptr( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer(KIND=int_kind), intent(in), DIMENSION(:), POINTER :: var, ref_var - IF ( ASSOCIATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - end if - - check_status%numFatal = check_status%numFatal+1 - END IF - END IF - END SUBROUTINE kgen_verify_integer_int_kind_dim1_ptr - - SUBROUTINE kgen_verify_cartesian3d_t_dim2_ptr( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - type(check_t) :: dtype_check_status - TYPE(cartesian3d_t), intent(in), DIMENSION(:,:), POINTER :: var, ref_var - integer :: idx1,idx2 - IF ( ASSOCIATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - DO idx1=LBOUND(var,1), UBOUND(var,1) - DO idx2=LBOUND(var,2), UBOUND(var,2) - CALL kgen_verify_mod6(varname, dtype_check_status, var(idx1,idx2), ref_var(idx1,idx2)) - END DO - END DO - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END IF - END SUBROUTINE kgen_verify_cartesian3d_t_dim2_ptr - - SUBROUTINE kgen_verify_logical_log_kind_dim1_ptr( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - logical(KIND=log_kind), intent(in), DIMENSION(:), POINTER :: var, ref_var - IF ( ASSOCIATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var .EQV. ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - end if - - check_status%numFatal = check_status%numFatal+1 - END IF - END IF - END SUBROUTINE kgen_verify_logical_log_kind_dim1_ptr - - SUBROUTINE kgen_verify_rotation_t_dim1_ptr( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - type(check_t) :: dtype_check_status - TYPE(rotation_t), intent(in), DIMENSION(:), POINTER :: var, ref_var - integer :: idx1 - IF ( ASSOCIATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - DO idx1=LBOUND(var,1), UBOUND(var,1) - CALL kgen_verify_rotation_t("rotation_t", dtype_check_status, var(idx1), ref_var(idx1)) - END DO - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END IF - END SUBROUTINE kgen_verify_rotation_t_dim1_ptr - - ! ========================================= - ! initEdgeBuffer: - ! - ! create an Real based communication buffer - ! ========================================= - - ! ========================================= - ! initLongEdgeBuffer: - ! - ! create an Integer based communication buffer - ! ========================================= - - ! ========================================= - ! edgeDGVpack: - ! - ! Pack edges of v into buf for DG stencil - ! ========================================= - - ! =========================================== - ! FreeEdgeBuffer: - ! - ! Freed an edge communication buffer - ! ========================================= - - - ! =========================================== - ! FreeLongEdgeBuffer: - ! - ! Freed an edge communication buffer - ! ========================================= - - ! ========================================= - ! - !> @brief Pack edges of v into an edge buffer for boundary exchange. - ! - !> This subroutine packs for one or more vertical layers into an edge - !! buffer. If the buffer associated with edge is not large enough to - !! hold all vertical layers you intent to pack, the method will - !! halt the program with a call to parallel_mod::haltmp(). - !! @param[in] edge Edge Buffer into which the data will be packed. - !! This buffer must be previously allocated with initEdgeBuffer(). - !! @param[in] v The data to be packed. - !! @param[in] vlyr Number of vertical level coming into the subroutine - !! for packing for input v. - !! @param[in] kptr Vertical pointer to the place in the edge buffer where - !! data will be located. - ! ========================================= - - ! ========================================= - ! LongEdgeVpack: - ! - ! Pack edges of v into buf... - ! ========================================= - - ! ======================================== - ! edgeVunpack: - ! - ! Unpack edges from edge buffer into v... - ! ======================================== - - - ! ======================================== - ! edgeDGVunpack: - ! - ! Unpack edges from edge buffer into v... - ! ======================================== - - ! ======================================== - ! edgeVunpackMIN/MAX: - ! - ! Finds the Min/Max edges from edge buffer into v... - ! ======================================== - - - ! ======================================== - ! LongEdgeVunpackMIN: - ! - ! Finds the Min edges from edge buffer into v... - ! ======================================== - - ! ============================= - ! edgerotate: - ! - ! Rotate edges in buffer... - ! ============================= - - ! ============================================= - ! buffermap: - ! - ! buffermap translates element number, inum and - ! element edge/corner, facet, into an edge buffer - ! memory location, loc. - ! ============================================= - - ! =========================================== - ! FreeGhostBuffer: - ! Author: Christoph Erath, Mark Taylor - ! Freed an ghostpoints communication buffer - ! ========================================= - - ! ========================================= - ! ========================================= - ! - !> @brief Pack edges of v into an edge buffer for boundary exchange. - ! - !> This subroutine packs for one or more vertical layers into an edge - !! buffer. If the buffer associated with edge is not large enough to - !! hold all vertical layers you intent to pack, the method will - !! halt the program with a call to parallel_mod::haltmp(). - !! @param[in] edge Ghost Buffer into which the data will be packed. - !! This buffer must be previously allocated with initghostbufferfull(). - !! @param[in] v The data to be packed. - !! @param[in] vlyr Number of vertical level coming into the subroutine - !! for packing for input v. - !! @param[in] kptr Vertical pointer to the place in the edge buffer where - !! data will be located. - ! ========================================= - - ! ======================================== - ! edgeVunpack: - ! - ! Unpack edges from edge buffer into v... - ! ======================================== - - ! ========================================= - ! - !> @brief Pack edges of v into an edge buffer for boundary exchange. - ! - !> This subroutine packs for one or more vertical layers into an edge - !! buffer. If the buffer associated with edge is not large enough to - !! hold all vertical layers you intent to pack, the method will - !! halt the program with a call to parallel_mod::haltmp(). - !! @param[in] edge Ghost Buffer into which the data will be packed. - !! This buffer must be previously allocated with initghostbuffer(). - !! @param[in] v The data to be packed. - !! @param[in] vlyr Number of vertical level coming into the subroutine - !! for packing for input v. - !! @param[in] kptr Vertical pointer to the place in the edge buffer where - !! data will be located. - ! ========================================= - - ! ======================================== - ! edgeVunpack: - ! - ! Unpack edges from edge buffer into v... - ! ======================================== - - ! ========================================= - ! initGhostBuffer: - ! Author: Christoph Erath - ! create an Real based communication buffer - ! npoints is the number of points on one side - ! nhc is the deep of the ghost/halo zone - ! ========================================= - - ! ========================================= - ! Christoph Erath - !> Packs the halo zone from v - ! ========================================= - - ! ========================================= - ! Christoph Erath - !> Packs the halo zone from v - ! ========================================= - ! NOTE: I have to give timelevels as argument, because element_mod is not compiled first - ! and the array call has to be done in this way because of performance reasons!!! - - ! ======================================== - ! Christoph Erath - ! - ! Unpack the halo zone into v - ! ======================================== - - ! ======================================== - ! Christoph Erath - ! - ! Unpack the halo zone into v - ! ======================================== - ! NOTE: I have to give timelevels as argument, because element_mod is not compiled first - ! and the array call has to be done in this way because of performance reasons!!! - - ! ================================================================================= - ! GHOSTVPACK2D - ! AUTHOR: Christoph Erath - ! Pack edges of v into an ghost buffer for boundary exchange. - ! - ! This subroutine packs for one vertical layers into an ghost - ! buffer. It is for cartesian points (v is only two dimensional). - ! If the buffer associated with edge is not large enough to - ! hold all vertical layers you intent to pack, the method will - ! halt the program with a call to parallel_mod::haltmp(). - ! INPUT: - ! - ghost Buffer into which the data will be packed. - ! This buffer must be previously allocated with initGhostBuffer(). - ! - v The data to be packed. - ! - nhc deep of ghost/halo zone - ! - npoints number of points on on side - ! - kptr Vertical pointer to the place in the edge buffer where - ! data will be located. - ! ================================================================================= - - ! ================================================================================= - ! GHOSTVUNPACK2D - ! AUTHOR: Christoph Erath - ! Unpack ghost points from ghost buffer into v... - ! It is for cartesian points (v is only two dimensional). - ! INPUT SAME arguments as for GHOSTVPACK2d - ! ================================================================================= - - ! ================================================================================= - ! GHOSTVPACK2D - ! AUTHOR: Christoph Erath - ! Pack edges of v into an ghost buffer for boundary exchange. - ! - ! This subroutine packs for one vertical layers into an ghost - ! buffer. It is for cartesian points (v is only two dimensional). - ! If the buffer associated with edge is not large enough to - ! hold all vertical layers you intent to pack, the method will - ! halt the program with a call to parallel_mod::haltmp(). - ! INPUT: - ! - ghost Buffer into which the data will be packed. - ! This buffer must be previously allocated with initGhostBuffer(). - ! - v The data to be packed. - ! - nhc deep of ghost/halo zone - ! - npoints number of points on on side - ! - kptr Vertical pointer to the place in the edge buffer where - ! data will be located. - ! ================================================================================= - - ! ================================================================================= - ! GHOSTVUNPACK2D - ! AUTHOR: Christoph Erath - ! Unpack ghost points from ghost buffer into v... - ! It is for cartesian points (v is only two dimensional). - ! INPUT SAME arguments as for GHOSTVPACK2d - ! ================================================================================= - - ! ================================================================================= - ! GHOSTVPACK2D - ! AUTHOR: Christoph Erath - ! Pack edges of v into an ghost buffer for boundary exchange. - ! - ! This subroutine packs for one vertical layers into an ghost - ! buffer. It is for cartesian points (v is only two dimensional). - ! If the buffer associated with edge is not large enough to - ! hold all vertical layers you intent to pack, the method will - ! halt the program with a call to parallel_mod::haltmp(). - ! INPUT: - ! - ghost Buffer into which the data will be packed. - ! This buffer must be previously allocated with initGhostBuffer(). - ! - v The data to be packed. - ! - nhc deep of ghost/halo zone - ! - npoints number of points on on side - ! - kptr Vertical pointer to the place in the edge buffer where - ! data will be located. - ! ================================================================================= - - ! ================================================================================= - ! GHOSTVUNPACK2D - ! AUTHOR: Christoph Erath - ! Unpack ghost points from ghost buffer into v... - ! It is for cartesian points (v is only two dimensional). - ! INPUT SAME arguments as for GHOSTVPACK2d - ! ================================================================================= - - ! ========================================= - ! initGhostBuffer3d: - ! Author: James Overfelt - ! create an Real based communication buffer - ! npoints is the number of points on one side - ! nhc is the deep of the ghost/halo zone - ! ========================================= - - ! ================================================================================= - ! GHOSTVPACK3D - ! AUTHOR: James Overfelt (from a subroutine of Christoph Erath, ghostvpack2D) - ! Pack edges of v into an ghost buffer for boundary exchange. - ! - ! This subroutine packs for many vertical layers into an ghost - ! buffer. - ! If the buffer associated with edge is not large enough to - ! hold all vertical layers you intent to pack, the method will - ! halt the program with a call to parallel_mod::haltmp(). - ! INPUT: - ! - ghost Buffer into which the data will be packed. - ! This buffer must be previously allocated with initGhostBuffer(). - ! - v The data to be packed. - ! - nhc deep of ghost/halo zone - ! - npoints number of points on on side - ! - kptr Vertical pointer to the place in the edge buffer where - ! data will be located. - ! ================================================================================= - - ! ================================================================================= - ! GHOSTVUNPACK3D - ! AUTHOR: James Overfelt (from a subroutine of Christoph Erath, ghostVunpack2d) - ! Unpack ghost points from ghost buffer into v... - ! It is for cartesian points (v is only two dimensional). - ! INPUT SAME arguments as for GHOSTVPACK - ! ================================================================================= - - END MODULE edge_mod diff --git a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/element_mod.F90 b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/element_mod.F90 deleted file mode 100644 index 113c562f8b..0000000000 --- a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/element_mod.F90 +++ /dev/null @@ -1,1290 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : element_mod.F90 -! Generated at: 2015-04-12 19:17:34 -! KGEN version: 0.4.9 - - - - MODULE element_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE coordinate_systems_mod, ONLY : kgen_read_mod6 => kgen_read - USE coordinate_systems_mod, ONLY : kgen_verify_mod6 => kgen_verify - USE gridgraph_mod, ONLY : kgen_read_mod8 => kgen_read - USE gridgraph_mod, ONLY : kgen_verify_mod8 => kgen_verify - USE edge_mod, ONLY : kgen_read_mod9 => kgen_read - USE edge_mod, ONLY : kgen_verify_mod9 => kgen_verify - USE kinds, ONLY: int_kind - USE kinds, ONLY: real_kind - USE kinds, ONLY: long_kind - USE coordinate_systems_mod, ONLY: spherical_polar_t - USE coordinate_systems_mod, ONLY: cartesian2d_t - USE coordinate_systems_mod, ONLY: cartesian3d_t - USE dimensions_mod, ONLY: np - USE dimensions_mod, ONLY: nlev - USE dimensions_mod, ONLY: qsize_d - USE dimensions_mod, ONLY: nlevp - USE dimensions_mod, ONLY: npsq - USE edge_mod, ONLY: edgedescriptor_t - USE gridgraph_mod, ONLY: gridvertex_t - IMPLICIT NONE - PRIVATE - INTEGER, public, parameter :: timelevels = 3 - ! =========== PRIMITIVE-EQUATION DATA-STRUCTURES ===================== - TYPE, public :: elem_state_t - ! prognostic variables for preqx solver - ! prognostics must match those in prim_restart_mod.F90 - ! vertically-lagrangian code advects dp3d instead of ps_v - ! tracers Q, Qdp always use 2 level time scheme - REAL(KIND=real_kind) :: v (np,np,2,nlev,timelevels) ! velocity 1 - REAL(KIND=real_kind) :: t (np,np,nlev,timelevels) ! temperature 2 - REAL(KIND=real_kind) :: dp3d(np,np,nlev,timelevels) ! delta p on levels 8 - REAL(KIND=real_kind) :: lnps(np,np,timelevels) ! log surface pressure 3 - REAL(KIND=real_kind) :: ps_v(np,np,timelevels) ! surface pressure 4 - REAL(KIND=real_kind) :: phis(np,np) ! surface geopotential (prescribed) 5 - REAL(KIND=real_kind) :: q (np,np,nlev,qsize_d) ! Tracer concentration 6 - REAL(KIND=real_kind) :: qdp (np,np,nlev,qsize_d,2) ! Tracer mass 7 - END TYPE elem_state_t - ! num prognistics variables (for prim_restart_mod.F90) - !___________________________________________________________________ - TYPE, public :: derived_state_t - ! diagnostic variables for preqx solver - ! storage for subcycling tracers/dynamics - ! if (compute_mean_flux==1) vn0=time_avg(U*dp) else vn0=U at tracer-time t - REAL(KIND=real_kind) :: vn0 (np,np,2,nlev) ! velocity for SE tracer advection - REAL(KIND=real_kind) :: vstar(np,np,2,nlev) ! velocity on Lagrangian surfaces - REAL(KIND=real_kind) :: dpdiss_biharmonic(np,np,nlev) ! mean dp dissipation tendency, if nu_p>0 - REAL(KIND=real_kind) :: dpdiss_ave(np,np,nlev) ! mean dp used to compute psdiss_tens - ! diagnostics for explicit timestep - REAL(KIND=real_kind) :: phi(np,np,nlev) ! geopotential - REAL(KIND=real_kind) :: omega_p(np,np,nlev) ! vertical tendency (derived) - REAL(KIND=real_kind) :: eta_dot_dpdn(np,np,nlevp) ! mean vertical flux from dynamics - ! semi-implicit diagnostics: computed in explict-component, reused in Helmholtz-component. - REAL(KIND=real_kind) :: grad_lnps(np,np,2) ! gradient of log surface pressure - REAL(KIND=real_kind) :: zeta(np,np,nlev) ! relative vorticity - REAL(KIND=real_kind) :: div(np,np,nlev,timelevels) ! divergence - ! tracer advection fields used for consistency and limiters - REAL(KIND=real_kind) :: dp(np,np,nlev) ! for dp_tracers at physics timestep - REAL(KIND=real_kind) :: divdp(np,np,nlev) ! divergence of dp - REAL(KIND=real_kind) :: divdp_proj(np,np,nlev) ! DSSed divdp - ! forcing terms for 1 - REAL(KIND=real_kind) :: fq(np,np,nlev,qsize_d, 1) ! tracer forcing - REAL(KIND=real_kind) :: fm(np,np,2,nlev, 1) ! momentum forcing - REAL(KIND=real_kind) :: ft(np,np,nlev, 1) ! temperature forcing - REAL(KIND=real_kind) :: omega_prescribed(np,np,nlev) ! prescribed vertical tendency - ! forcing terms for both 1 and HOMME - ! FQps for conserving dry mass in the presence of precipitation - REAL(KIND=real_kind) :: pecnd(np,np,nlev) ! pressure perturbation from condensate - REAL(KIND=real_kind) :: fqps(np,np,timelevels) ! forcing of FQ on ps_v - END TYPE derived_state_t - !___________________________________________________________________ - TYPE, public :: elem_accum_t - ! the "4" timelevels represents data computed at: - ! 1 t-.5 - ! 2 t+.5 after dynamics - ! 3 t+.5 after forcing - ! 4 t+.5 after Robert - ! after calling TimeLevelUpdate, all times above decrease by 1.0 - REAL(KIND=real_kind) :: kener(np,np,4) - REAL(KIND=real_kind) :: pener(np,np,4) - REAL(KIND=real_kind) :: iener(np,np,4) - REAL(KIND=real_kind) :: iener_wet(np,np,4) - REAL(KIND=real_kind) :: qvar(np,np,qsize_d,4) ! Q variance at half time levels - REAL(KIND=real_kind) :: qmass(np,np,qsize_d,4) ! Q mass at half time levels - REAL(KIND=real_kind) :: q1mass(np,np,qsize_d) ! Q mass at full time levels - END TYPE elem_accum_t - ! ============= DATA-STRUCTURES COMMON TO ALL SOLVERS ================ - TYPE, public :: index_t - INTEGER(KIND=int_kind) :: ia(npsq), ja(npsq) - INTEGER(KIND=int_kind) :: is, ie - INTEGER(KIND=int_kind) :: numuniquepts - INTEGER(KIND=int_kind) :: uniqueptoffset - END TYPE index_t - !___________________________________________________________________ - TYPE, public :: element_t - INTEGER(KIND=int_kind) :: localid - INTEGER(KIND=int_kind) :: globalid - ! Coordinate values of element points - TYPE(spherical_polar_t) :: spherep(np,np) ! Spherical coords of GLL points - ! Equ-angular gnomonic projection coordinates - TYPE(cartesian2d_t) :: cartp(np,np) ! gnomonic coords of GLL points - TYPE(cartesian2d_t) :: corners(4) ! gnomonic coords of element corners - REAL(KIND=real_kind) :: u2qmap(4,2) ! bilinear map from ref element to quad in cubedsphere coordinates - ! SHOULD BE REMOVED - ! 3D cartesian coordinates - TYPE(cartesian3d_t) :: corners3d(4) - ! Element diagnostics - REAL(KIND=real_kind) :: area ! Area of element - REAL(KIND=real_kind) :: normdinv ! some type of norm of Dinv used for CFL - REAL(KIND=real_kind) :: dx_short ! short length scale in km - REAL(KIND=real_kind) :: dx_long ! long length scale in km - REAL(KIND=real_kind) :: variable_hyperviscosity(np,np) ! hyperviscosity based on above - REAL(KIND=real_kind) :: hv_courant ! hyperviscosity courant number - REAL(KIND=real_kind) :: tensorvisc(2,2,np,np) !og, matrix V for tensor viscosity - ! Edge connectivity information - ! integer(kind=int_kind) :: node_numbers(4) - ! integer(kind=int_kind) :: node_multiplicity(4) ! number of elements sharing corner node - TYPE(gridvertex_t) :: vertex ! element grid vertex information - TYPE(edgedescriptor_t) :: desc - TYPE(elem_state_t) :: state - TYPE(derived_state_t) :: derived - TYPE(elem_accum_t) :: accum - ! Metric terms - REAL(KIND=real_kind) :: met(2,2,np,np) ! metric tensor on velocity and pressure grid - REAL(KIND=real_kind) :: metinv(2,2,np,np) ! metric tensor on velocity and pressure grid - REAL(KIND=real_kind) :: metdet(np,np) ! g = SQRT(det(g_ij)) on velocity and pressure grid - REAL(KIND=real_kind) :: rmetdet(np,np) ! 1/metdet on velocity pressure grid - REAL(KIND=real_kind) :: d(2,2,np,np) ! Map covariant field on cube to vector field on the sphere - REAL(KIND=real_kind) :: dinv(2,2,np,np) ! Map vector field on the sphere to covariant v on cube - ! Convert vector fields from spherical to rectangular components - ! The transpose of this operation is its pseudoinverse. - REAL(KIND=real_kind) :: vec_sphere2cart(np,np,3,2) - ! Mass matrix terms for an element on a cube face - REAL(KIND=real_kind) :: mp(np,np) ! mass matrix on v and p grid - REAL(KIND=real_kind) :: rmp(np,np) ! inverse mass matrix on v and p grid - ! Mass matrix terms for an element on the sphere - ! This mass matrix is used when solving the equations in weak form - ! with the natural (surface area of the sphere) inner product - REAL(KIND=real_kind) :: spheremp(np,np) ! mass matrix on v and p grid - REAL(KIND=real_kind) :: rspheremp(np,np) ! inverse mass matrix on v and p grid - INTEGER(KIND=long_kind) :: gdofp(np,np) ! global degree of freedom (P-grid) - REAL(KIND=real_kind) :: fcor(np,np) ! Coreolis term - TYPE(index_t) :: idxp - TYPE(index_t), pointer :: idxv - INTEGER :: facenum - ! force element_t to be a multiple of 8 bytes. - ! on BGP, code will crash (signal 7, or signal 15) if 8 byte alignment is off - ! check core file for: - ! core.63:Generated by interrupt..(Alignment Exception DEAR=0xa1ef671c ESR=0x01800000 CCR0=0x4800a002) - INTEGER :: dummy - END TYPE element_t - !___________________________________________________________________ - - ! read interface - PUBLIC kgen_read - INTERFACE kgen_read - MODULE PROCEDURE kgen_read_elem_state_t - MODULE PROCEDURE kgen_read_derived_state_t - MODULE PROCEDURE kgen_read_elem_accum_t - MODULE PROCEDURE kgen_read_index_t - MODULE PROCEDURE kgen_read_element_t - END INTERFACE kgen_read - - PUBLIC kgen_verify - INTERFACE kgen_verify - MODULE PROCEDURE kgen_verify_elem_state_t - MODULE PROCEDURE kgen_verify_derived_state_t - MODULE PROCEDURE kgen_verify_elem_accum_t - MODULE PROCEDURE kgen_verify_index_t - MODULE PROCEDURE kgen_verify_element_t - END INTERFACE kgen_verify - - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_index_t_ptr(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(index_t), INTENT(OUT), POINTER :: var - LOGICAL :: is_true - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - ALLOCATE(var) - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_index_t(var, kgen_unit, printvar=printvar//"%index_t") - ELSE - CALL kgen_read_index_t(var, kgen_unit) - END IF - END IF - END SUBROUTINE kgen_read_index_t_ptr - - SUBROUTINE kgen_read_cartesian2d_t_dim2(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(cartesian2d_t), INTENT(OUT), DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - DO idx1=kgen_bound(1,1), kgen_bound(2, 1) - DO idx2=kgen_bound(1,2), kgen_bound(2, 2) - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_mod6(var(idx1,idx2), kgen_unit, printvar=printvar) - ELSE - CALL kgen_read_mod6(var(idx1,idx2), kgen_unit) - END IF - END DO - END DO - END IF - END SUBROUTINE kgen_read_cartesian2d_t_dim2 - - SUBROUTINE kgen_read_cartesian3d_t_dim1(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(cartesian3d_t), INTENT(OUT), DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - DO idx1=kgen_bound(1,1), kgen_bound(2, 1) - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_mod6(var(idx1), kgen_unit, printvar=printvar) - ELSE - CALL kgen_read_mod6(var(idx1), kgen_unit) - END IF - END DO - END IF - END SUBROUTINE kgen_read_cartesian3d_t_dim1 - - SUBROUTINE kgen_read_cartesian2d_t_dim1(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(cartesian2d_t), INTENT(OUT), DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - DO idx1=kgen_bound(1,1), kgen_bound(2, 1) - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_mod6(var(idx1), kgen_unit, printvar=printvar) - ELSE - CALL kgen_read_mod6(var(idx1), kgen_unit) - END IF - END DO - END IF - END SUBROUTINE kgen_read_cartesian2d_t_dim1 - - SUBROUTINE kgen_read_spherical_polar_t_dim2(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(spherical_polar_t), INTENT(OUT), DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - DO idx1=kgen_bound(1,1), kgen_bound(2, 1) - DO idx2=kgen_bound(1,2), kgen_bound(2, 2) - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_mod6(var(idx1,idx2), kgen_unit, printvar=printvar) - ELSE - CALL kgen_read_mod6(var(idx1,idx2), kgen_unit) - END IF - END DO - END DO - END IF - END SUBROUTINE kgen_read_spherical_polar_t_dim2 - - ! No module extern variables - SUBROUTINE kgen_read_elem_state_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(elem_state_t), INTENT(out) :: var - READ(UNIT=kgen_unit) var%v - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%v **", var%v - END IF - READ(UNIT=kgen_unit) var%t - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%t **", var%t - END IF - READ(UNIT=kgen_unit) var%dp3d - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dp3d **", var%dp3d - END IF - READ(UNIT=kgen_unit) var%lnps - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%lnps **", var%lnps - END IF - READ(UNIT=kgen_unit) var%ps_v - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%ps_v **", var%ps_v - END IF - READ(UNIT=kgen_unit) var%phis - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%phis **", var%phis - END IF - READ(UNIT=kgen_unit) var%q - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%q **", var%q - END IF - READ(UNIT=kgen_unit) var%qdp - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%qdp **", var%qdp - END IF - END SUBROUTINE - SUBROUTINE kgen_read_derived_state_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(derived_state_t), INTENT(out) :: var - READ(UNIT=kgen_unit) var%vn0 - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%vn0 **", var%vn0 - END IF - READ(UNIT=kgen_unit) var%vstar - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%vstar **", var%vstar - END IF - READ(UNIT=kgen_unit) var%dpdiss_biharmonic - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dpdiss_biharmonic **", var%dpdiss_biharmonic - END IF - READ(UNIT=kgen_unit) var%dpdiss_ave - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dpdiss_ave **", var%dpdiss_ave - END IF - READ(UNIT=kgen_unit) var%phi - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%phi **", var%phi - END IF - READ(UNIT=kgen_unit) var%omega_p - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%omega_p **", var%omega_p - END IF - READ(UNIT=kgen_unit) var%eta_dot_dpdn - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%eta_dot_dpdn **", var%eta_dot_dpdn - END IF - READ(UNIT=kgen_unit) var%grad_lnps - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%grad_lnps **", var%grad_lnps - END IF - READ(UNIT=kgen_unit) var%zeta - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%zeta **", var%zeta - END IF - READ(UNIT=kgen_unit) var%div - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%div **", var%div - END IF - READ(UNIT=kgen_unit) var%dp - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dp **", var%dp - END IF - READ(UNIT=kgen_unit) var%divdp - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%divdp **", var%divdp - END IF - READ(UNIT=kgen_unit) var%divdp_proj - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%divdp_proj **", var%divdp_proj - END IF - READ(UNIT=kgen_unit) var%fq - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%fq **", var%fq - END IF - READ(UNIT=kgen_unit) var%fm - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%fm **", var%fm - END IF - READ(UNIT=kgen_unit) var%ft - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%ft **", var%ft - END IF - READ(UNIT=kgen_unit) var%omega_prescribed - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%omega_prescribed **", var%omega_prescribed - END IF - READ(UNIT=kgen_unit) var%pecnd - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%pecnd **", var%pecnd - END IF - READ(UNIT=kgen_unit) var%fqps - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%fqps **", var%fqps - END IF - END SUBROUTINE - SUBROUTINE kgen_read_elem_accum_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(elem_accum_t), INTENT(out) :: var - READ(UNIT=kgen_unit) var%kener - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%kener **", var%kener - END IF - READ(UNIT=kgen_unit) var%pener - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%pener **", var%pener - END IF - READ(UNIT=kgen_unit) var%iener - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%iener **", var%iener - END IF - READ(UNIT=kgen_unit) var%iener_wet - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%iener_wet **", var%iener_wet - END IF - READ(UNIT=kgen_unit) var%qvar - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%qvar **", var%qvar - END IF - READ(UNIT=kgen_unit) var%qmass - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%qmass **", var%qmass - END IF - READ(UNIT=kgen_unit) var%q1mass - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%q1mass **", var%q1mass - END IF - END SUBROUTINE - SUBROUTINE kgen_read_index_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(index_t), INTENT(out) :: var - READ(UNIT=kgen_unit) var%ia - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%ia **", var%ia - END IF - READ(UNIT=kgen_unit) var%ja - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%ja **", var%ja - END IF - READ(UNIT=kgen_unit) var%is - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%is **", var%is - END IF - READ(UNIT=kgen_unit) var%ie - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%ie **", var%ie - END IF - READ(UNIT=kgen_unit) var%numuniquepts - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%numuniquepts **", var%numuniquepts - END IF - READ(UNIT=kgen_unit) var%uniqueptoffset - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%uniqueptoffset **", var%uniqueptoffset - END IF - END SUBROUTINE - SUBROUTINE kgen_read_element_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(element_t), INTENT(out) :: var - READ(UNIT=kgen_unit) var%localid - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%localid **", var%localid - END IF - READ(UNIT=kgen_unit) var%globalid - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%globalid **", var%globalid - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_spherical_polar_t_dim2(var%spherep, kgen_unit, printvar=printvar//"%spherep") - ELSE - CALL kgen_read_spherical_polar_t_dim2(var%spherep, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_cartesian2d_t_dim2(var%cartp, kgen_unit, printvar=printvar//"%cartp") - ELSE - CALL kgen_read_cartesian2d_t_dim2(var%cartp, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_cartesian2d_t_dim1(var%corners, kgen_unit, printvar=printvar//"%corners") - ELSE - CALL kgen_read_cartesian2d_t_dim1(var%corners, kgen_unit) - END IF - READ(UNIT=kgen_unit) var%u2qmap - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%u2qmap **", var%u2qmap - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_cartesian3d_t_dim1(var%corners3d, kgen_unit, printvar=printvar//"%corners3d") - ELSE - CALL kgen_read_cartesian3d_t_dim1(var%corners3d, kgen_unit) - END IF - READ(UNIT=kgen_unit) var%area - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%area **", var%area - END IF - READ(UNIT=kgen_unit) var%normdinv - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%normdinv **", var%normdinv - END IF - READ(UNIT=kgen_unit) var%dx_short - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dx_short **", var%dx_short - END IF - READ(UNIT=kgen_unit) var%dx_long - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dx_long **", var%dx_long - END IF - READ(UNIT=kgen_unit) var%variable_hyperviscosity - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%variable_hyperviscosity **", var%variable_hyperviscosity - END IF - READ(UNIT=kgen_unit) var%hv_courant - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%hv_courant **", var%hv_courant - END IF - READ(UNIT=kgen_unit) var%tensorvisc - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%tensorvisc **", var%tensorvisc - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_mod8(var%vertex, kgen_unit, printvar=printvar//"%vertex") - ELSE - CALL kgen_read_mod8(var%vertex, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_mod9(var%desc, kgen_unit, printvar=printvar//"%desc") - ELSE - CALL kgen_read_mod9(var%desc, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_elem_state_t(var%state, kgen_unit, printvar=printvar//"%state") - ELSE - CALL kgen_read_elem_state_t(var%state, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_derived_state_t(var%derived, kgen_unit, printvar=printvar//"%derived") - ELSE - CALL kgen_read_derived_state_t(var%derived, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_elem_accum_t(var%accum, kgen_unit, printvar=printvar//"%accum") - ELSE - CALL kgen_read_elem_accum_t(var%accum, kgen_unit) - END IF - READ(UNIT=kgen_unit) var%met - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%met **", var%met - END IF - READ(UNIT=kgen_unit) var%metinv - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%metinv **", var%metinv - END IF - READ(UNIT=kgen_unit) var%metdet - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%metdet **", var%metdet - END IF - READ(UNIT=kgen_unit) var%rmetdet - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%rmetdet **", var%rmetdet - END IF - READ(UNIT=kgen_unit) var%d - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%d **", var%d - END IF - READ(UNIT=kgen_unit) var%dinv - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dinv **", var%dinv - END IF - READ(UNIT=kgen_unit) var%vec_sphere2cart - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%vec_sphere2cart **", var%vec_sphere2cart - END IF - READ(UNIT=kgen_unit) var%mp - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%mp **", var%mp - END IF - READ(UNIT=kgen_unit) var%rmp - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%rmp **", var%rmp - END IF - READ(UNIT=kgen_unit) var%spheremp - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%spheremp **", var%spheremp - END IF - READ(UNIT=kgen_unit) var%rspheremp - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%rspheremp **", var%rspheremp - END IF - READ(UNIT=kgen_unit) var%gdofp - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%gdofp **", var%gdofp - END IF - READ(UNIT=kgen_unit) var%fcor - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%fcor **", var%fcor - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_index_t(var%idxp, kgen_unit, printvar=printvar//"%idxp") - ELSE - CALL kgen_read_index_t(var%idxp, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_index_t_ptr(var%idxv, kgen_unit, printvar=printvar//"%idxv") - ELSE - CALL kgen_read_index_t_ptr(var%idxv, kgen_unit) - END IF - READ(UNIT=kgen_unit) var%facenum - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%facenum **", var%facenum - END IF - READ(UNIT=kgen_unit) var%dummy - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dummy **", var%dummy - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_elem_state_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(elem_state_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_real_real_kind_dim5("v", dtype_check_status, var%v, ref_var%v) - CALL kgen_verify_real_real_kind_dim4("t", dtype_check_status, var%t, ref_var%t) - CALL kgen_verify_real_real_kind_dim4("dp3d", dtype_check_status, var%dp3d, ref_var%dp3d) - CALL kgen_verify_real_real_kind_dim3("lnps", dtype_check_status, var%lnps, ref_var%lnps) - CALL kgen_verify_real_real_kind_dim3("ps_v", dtype_check_status, var%ps_v, ref_var%ps_v) - CALL kgen_verify_real_real_kind_dim2("phis", dtype_check_status, var%phis, ref_var%phis) - CALL kgen_verify_real_real_kind_dim4("q", dtype_check_status, var%q, ref_var%q) - CALL kgen_verify_real_real_kind_dim5("qdp", dtype_check_status, var%qdp, ref_var%qdp) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_derived_state_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(derived_state_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_real_real_kind_dim4("vn0", dtype_check_status, var%vn0, ref_var%vn0) - CALL kgen_verify_real_real_kind_dim4("vstar", dtype_check_status, var%vstar, ref_var%vstar) - CALL kgen_verify_real_real_kind_dim3("dpdiss_biharmonic", dtype_check_status, var%dpdiss_biharmonic, ref_var%dpdiss_biharmonic) - CALL kgen_verify_real_real_kind_dim3("dpdiss_ave", dtype_check_status, var%dpdiss_ave, ref_var%dpdiss_ave) - CALL kgen_verify_real_real_kind_dim3("phi", dtype_check_status, var%phi, ref_var%phi) - CALL kgen_verify_real_real_kind_dim3("omega_p", dtype_check_status, var%omega_p, ref_var%omega_p) - CALL kgen_verify_real_real_kind_dim3("eta_dot_dpdn", dtype_check_status, var%eta_dot_dpdn, ref_var%eta_dot_dpdn) - CALL kgen_verify_real_real_kind_dim3("grad_lnps", dtype_check_status, var%grad_lnps, ref_var%grad_lnps) - CALL kgen_verify_real_real_kind_dim3("zeta", dtype_check_status, var%zeta, ref_var%zeta) - CALL kgen_verify_real_real_kind_dim4("div", dtype_check_status, var%div, ref_var%div) - CALL kgen_verify_real_real_kind_dim3("dp", dtype_check_status, var%dp, ref_var%dp) - CALL kgen_verify_real_real_kind_dim3("divdp", dtype_check_status, var%divdp, ref_var%divdp) - CALL kgen_verify_real_real_kind_dim3("divdp_proj", dtype_check_status, var%divdp_proj, ref_var%divdp_proj) - CALL kgen_verify_real_real_kind_dim5("fq", dtype_check_status, var%fq, ref_var%fq) - CALL kgen_verify_real_real_kind_dim5("fm", dtype_check_status, var%fm, ref_var%fm) - CALL kgen_verify_real_real_kind_dim4("ft", dtype_check_status, var%ft, ref_var%ft) - CALL kgen_verify_real_real_kind_dim3("omega_prescribed", dtype_check_status, var%omega_prescribed, ref_var%omega_prescribed) - CALL kgen_verify_real_real_kind_dim3("pecnd", dtype_check_status, var%pecnd, ref_var%pecnd) - CALL kgen_verify_real_real_kind_dim3("fqps", dtype_check_status, var%fqps, ref_var%fqps) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_elem_accum_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(elem_accum_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_real_real_kind_dim3("kener", dtype_check_status, var%kener, ref_var%kener) - CALL kgen_verify_real_real_kind_dim3("pener", dtype_check_status, var%pener, ref_var%pener) - CALL kgen_verify_real_real_kind_dim3("iener", dtype_check_status, var%iener, ref_var%iener) - CALL kgen_verify_real_real_kind_dim3("iener_wet", dtype_check_status, var%iener_wet, ref_var%iener_wet) - CALL kgen_verify_real_real_kind_dim4("qvar", dtype_check_status, var%qvar, ref_var%qvar) - CALL kgen_verify_real_real_kind_dim4("qmass", dtype_check_status, var%qmass, ref_var%qmass) - CALL kgen_verify_real_real_kind_dim3("q1mass", dtype_check_status, var%q1mass, ref_var%q1mass) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_index_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(index_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_integer_int_kind_dim1("ia", dtype_check_status, var%ia, ref_var%ia) - CALL kgen_verify_integer_int_kind_dim1("ja", dtype_check_status, var%ja, ref_var%ja) - CALL kgen_verify_integer_int_kind("is", dtype_check_status, var%is, ref_var%is) - CALL kgen_verify_integer_int_kind("ie", dtype_check_status, var%ie, ref_var%ie) - CALL kgen_verify_integer_int_kind("numuniquepts", dtype_check_status, var%numuniquepts, ref_var%numuniquepts) - CALL kgen_verify_integer_int_kind("uniqueptoffset", dtype_check_status, var%uniqueptoffset, ref_var%uniqueptoffset) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_element_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(element_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_integer_int_kind("localid", dtype_check_status, var%localid, ref_var%localid) - CALL kgen_verify_integer_int_kind("globalid", dtype_check_status, var%globalid, ref_var%globalid) - CALL kgen_verify_spherical_polar_t_dim2("spherep", dtype_check_status, var%spherep, ref_var%spherep) - CALL kgen_verify_cartesian2d_t_dim2("cartp", dtype_check_status, var%cartp, ref_var%cartp) - CALL kgen_verify_cartesian2d_t_dim1("corners", dtype_check_status, var%corners, ref_var%corners) - CALL kgen_verify_real_real_kind_dim2("u2qmap", dtype_check_status, var%u2qmap, ref_var%u2qmap) - CALL kgen_verify_cartesian3d_t_dim1("corners3d", dtype_check_status, var%corners3d, ref_var%corners3d) - CALL kgen_verify_real_real_kind("area", dtype_check_status, var%area, ref_var%area) - CALL kgen_verify_real_real_kind("normdinv", dtype_check_status, var%normdinv, ref_var%normdinv) - CALL kgen_verify_real_real_kind("dx_short", dtype_check_status, var%dx_short, ref_var%dx_short) - CALL kgen_verify_real_real_kind("dx_long", dtype_check_status, var%dx_long, ref_var%dx_long) - CALL kgen_verify_real_real_kind_dim2("variable_hyperviscosity", dtype_check_status, var%variable_hyperviscosity, ref_var%variable_hyperviscosity) - CALL kgen_verify_real_real_kind("hv_courant", dtype_check_status, var%hv_courant, ref_var%hv_courant) - CALL kgen_verify_real_real_kind_dim4("tensorvisc", dtype_check_status, var%tensorvisc, ref_var%tensorvisc) - CALL kgen_verify_mod8("vertex", dtype_check_status, var%vertex, ref_var%vertex) - CALL kgen_verify_mod9("desc", dtype_check_status, var%desc, ref_var%desc) - CALL kgen_verify_elem_state_t("state", dtype_check_status, var%state, ref_var%state) - CALL kgen_verify_derived_state_t("derived", dtype_check_status, var%derived, ref_var%derived) - CALL kgen_verify_elem_accum_t("accum", dtype_check_status, var%accum, ref_var%accum) - CALL kgen_verify_real_real_kind_dim4("met", dtype_check_status, var%met, ref_var%met) - CALL kgen_verify_real_real_kind_dim4("metinv", dtype_check_status, var%metinv, ref_var%metinv) - CALL kgen_verify_real_real_kind_dim2("metdet", dtype_check_status, var%metdet, ref_var%metdet) - CALL kgen_verify_real_real_kind_dim2("rmetdet", dtype_check_status, var%rmetdet, ref_var%rmetdet) - CALL kgen_verify_real_real_kind_dim4("d", dtype_check_status, var%d, ref_var%d) - CALL kgen_verify_real_real_kind_dim4("dinv", dtype_check_status, var%dinv, ref_var%dinv) - CALL kgen_verify_real_real_kind_dim4("vec_sphere2cart", dtype_check_status, var%vec_sphere2cart, ref_var%vec_sphere2cart) - CALL kgen_verify_real_real_kind_dim2("mp", dtype_check_status, var%mp, ref_var%mp) - CALL kgen_verify_real_real_kind_dim2("rmp", dtype_check_status, var%rmp, ref_var%rmp) - CALL kgen_verify_real_real_kind_dim2("spheremp", dtype_check_status, var%spheremp, ref_var%spheremp) - CALL kgen_verify_real_real_kind_dim2("rspheremp", dtype_check_status, var%rspheremp, ref_var%rspheremp) - CALL kgen_verify_integer_long_kind_dim2("gdofp", dtype_check_status, var%gdofp, ref_var%gdofp) - CALL kgen_verify_real_real_kind_dim2("fcor", dtype_check_status, var%fcor, ref_var%fcor) - CALL kgen_verify_index_t("idxp", dtype_check_status, var%idxp, ref_var%idxp) - CALL kgen_verify_index_t_ptr("idxv", dtype_check_status, var%idxv, ref_var%idxv) - CALL kgen_verify_integer("facenum", dtype_check_status, var%facenum, ref_var%facenum) - CALL kgen_verify_integer("dummy", dtype_check_status, var%dummy, ref_var%dummy) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_real_real_kind_dim5( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=real_kind), intent(in), DIMENSION(:,:,:,:,:) :: var, ref_var - real(KIND=real_kind) :: nrmsdiff, rmsdiff - real(KIND=real_kind), allocatable, DIMENSION(:,:,:,:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3),SIZE(var,dim=4),SIZE(var,dim=5))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3),SIZE(var,dim=4),SIZE(var,dim=5))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_real_kind_dim5 - - SUBROUTINE kgen_verify_real_real_kind_dim4( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=real_kind), intent(in), DIMENSION(:,:,:,:) :: var, ref_var - real(KIND=real_kind) :: nrmsdiff, rmsdiff - real(KIND=real_kind), allocatable, DIMENSION(:,:,:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3),SIZE(var,dim=4))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3),SIZE(var,dim=4))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_real_kind_dim4 - - SUBROUTINE kgen_verify_real_real_kind_dim3( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=real_kind), intent(in), DIMENSION(:,:,:) :: var, ref_var - real(KIND=real_kind) :: nrmsdiff, rmsdiff - real(KIND=real_kind), allocatable, DIMENSION(:,:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_real_kind_dim3 - - SUBROUTINE kgen_verify_real_real_kind_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=real_kind), intent(in), DIMENSION(:,:) :: var, ref_var - real(KIND=real_kind) :: nrmsdiff, rmsdiff - real(KIND=real_kind), allocatable, DIMENSION(:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_real_kind_dim2 - - SUBROUTINE kgen_verify_integer_int_kind_dim1( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer(KIND=int_kind), intent(in), DIMENSION(:) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - end if - - check_status%numFatal = check_status%numFatal+1 - END IF - END SUBROUTINE kgen_verify_integer_int_kind_dim1 - - SUBROUTINE kgen_verify_integer_int_kind( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer(KIND=int_kind), intent(in) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - END SUBROUTINE kgen_verify_integer_int_kind - - SUBROUTINE kgen_verify_spherical_polar_t_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - type(check_t) :: dtype_check_status - TYPE(spherical_polar_t), intent(in), DIMENSION(:,:) :: var, ref_var - integer :: idx1,idx2 - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - DO idx1=LBOUND(var,1), UBOUND(var,1) - DO idx2=LBOUND(var,2), UBOUND(var,2) - CALL kgen_verify_mod6(varname, dtype_check_status, var(idx1,idx2), ref_var(idx1,idx2)) - END DO - END DO - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE kgen_verify_spherical_polar_t_dim2 - - SUBROUTINE kgen_verify_cartesian2d_t_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - type(check_t) :: dtype_check_status - TYPE(cartesian2d_t), intent(in), DIMENSION(:,:) :: var, ref_var - integer :: idx1,idx2 - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - DO idx1=LBOUND(var,1), UBOUND(var,1) - DO idx2=LBOUND(var,2), UBOUND(var,2) - CALL kgen_verify_mod6(varname, dtype_check_status, var(idx1,idx2), ref_var(idx1,idx2)) - END DO - END DO - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE kgen_verify_cartesian2d_t_dim2 - - SUBROUTINE kgen_verify_cartesian2d_t_dim1( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - type(check_t) :: dtype_check_status - TYPE(cartesian2d_t), intent(in), DIMENSION(:) :: var, ref_var - integer :: idx1 - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - DO idx1=LBOUND(var,1), UBOUND(var,1) - CALL kgen_verify_mod6(varname, dtype_check_status, var(idx1), ref_var(idx1)) - END DO - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE kgen_verify_cartesian2d_t_dim1 - - SUBROUTINE kgen_verify_cartesian3d_t_dim1( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - type(check_t) :: dtype_check_status - TYPE(cartesian3d_t), intent(in), DIMENSION(:) :: var, ref_var - integer :: idx1 - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - DO idx1=LBOUND(var,1), UBOUND(var,1) - CALL kgen_verify_mod6(varname, dtype_check_status, var(idx1), ref_var(idx1)) - END DO - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE kgen_verify_cartesian3d_t_dim1 - - SUBROUTINE kgen_verify_real_real_kind( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=real_kind), intent(in) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - END SUBROUTINE kgen_verify_real_real_kind - - SUBROUTINE kgen_verify_integer_long_kind_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer(KIND=long_kind), intent(in), DIMENSION(:,:) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - end if - - check_status%numFatal = check_status%numFatal+1 - END IF - END SUBROUTINE kgen_verify_integer_long_kind_dim2 - - SUBROUTINE kgen_verify_index_t_ptr( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - type(check_t) :: dtype_check_status - TYPE(index_t), intent(in), POINTER :: var, ref_var - IF ( ASSOCIATED(var) ) THEN - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_integer_int_kind_dim1("ia", dtype_check_status, var%ia, ref_var%ia) - CALL kgen_verify_integer_int_kind_dim1("ja", dtype_check_status, var%ja, ref_var%ja) - CALL kgen_verify_integer_int_kind("is", dtype_check_status, var%is, ref_var%is) - CALL kgen_verify_integer_int_kind("ie", dtype_check_status, var%ie, ref_var%ie) - CALL kgen_verify_integer_int_kind("numuniquepts", dtype_check_status, var%numuniquepts, ref_var%numuniquepts) - CALL kgen_verify_integer_int_kind("uniqueptoffset", dtype_check_status, var%uniqueptoffset, ref_var%uniqueptoffset) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END IF - END SUBROUTINE kgen_verify_index_t_ptr - - SUBROUTINE kgen_verify_integer( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - END SUBROUTINE kgen_verify_integer - - ! ===================== ELEMENT_MOD METHODS ========================== - - !___________________________________________________________________ - - !___________________________________________________________________ - - !___________________________________________________________________ - - !___________________________________________________________________ - - !___________________________________________________________________ - - END MODULE element_mod diff --git a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/gridgraph_mod.F90 b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/gridgraph_mod.F90 deleted file mode 100644 index fa58f27a79..0000000000 --- a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/gridgraph_mod.F90 +++ /dev/null @@ -1,272 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : gridgraph_mod.F90 -! Generated at: 2015-04-12 19:17:34 -! KGEN version: 0.4.9 - - - - MODULE gridgraph_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !------------------------- - !------------------------------- - !------------------------- - !----- - IMPLICIT NONE - PRIVATE - INTEGER, public, parameter :: num_neighbors=8 ! for north, south, east, west, neast, nwest, seast, swest - TYPE, public :: gridvertex_t - INTEGER, pointer :: nbrs(:) => null() ! The numbers of the neighbor elements - INTEGER, pointer :: nbrs_face(:) => null() ! The cube face number of the neighbor element (nbrs array) - INTEGER, pointer :: nbrs_wgt(:) => null() ! The weights for edges defined by nbrs array - INTEGER, pointer :: nbrs_wgt_ghost(:) => null() ! The weights for edges defined by nbrs array - INTEGER :: nbrs_ptr(num_neighbors + 1) !index into the nbrs array for each neighbor direction - INTEGER :: face_number ! which face of the cube this vertex is on - INTEGER :: number ! element number - INTEGER :: processor_number ! processor number - INTEGER :: spacecurve ! index in Space-Filling curve - END TYPE gridvertex_t - ! ========================================== - ! Public Interfaces - ! ========================================== - - - ! read interface - PUBLIC kgen_read - INTERFACE kgen_read - MODULE PROCEDURE kgen_read_gridvertex_t - END INTERFACE kgen_read - - PUBLIC kgen_verify - INTERFACE kgen_verify - MODULE PROCEDURE kgen_verify_gridvertex_t - END INTERFACE kgen_verify - - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_integer_4_dim1_ptr(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - integer(KIND=4), INTENT(OUT), POINTER, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_integer_4_dim1_ptr - - ! No module extern variables - SUBROUTINE kgen_read_gridvertex_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(gridvertex_t), INTENT(out) :: var - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_integer_4_dim1_ptr(var%nbrs, kgen_unit, printvar=printvar//"%nbrs") - ELSE - CALL kgen_read_integer_4_dim1_ptr(var%nbrs, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_integer_4_dim1_ptr(var%nbrs_face, kgen_unit, printvar=printvar//"%nbrs_face") - ELSE - CALL kgen_read_integer_4_dim1_ptr(var%nbrs_face, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_integer_4_dim1_ptr(var%nbrs_wgt, kgen_unit, printvar=printvar//"%nbrs_wgt") - ELSE - CALL kgen_read_integer_4_dim1_ptr(var%nbrs_wgt, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_integer_4_dim1_ptr(var%nbrs_wgt_ghost, kgen_unit, printvar=printvar//"%nbrs_wgt_ghost") - ELSE - CALL kgen_read_integer_4_dim1_ptr(var%nbrs_wgt_ghost, kgen_unit) - END IF - READ(UNIT=kgen_unit) var%nbrs_ptr - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%nbrs_ptr **", var%nbrs_ptr - END IF - READ(UNIT=kgen_unit) var%face_number - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%face_number **", var%face_number - END IF - READ(UNIT=kgen_unit) var%number - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%number **", var%number - END IF - READ(UNIT=kgen_unit) var%processor_number - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%processor_number **", var%processor_number - END IF - READ(UNIT=kgen_unit) var%spacecurve - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%spacecurve **", var%spacecurve - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_gridvertex_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(gridvertex_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_integer_4_dim1_ptr("nbrs", dtype_check_status, var%nbrs, ref_var%nbrs) - CALL kgen_verify_integer_4_dim1_ptr("nbrs_face", dtype_check_status, var%nbrs_face, ref_var%nbrs_face) - CALL kgen_verify_integer_4_dim1_ptr("nbrs_wgt", dtype_check_status, var%nbrs_wgt, ref_var%nbrs_wgt) - CALL kgen_verify_integer_4_dim1_ptr("nbrs_wgt_ghost", dtype_check_status, var%nbrs_wgt_ghost, ref_var%nbrs_wgt_ghost) - CALL kgen_verify_integer_4_dim1("nbrs_ptr", dtype_check_status, var%nbrs_ptr, ref_var%nbrs_ptr) - CALL kgen_verify_integer("face_number", dtype_check_status, var%face_number, ref_var%face_number) - CALL kgen_verify_integer("number", dtype_check_status, var%number, ref_var%number) - CALL kgen_verify_integer("processor_number", dtype_check_status, var%processor_number, ref_var%processor_number) - CALL kgen_verify_integer("spacecurve", dtype_check_status, var%spacecurve, ref_var%spacecurve) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_integer_4_dim1_ptr( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in), DIMENSION(:), POINTER :: var, ref_var - IF ( ASSOCIATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - end if - - check_status%numFatal = check_status%numFatal+1 - END IF - END IF - END SUBROUTINE kgen_verify_integer_4_dim1_ptr - - SUBROUTINE kgen_verify_integer_4_dim1( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in), DIMENSION(:) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - end if - - check_status%numFatal = check_status%numFatal+1 - END IF - END SUBROUTINE kgen_verify_integer_4_dim1 - - SUBROUTINE kgen_verify_integer( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - END SUBROUTINE kgen_verify_integer - - !====================================================================== - - !====================================================================== - - !====================================================================== - ! ===================================== - ! copy edge: - ! copy device for overloading = sign. - ! ===================================== - - !====================================================================== - - !====================================================================== - - !====================================================================== - - !====================================================================== - !=========================== - ! search edge list for match - !=========================== - - !====================================================================== - - !====================================================================== - - !====================================================================== - - !====================================================================== - - !====================================================================== - - !====================================================================== - ! ========================================== - ! set_GridVertex_neighbors: - ! - ! Set global element number for element elem - ! ========================================== - - !====================================================================== - - !====================================================================== - - !====================================================================== - - !====================================================================== - END MODULE gridgraph_mod diff --git a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/kernel_driver.f90 b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/kernel_driver.f90 deleted file mode 100644 index ace6711a15..0000000000 --- a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/kernel_driver.f90 +++ /dev/null @@ -1,152 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-04-12 19:17:34 -! KGEN version: 0.4.9 - - -PROGRAM kernel_driver - USE viscosity_mod, ONLY : biharmonic_wk_dp3d - USE derivative_mod, ONLY: derivative_t - USE element_mod, ONLY: element_t - USE dimensions_mod, ONLY: np - USE kinds, ONLY: real_kind - USE dimensions_mod, ONLY: nlev - USE control_mod, ONLY : kgen_read_externs_control_mod - USE physconst, ONLY : kgen_read_externs_physconst - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE element_mod, ONLY : kgen_read_mod3 => kgen_read - USE element_mod, ONLY : kgen_verify_mod3 => kgen_verify - USE derivative_mod, ONLY : kgen_read_mod2 => kgen_read - USE derivative_mod, ONLY : kgen_verify_mod2 => kgen_verify - - IMPLICIT NONE - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(1), PARAMETER :: kgen_mpi_rank_at = (/ 0 /) - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(1), PARAMETER :: kgen_counter_at = (/ 1 /) - CHARACTER(LEN=1024) :: kgen_filepath - INTEGER :: nets - INTEGER :: nt - TYPE(derivative_t) :: deriv - INTEGER :: nete - TYPE(element_t), target, allocatable :: elem(:) - REAL(KIND=real_kind), allocatable :: vtens(:,:,:,:,:) - - DO kgen_repeat_counter = 0, 0 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 1)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 1)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - kgen_filepath = "../data/vlaplace_sphere_wk." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "** Verification against '" // trim(adjustl(kgen_filepath)) // "' **" - - CALL kgen_read_externs_control_mod(kgen_unit) - CALL kgen_read_externs_physconst(kgen_unit) - - ! driver variables - READ(UNIT=kgen_unit) nt - READ(UNIT=kgen_unit) nets - READ(UNIT=kgen_unit) nete - CALL kgen_read_real_real_kind_dim5(vtens, kgen_unit) - CALL kgen_read_element_t_dim1(elem, kgen_unit) - CALL kgen_read_mod2(deriv, kgen_unit) - - call biharmonic_wk_dp3d(elem, nt, nets, nete, vtens, deriv, kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_element_t_dim1(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(element_t), INTENT(OUT), ALLOCATABLE, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - DO idx1=kgen_bound(1,1), kgen_bound(2, 1) - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_mod3(var(idx1), kgen_unit, printvar=printvar) - ELSE - CALL kgen_read_mod3(var(idx1), kgen_unit) - END IF - END DO - END IF - END SUBROUTINE kgen_read_element_t_dim1 - - SUBROUTINE kgen_read_real_real_kind_dim5(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=real_kind), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:,:,:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2,idx3,idx4,idx5 - INTEGER, DIMENSION(2,5) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - READ(UNIT = kgen_unit) kgen_bound(1, 4) - READ(UNIT = kgen_unit) kgen_bound(2, 4) - READ(UNIT = kgen_unit) kgen_bound(1, 5) - READ(UNIT = kgen_unit) kgen_bound(2, 5) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1, kgen_bound(2, 4) - kgen_bound(1, 4) + 1, kgen_bound(2, 5) - kgen_bound(1, 5) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_real_kind_dim5 - - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/kgen_utils.f90 b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/kgen_utils.f90 deleted file mode 100644 index cfa8d114e0..0000000000 --- a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/kgen_utils.f90 +++ /dev/null @@ -1,61 +0,0 @@ -module kgen_utils_mod - -INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - -type check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - real(kind=kgen_dp) :: minvalue -end type check_t - -public kgen_dp, check_t, kgen_init_check, kgen_print_check - -contains - -subroutine kgen_init_check(check, tolerance, minvalue) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - real(kind=kgen_dp), intent(in), optional :: minvalue - - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.0D-15 - endif - if(present(minvalue)) then - check%minvalue = minvalue - else - check%minvalue = 1.0D-15 - endif -end subroutine kgen_init_check - -subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif -end subroutine kgen_print_check - -end module diff --git a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/kinds.F90 b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/kinds.F90 deleted file mode 100644 index c534803ce6..0000000000 --- a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/kinds.F90 +++ /dev/null @@ -1,31 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kinds.F90 -! Generated at: 2015-04-12 19:17:34 -! KGEN version: 0.4.9 - - - - MODULE kinds - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: shr_kind_i4 - USE shr_kind_mod, ONLY: shr_kind_i8 - USE shr_kind_mod, ONLY: shr_kind_r8 - ! _EXTERNAL - IMPLICIT NONE - PRIVATE - ! - ! most floating point variables should be of type real_kind = real*8 - ! For higher precision, we also have quad_kind = real*16, but this - ! is only supported on IBM systems - ! - INTEGER(KIND=4), public, parameter :: int_kind = shr_kind_i4 - INTEGER(KIND=4), public, parameter :: real_kind = shr_kind_r8 - INTEGER(KIND=4), public, parameter :: log_kind = kind(.true.) - INTEGER(KIND=4), public, parameter :: long_kind = shr_kind_i8 - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE kinds diff --git a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/parallel_mod.F90 b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/parallel_mod.F90 deleted file mode 100644 index c72a467b5f..0000000000 --- a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/parallel_mod.F90 +++ /dev/null @@ -1,180 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : parallel_mod.F90 -! Generated at: 2015-04-12 19:17:34 -! KGEN version: 0.4.9 - - - - MODULE parallel_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! --------------------------- - ! --------------------------- - IMPLICIT NONE - PUBLIC - ! - ! Copyright (C) 2003-2011 Intel Corporation. All Rights Reserved. - ! - ! The source code contained or described herein and all documents - ! related to the source code ("Material") are owned by Intel Corporation - ! or its suppliers or licensors. Title to the Material remains with - ! Intel Corporation or its suppliers and licensors. The Material is - ! protected by worldwide copyright and trade secret laws and treaty - ! provisions. No part of the Material may be used, copied, reproduced, - ! modified, published, uploaded, posted, transmitted, distributed, or - ! disclosed in any way without Intel's prior express written permission. - ! - ! No license under any patent, copyright, trade secret or other - ! intellectual property right is granted to or conferred upon you by - ! disclosure or delivery of the Materials, either expressly, by - ! implication, inducement, estoppel or otherwise. Any license under - ! such intellectual property rights must be express and approved by - ! Intel in writing. - ! /* -*- Mode: Fortran; -*- */ - ! - ! (C) 2001 by Argonne National Laboratory. - ! - ! MPICH2 COPYRIGHT - ! - ! The following is a notice of limited availability of the code, and disclaimer - ! which must be included in the prologue of the code and in all source listings - ! of the code. - ! - ! Copyright Notice - ! + 2002 University of Chicago - ! - ! Permission is hereby granted to use, reproduce, prepare derivative works, and - ! to redistribute to others. This software was authored by: - ! - ! Argonne National Laboratory Group - ! W. Gropp: (630) 252-4318; FAX: (630) 252-5986; e-mail: gropp@mcs.anl.gov - ! E. Lusk: (630) 252-7852; FAX: (630) 252-5986; e-mail: lusk@mcs.anl.gov - ! Mathematics and Computer Science Division - ! Argonne National Laboratory, Argonne IL 60439 - ! - ! - ! GOVERNMENT LICENSE - ! - ! Portions of this material resulted from work developed under a U.S. - ! Government Contract and are subject to the following license: the Government - ! is granted for itself and others acting on its behalf a paid-up, nonexclusive, - ! irrevocable worldwide license in this computer software to reproduce, prepare - ! derivative works, and perform publicly and display publicly. - ! - ! DISCLAIMER - ! - ! This computer code material was prepared, in part, as an account of work - ! sponsored by an agency of the United States Government. Neither the United - ! States, nor the University of Chicago, nor any of their employees, makes any - ! warranty express or implied, or assumes any legal liability or responsibility - ! for the accuracy, completeness, or usefulness of any information, apparatus, - ! product, or process disclosed, or represents that its use would not infringe - ! privately owned rights. - ! - ! Portions of this code were written by Microsoft. Those portions are - ! Copyright (c) 2007 Microsoft Corporation. Microsoft grants permission to - ! use, reproduce, prepare derivative works, and to redistribute to - ! others. The code is licensed "as is." The User bears the risk of using - ! it. Microsoft gives no express warranties, guarantees or - ! conditions. To the extent permitted by law, Microsoft excludes the - ! implied warranties of merchantability, fitness for a particular - ! purpose and non-infringement. - ! - ! - ! - ! - ! - ! DO NOT EDIT - ! This file created by buildiface - ! - !S-JMD integer, public, allocatable :: recvcount(:),displs(:) - ! ================================================== - ! Define type parallel_t for distributed memory info - ! ================================================== - ! parallel structure for distributed memory programming - ! =================================================== - ! Module Interfaces - ! =================================================== - - PUBLIC abortmp - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - ! ================================================ - ! copy_par: copy constructor for parallel_t type - ! - ! - ! Overload assignment operator for parallel_t - ! ================================================ - - ! ================================================ - ! initmp: - ! Initializes the parallel (message passing) - ! environment, returns a parallel_t structure.. - ! ================================================ - - ! ========================================================= - ! abortmp: - ! - ! Tries to abort the parallel (message passing) environment - ! and prints a message - ! ========================================================= - - SUBROUTINE abortmp(string) - CHARACTER(LEN=*) :: string - !kgen_excluded CALL endrun(string) - END SUBROUTINE abortmp - ! ========================================================= - ! haltmp: - ! - !> stops the parallel (message passing) environment - !! and prints a message. - ! - !> Print the message and call MPI_finalize. - !! @param[in] string The message to be printed. - ! ========================================================= - - ! ========================================================= - ! split: - ! - ! splits the message passing world into components - ! and returns a new parallel structure for the - ! component resident at this process, i.e. lcl_component - ! ========================================================= - - ! ========================================================= - ! connect: - ! - ! connects this MPI component to all others by constructing - ! intercommunicator array and storing it in the local parallel - ! structure lcl_par. Connect assumes you have called split - ! to create the lcl_par structure. - ! - ! ========================================================= - - ! ===================================== - ! syncmp: - ! - ! sychronize message passing domains - ! - ! ===================================== - - ! ============================================= - ! pmin_1d: - ! 1D version of the parallel MIN - ! ============================================= - - ! ============================================= - ! pmax_1d: - ! 1D version of the parallel MAX - ! ============================================= - - ! ============================================= - ! psum_1d: - ! 1D version of the parallel MAX - ! ============================================= - - END MODULE parallel_mod diff --git a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/physconst.F90 b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/physconst.F90 deleted file mode 100644 index d8c4734a39..0000000000 --- a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/physconst.F90 +++ /dev/null @@ -1,92 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : physconst.F90 -! Generated at: 2015-04-12 19:17:34 -! KGEN version: 0.4.9 - - - - MODULE physconst - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! Physical constants. Use CCSM shared values whenever available. - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - USE shr_const_mod, ONLY: shr_const_rearth - ! Dimensions and chunk bounds - IMPLICIT NONE - PRIVATE - ! Constants based off share code or defined in physconst - ! Avogadro's number (molecules/kmole) - ! Boltzman's constant (J/K/molecule) - ! sec in calendar day ~ sec - ! specific heat of dry air (J/K/kg) - ! specific heat of fresh h2o (J/K/kg) - ! Von Karman constant - ! Latent heat of fusion (J/kg) - ! Latent heat of vaporization (J/kg) - ! 3.14... - ! Standard pressure (Pascals) - ! Universal gas constant (J/K/kmol) - ! Density of liquid water (STP) - !special value - ! Stefan-Boltzmann's constant (W/m^2/K^4) - ! Triple point temperature of water (K) - ! Speed of light in a vacuum (m/s) - ! Planck's constant (J.s) - ! Molecular weights - ! molecular weight co2 - ! molecular weight n2o - ! molecular weight ch4 - ! molecular weight cfc11 - ! molecular weight cfc12 - ! molecular weight O3 - ! modifiable physical constants for aquaplanet - ! gravitational acceleration (m/s**2) - ! sec in siderial day ~ sec - ! molecular weight h2o - ! specific heat of water vapor (J/K/kg) - ! molecular weight dry air - ! radius of earth (m) - ! Freezing point of water (K) - !--------------- Variables below here are derived from those above ----------------------- - ! reciprocal of gravit - REAL(KIND=r8), public :: ra = 1._r8/shr_const_rearth ! reciprocal of earth radius - ! earth rot ~ rad/sec - ! Water vapor gas constant ~ J/K/kg - ! Dry air gas constant ~ J/K/kg - ! ratio of h2o to dry air molecular weights - ! (rh2o/rair) - 1 - ! CPWV/CPDAIR - 1.0 - ! density of dry air at STP ~ kg/m^3 - ! R/Cp - ! Coriolis expansion coeff -> omega/sqrt(0.375) - !--------------- Variables below here are for WACCM-X ----------------------- - ! composition dependent specific heat at constant pressure - ! composition dependent gas "constant" - ! rairv/cpairv - ! composition dependent atmosphere mean mass - ! molecular viscosity kg/m/s - ! molecular conductivity J/m/s/K - !--------------- Variables below here are for turbulent mountain stress ----------------------- - !================================================================================================ - PUBLIC kgen_read_externs_physconst - CONTAINS - - ! write subroutines - ! No subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_physconst(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) ra - END SUBROUTINE kgen_read_externs_physconst - - !================================================================================================ - - !============================================================================== - ! Read namelist variables. - - !=============================================================================== - - END MODULE physconst diff --git a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/physical_constants.F90 b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/physical_constants.F90 deleted file mode 100644 index 77b68ab7e2..0000000000 --- a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/physical_constants.F90 +++ /dev/null @@ -1,26 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : physical_constants.F90 -! Generated at: 2015-04-12 19:17:34 -! KGEN version: 0.4.9 - - - - MODULE physical_constants - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! ------------------------------ - USE physconst, ONLY: rrearth => ra ! _EXTERNAL - ! ----------------------------- - IMPLICIT NONE - PRIVATE - ! m s^-2 - ! m - ! s^-1 - ! Pa - PUBLIC rrearth ! m - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE physical_constants diff --git a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/shr_const_mod.F90 b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/shr_const_mod.F90 deleted file mode 100644 index 4126a9260e..0000000000 --- a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/shr_const_mod.F90 +++ /dev/null @@ -1,66 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : shr_const_mod.F90 -! Generated at: 2015-04-12 19:17:34 -! KGEN version: 0.4.9 - - - - MODULE shr_const_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, only : shr_kind_in - USE shr_kind_mod, only : shr_kind_r8 - INTEGER(KIND=shr_kind_in), parameter, private :: r8 = shr_kind_r8 ! rename for local readability only - !---------------------------------------------------------------------------- - ! physical constants (all data public) - !---------------------------------------------------------------------------- - PUBLIC - ! pi - ! sec in calendar day ~ sec - ! sec in siderial day ~ sec - ! earth rot ~ rad/sec - REAL(KIND=r8), parameter :: shr_const_rearth = 6.37122e6_r8 ! radius of earth ~ m - ! acceleration of gravity ~ m/s^2 - ! Stefan-Boltzmann constant ~ W/m^2/K^4 - ! Boltzmann's constant ~ J/K/molecule - ! Avogadro's number ~ molecules/kmole - ! Universal gas constant ~ J/K/kmole - ! molecular weight dry air ~ kg/kmole - ! molecular weight water vapor - ! Dry air gas constant ~ J/K/kg - ! Water vapor gas constant ~ J/K/kg - ! RWV/RDAIR - 1.0 - ! Von Karman constant - ! standard pressure ~ pascals - ! ratio of 13C/12C in Pee Dee Belemnite (C isotope standard) - ! triple point of fresh water ~ K - ! freezing T of fresh water ~ K - ! freezing T of salt water ~ K - ! density of dry air at STP ~ kg/m^3 - ! density of fresh water ~ kg/m^3 - ! density of sea water ~ kg/m^3 - ! density of ice ~ kg/m^3 - ! specific heat of dry air ~ J/kg/K - ! specific heat of water vap ~ J/kg/K - ! CPWV/CPDAIR - 1.0 - ! specific heat of fresh h2o ~ J/kg/K - ! specific heat of sea h2o ~ J/kg/K - ! specific heat of fresh ice ~ J/kg/K - ! latent heat of fusion ~ J/kg - ! latent heat of evaporation ~ J/kg - ! latent heat of sublimation ~ J/kg - ! ocn ref salinity (psu) - ! ice ref salinity (psu) - ! special missing value - ! min spval tolerance - ! max spval tolerance - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !----------------------------------------------------------------------------- - - !----------------------------------------------------------------------------- - END MODULE shr_const_mod diff --git a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/shr_kind_mod.F90 b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/shr_kind_mod.F90 deleted file mode 100644 index 0a4e7acfc7..0000000000 --- a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/shr_kind_mod.F90 +++ /dev/null @@ -1,31 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : shr_kind_mod.F90 -! Generated at: 2015-04-12 19:17:34 -! KGEN version: 0.4.9 - - - - MODULE shr_kind_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - PUBLIC - INTEGER, parameter :: shr_kind_r8 = selected_real_kind(12) ! 8 byte real - ! 4 byte real - ! native real - INTEGER, parameter :: shr_kind_i8 = selected_int_kind (13) ! 8 byte integer - INTEGER, parameter :: shr_kind_i4 = selected_int_kind ( 6) ! 4 byte integer - INTEGER, parameter :: shr_kind_in = kind(1) ! native integer - ! short char - ! mid-sized char - ! long char - ! extra-long char - ! extra-extra-long char - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE shr_kind_mod diff --git a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/viscosity_mod.F90 b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/viscosity_mod.F90 deleted file mode 100644 index b511d89fa9..0000000000 --- a/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/viscosity_mod.F90 +++ /dev/null @@ -1,233 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : viscosity_mod.F90 -! Generated at: 2015-04-12 19:17:34 -! KGEN version: 0.4.9 - - - - MODULE viscosity_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE element_mod, ONLY : kgen_read_mod3 => kgen_read - USE element_mod, ONLY : kgen_verify_mod3 => kgen_verify - USE derivative_mod, ONLY : kgen_read_mod2 => kgen_read - USE derivative_mod, ONLY : kgen_verify_mod2 => kgen_verify - ! - ! This module should be renamed "global_deriv_mod.F90" - ! - ! It is a collection of derivative operators that must be applied to the field - ! over the sphere (as opposed to derivative operators that can be applied element - ! by element) - ! - ! - USE kinds, ONLY: real_kind - USE dimensions_mod, ONLY: np - USE dimensions_mod, ONLY: nlev - USE element_mod, ONLY: element_t - USE derivative_mod, ONLY: vlaplace_sphere_wk - USE derivative_mod, ONLY: derivative_t - IMPLICIT NONE - PUBLIC biharmonic_wk_dp3d - ! - ! compute vorticity/divergence and then project to make continious - ! high-level routines uses only for I/O - - - ! for older versions of sweq which carry - ! velocity around in contra-coordinates - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - - - SUBROUTINE biharmonic_wk_dp3d(elem, nt, nets, nete, vtens, deriv, kgen_unit) - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! compute weak biharmonic operator - ! input: h,v (stored in elem()%, in lat-lon coordinates - ! output: ptens,vtens overwritten with weak biharmonic of h,v (output in lat-lon coordinates) - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - integer, intent(in) :: kgen_unit - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - TYPE(element_t), intent(inout), target :: elem(:) - INTEGER :: nt - INTEGER :: nets - INTEGER :: nete - REAL(KIND=real_kind), dimension(np,np,2,nlev,nets:nete) :: vtens - REAL(KIND=real_kind) :: ref_vtens(np,np,2,nlev,nets:nete) - TYPE(derivative_t), intent(in) :: deriv - ! local - INTEGER :: ie - INTEGER :: k - REAL(KIND=real_kind) :: nu_ratio1 - REAL(KIND=real_kind) :: ref_nu_ratio1 - LOGICAL :: var_coef1 - !if tensor hyperviscosity with tensor V is used, then biharmonic operator is (\grad\cdot V\grad) (\grad \cdot \grad) - !so tensor is only used on second call to laplace_sphere_wk - ! note: there is a scaling bug in the treatment of nu_div - ! nu_ratio is applied twice, once in each laplace operator - ! so in reality: nu_div_actual = (nu_div/nu)**2 nu - ! We should fix this, but it requires adjusting all 1 defaults - tolerance = 1.E-14 - CALL kgen_init_check(check_status, tolerance) - READ(UNIT=kgen_unit) ie - READ(UNIT=kgen_unit) k - READ(UNIT=kgen_unit) nu_ratio1 - READ(UNIT=kgen_unit) var_coef1 - - READ(UNIT=kgen_unit) ref_vtens - READ(UNIT=kgen_unit) ref_nu_ratio1 - - - ! call to kernel - vtens(:, :, :, k, ie) = vlaplace_sphere_wk(elem(ie) % state % v(:, :, :, k, nt), deriv, elem(ie), var_coef = var_coef1, nu_ratio = nu_ratio1) - ! kernel verification for output variables - CALL kgen_verify_real_real_kind_dim5( "vtens", check_status, vtens, ref_vtens) - CALL kgen_verify_real_real_kind( "nu_ratio1", check_status, nu_ratio1, ref_nu_ratio1) - CALL kgen_print_check("vlaplace_sphere_wk", check_status) - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,10 - vtens(:, :, :, k, ie) = vlaplace_sphere_wk(elem(ie) % state % v(:, :, :, k, nt), deriv, elem(ie), var_coef = var_coef1, nu_ratio = nu_ratio1) - END DO - CALL system_clock(stop_clock, rate_clock) - WRITE(*,*) - PRINT *, "Elapsed time (sec): ", (stop_clock - start_clock)/REAL(rate_clock*10) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_real_kind_dim5(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=real_kind), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:,:,:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2,idx3,idx4,idx5 - INTEGER, DIMENSION(2,5) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - READ(UNIT = kgen_unit) kgen_bound(1, 4) - READ(UNIT = kgen_unit) kgen_bound(2, 4) - READ(UNIT = kgen_unit) kgen_bound(1, 5) - READ(UNIT = kgen_unit) kgen_bound(2, 5) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1, kgen_bound(2, 4) - kgen_bound(1, 4) + 1, kgen_bound(2, 5) - kgen_bound(1, 5) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_real_kind_dim5 - - - ! verify subroutines - SUBROUTINE kgen_verify_real_real_kind_dim5( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=real_kind), intent(in), DIMENSION(:,:,:,:,:) :: var, ref_var - real(KIND=real_kind) :: nrmsdiff, rmsdiff - real(KIND=real_kind), allocatable, DIMENSION(:,:,:,:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3),SIZE(var,dim=4),SIZE(var,dim=5))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3),SIZE(var,dim=4),SIZE(var,dim=5))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_real_kind_dim5 - - SUBROUTINE kgen_verify_real_real_kind( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=real_kind), intent(in) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - END SUBROUTINE kgen_verify_real_real_kind - - END SUBROUTINE - - - - - - - - - - - - - - END MODULE diff --git a/test/ncar_kernels/PORT_binterp/CESM_license.txt b/test/ncar_kernels/PORT_binterp/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/PORT_binterp/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/PORT_binterp/data/binterp.1.0 b/test/ncar_kernels/PORT_binterp/data/binterp.1.0 deleted file mode 100644 index 2136099db3..0000000000 Binary files a/test/ncar_kernels/PORT_binterp/data/binterp.1.0 and /dev/null differ diff --git a/test/ncar_kernels/PORT_binterp/data/binterp.1.1 b/test/ncar_kernels/PORT_binterp/data/binterp.1.1 deleted file mode 100644 index a2c28268a6..0000000000 Binary files a/test/ncar_kernels/PORT_binterp/data/binterp.1.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_binterp/data/binterp.1.2 b/test/ncar_kernels/PORT_binterp/data/binterp.1.2 deleted file mode 100644 index f19e429fe0..0000000000 Binary files a/test/ncar_kernels/PORT_binterp/data/binterp.1.2 and /dev/null differ diff --git a/test/ncar_kernels/PORT_binterp/inc/t1.mk b/test/ncar_kernels/PORT_binterp/inc/t1.mk deleted file mode 100644 index 96f2c957e5..0000000000 --- a/test/ncar_kernels/PORT_binterp/inc/t1.mk +++ /dev/null @@ -1,55 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# - -# PGI default flags -# -# FC_FLAGS := -fast -# -# Intel default flags -# -# FC_FFLAGS := -O3 -xAVX -ftz -ip -no-fp-port -fp-model fast -no-prec-div -# -no-prec -sqrt -override-limits -align array64byte -# -DCPRINTEL -mkl -# -# -FC_FLAGS := $(OPT) -FC_FLAGS += -Mnofma - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - -ALL_OBJS := kernel_binterp.o - -all: build run verify - -verify: - @(grep "FAIL" $(TEST).rslt && echo "FAILED") || (grep "PASSED" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt | grep -v "PASSED" - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_binterp.o: $(SRC_DIR)/kernel_binterp.F90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f *.exe *.mod *.o *.rslt diff --git a/test/ncar_kernels/PORT_binterp/lit/runmake b/test/ncar_kernels/PORT_binterp/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/PORT_binterp/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/PORT_binterp/lit/t1.sh b/test/ncar_kernels/PORT_binterp/lit/t1.sh deleted file mode 100644 index 33c953a156..0000000000 --- a/test/ncar_kernels/PORT_binterp/lit/t1.sh +++ /dev/null @@ -1,9 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -# Shared lit script for each tests. Run bash commands that run tests with make. - -# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t -# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/PORT_binterp/makefile b/test/ncar_kernels/PORT_binterp/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/PORT_binterp/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/PORT_binterp/src/kernel_binterp.F90 b/test/ncar_kernels/PORT_binterp/src/kernel_binterp.F90 deleted file mode 100644 index 28cd30a0e6..0000000000 --- a/test/ncar_kernels/PORT_binterp/src/kernel_binterp.F90 +++ /dev/null @@ -1,528 +0,0 @@ - MODULE resolvers - - ! RESOLVER SPECS - INTEGER, PARAMETER :: r8 = selected_real_kind(12) - INTEGER, PARAMETER :: pcols = 16 - INTEGER, PARAMETER :: ncoef = 5 - INTEGER, PARAMETER :: prefr = 7 - INTEGER, PARAMETER :: prefi = 10 - - END MODULE - - PROGRAM kernel_binterp - USE resolvers - USE omp_lib - IMPLICIT NONE - - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_mpi_rank_at = (/ 0,1,2 /) - INTEGER :: kgen_ierr, kgen_unit, kgen_get_newunit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(1), PARAMETER :: kgen_counter_at = (/ 1 /) - CHARACTER(LEN=1024) :: kgen_filepath - INTEGER, DIMENSION(2,10) :: kgen_bound - - ! DRIVER SPECS - - DO kgen_repeat_counter = 1, 1 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 1)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - - kgen_filepath = "../data/binterp." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit(kgen_mpi_rank+kgen_counter) - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - ! READ DRIVER INSTATE - - - ! KERNEL DRIVER RUN - CALL kernel_driver(kgen_unit) - CLOSE (UNIT=kgen_unit) - - END DO - END PROGRAM kernel_binterp - - ! KERNEL DRIVER SUBROUTINE - SUBROUTINE kernel_driver(kgen_unit) - USE resolvers - - IMPLICIT NONE - INTEGER, INTENT(IN) :: kgen_unit - INTEGER, DIMENSION(2,10) :: kgen_bound - - ! STATE SPECS - INTEGER :: itab(pcols) - REAL(KIND = r8) :: refr(pcols) - REAL(KIND = r8) :: cext(pcols, ncoef) - REAL(KIND = r8) :: utab(pcols) - REAL(KIND = r8), POINTER :: refitabsw(:, :) - REAL(KIND = r8), POINTER :: refrtabsw(:, :) - REAL(KIND = r8) :: ttab(pcols) - REAL(KIND = r8) :: refi(pcols) - INTEGER :: ncol - INTEGER :: jtab(pcols) - REAL(KIND = r8), POINTER :: extpsw(:, :, :, :) - INTEGER :: outstate_itab(pcols) - REAL(KIND = r8) :: outstate_refr(pcols) - REAL(KIND = r8) :: outstate_cext(pcols, ncoef) - REAL(KIND = r8) :: outstate_utab(pcols) - REAL(KIND = r8), POINTER :: outstate_refitabsw(:, :) - REAL(KIND = r8), POINTER :: outstate_refrtabsw(:, :) - REAL(KIND = r8) :: outstate_ttab(pcols) - REAL(KIND = r8) :: outstate_refi(pcols) - INTEGER :: outstate_ncol - INTEGER :: outstate_jtab(pcols) - REAL(KIND = r8), POINTER :: outstate_extpsw(:, :, :, :) - - !JMD manual timer additions - integer*8 c1,c2,cr,cm - real*8 dt - integer :: itmax=10000 - character(len=80), parameter :: kname='[kernel_binterp]' - integer :: it - !JMD - integer :: i, j - - LOGICAL :: lstatus = .TRUE. - - ! READ CALLER INSTATE - READ(UNIT = kgen_unit) itab - READ(UNIT = kgen_unit) refr - READ(UNIT = kgen_unit) cext - READ(UNIT = kgen_unit) utab - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(refitabsw(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) refitabsw - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(refrtabsw(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) refrtabsw - READ(UNIT = kgen_unit) ttab - READ(UNIT = kgen_unit) refi - READ(UNIT = kgen_unit) ncol - READ(UNIT = kgen_unit) jtab - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - READ(UNIT = kgen_unit) kgen_bound(1, 4) - READ(UNIT = kgen_unit) kgen_bound(2, 4) - ALLOCATE(extpsw(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1, kgen_bound(2, 4) - kgen_bound(1, 4) + 1)) - READ(UNIT = kgen_unit) extpsw - ! READ CALLEE INSTATE - - ! READ CALLEE OUTSTATE - - ! READ CALLER OUTSTATE - - READ(UNIT = kgen_unit) outstate_itab - READ(UNIT = kgen_unit) outstate_refr - READ(UNIT = kgen_unit) outstate_cext - READ(UNIT = kgen_unit) outstate_utab - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(outstate_refitabsw(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) outstate_refitabsw - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(outstate_refrtabsw(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) outstate_refrtabsw - READ(UNIT = kgen_unit) outstate_ttab - READ(UNIT = kgen_unit) outstate_refi - READ(UNIT = kgen_unit) outstate_ncol - READ(UNIT = kgen_unit) outstate_jtab - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - READ(UNIT = kgen_unit) kgen_bound(1, 4) - READ(UNIT = kgen_unit) kgen_bound(2, 4) - ALLOCATE(outstate_extpsw(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1, kgen_bound(2, 4) - kgen_bound(1, 4) + 1)) - READ(UNIT = kgen_unit) outstate_extpsw - - call system_clock(c1,cr,cm) - ! KERNEL RUN - do it=1,itmax - CALL binterp(extpsw, ncol, ncoef, prefr, prefi, refr, refi, refrtabsw, refitabsw, itab, jtab, ttab, utab, cext) - enddo - call system_clock(c2,cr,cm) - dt = dble(c2-c1)/dble(cr) - print *, TRIM(kname), ' total time (sec): ',dt - print *, TRIM(kname), ' time per call (usec): ',1.e6*dt/dble(itmax) - - - ! STATE VERIFICATION - IF ( ALL( outstate_itab == itab ) ) THEN - WRITE(*,*) "itab is IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_itab - !WRITE(*,*) "KERNEL: ", itab - IF ( ALL( outstate_itab == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - lstatus = .FALSE. - WRITE(*,*) "itab is NOT IDENTICAL." - WRITE(*,*) count( outstate_itab /= itab), " of ", size( itab ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_itab - itab)**2)/real(size(outstate_itab))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_itab - itab)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_itab - itab)) - WRITE(*,*) "Mean value of kernel-generated outstate_itab is ", sum(itab)/real(size(itab)) - WRITE(*,*) "Mean value of original outstate_itab is ", sum(outstate_itab)/real(size(outstate_itab)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_refr == refr ) ) THEN - WRITE(*,*) "refr is IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_refr - !WRITE(*,*) "KERNEL: ", refr - IF ( ALL( outstate_refr == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - lstatus = .FALSE. - WRITE(*,*) "refr is NOT IDENTICAL." - WRITE(*,*) count( outstate_refr /= refr), " of ", size( refr ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_refr - refr)**2)/real(size(outstate_refr))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_refr - refr)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_refr - refr)) - WRITE(*,*) "Mean value of kernel-generated outstate_refr is ", sum(refr)/real(size(refr)) - WRITE(*,*) "Mean value of original outstate_refr is ", sum(outstate_refr)/real(size(outstate_refr)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_cext == cext ) ) THEN - WRITE(*,*) "cext is IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_cext - !WRITE(*,*) "KERNEL: ", cext - IF ( ALL( outstate_cext == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - lstatus = .FALSE. - WRITE(*,*) "cext is NOT IDENTICAL." - WRITE(*,*) count( outstate_cext /= cext), " of ", size( cext ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_cext - cext)**2)/real(size(outstate_cext))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_cext - cext)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_cext - cext)) - WRITE(*,*) "Mean value of kernel-generated outstate_cext is ", sum(cext)/real(size(cext)) - WRITE(*,*) "Mean value of original outstate_cext is ", sum(outstate_cext)/real(size(outstate_cext)) - WRITE(*,*) "" - do j = 1, ncoef - do i = 1, pcols - if (cext(i,j) /= outstate_cext(i,j)) then - print '("cext(", i3, ",", i3, ")=", 2(1x, z16))', i, j, cext(i,j), outstate_cext(i,j) - end if - end do - end do - END IF - IF ( ALL( outstate_utab == utab ) ) THEN - WRITE(*,*) "utab is IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_utab - !WRITE(*,*) "KERNEL: ", utab - IF ( ALL( outstate_utab == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - lstatus = .FALSE. - WRITE(*,*) "utab is NOT IDENTICAL." - WRITE(*,*) count( outstate_utab /= utab), " of ", size( utab ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_utab - utab)**2)/real(size(outstate_utab))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_utab - utab)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_utab - utab)) - WRITE(*,*) "Mean value of kernel-generated outstate_utab is ", sum(utab)/real(size(utab)) - WRITE(*,*) "Mean value of original outstate_utab is ", sum(outstate_utab)/real(size(outstate_utab)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_refitabsw == refitabsw ) ) THEN - WRITE(*,*) "refitabsw is IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_refitabsw - !WRITE(*,*) "KERNEL: ", refitabsw - IF ( ALL( outstate_refitabsw == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - lstatus = .FALSE. - WRITE(*,*) "refitabsw is NOT IDENTICAL." - WRITE(*,*) count( outstate_refitabsw /= refitabsw), " of ", size( refitabsw ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_refitabsw - refitabsw)**2)/real(size(outstate_refitabsw))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_refitabsw - refitabsw)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_refitabsw - refitabsw)) - WRITE(*,*) "Mean value of kernel-generated outstate_refitabsw is ", sum(refitabsw)/real(size(refitabsw)) - WRITE(*,*) "Mean value of original outstate_refitabsw is ", sum(outstate_refitabsw)/real(size(outstate_refitabsw)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_refrtabsw == refrtabsw ) ) THEN - WRITE(*,*) "refrtabsw is IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_refrtabsw - !WRITE(*,*) "KERNEL: ", refrtabsw - IF ( ALL( outstate_refrtabsw == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - lstatus = .FALSE. - WRITE(*,*) "refrtabsw is NOT IDENTICAL." - WRITE(*,*) count( outstate_refrtabsw /= refrtabsw), " of ", size( refrtabsw ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_refrtabsw - refrtabsw)**2)/real(size(outstate_refrtabsw))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_refrtabsw - refrtabsw)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_refrtabsw - refrtabsw)) - WRITE(*,*) "Mean value of kernel-generated outstate_refrtabsw is ", sum(refrtabsw)/real(size(refrtabsw)) - WRITE(*,*) "Mean value of original outstate_refrtabsw is ", sum(outstate_refrtabsw)/real(size(outstate_refrtabsw)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_ttab == ttab ) ) THEN - WRITE(*,*) "ttab is IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_ttab - !WRITE(*,*) "KERNEL: ", ttab - IF ( ALL( outstate_ttab == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - lstatus = .FALSE. - WRITE(*,*) "ttab is NOT IDENTICAL." - WRITE(*,*) count( outstate_ttab /= ttab), " of ", size( ttab ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_ttab - ttab)**2)/real(size(outstate_ttab))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_ttab - ttab)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_ttab - ttab)) - WRITE(*,*) "Mean value of kernel-generated outstate_ttab is ", sum(ttab)/real(size(ttab)) - WRITE(*,*) "Mean value of original outstate_ttab is ", sum(outstate_ttab)/real(size(outstate_ttab)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_refi == refi ) ) THEN - WRITE(*,*) "refi is IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_refi - !WRITE(*,*) "KERNEL: ", refi - IF ( ALL( outstate_refi == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - lstatus = .FALSE. - WRITE(*,*) "refi is NOT IDENTICAL." - WRITE(*,*) count( outstate_refi /= refi), " of ", size( refi ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_refi - refi)**2)/real(size(outstate_refi))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_refi - refi)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_refi - refi)) - WRITE(*,*) "Mean value of kernel-generated outstate_refi is ", sum(refi)/real(size(refi)) - WRITE(*,*) "Mean value of original outstate_refi is ", sum(outstate_refi)/real(size(outstate_refi)) - WRITE(*,*) "" - END IF - IF ( outstate_ncol == ncol ) THEN - WRITE(*,*) "ncol is IDENTICAL." - WRITE(*,*) "STATE : ", outstate_ncol - WRITE(*,*) "KERNEL: ", ncol - ELSE - lstatus = .FALSE. - WRITE(*,*) "ncol is NOT IDENTICAL." - WRITE(*,*) "STATE : ", outstate_ncol - WRITE(*,*) "KERNEL: ", ncol - END IF - IF ( ALL( outstate_jtab == jtab ) ) THEN - WRITE(*,*) "jtab is IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_jtab - !WRITE(*,*) "KERNEL: ", jtab - IF ( ALL( outstate_jtab == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - lstatus = .FALSE. - WRITE(*,*) "jtab is NOT IDENTICAL." - WRITE(*,*) count( outstate_jtab /= jtab), " of ", size( jtab ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_jtab - jtab)**2)/real(size(outstate_jtab))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_jtab - jtab)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_jtab - jtab)) - WRITE(*,*) "Mean value of kernel-generated outstate_jtab is ", sum(jtab)/real(size(jtab)) - WRITE(*,*) "Mean value of original outstate_jtab is ", sum(outstate_jtab)/real(size(outstate_jtab)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_extpsw == extpsw ) ) THEN - WRITE(*,*) "extpsw is IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_extpsw - !WRITE(*,*) "KERNEL: ", extpsw - IF ( ALL( outstate_extpsw == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - lstatus = .FALSE. - WRITE(*,*) "extpsw is NOT IDENTICAL." - WRITE(*,*) count( outstate_extpsw /= extpsw), " of ", size( extpsw ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_extpsw - extpsw)**2)/real(size(outstate_extpsw))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_extpsw - extpsw)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_extpsw - extpsw)) - WRITE(*,*) "Mean value of kernel-generated outstate_extpsw is ", sum(extpsw)/real(size(extpsw)) - WRITE(*,*) "Mean value of original outstate_extpsw is ", sum(outstate_extpsw)/real(size(outstate_extpsw)) - WRITE(*,*) "" - END IF - - IF ( lstatus ) THEN - WRITE(*,*) "PASSED" - ELSE - WRITE(*,*) "FAILED" - END IF - - ! DEALLOCATE INSTATE - DEALLOCATE(refitabsw) - DEALLOCATE(refrtabsw) - DEALLOCATE(extpsw) - - ! DEALLOCATE OUTSTATE - DEALLOCATE(outstate_refitabsw) - DEALLOCATE(outstate_refrtabsw) - DEALLOCATE(outstate_extpsw) - ! DEALLOCATE CALLEE INSTATE - - ! DEALLOCATE INSTATE - ! DEALLOCATE CALEE OUTSTATE - - ! DEALLOCATE OUTSTATE - - CONTAINS - - - ! KERNEL SUBPROGRAM - subroutine binterp(table,ncol,km,im,jm,x,y,xtab,ytab,ix,jy,t,u,out) - - ! bilinear interpolation of table - ! - implicit none - integer im,jm,km,ncol - real(r8) table(km,im,jm),xtab(im),ytab(jm),out(pcols,km) - integer i,ix(pcols),ip1,j,jy(pcols),jp1,k,ic - real(r8) x(pcols),dx,t(pcols),y(pcols),dy,u(pcols),tu(pcols),tuc(pcols),tcu(pcols),tcuc(pcols) - real(r8) temp1,temp2,temp3,temp4 - common/tu/tu - common/tuc/tuc - common/tcu/tcu - common/tcuc/tcuc -!dir$ assume_aligned table:64 -!dir$ assume_aligned xtab:64 -!dir$ assume_aligned ytab:64 -!dir$ assume_aligned out:64 -!dir$ assume_aligned ix:64 -!dir$ assume_aligned jy:64 -!dir$ assume_aligned x:64 -!dir$ assume_aligned t:64 -!dir$ assume_aligned tu:64 -!dir$ assume_aligned y:64 -!dir$ assume_aligned u:64 -!dir$ assume_aligned tuc:64 -!dir$ assume_aligned tcu:64 -!dir$ assume_aligned tcuc:64 - !print *,km - if(ix(1).gt.0) go to 30 - if(im.gt.1)then -!dir$ SIMD - do ic=1,ncol - do i=1,im - if(x(ic).lt.xtab(i))go to 10 - enddo - 10 ix(ic)=max0(i-1,1) - ip1=min(ix(ic)+1,im) - dx=(xtab(ip1)-xtab(ix(ic))) - if(abs(dx).gt.1.e-20_r8)then - t(ic)=(x(ic)-xtab(ix(ic)))/dx - else - t(ic)=0._r8 - endif - end do - else - ix(:ncol)=1 - t(:ncol)=0._r8 - endif - if(jm.gt.1)then -!dir$ SIMD - do ic=1,ncol - do j=1,jm - if(y(ic).lt.ytab(j))go to 20 - enddo - 20 jy(ic)=max0(j-1,1) - jp1=min(jy(ic)+1,jm) - dy=(ytab(jp1)-ytab(jy(ic))) - if(abs(dy).gt.1.e-20_r8)then - u(ic)=(y(ic)-ytab(jy(ic)))/dy - else - u(ic)=0._r8 - endif - end do - else - jy(:ncol)=1 - u(:ncol)=0._r8 - endif - 30 continue -!Do not use SIMD here - do ic=1,ncol - tu(ic)=t(ic)*u(ic) - tuc(ic)=t(ic)-tu(ic) - tcuc(ic)=1._r8-tuc(ic)-u(ic) - tcu(ic)=u(ic)-tu(ic) - jp1=min(jy(ic)+1,jm) - ip1=min(ix(ic)+1,im) -!dir$ SIMD - do k=1,km -! -! The kernel test came with the following computation of the output array -! 'out': -! out(ic,k) = tcuc(ic) * table(k,ix(ic),jy(ic)) + tuc(ic) * table(k,ip1,jy(ic)) + tu(ic) * table(k,ip1,jp1) + tcu(ic) * table(k,ix(ic),jp1) -! -! Certain values of the array 'out' do not match the reference output for -! reasons: -! 1) Default compiler option for Intel processors that have an FMA unit -! is to generate FMA instructions. -! 2) Without parentheses, the compiler is free to reorder the evaluation -! of the expression. -! -! In order to not have to add logic to compute relative differences or RMZ -! values, parentheses have been added to get the kernel to and compare bit -! for bit against the reference data. -! - out(ic,k) = ((((tcuc(ic) * table(k,ix(ic),jy(ic))) + tuc(ic) * table(k,ip1,jy(ic))) + tu(ic) * table(k,ip1,jp1)) + tcu(ic) * table(k,ix(ic),jp1)) - end do - enddo - return - end subroutine binterp - - END SUBROUTINE kernel_driver - - - FUNCTION kgen_get_newunit(seed) RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - INTEGER, INTENT(IN) :: seed - - new_unit = -1 - - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE diff --git a/test/ncar_kernels/PORT_binterp/src_orig/kernel_binterp.F90 b/test/ncar_kernels/PORT_binterp/src_orig/kernel_binterp.F90 deleted file mode 100644 index 734fa5af1a..0000000000 --- a/test/ncar_kernels/PORT_binterp/src_orig/kernel_binterp.F90 +++ /dev/null @@ -1,481 +0,0 @@ - MODULE resolvers - - ! RESOLVER SPECS - INTEGER, PARAMETER :: r8 = selected_real_kind(12) - INTEGER, PARAMETER :: pcols = 16 - INTEGER, PARAMETER :: ncoef = 5 - INTEGER, PARAMETER :: prefr = 7 - INTEGER, PARAMETER :: prefi = 10 - - END MODULE - - PROGRAM kernel_binterp - USE resolvers - USE omp_lib - IMPLICIT NONE - - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_mpi_rank_at = (/ 0,1,2 /) - INTEGER :: kgen_ierr, kgen_unit, kgen_get_newunit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(1), PARAMETER :: kgen_counter_at = (/ 1 /) - CHARACTER(LEN=1024) :: kgen_filepath - INTEGER, DIMENSION(2,10) :: kgen_bound - - ! DRIVER SPECS - - DO kgen_repeat_counter = 1, 1 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 1)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - - kgen_filepath = "../data/binterp." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit(kgen_mpi_rank+kgen_counter) - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - ! READ DRIVER INSTATE - - - ! KERNEL DRIVER RUN - CALL kernel_driver(kgen_unit) - CLOSE (UNIT=kgen_unit) - - END DO - END PROGRAM kernel_binterp - - ! KERNEL DRIVER SUBROUTINE - SUBROUTINE kernel_driver(kgen_unit) - USE resolvers - - IMPLICIT NONE - INTEGER, INTENT(IN) :: kgen_unit - INTEGER, DIMENSION(2,10) :: kgen_bound - - ! STATE SPECS - INTEGER :: itab(pcols) - REAL(KIND = r8) :: refr(pcols) - REAL(KIND = r8) :: cext(pcols, ncoef) - REAL(KIND = r8) :: utab(pcols) - REAL(KIND = r8), POINTER :: refitabsw(:, :) - REAL(KIND = r8), POINTER :: refrtabsw(:, :) - REAL(KIND = r8) :: ttab(pcols) - REAL(KIND = r8) :: refi(pcols) - INTEGER :: ncol - INTEGER :: jtab(pcols) - REAL(KIND = r8), POINTER :: extpsw(:, :, :, :) - INTEGER :: outstate_itab(pcols) - REAL(KIND = r8) :: outstate_refr(pcols) - REAL(KIND = r8) :: outstate_cext(pcols, ncoef) - REAL(KIND = r8) :: outstate_utab(pcols) - REAL(KIND = r8), POINTER :: outstate_refitabsw(:, :) - REAL(KIND = r8), POINTER :: outstate_refrtabsw(:, :) - REAL(KIND = r8) :: outstate_ttab(pcols) - REAL(KIND = r8) :: outstate_refi(pcols) - INTEGER :: outstate_ncol - INTEGER :: outstate_jtab(pcols) - REAL(KIND = r8), POINTER :: outstate_extpsw(:, :, :, :) - - !JMD manual timer additions - integer*8 c1,c2,cr,cm - real*8 dt - integer :: itmax=10000 - character(len=80), parameter :: kname='[kernel_binterp]' - integer :: it - !JMD - - ! READ CALLER INSTATE - READ(UNIT = kgen_unit) itab - READ(UNIT = kgen_unit) refr - READ(UNIT = kgen_unit) cext - READ(UNIT = kgen_unit) utab - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(refitabsw(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) refitabsw - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(refrtabsw(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) refrtabsw - READ(UNIT = kgen_unit) ttab - READ(UNIT = kgen_unit) refi - READ(UNIT = kgen_unit) ncol - READ(UNIT = kgen_unit) jtab - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - READ(UNIT = kgen_unit) kgen_bound(1, 4) - READ(UNIT = kgen_unit) kgen_bound(2, 4) - ALLOCATE(extpsw(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1, kgen_bound(2, 4) - kgen_bound(1, 4) + 1)) - READ(UNIT = kgen_unit) extpsw - ! READ CALLEE INSTATE - - ! READ CALLEE OUTSTATE - - ! READ CALLER OUTSTATE - - READ(UNIT = kgen_unit) outstate_itab - READ(UNIT = kgen_unit) outstate_refr - READ(UNIT = kgen_unit) outstate_cext - READ(UNIT = kgen_unit) outstate_utab - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(outstate_refitabsw(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) outstate_refitabsw - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(outstate_refrtabsw(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) outstate_refrtabsw - READ(UNIT = kgen_unit) outstate_ttab - READ(UNIT = kgen_unit) outstate_refi - READ(UNIT = kgen_unit) outstate_ncol - READ(UNIT = kgen_unit) outstate_jtab - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - READ(UNIT = kgen_unit) kgen_bound(1, 4) - READ(UNIT = kgen_unit) kgen_bound(2, 4) - ALLOCATE(outstate_extpsw(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1, kgen_bound(2, 4) - kgen_bound(1, 4) + 1)) - READ(UNIT = kgen_unit) outstate_extpsw - - call system_clock(c1,cr,cm) - ! KERNEL RUN - do it=1,itmax - CALL binterp(extpsw, ncol, ncoef, prefr, prefi, refr, refi, refrtabsw, refitabsw, itab, jtab, ttab, utab, cext) - enddo - call system_clock(c2,cr,cm) - dt = dble(c2-c1)/dble(cr) - print *, TRIM(kname), ' total time (sec): ',dt - print *, TRIM(kname), ' time per call (usec): ',1.e6*dt/dble(itmax) - - - ! STATE VERIFICATION - IF ( ALL( outstate_itab == itab ) ) THEN - WRITE(*,*) "itab is IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_itab - !WRITE(*,*) "KERNEL: ", itab - IF ( ALL( outstate_itab == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "itab is NOT IDENTICAL." - WRITE(*,*) count( outstate_itab /= itab), " of ", size( itab ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_itab - itab)**2)/real(size(outstate_itab))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_itab - itab)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_itab - itab)) - WRITE(*,*) "Mean value of kernel-generated outstate_itab is ", sum(itab)/real(size(itab)) - WRITE(*,*) "Mean value of original outstate_itab is ", sum(outstate_itab)/real(size(outstate_itab)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_refr == refr ) ) THEN - WRITE(*,*) "refr is IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_refr - !WRITE(*,*) "KERNEL: ", refr - IF ( ALL( outstate_refr == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "refr is NOT IDENTICAL." - WRITE(*,*) count( outstate_refr /= refr), " of ", size( refr ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_refr - refr)**2)/real(size(outstate_refr))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_refr - refr)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_refr - refr)) - WRITE(*,*) "Mean value of kernel-generated outstate_refr is ", sum(refr)/real(size(refr)) - WRITE(*,*) "Mean value of original outstate_refr is ", sum(outstate_refr)/real(size(outstate_refr)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_cext == cext ) ) THEN - WRITE(*,*) "cext is IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_cext - !WRITE(*,*) "KERNEL: ", cext - IF ( ALL( outstate_cext == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "cext is NOT IDENTICAL." - WRITE(*,*) count( outstate_cext /= cext), " of ", size( cext ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_cext - cext)**2)/real(size(outstate_cext))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_cext - cext)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_cext - cext)) - WRITE(*,*) "Mean value of kernel-generated outstate_cext is ", sum(cext)/real(size(cext)) - WRITE(*,*) "Mean value of original outstate_cext is ", sum(outstate_cext)/real(size(outstate_cext)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_utab == utab ) ) THEN - WRITE(*,*) "utab is IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_utab - !WRITE(*,*) "KERNEL: ", utab - IF ( ALL( outstate_utab == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "utab is NOT IDENTICAL." - WRITE(*,*) count( outstate_utab /= utab), " of ", size( utab ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_utab - utab)**2)/real(size(outstate_utab))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_utab - utab)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_utab - utab)) - WRITE(*,*) "Mean value of kernel-generated outstate_utab is ", sum(utab)/real(size(utab)) - WRITE(*,*) "Mean value of original outstate_utab is ", sum(outstate_utab)/real(size(outstate_utab)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_refitabsw == refitabsw ) ) THEN - WRITE(*,*) "refitabsw is IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_refitabsw - !WRITE(*,*) "KERNEL: ", refitabsw - IF ( ALL( outstate_refitabsw == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "refitabsw is NOT IDENTICAL." - WRITE(*,*) count( outstate_refitabsw /= refitabsw), " of ", size( refitabsw ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_refitabsw - refitabsw)**2)/real(size(outstate_refitabsw))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_refitabsw - refitabsw)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_refitabsw - refitabsw)) - WRITE(*,*) "Mean value of kernel-generated outstate_refitabsw is ", sum(refitabsw)/real(size(refitabsw)) - WRITE(*,*) "Mean value of original outstate_refitabsw is ", sum(outstate_refitabsw)/real(size(outstate_refitabsw)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_refrtabsw == refrtabsw ) ) THEN - WRITE(*,*) "refrtabsw is IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_refrtabsw - !WRITE(*,*) "KERNEL: ", refrtabsw - IF ( ALL( outstate_refrtabsw == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "refrtabsw is NOT IDENTICAL." - WRITE(*,*) count( outstate_refrtabsw /= refrtabsw), " of ", size( refrtabsw ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_refrtabsw - refrtabsw)**2)/real(size(outstate_refrtabsw))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_refrtabsw - refrtabsw)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_refrtabsw - refrtabsw)) - WRITE(*,*) "Mean value of kernel-generated outstate_refrtabsw is ", sum(refrtabsw)/real(size(refrtabsw)) - WRITE(*,*) "Mean value of original outstate_refrtabsw is ", sum(outstate_refrtabsw)/real(size(outstate_refrtabsw)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_ttab == ttab ) ) THEN - WRITE(*,*) "ttab is IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_ttab - !WRITE(*,*) "KERNEL: ", ttab - IF ( ALL( outstate_ttab == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "ttab is NOT IDENTICAL." - WRITE(*,*) count( outstate_ttab /= ttab), " of ", size( ttab ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_ttab - ttab)**2)/real(size(outstate_ttab))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_ttab - ttab)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_ttab - ttab)) - WRITE(*,*) "Mean value of kernel-generated outstate_ttab is ", sum(ttab)/real(size(ttab)) - WRITE(*,*) "Mean value of original outstate_ttab is ", sum(outstate_ttab)/real(size(outstate_ttab)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_refi == refi ) ) THEN - WRITE(*,*) "refi is IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_refi - !WRITE(*,*) "KERNEL: ", refi - IF ( ALL( outstate_refi == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "refi is NOT IDENTICAL." - WRITE(*,*) count( outstate_refi /= refi), " of ", size( refi ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_refi - refi)**2)/real(size(outstate_refi))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_refi - refi)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_refi - refi)) - WRITE(*,*) "Mean value of kernel-generated outstate_refi is ", sum(refi)/real(size(refi)) - WRITE(*,*) "Mean value of original outstate_refi is ", sum(outstate_refi)/real(size(outstate_refi)) - WRITE(*,*) "" - END IF - IF ( outstate_ncol == ncol ) THEN - WRITE(*,*) "ncol is IDENTICAL." - WRITE(*,*) "STATE : ", outstate_ncol - WRITE(*,*) "KERNEL: ", ncol - ELSE - WRITE(*,*) "ncol is NOT IDENTICAL." - WRITE(*,*) "STATE : ", outstate_ncol - WRITE(*,*) "KERNEL: ", ncol - END IF - IF ( ALL( outstate_jtab == jtab ) ) THEN - WRITE(*,*) "jtab is IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_jtab - !WRITE(*,*) "KERNEL: ", jtab - IF ( ALL( outstate_jtab == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "jtab is NOT IDENTICAL." - WRITE(*,*) count( outstate_jtab /= jtab), " of ", size( jtab ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_jtab - jtab)**2)/real(size(outstate_jtab))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_jtab - jtab)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_jtab - jtab)) - WRITE(*,*) "Mean value of kernel-generated outstate_jtab is ", sum(jtab)/real(size(jtab)) - WRITE(*,*) "Mean value of original outstate_jtab is ", sum(outstate_jtab)/real(size(outstate_jtab)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_extpsw == extpsw ) ) THEN - WRITE(*,*) "extpsw is IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_extpsw - !WRITE(*,*) "KERNEL: ", extpsw - IF ( ALL( outstate_extpsw == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "extpsw is NOT IDENTICAL." - WRITE(*,*) count( outstate_extpsw /= extpsw), " of ", size( extpsw ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_extpsw - extpsw)**2)/real(size(outstate_extpsw))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_extpsw - extpsw)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_extpsw - extpsw)) - WRITE(*,*) "Mean value of kernel-generated outstate_extpsw is ", sum(extpsw)/real(size(extpsw)) - WRITE(*,*) "Mean value of original outstate_extpsw is ", sum(outstate_extpsw)/real(size(outstate_extpsw)) - WRITE(*,*) "" - END IF - - ! DEALLOCATE INSTATE - DEALLOCATE(refitabsw) - DEALLOCATE(refrtabsw) - DEALLOCATE(extpsw) - - ! DEALLOCATE OUTSTATE - DEALLOCATE(outstate_refitabsw) - DEALLOCATE(outstate_refrtabsw) - DEALLOCATE(outstate_extpsw) - ! DEALLOCATE CALLEE INSTATE - - ! DEALLOCATE INSTATE - ! DEALLOCATE CALEE OUTSTATE - - ! DEALLOCATE OUTSTATE - - CONTAINS - - - ! KERNEL SUBPROGRAM - subroutine binterp(table,ncol,km,im,jm,x,y,xtab,ytab,ix,jy,t,u,out) - - ! bilinear interpolation of table - ! - implicit none - integer im,jm,km,ncol - real(r8) table(km,im,jm),xtab(im),ytab(jm),out(pcols,km) - integer i,ix(pcols),ip1,j,jy(pcols),jp1,k,ic - real(r8) x(pcols),dx,t(pcols),y(pcols),dy,u(pcols),tu(pcols),tuc(pcols),tcu(pcols),tcuc(pcols) - real(r8) temp1,temp2,temp3,temp4 -!dir$ assume_aligned table:64 -!dir$ assume_aligned xtab:64 -!dir$ assume_aligned ytab:64 -!dir$ assume_aligned out:64 -!dir$ assume_aligned ix:64 -!dir$ assume_aligned jy:64 -!dir$ assume_aligned x:64 -!dir$ assume_aligned t:64 -!dir$ assume_aligned tu:64 -!dir$ assume_aligned y:64 -!dir$ assume_aligned u:64 -!dir$ assume_aligned tuc:64 -!dir$ assume_aligned tcu:64 -!dir$ assume_aligned tcuc:64 - !print *,km - if(ix(1).gt.0) go to 30 - if(im.gt.1)then -!dir$ SIMD - do ic=1,ncol - do i=1,im - if(x(ic).lt.xtab(i))go to 10 - enddo - 10 ix(ic)=max0(i-1,1) - ip1=min(ix(ic)+1,im) - dx=(xtab(ip1)-xtab(ix(ic))) - if(abs(dx).gt.1.e-20_r8)then - t(ic)=(x(ic)-xtab(ix(ic)))/dx - else - t(ic)=0._r8 - endif - end do - else - ix(:ncol)=1 - t(:ncol)=0._r8 - endif - if(jm.gt.1)then -!dir$ SIMD - do ic=1,ncol - do j=1,jm - if(y(ic).lt.ytab(j))go to 20 - enddo - 20 jy(ic)=max0(j-1,1) - jp1=min(jy(ic)+1,jm) - dy=(ytab(jp1)-ytab(jy(ic))) - if(abs(dy).gt.1.e-20_r8)then - u(ic)=(y(ic)-ytab(jy(ic)))/dy - else - u(ic)=0._r8 - endif - end do - else - jy(:ncol)=1 - u(:ncol)=0._r8 - endif - 30 continue -!Do not use SIMD here - do ic=1,ncol - tu(ic)=t(ic)*u(ic) - tuc(ic)=t(ic)-tu(ic) - tcuc(ic)=1._r8-tuc(ic)-u(ic) - tcu(ic)=u(ic)-tu(ic) - jp1=min(jy(ic)+1,jm) - ip1=min(ix(ic)+1,im) -!dir$ SIMD - do k=1,km - out(ic,k) = tcuc(ic) * table(k,ix(ic),jy(ic)) + tuc(ic) * table(k,ip1,jy(ic)) + tu(ic) * table(k,ip1,jp1) + tcu(ic) * table(k,ix(ic),jp1) - end do - enddo - return - end subroutine binterp - - END SUBROUTINE kernel_driver - - - FUNCTION kgen_get_newunit(seed) RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - INTEGER, INTENT(IN) :: seed - - new_unit = -1 - - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE diff --git a/test/ncar_kernels/PORT_cldprmc/CESM_license.txt b/test/ncar_kernels/PORT_cldprmc/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/PORT_cldprmc/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/PORT_cldprmc/data/cldprmc.10.1 b/test/ncar_kernels/PORT_cldprmc/data/cldprmc.10.1 deleted file mode 100644 index 3a12099f60..0000000000 Binary files a/test/ncar_kernels/PORT_cldprmc/data/cldprmc.10.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_cldprmc/data/cldprmc.10.2 b/test/ncar_kernels/PORT_cldprmc/data/cldprmc.10.2 deleted file mode 100644 index 680a163fe3..0000000000 Binary files a/test/ncar_kernels/PORT_cldprmc/data/cldprmc.10.2 and /dev/null differ diff --git a/test/ncar_kernels/PORT_cldprmc/data/cldprmc.20.1 b/test/ncar_kernels/PORT_cldprmc/data/cldprmc.20.1 deleted file mode 100644 index 8c74569986..0000000000 Binary files a/test/ncar_kernels/PORT_cldprmc/data/cldprmc.20.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_cldprmc/data/cldprmc.20.2 b/test/ncar_kernels/PORT_cldprmc/data/cldprmc.20.2 deleted file mode 100644 index 7efb085b14..0000000000 Binary files a/test/ncar_kernels/PORT_cldprmc/data/cldprmc.20.2 and /dev/null differ diff --git a/test/ncar_kernels/PORT_cldprmc/inc/t1.mk b/test/ncar_kernels/PORT_cldprmc/inc/t1.mk deleted file mode 100644 index 8521c574a8..0000000000 --- a/test/ncar_kernels/PORT_cldprmc/inc/t1.mk +++ /dev/null @@ -1,52 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# - -# PGI default flags -# -# FC_FLAGS := -# -# Intel default flags -# -# FC_FFLAGS := -# -# -FC_FLAGS := $(OPT) - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - -ALL_OBJS := kernel_cldprmc.o - -all: build run verify - -verify: - @(grep "FAIL" $(TEST).rslt && echo "FAILED") || (grep "PASSED" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt | grep -v "PASSED" - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_cldprmc.o: $(SRC_DIR)/kernel_cldprmc.F90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f *.exe *.mod *.o *.rslt diff --git a/test/ncar_kernels/PORT_cldprmc/lit/runmake b/test/ncar_kernels/PORT_cldprmc/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/PORT_cldprmc/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/PORT_cldprmc/lit/t1.sh b/test/ncar_kernels/PORT_cldprmc/lit/t1.sh deleted file mode 100644 index 33c953a156..0000000000 --- a/test/ncar_kernels/PORT_cldprmc/lit/t1.sh +++ /dev/null @@ -1,9 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -# Shared lit script for each tests. Run bash commands that run tests with make. - -# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t -# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/PORT_cldprmc/makefile b/test/ncar_kernels/PORT_cldprmc/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/PORT_cldprmc/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/PORT_cldprmc/src/kernel_cldprmc.F90 b/test/ncar_kernels/PORT_cldprmc/src/kernel_cldprmc.F90 deleted file mode 100644 index 22ce93c8c2..0000000000 --- a/test/ncar_kernels/PORT_cldprmc/src/kernel_cldprmc.F90 +++ /dev/null @@ -1,291 +0,0 @@ - MODULE resolvers - - ! RESOLVER SPECS - INTEGER, PARAMETER :: r8 = selected_real_kind(12) - INTEGER, PARAMETER :: ngptlw = 140 - - END MODULE - - PROGRAM kernel_cldprmc - USE resolvers - - IMPLICIT NONE - - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(2), PARAMETER :: kgen_mpi_rank_at = (/ 1,2 /) - INTEGER :: kgen_ierr, kgen_unit, kgen_get_newunit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(2), PARAMETER :: kgen_counter_at = (/ 10,20 /) - CHARACTER(LEN=1024) :: kgen_filepath - INTEGER, DIMENSION(2,10) :: kgen_bound - - ! DRIVER SPECS - INTEGER :: nlay - - DO kgen_repeat_counter = 1, 4 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 2)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 2)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - - kgen_filepath = "../data/cldprmc." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit(kgen_mpi_rank+kgen_counter) - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) "Kernel output is being verified against " // trim(adjustl(kgen_filepath)) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - ! READ DRIVER INSTATE - - READ(UNIT = kgen_unit) nlay - - ! KERNEL DRIVER RUN - CALL kernel_driver(nlay, kgen_unit) - CLOSE (UNIT=kgen_unit) - - WRITE (*,*) - END DO - END PROGRAM kernel_cldprmc - - ! KERNEL DRIVER SUBROUTINE - SUBROUTINE kernel_driver(nlay, kgen_unit) - USE resolvers - - IMPLICIT NONE - LOGICAL :: passed = .true. - INTEGER, INTENT(IN) :: kgen_unit - INTEGER, DIMENSION(2,10) :: kgen_bound - - ! STATE SPECS - REAL(KIND = r8), DIMENSION(2) :: absice0 - REAL(KIND = r8), DIMENSION(2, 5) :: absice1 - CHARACTER*18 :: hvrclc - REAL(KIND = r8), DIMENSION(46, 16) :: absice3 - INTEGER :: iceflag - REAL(KIND = r8) :: absliq0 - INTEGER :: ngb(ngptlw) - INTEGER :: ncbands - REAL(KIND = r8) :: clwpmc(ngptlw, nlay) - REAL(KIND = r8), DIMENSION(43, 16) :: absice2 - REAL(KIND = r8) :: taucmc(ngptlw, nlay) - REAL(KIND = r8) :: relqmc(nlay) - INTEGER :: liqflag - REAL(KIND = r8) :: dgesmc(nlay) - REAL(KIND = r8) :: reicmc(nlay) - REAL(KIND = r8) :: ciwpmc(ngptlw, nlay) - INTEGER, INTENT(IN) :: nlay - REAL(KIND = r8), DIMENSION(58, 16) :: absliq1 - INTEGER :: inflag - REAL(KIND = r8) :: cldfmc(ngptlw, nlay) - INTEGER :: outstate_ncbands - REAL(KIND = r8) :: outstate_taucmc(ngptlw, nlay) - ! READ CALLER INSTATE - - READ(UNIT = kgen_unit) iceflag - READ(UNIT = kgen_unit) clwpmc - READ(UNIT = kgen_unit) taucmc - READ(UNIT = kgen_unit) relqmc - READ(UNIT = kgen_unit) liqflag - READ(UNIT = kgen_unit) dgesmc - READ(UNIT = kgen_unit) reicmc - READ(UNIT = kgen_unit) ciwpmc - READ(UNIT = kgen_unit) inflag - READ(UNIT = kgen_unit) cldfmc - ! READ CALLEE INSTATE - - READ(UNIT = kgen_unit) absice0 - READ(UNIT = kgen_unit) absice1 - READ(UNIT = kgen_unit) hvrclc - READ(UNIT = kgen_unit) absice3 - READ(UNIT = kgen_unit) absliq0 - READ(UNIT = kgen_unit) ngb - READ(UNIT = kgen_unit) absice2 - READ(UNIT = kgen_unit) absliq1 - ! READ CALLEE OUTSTATE - - ! READ CALLER OUTSTATE - - READ(UNIT = kgen_unit) outstate_ncbands - READ(UNIT = kgen_unit) outstate_taucmc - - ! KERNEL RUN - CALL cldprmc(nlay, inflag, iceflag, liqflag, cldfmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, ncbands, taucmc) - - ! STATE VERIFICATION - IF ( outstate_ncbands == ncbands ) THEN - WRITE(*,*) "ncbands is IDENTICAL( ", outstate_ncbands, " )." - ELSE - passed = .false. - WRITE(*,*) "ncbands is NOT IDENTICAL." - WRITE(*,*) "STATE : ", outstate_ncbands - WRITE(*,*) "KERNEL: ", ncbands - END IF - IF ( ALL( outstate_taucmc == taucmc ) ) THEN - WRITE(*,*) "All elements of taucmc are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_taucmc - !WRITE(*,*) "KERNEL: ", taucmc - IF ( ALL( outstate_taucmc == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - passed = .false. - WRITE(*,*) "taucmc is NOT IDENTICAL." - WRITE(*,*) count( outstate_taucmc /= taucmc), " of ", size( taucmc ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_taucmc - taucmc)**2)/real(size(outstate_taucmc))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_taucmc - taucmc)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_taucmc - taucmc)) - WRITE(*,*) "Mean value of kernel-generated outstate_taucmc is ", sum(taucmc)/real(size(taucmc)) - WRITE(*,*) "Mean value of original outstate_taucmc is ", sum(outstate_taucmc)/real(size(outstate_taucmc)) - WRITE(*,*) "" - END IF - IF ( passed ) THEN - WRITE(*,*) "PASSED" - ELSE - WRITE(*,*) "FAILED" - END IF - - ! DEALLOCATE INSTATE - - ! DEALLOCATE OUTSTATE - ! DEALLOCATE CALLEE INSTATE - - ! DEALLOCATE INSTATE - ! DEALLOCATE CALEE OUTSTATE - - ! DEALLOCATE OUTSTATE - - CONTAINS - - - ! KERNEL SUBPROGRAM - subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, ncbands, taucmc) - integer, intent(in) :: nlayers - integer, intent(in) :: inflag - integer, intent(in) :: iceflag - integer, intent(in) :: liqflag - real(kind=r8), intent(in) :: cldfmc(:,:) - real(kind=r8), intent(in) :: ciwpmc(:,:) - real(kind=r8), intent(in) :: clwpmc(:,:) - real(kind=r8), intent(in) :: relqmc(:) - real(kind=r8), intent(in) :: reicmc(:) - real(kind=r8), intent(in) :: dgesmc(:) - integer, intent(out) :: ncbands - real(kind=r8), intent(inout) :: taucmc(:,:) - integer :: lay - integer :: ib - integer :: ig - integer :: index - real(kind=r8) :: abscoice(ngptlw) - real(kind=r8) :: abscoliq(ngptlw) - real(kind=r8) :: cwp - real(kind=r8) :: radice - real(kind=r8) :: dgeice - real(kind=r8) :: factor - real(kind=r8) :: fint - real(kind=r8) :: radliq - real(kind=r8), parameter :: eps = 1.e-6_r8 - real(kind=r8), parameter :: cldmin = 1.e-80_r8 - hvrclc = '$Revision$' - ncbands = 1 - do lay = 1, nlayers - do ig = 1, ngptlw - cwp = ciwpmc(ig,lay) + clwpmc(ig,lay) - if (cldfmc(ig,lay) .ge. cldmin .and. (cwp .ge. cldmin .or. taucmc(ig,lay) .ge. cldmin)) then - if (inflag .eq. 0) then - return - elseif(inflag .eq. 1) then - stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA' - elseif(inflag .eq. 2) then - radice = reicmc(lay) - if (ciwpmc(ig,lay) .eq. 0.0_r8) then - abscoice(ig) = 0.0_r8 - elseif (iceflag .eq. 0) then - if (radice .lt. 10.0_r8) stop 'ICE RADIUS TOO SMALL' - abscoice(ig) = absice0(1) + absice0(2)/radice - elseif (iceflag .eq. 1) then - ncbands = 5 - ib = ngb(ig) - abscoice(ig) = absice1(1,ib) + absice1(2,ib)/radice - elseif (iceflag .eq. 2) then - if (radice .lt. 5.0_r8) stop 'ICE RADIUS OUT OF BOUNDS' - if (radice .ge. 5.0_r8 .and. radice .le. 131._r8) then - ncbands = 16 - factor = (radice - 2._r8)/3._r8 - index = int(factor) - if (index .eq. 43) index = 42 - fint = factor - float(index) - ib = ngb(ig) - abscoice(ig) = absice2(index,ib) + fint * (absice2(index+1,ib) - (absice2(index,ib))) - elseif (radice .gt. 131._r8) then - abscoice(ig) = absice0(1) + absice0(2)/radice - endif - elseif (iceflag .eq. 3) then - dgeice = dgesmc(lay) - if (dgeice .lt. 5.0_r8) stop 'ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' - if (dgeice .ge. 5.0_r8 .and. dgeice .le. 140._r8) then - ncbands = 16 - factor = (dgeice - 2._r8)/3._r8 - index = int(factor) - if (index .eq. 46) index = 45 - fint = factor - float(index) - ib = ngb(ig) - abscoice(ig) = absice3(index,ib) + fint * (absice3(index+1,ib) - (absice3(index,ib))) - elseif (dgeice .gt. 140._r8) then - abscoice(ig) = absice0(1) + absice0(2)/radice - endif - endif - if (clwpmc(ig,lay) .eq. 0.0_r8) then - abscoliq(ig) = 0.0_r8 - elseif (liqflag .eq. 0) then - abscoliq(ig) = absliq0 - elseif (liqflag .eq. 1) then - radliq = relqmc(lay) - if (radliq .lt. 1.5_r8 .or. radliq .gt. 60._r8) stop 'LIQUID EFFECTIVE RADIUS OUT OF BOUNDS' - index = radliq - 1.5_r8 - if (index .eq. 58) index = 57 - if (index .eq. 0) index = 1 - fint = radliq - 1.5_r8 - index - ib = ngb(ig) - abscoliq(ig) = absliq1(index,ib) + fint * (absliq1(index+1,ib) - (absliq1(index,ib))) - endif - taucmc(ig,lay) = ciwpmc(ig,lay) * abscoice(ig) + clwpmc(ig,lay) * abscoliq(ig) - endif - endif - enddo - enddo - end subroutine cldprmc - - END SUBROUTINE kernel_driver - - - ! RESOLVER SUBPROGRAMS - - FUNCTION kgen_get_newunit(seed) RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - INTEGER, INTENT(IN) :: seed - - new_unit = -1 - - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE diff --git a/test/ncar_kernels/PORT_cldprmc/src/kernel_cldprmc.F90_orig b/test/ncar_kernels/PORT_cldprmc/src/kernel_cldprmc.F90_orig deleted file mode 100644 index 483338257c..0000000000 --- a/test/ncar_kernels/PORT_cldprmc/src/kernel_cldprmc.F90_orig +++ /dev/null @@ -1,283 +0,0 @@ - MODULE resolvers - - ! RESOLVER SPECS - INTEGER, PARAMETER :: r8 = selected_real_kind(12) - INTEGER, PARAMETER :: ngptlw = 140 - - END MODULE - - PROGRAM kernel_cldprmc - USE resolvers - - IMPLICIT NONE - - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(2), PARAMETER :: kgen_mpi_rank_at = (/ 1,2 /) - INTEGER :: kgen_ierr, kgen_unit, kgen_get_newunit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(2), PARAMETER :: kgen_counter_at = (/ 10,20 /) - CHARACTER(LEN=1024) :: kgen_filepath - INTEGER, DIMENSION(2,10) :: kgen_bound - - ! DRIVER SPECS - INTEGER :: nlay - - DO kgen_repeat_counter = 1, 4 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 2)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 2)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - - kgen_filepath = "../data/cldprmc." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit(kgen_mpi_rank+kgen_counter) - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) "Kernel output is being verified against " // trim(adjustl(kgen_filepath)) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - ! READ DRIVER INSTATE - - READ(UNIT = kgen_unit) nlay - - ! KERNEL DRIVER RUN - CALL kernel_driver(nlay, kgen_unit) - CLOSE (UNIT=kgen_unit) - - WRITE (*,*) - END DO - END PROGRAM kernel_cldprmc - - ! KERNEL DRIVER SUBROUTINE - SUBROUTINE kernel_driver(nlay, kgen_unit) - USE resolvers - - IMPLICIT NONE - INTEGER, INTENT(IN) :: kgen_unit - INTEGER, DIMENSION(2,10) :: kgen_bound - - ! STATE SPECS - REAL(KIND = r8), DIMENSION(2) :: absice0 - REAL(KIND = r8), DIMENSION(2, 5) :: absice1 - CHARACTER*18 :: hvrclc - REAL(KIND = r8), DIMENSION(46, 16) :: absice3 - INTEGER :: iceflag - REAL(KIND = r8) :: absliq0 - INTEGER :: ngb(ngptlw) - INTEGER :: ncbands - REAL(KIND = r8) :: clwpmc(ngptlw, nlay) - REAL(KIND = r8), DIMENSION(43, 16) :: absice2 - REAL(KIND = r8) :: taucmc(ngptlw, nlay) - REAL(KIND = r8) :: relqmc(nlay) - INTEGER :: liqflag - REAL(KIND = r8) :: dgesmc(nlay) - REAL(KIND = r8) :: reicmc(nlay) - REAL(KIND = r8) :: ciwpmc(ngptlw, nlay) - INTEGER, INTENT(IN) :: nlay - REAL(KIND = r8), DIMENSION(58, 16) :: absliq1 - INTEGER :: inflag - REAL(KIND = r8) :: cldfmc(ngptlw, nlay) - INTEGER :: outstate_ncbands - REAL(KIND = r8) :: outstate_taucmc(ngptlw, nlay) - ! READ CALLER INSTATE - - READ(UNIT = kgen_unit) iceflag - READ(UNIT = kgen_unit) clwpmc - READ(UNIT = kgen_unit) taucmc - READ(UNIT = kgen_unit) relqmc - READ(UNIT = kgen_unit) liqflag - READ(UNIT = kgen_unit) dgesmc - READ(UNIT = kgen_unit) reicmc - READ(UNIT = kgen_unit) ciwpmc - READ(UNIT = kgen_unit) inflag - READ(UNIT = kgen_unit) cldfmc - ! READ CALLEE INSTATE - - READ(UNIT = kgen_unit) absice0 - READ(UNIT = kgen_unit) absice1 - READ(UNIT = kgen_unit) hvrclc - READ(UNIT = kgen_unit) absice3 - READ(UNIT = kgen_unit) absliq0 - READ(UNIT = kgen_unit) ngb - READ(UNIT = kgen_unit) absice2 - READ(UNIT = kgen_unit) absliq1 - ! READ CALLEE OUTSTATE - - ! READ CALLER OUTSTATE - - READ(UNIT = kgen_unit) outstate_ncbands - READ(UNIT = kgen_unit) outstate_taucmc - - ! KERNEL RUN - CALL cldprmc(nlay, inflag, iceflag, liqflag, cldfmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, ncbands, taucmc) - - ! STATE VERIFICATION - IF ( outstate_ncbands == ncbands ) THEN - WRITE(*,*) "ncbands is IDENTICAL( ", outstate_ncbands, " )." - ELSE - WRITE(*,*) "ncbands is NOT IDENTICAL." - WRITE(*,*) "STATE : ", outstate_ncbands - WRITE(*,*) "KERNEL: ", ncbands - END IF - IF ( ALL( outstate_taucmc == taucmc ) ) THEN - WRITE(*,*) "All elements of taucmc are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_taucmc - !WRITE(*,*) "KERNEL: ", taucmc - IF ( ALL( outstate_taucmc == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "taucmc is NOT IDENTICAL." - WRITE(*,*) count( outstate_taucmc /= taucmc), " of ", size( taucmc ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_taucmc - taucmc)**2)/real(size(outstate_taucmc))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_taucmc - taucmc)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_taucmc - taucmc)) - WRITE(*,*) "Mean value of kernel-generated outstate_taucmc is ", sum(taucmc)/real(size(taucmc)) - WRITE(*,*) "Mean value of original outstate_taucmc is ", sum(outstate_taucmc)/real(size(outstate_taucmc)) - WRITE(*,*) "" - END IF - - ! DEALLOCATE INSTATE - - ! DEALLOCATE OUTSTATE - ! DEALLOCATE CALLEE INSTATE - - ! DEALLOCATE INSTATE - ! DEALLOCATE CALEE OUTSTATE - - ! DEALLOCATE OUTSTATE - - CONTAINS - - - ! KERNEL SUBPROGRAM - subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, ncbands, taucmc) - integer, intent(in) :: nlayers - integer, intent(in) :: inflag - integer, intent(in) :: iceflag - integer, intent(in) :: liqflag - real(kind=r8), intent(in) :: cldfmc(:,:) - real(kind=r8), intent(in) :: ciwpmc(:,:) - real(kind=r8), intent(in) :: clwpmc(:,:) - real(kind=r8), intent(in) :: relqmc(:) - real(kind=r8), intent(in) :: reicmc(:) - real(kind=r8), intent(in) :: dgesmc(:) - integer, intent(out) :: ncbands - real(kind=r8), intent(inout) :: taucmc(:,:) - integer :: lay - integer :: ib - integer :: ig - integer :: index - real(kind=r8) :: abscoice(ngptlw) - real(kind=r8) :: abscoliq(ngptlw) - real(kind=r8) :: cwp - real(kind=r8) :: radice - real(kind=r8) :: dgeice - real(kind=r8) :: factor - real(kind=r8) :: fint - real(kind=r8) :: radliq - real(kind=r8), parameter :: eps = 1.e-6_r8 - real(kind=r8), parameter :: cldmin = 1.e-80_r8 - hvrclc = '$Revision$' - ncbands = 1 - do lay = 1, nlayers - do ig = 1, ngptlw - cwp = ciwpmc(ig,lay) + clwpmc(ig,lay) - if (cldfmc(ig,lay) .ge. cldmin .and. (cwp .ge. cldmin .or. taucmc(ig,lay) .ge. cldmin)) then - if (inflag .eq. 0) then - return - elseif(inflag .eq. 1) then - stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA' - elseif(inflag .eq. 2) then - radice = reicmc(lay) - if (ciwpmc(ig,lay) .eq. 0.0_r8) then - abscoice(ig) = 0.0_r8 - elseif (iceflag .eq. 0) then - if (radice .lt. 10.0_r8) stop 'ICE RADIUS TOO SMALL' - abscoice(ig) = absice0(1) + absice0(2)/radice - elseif (iceflag .eq. 1) then - ncbands = 5 - ib = ngb(ig) - abscoice(ig) = absice1(1,ib) + absice1(2,ib)/radice - elseif (iceflag .eq. 2) then - if (radice .lt. 5.0_r8) stop 'ICE RADIUS OUT OF BOUNDS' - if (radice .ge. 5.0_r8 .and. radice .le. 131._r8) then - ncbands = 16 - factor = (radice - 2._r8)/3._r8 - index = int(factor) - if (index .eq. 43) index = 42 - fint = factor - float(index) - ib = ngb(ig) - abscoice(ig) = absice2(index,ib) + fint * (absice2(index+1,ib) - (absice2(index,ib))) - elseif (radice .gt. 131._r8) then - abscoice(ig) = absice0(1) + absice0(2)/radice - endif - elseif (iceflag .eq. 3) then - dgeice = dgesmc(lay) - if (dgeice .lt. 5.0_r8) stop 'ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' - if (dgeice .ge. 5.0_r8 .and. dgeice .le. 140._r8) then - ncbands = 16 - factor = (dgeice - 2._r8)/3._r8 - index = int(factor) - if (index .eq. 46) index = 45 - fint = factor - float(index) - ib = ngb(ig) - abscoice(ig) = absice3(index,ib) + fint * (absice3(index+1,ib) - (absice3(index,ib))) - elseif (dgeice .gt. 140._r8) then - abscoice(ig) = absice0(1) + absice0(2)/radice - endif - endif - if (clwpmc(ig,lay) .eq. 0.0_r8) then - abscoliq(ig) = 0.0_r8 - elseif (liqflag .eq. 0) then - abscoliq(ig) = absliq0 - elseif (liqflag .eq. 1) then - radliq = relqmc(lay) - if (radliq .lt. 1.5_r8 .or. radliq .gt. 60._r8) stop 'LIQUID EFFECTIVE RADIUS OUT OF BOUNDS' - index = radliq - 1.5_r8 - if (index .eq. 58) index = 57 - if (index .eq. 0) index = 1 - fint = radliq - 1.5_r8 - index - ib = ngb(ig) - abscoliq(ig) = absliq1(index,ib) + fint * (absliq1(index+1,ib) - (absliq1(index,ib))) - endif - taucmc(ig,lay) = ciwpmc(ig,lay) * abscoice(ig) + clwpmc(ig,lay) * abscoliq(ig) - endif - endif - enddo - enddo - end subroutine cldprmc - - END SUBROUTINE kernel_driver - - - ! RESOLVER SUBPROGRAMS - - FUNCTION kgen_get_newunit(seed) RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - INTEGER, INTENT(IN) :: seed - - new_unit = -1 - - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE diff --git a/test/ncar_kernels/PORT_inatm/CESM_license.txt b/test/ncar_kernels/PORT_inatm/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/PORT_inatm/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/PORT_inatm/data/inatm.1.0 b/test/ncar_kernels/PORT_inatm/data/inatm.1.0 deleted file mode 100644 index 35fb13a7bb..0000000000 Binary files a/test/ncar_kernels/PORT_inatm/data/inatm.1.0 and /dev/null differ diff --git a/test/ncar_kernels/PORT_inatm/inc/t1.mk b/test/ncar_kernels/PORT_inatm/inc/t1.mk deleted file mode 100644 index 077eca6588..0000000000 --- a/test/ncar_kernels/PORT_inatm/inc/t1.mk +++ /dev/null @@ -1,52 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# - -# PGI default flags -# -# FC_FLAGS := -# -# Intel default flags -# -# FC_FFLAGS := -# -# -FC_FLAGS := $(OPT) - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - -ALL_OBJS := kernel_inatm.o - -all: build run verify - -verify: - @(grep "FAIL" $(TEST).rslt && echo "FAILED") || (grep "PASSED" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt | grep -v "PASSED" - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_inatm.o: $(SRC_DIR)/kernel_inatm.F90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f *.exe *.mod *.o *.rslt diff --git a/test/ncar_kernels/PORT_inatm/lit/runmake b/test/ncar_kernels/PORT_inatm/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/PORT_inatm/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/PORT_inatm/lit/t1.sh b/test/ncar_kernels/PORT_inatm/lit/t1.sh deleted file mode 100644 index 33c953a156..0000000000 --- a/test/ncar_kernels/PORT_inatm/lit/t1.sh +++ /dev/null @@ -1,9 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -# Shared lit script for each tests. Run bash commands that run tests with make. - -# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t -# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/PORT_inatm/makefile b/test/ncar_kernels/PORT_inatm/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/PORT_inatm/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/PORT_inatm/src/kernel_inatm.F90 b/test/ncar_kernels/PORT_inatm/src/kernel_inatm.F90 deleted file mode 100644 index 166f76c795..0000000000 --- a/test/ncar_kernels/PORT_inatm/src/kernel_inatm.F90 +++ /dev/null @@ -1,960 +0,0 @@ - MODULE resolvers - - ! RESOLVER SPECS - INTEGER, PARAMETER :: r8 = selected_real_kind(12) - INTEGER, PARAMETER :: nmol = 7 - INTEGER, PARAMETER :: maxxsec = 4 - INTEGER, PARAMETER :: nbndlw = 16 - INTEGER, PARAMETER :: ngptlw = 140 - INTEGER, PARAMETER :: mxmol = 38 - INTEGER, PARAMETER :: maxinpx = 38 - - END MODULE - - MODULE subprograms - - CONTAINS - - - ! KERNEL DRIVER SUBROUTINE - SUBROUTINE kernel_driver(taucmcl, ch4vmr, icld, emis, tlay, reicmcl, nlay, cfc11vmr, tsfc, relqmcl, o3vmr, n2ovmr, plev, play, tauaer, clwpmcl, o2vmr, co2vmr, ccl4vmr, iceflglw, cfc12vmr, tlev, h2ovmr, inflglw, ciwpmcl, cldfmcl, liqflglw, cfc22vmr, kgen_unit) - USE resolvers - - IMPLICIT NONE - INTEGER, INTENT(IN) :: kgen_unit - INTEGER, DIMENSION(2,10) :: kgen_bound - - - ! STATE SPECS - REAL(KIND = r8), INTENT(IN) :: taucmcl(:, :, :) - INTEGER :: iceflag - REAL(KIND = r8) :: wkl(mxmol, nlay) - REAL(KIND = r8) :: coldry(nlay) - REAL(KIND = r8), INTENT(IN) :: ch4vmr(:, :) - REAL(KIND = r8) :: clwpmc(ngptlw, nlay) - INTEGER, INTENT(INOUT) :: icld - REAL(KIND = r8), INTENT(IN) :: emis(:, :) - REAL(KIND = r8) :: avogad - REAL(KIND = r8) :: cldfmc(ngptlw, nlay) - REAL(KIND = r8) :: relqmc(nlay) - REAL(KIND = r8) :: ciwpmc(ngptlw, nlay) - REAL(KIND = r8) :: wbrodl(nlay) - REAL(KIND = r8), INTENT(IN) :: tlay(:, :) - REAL(KIND = r8), INTENT(IN) :: reicmcl(:, :) - INTEGER, INTENT(IN) :: nlay - REAL(KIND = r8) :: tavel(nlay) - INTEGER :: liqflag - REAL(KIND = r8) :: tz(0 : nlay) - REAL(KIND = r8), INTENT(IN) :: cfc11vmr(:, :) - REAL(KIND = r8), INTENT(IN) :: tsfc(:) - REAL(KIND = r8) :: pz(0 : nlay) - REAL(KIND = r8), INTENT(IN) :: relqmcl(:, :) - REAL(KIND = r8), INTENT(IN) :: o3vmr(:, :) - REAL(KIND = r8) :: tbound - INTEGER :: iaer - REAL(KIND = r8), INTENT(IN) :: n2ovmr(:, :) - REAL(KIND = r8) :: reicmc(nlay) - REAL(KIND = r8), INTENT(IN) :: plev(:, :) - REAL(KIND = r8), INTENT(IN) :: play(:, :) - REAL(KIND = r8), INTENT(IN) :: tauaer(:, :, :) - REAL(KIND = r8) :: semiss(nbndlw) - REAL(KIND = r8) :: pavel(nlay) - REAL(KIND = r8), INTENT(IN) :: clwpmcl(:, :, :) - REAL(KIND = r8), INTENT(IN) :: o2vmr(:, :) - REAL(KIND = r8) :: dgesmc(nlay) - REAL(KIND = r8) :: pwvcm - REAL(KIND = r8), INTENT(IN) :: co2vmr(:, :) - INTEGER :: inflag - REAL(KIND = r8) :: wx(maxxsec, nlay) - REAL(KIND = r8), INTENT(IN) :: ccl4vmr(:, :) - REAL(KIND = r8) :: taua(nlay, nbndlw) - INTEGER, INTENT(IN) :: iceflglw - REAL(KIND = r8), INTENT(IN) :: cfc12vmr(:, :) - REAL(KIND = r8), INTENT(IN) :: tlev(:, :) - REAL(KIND = r8) :: grav - REAL(KIND = r8) :: taucmc(ngptlw, nlay) - REAL(KIND = r8), INTENT(IN) :: h2ovmr(:, :) - INTEGER :: iplon - INTEGER, INTENT(IN) :: inflglw - REAL(KIND = r8), INTENT(IN) :: ciwpmcl(:, :, :) - INTEGER :: ixindx(maxinpx) - REAL(KIND = r8), INTENT(IN) :: cldfmcl(:, :, :) - INTEGER, INTENT(IN) :: liqflglw - REAL(KIND = r8), INTENT(IN) :: cfc22vmr(:, :) - INTEGER :: outstate_iceflag - REAL(KIND = r8) :: outstate_wkl(mxmol, nlay) - REAL(KIND = r8) :: outstate_coldry(nlay) - REAL(KIND = r8) :: outstate_clwpmc(ngptlw, nlay) - REAL(KIND = r8) :: outstate_cldfmc(ngptlw, nlay) - REAL(KIND = r8) :: outstate_relqmc(nlay) - REAL(KIND = r8) :: outstate_ciwpmc(ngptlw, nlay) - REAL(KIND = r8) :: outstate_wbrodl(nlay) - REAL(KIND = r8) :: outstate_tavel(nlay) - INTEGER :: outstate_liqflag - REAL(KIND = r8) :: outstate_tz(0 : nlay) - REAL(KIND = r8) :: outstate_pz(0 : nlay) - REAL(KIND = r8) :: outstate_tbound - REAL(KIND = r8) :: outstate_reicmc(nlay) - REAL(KIND = r8) :: outstate_semiss(nbndlw) - REAL(KIND = r8) :: outstate_pavel(nlay) - REAL(KIND = r8) :: outstate_dgesmc(nlay) - REAL(KIND = r8) :: outstate_pwvcm - INTEGER :: outstate_inflag - REAL(KIND = r8) :: outstate_wx(maxxsec, nlay) - REAL(KIND = r8) :: outstate_taua(nlay, nbndlw) - REAL(KIND = r8) :: outstate_taucmc(ngptlw, nlay) - - LOGICAL :: passed = .true. - - - ! READ CALLER INSTATE - READ(UNIT = kgen_unit) iaer - READ(UNIT = kgen_unit) iplon - - - ! READ CALLEE INSTATE - READ(UNIT = kgen_unit) avogad - READ(UNIT = kgen_unit) grav - READ(UNIT = kgen_unit) ixindx - - - ! READ CALLEE OUTSTATE - - - ! READ CALLER OUTSTATE - READ(UNIT = kgen_unit) outstate_iceflag - READ(UNIT = kgen_unit) outstate_wkl - READ(UNIT = kgen_unit) outstate_coldry - READ(UNIT = kgen_unit) outstate_clwpmc - READ(UNIT = kgen_unit) outstate_cldfmc - READ(UNIT = kgen_unit) outstate_relqmc - READ(UNIT = kgen_unit) outstate_ciwpmc - READ(UNIT = kgen_unit) outstate_wbrodl - READ(UNIT = kgen_unit) outstate_tavel - READ(UNIT = kgen_unit) outstate_liqflag - READ(UNIT = kgen_unit) outstate_tz - READ(UNIT = kgen_unit) outstate_pz - READ(UNIT = kgen_unit) outstate_tbound - READ(UNIT = kgen_unit) outstate_reicmc - READ(UNIT = kgen_unit) outstate_semiss - READ(UNIT = kgen_unit) outstate_pavel - READ(UNIT = kgen_unit) outstate_dgesmc - READ(UNIT = kgen_unit) outstate_pwvcm - READ(UNIT = kgen_unit) outstate_inflag - READ(UNIT = kgen_unit) outstate_wx - READ(UNIT = kgen_unit) outstate_taua - READ(UNIT = kgen_unit) outstate_taucmc - - - ! KERNEL RUN - CALL inatm(iplon, nlay, icld, iaer, play, plev, tlay, tlev, tsfc, & - h2ovmr, o3vmr, co2vmr, ch4vmr, o2vmr, n2ovmr, cfc11vmr, & - cfc12vmr, cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, & - liqflglw, cldfmcl, taucmcl, ciwpmcl, clwpmcl, reicmcl, & - relqmcl, tauaer, pavel, pz, tavel, tz, tbound, semiss, & - coldry, wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag, & - cldfmc, taucmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, taua) - - - ! STATE VERIFICATION - IF ( outstate_iceflag == iceflag ) THEN - WRITE(*,*) "iceflag is IDENTICAL( ", outstate_iceflag, " )." - ELSE - passed = .false. - WRITE(*,*) "iceflag is NOT IDENTICAL." - WRITE(*,*) "STATE : ", outstate_iceflag - WRITE(*,*) "KERNEL: ", iceflag - END IF - IF ( ALL( outstate_wkl == wkl ) ) THEN - WRITE(*,*) "All elements of wkl are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_wkl - !WRITE(*,*) "KERNEL: ", wkl - IF ( ALL( outstate_wkl == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - passed = .false. - WRITE(*,*) "wkl is NOT IDENTICAL." - WRITE(*,*) count( outstate_wkl /= wkl), " of ", size( wkl ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_wkl - wkl)**2)/real(size(outstate_wkl))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_wkl - wkl)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_wkl - wkl)) - WRITE(*,*) "Mean value of kernel-generated outstate_wkl is ", sum(wkl)/real(size(wkl)) - WRITE(*,*) "Mean value of original outstate_wkl is ", sum(outstate_wkl)/real(size(outstate_wkl)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_coldry == coldry ) ) THEN - WRITE(*,*) "All elements of coldry are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_coldry - !WRITE(*,*) "KERNEL: ", coldry - IF ( ALL( outstate_coldry == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - passed = .false. - WRITE(*,*) "coldry is NOT IDENTICAL." - WRITE(*,*) count( outstate_coldry /= coldry), " of ", size( coldry ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_coldry - coldry)**2)/real(size(outstate_coldry))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_coldry - coldry)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_coldry - coldry)) - WRITE(*,*) "Mean value of kernel-generated outstate_coldry is ", sum(coldry)/real(size(coldry)) - WRITE(*,*) "Mean value of original outstate_coldry is ", sum(outstate_coldry)/real(size(outstate_coldry)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_clwpmc == clwpmc ) ) THEN - WRITE(*,*) "All elements of clwpmc are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_clwpmc - !WRITE(*,*) "KERNEL: ", clwpmc - IF ( ALL( outstate_clwpmc == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - passed = .false. - WRITE(*,*) "clwpmc is NOT IDENTICAL." - WRITE(*,*) count( outstate_clwpmc /= clwpmc), " of ", size( clwpmc ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_clwpmc - clwpmc)**2)/real(size(outstate_clwpmc))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_clwpmc - clwpmc)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_clwpmc - clwpmc)) - WRITE(*,*) "Mean value of kernel-generated outstate_clwpmc is ", sum(clwpmc)/real(size(clwpmc)) - WRITE(*,*) "Mean value of original outstate_clwpmc is ", sum(outstate_clwpmc)/real(size(outstate_clwpmc)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_cldfmc == cldfmc ) ) THEN - WRITE(*,*) "All elements of cldfmc are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_cldfmc - !WRITE(*,*) "KERNEL: ", cldfmc - IF ( ALL( outstate_cldfmc == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - passed = .false. - WRITE(*,*) "cldfmc is NOT IDENTICAL." - WRITE(*,*) count( outstate_cldfmc /= cldfmc), " of ", size( cldfmc ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_cldfmc - cldfmc)**2)/real(size(outstate_cldfmc))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_cldfmc - cldfmc)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_cldfmc - cldfmc)) - WRITE(*,*) "Mean value of kernel-generated outstate_cldfmc is ", sum(cldfmc)/real(size(cldfmc)) - WRITE(*,*) "Mean value of original outstate_cldfmc is ", sum(outstate_cldfmc)/real(size(outstate_cldfmc)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_relqmc == relqmc ) ) THEN - WRITE(*,*) "All elements of relqmc are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_relqmc - !WRITE(*,*) "KERNEL: ", relqmc - IF ( ALL( outstate_relqmc == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - passed = .false. - WRITE(*,*) "relqmc is NOT IDENTICAL." - WRITE(*,*) count( outstate_relqmc /= relqmc), " of ", size( relqmc ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_relqmc - relqmc)**2)/real(size(outstate_relqmc))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_relqmc - relqmc)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_relqmc - relqmc)) - WRITE(*,*) "Mean value of kernel-generated outstate_relqmc is ", sum(relqmc)/real(size(relqmc)) - WRITE(*,*) "Mean value of original outstate_relqmc is ", sum(outstate_relqmc)/real(size(outstate_relqmc)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_ciwpmc == ciwpmc ) ) THEN - WRITE(*,*) "All elements of ciwpmc are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_ciwpmc - !WRITE(*,*) "KERNEL: ", ciwpmc - IF ( ALL( outstate_ciwpmc == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - passed = .false. - WRITE(*,*) "ciwpmc is NOT IDENTICAL." - WRITE(*,*) count( outstate_ciwpmc /= ciwpmc), " of ", size( ciwpmc ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_ciwpmc - ciwpmc)**2)/real(size(outstate_ciwpmc))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_ciwpmc - ciwpmc)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_ciwpmc - ciwpmc)) - WRITE(*,*) "Mean value of kernel-generated outstate_ciwpmc is ", sum(ciwpmc)/real(size(ciwpmc)) - WRITE(*,*) "Mean value of original outstate_ciwpmc is ", sum(outstate_ciwpmc)/real(size(outstate_ciwpmc)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_wbrodl == wbrodl ) ) THEN - WRITE(*,*) "All elements of wbrodl are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_wbrodl - !WRITE(*,*) "KERNEL: ", wbrodl - IF ( ALL( outstate_wbrodl == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - passed = .false. - WRITE(*,*) "wbrodl is NOT IDENTICAL." - WRITE(*,*) count( outstate_wbrodl /= wbrodl), " of ", size( wbrodl ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_wbrodl - wbrodl)**2)/real(size(outstate_wbrodl))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_wbrodl - wbrodl)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_wbrodl - wbrodl)) - WRITE(*,*) "Mean value of kernel-generated outstate_wbrodl is ", sum(wbrodl)/real(size(wbrodl)) - WRITE(*,*) "Mean value of original outstate_wbrodl is ", sum(outstate_wbrodl)/real(size(outstate_wbrodl)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_tavel == tavel ) ) THEN - WRITE(*,*) "All elements of tavel are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_tavel - !WRITE(*,*) "KERNEL: ", tavel - IF ( ALL( outstate_tavel == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - passed = .false. - WRITE(*,*) "tavel is NOT IDENTICAL." - WRITE(*,*) count( outstate_tavel /= tavel), " of ", size( tavel ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_tavel - tavel)**2)/real(size(outstate_tavel))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_tavel - tavel)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_tavel - tavel)) - WRITE(*,*) "Mean value of kernel-generated outstate_tavel is ", sum(tavel)/real(size(tavel)) - WRITE(*,*) "Mean value of original outstate_tavel is ", sum(outstate_tavel)/real(size(outstate_tavel)) - WRITE(*,*) "" - END IF - IF ( outstate_liqflag == liqflag ) THEN - WRITE(*,*) "liqflag is IDENTICAL( ", outstate_liqflag, " )." - ELSE - passed = .false. - WRITE(*,*) "liqflag is NOT IDENTICAL." - WRITE(*,*) "STATE : ", outstate_liqflag - WRITE(*,*) "KERNEL: ", liqflag - END IF - IF ( ALL( outstate_tz == tz ) ) THEN - WRITE(*,*) "All elements of tz are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_tz - !WRITE(*,*) "KERNEL: ", tz - IF ( ALL( outstate_tz == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - passed = .false. - WRITE(*,*) "tz is NOT IDENTICAL." - WRITE(*,*) count( outstate_tz /= tz), " of ", size( tz ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_tz - tz)**2)/real(size(outstate_tz))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_tz - tz)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_tz - tz)) - WRITE(*,*) "Mean value of kernel-generated outstate_tz is ", sum(tz)/real(size(tz)) - WRITE(*,*) "Mean value of original outstate_tz is ", sum(outstate_tz)/real(size(outstate_tz)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_pz == pz ) ) THEN - WRITE(*,*) "All elements of pz are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_pz - !WRITE(*,*) "KERNEL: ", pz - IF ( ALL( outstate_pz == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - passed = .false. - WRITE(*,*) "pz is NOT IDENTICAL." - WRITE(*,*) count( outstate_pz /= pz), " of ", size( pz ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_pz - pz)**2)/real(size(outstate_pz))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_pz - pz)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_pz - pz)) - WRITE(*,*) "Mean value of kernel-generated outstate_pz is ", sum(pz)/real(size(pz)) - WRITE(*,*) "Mean value of original outstate_pz is ", sum(outstate_pz)/real(size(outstate_pz)) - WRITE(*,*) "" - END IF - IF ( outstate_tbound == tbound ) THEN - WRITE(*,*) "tbound is IDENTICAL( ", outstate_tbound, " )." - ELSE - passed = .false. - WRITE(*,*) "tbound is NOT IDENTICAL." - WRITE(*,*) "STATE : ", outstate_tbound - WRITE(*,*) "KERNEL: ", tbound - END IF - IF ( ALL( outstate_reicmc == reicmc ) ) THEN - WRITE(*,*) "All elements of reicmc are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_reicmc - !WRITE(*,*) "KERNEL: ", reicmc - IF ( ALL( outstate_reicmc == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - passed = .false. - WRITE(*,*) "reicmc is NOT IDENTICAL." - WRITE(*,*) count( outstate_reicmc /= reicmc), " of ", size( reicmc ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_reicmc - reicmc)**2)/real(size(outstate_reicmc))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_reicmc - reicmc)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_reicmc - reicmc)) - WRITE(*,*) "Mean value of kernel-generated outstate_reicmc is ", sum(reicmc)/real(size(reicmc)) - WRITE(*,*) "Mean value of original outstate_reicmc is ", sum(outstate_reicmc)/real(size(outstate_reicmc)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_semiss == semiss ) ) THEN - WRITE(*,*) "All elements of semiss are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_semiss - !WRITE(*,*) "KERNEL: ", semiss - IF ( ALL( outstate_semiss == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - passed = .false. - WRITE(*,*) "semiss is NOT IDENTICAL." - WRITE(*,*) count( outstate_semiss /= semiss), " of ", size( semiss ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_semiss - semiss)**2)/real(size(outstate_semiss))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_semiss - semiss)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_semiss - semiss)) - WRITE(*,*) "Mean value of kernel-generated outstate_semiss is ", sum(semiss)/real(size(semiss)) - WRITE(*,*) "Mean value of original outstate_semiss is ", sum(outstate_semiss)/real(size(outstate_semiss)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_pavel == pavel ) ) THEN - WRITE(*,*) "All elements of pavel are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_pavel - !WRITE(*,*) "KERNEL: ", pavel - IF ( ALL( outstate_pavel == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - passed = .false. - WRITE(*,*) "pavel is NOT IDENTICAL." - WRITE(*,*) count( outstate_pavel /= pavel), " of ", size( pavel ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_pavel - pavel)**2)/real(size(outstate_pavel))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_pavel - pavel)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_pavel - pavel)) - WRITE(*,*) "Mean value of kernel-generated outstate_pavel is ", sum(pavel)/real(size(pavel)) - WRITE(*,*) "Mean value of original outstate_pavel is ", sum(outstate_pavel)/real(size(outstate_pavel)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_dgesmc == dgesmc ) ) THEN - WRITE(*,*) "All elements of dgesmc are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_dgesmc - !WRITE(*,*) "KERNEL: ", dgesmc - IF ( ALL( outstate_dgesmc == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - passed = .false. - WRITE(*,*) "dgesmc is NOT IDENTICAL." - WRITE(*,*) count( outstate_dgesmc /= dgesmc), " of ", size( dgesmc ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_dgesmc - dgesmc)**2)/real(size(outstate_dgesmc))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_dgesmc - dgesmc)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_dgesmc - dgesmc)) - WRITE(*,*) "Mean value of kernel-generated outstate_dgesmc is ", sum(dgesmc)/real(size(dgesmc)) - WRITE(*,*) "Mean value of original outstate_dgesmc is ", sum(outstate_dgesmc)/real(size(outstate_dgesmc)) - WRITE(*,*) "" - END IF - IF ( outstate_pwvcm == pwvcm ) THEN - WRITE(*,*) "pwvcm is IDENTICAL( ", outstate_pwvcm, " )." - ELSE IF ( ABS(outstate_pwvcm-pwvcm)/ABS(outstate_pwvcm) < 1.0e-15 ) THEN - WRITE(*,*) "pwvcm is NOT IDENTICAL - BUT WITHIN TOLERANCE." - WRITE(*,*) "STATE : ", outstate_pwvcm - WRITE(*,*) "KERNEL: ", pwvcm - WRITE(*,*) "Relative diff", ABS(ABS(outstate_pwvcm)-ABS(pwvcm))/ABS(outstate_pwvcm) - ELSE - passed = .false. - WRITE(*,*) "pwvcm is NOT IDENTICAL." - WRITE(*,*) "STATE : ", outstate_pwvcm - WRITE(*,*) "KERNEL: ", pwvcm - END IF - IF ( outstate_inflag == inflag ) THEN - WRITE(*,*) "inflag is IDENTICAL( ", outstate_inflag, " )." - ELSE - passed = .false. - WRITE(*,*) "inflag is NOT IDENTICAL." - WRITE(*,*) "STATE : ", outstate_inflag - WRITE(*,*) "KERNEL: ", inflag - END IF - IF ( ALL( outstate_wx == wx ) ) THEN - WRITE(*,*) "All elements of wx are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_wx - !WRITE(*,*) "KERNEL: ", wx - IF ( ALL( outstate_wx == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - passed = .false. - WRITE(*,*) "wx is NOT IDENTICAL." - WRITE(*,*) count( outstate_wx /= wx), " of ", size( wx ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_wx - wx)**2)/real(size(outstate_wx))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_wx - wx)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_wx - wx)) - WRITE(*,*) "Mean value of kernel-generated outstate_wx is ", sum(wx)/real(size(wx)) - WRITE(*,*) "Mean value of original outstate_wx is ", sum(outstate_wx)/real(size(outstate_wx)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_taua == taua ) ) THEN - WRITE(*,*) "All elements of taua are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_taua - !WRITE(*,*) "KERNEL: ", taua - IF ( ALL( outstate_taua == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - passed = .false. - WRITE(*,*) "taua is NOT IDENTICAL." - WRITE(*,*) count( outstate_taua /= taua), " of ", size( taua ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_taua - taua)**2)/real(size(outstate_taua))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_taua - taua)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_taua - taua)) - WRITE(*,*) "Mean value of kernel-generated outstate_taua is ", sum(taua)/real(size(taua)) - WRITE(*,*) "Mean value of original outstate_taua is ", sum(outstate_taua)/real(size(outstate_taua)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_taucmc == taucmc ) ) THEN - WRITE(*,*) "All elements of taucmc are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_taucmc - !WRITE(*,*) "KERNEL: ", taucmc - IF ( ALL( outstate_taucmc == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - passed = .false. - WRITE(*,*) "taucmc is NOT IDENTICAL." - WRITE(*,*) count( outstate_taucmc /= taucmc), " of ", size( taucmc ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_taucmc - taucmc)**2)/real(size(outstate_taucmc))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_taucmc - taucmc)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_taucmc - taucmc)) - WRITE(*,*) "Mean value of kernel-generated outstate_taucmc is ", sum(taucmc)/real(size(taucmc)) - WRITE(*,*) "Mean value of original outstate_taucmc is ", sum(outstate_taucmc)/real(size(outstate_taucmc)) - WRITE(*,*) "" - END IF - - IF ( passed ) THEN - WRITE(*,*) "PASSED" - ELSE - WRITE(*,*) "FAILED" - END IF - - - ! DEALLOCATE INSTATE - - - ! DEALLOCATE OUTSTATE - - - ! DEALLOCATE CALLEE INSTATE - ! DEALLOCATE INSTATE - - - ! DEALLOCATE CALEE OUTSTATE - ! DEALLOCATE OUTSTATE - - - CONTAINS - - - ! KERNEL SUBPROGRAM - subroutine inatm (iplon, nlay, icld, iaer,& - play, plev, tlay, tlev, tsfc, h2ovmr,& - o3vmr, co2vmr, ch4vmr, o2vmr, n2ovmr, cfc11vmr, cfc12vmr,& - cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw,& - cldfmcl, taucmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, tauaer,& - pavel, pz, tavel, tz, tbound, semiss, coldry,& - wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag,& - cldfmc, taucmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, taua) - integer, intent(in) :: iplon - integer, intent(in) :: nlay - integer, intent(in) :: icld - integer, intent(in) :: iaer - real(kind=r8), intent(in) :: play(:,:) - real(kind=r8), intent(in) :: plev(:,:) - real(kind=r8), intent(in) :: tlay(:,:) - real(kind=r8), intent(in) :: tlev(:,:) - real(kind=r8), intent(in) :: tsfc(:) - real(kind=r8), intent(in) :: h2ovmr(:,:) - real(kind=r8), intent(in) :: o3vmr(:,:) - real(kind=r8), intent(in) :: co2vmr(:,:) - real(kind=r8), intent(in) :: ch4vmr(:,:) - real(kind=r8), intent(in) :: o2vmr(:,:) - real(kind=r8), intent(in) :: n2ovmr(:,:) - real(kind=r8), intent(in) :: cfc11vmr(:,:) - real(kind=r8), intent(in) :: cfc12vmr(:,:) - real(kind=r8), intent(in) :: cfc22vmr(:,:) - real(kind=r8), intent(in) :: ccl4vmr(:,:) - real(kind=r8), intent(in) :: emis(:,:) - integer, intent(in) :: inflglw - integer, intent(in) :: iceflglw - integer, intent(in) :: liqflglw - real(kind=r8), intent(in) :: cldfmcl(:,:,:) - real(kind=r8), intent(in) :: ciwpmcl(:,:,:) - real(kind=r8), intent(in) :: clwpmcl(:,:,:) - real(kind=r8), intent(in) :: reicmcl(:,:) - real(kind=r8), intent(in) :: relqmcl(:,:) - real(kind=r8), intent(in) :: taucmcl(:,:,:) - real(kind=r8), intent(in) :: tauaer(:,:,:) - real(kind=r8), intent(out) :: pavel(:) - real(kind=r8), intent(out) :: tavel(:) - real(kind=r8), intent(out) :: pz(0:) - real(kind=r8), intent(out) :: tz(0:) - real(kind=r8), intent(out) :: tbound - real(kind=r8), intent(out) :: coldry(:) - real(kind=r8), intent(out) :: wbrodl(:) - real(kind=r8), intent(out) :: wkl(:,:) - real(kind=r8), intent(out) :: wx(:,:) - real(kind=r8), intent(out) :: pwvcm - real(kind=r8), intent(out) :: semiss(:) - integer, intent(out) :: inflag - integer, intent(out) :: iceflag - integer, intent(out) :: liqflag - real(kind=r8), intent(out) :: cldfmc(:,:) - real(kind=r8), intent(out) :: ciwpmc(:,:) - real(kind=r8), intent(out) :: clwpmc(:,:) - real(kind=r8), intent(out) :: relqmc(:) - real(kind=r8), intent(out) :: reicmc(:) - real(kind=r8), intent(out) :: dgesmc(:) - real(kind=r8), intent(out) :: taucmc(:,:) - real(kind=r8), intent(out) :: taua(:,:) - real(kind=r8), parameter :: amd = 28.9660_r8 - real(kind=r8), parameter :: amw = 18.0160_r8 - real(kind=r8), parameter :: amdw = 1.607793_r8 - real(kind=r8), parameter :: amdc = 0.658114_r8 - real(kind=r8), parameter :: amdo = 0.603428_r8 - real(kind=r8), parameter :: amdm = 1.805423_r8 - real(kind=r8), parameter :: amdn = 0.658090_r8 - real(kind=r8), parameter :: amdc1 = 0.210852_r8 - real(kind=r8), parameter :: amdc2 = 0.239546_r8 - real(kind=r8), parameter :: sbc = 5.67e-08_r8 - integer :: isp, l, ix, n, imol, ib, ig - real(kind=r8) :: amm, amttl, wvttl, wvsh, summol - wkl(:,:) = 0.0_r8 - wx(:,:) = 0.0_r8 - cldfmc(:,:) = 0.0_r8 - taucmc(:,:) = 0.0_r8 - ciwpmc(:,:) = 0.0_r8 - clwpmc(:,:) = 0.0_r8 - reicmc(:) = 0.0_r8 - dgesmc(:) = 0.0_r8 - relqmc(:) = 0.0_r8 - taua(:,:) = 0.0_r8 - amttl = 0.0_r8 - wvttl = 0.0_r8 - tbound = tsfc(iplon) - pz(0) = plev(iplon,nlay+1) - tz(0) = tlev(iplon,nlay+1) - do l = 1, nlay - pavel(l) = play(iplon,nlay-l+1) - tavel(l) = tlay(iplon,nlay-l+1) - pz(l) = plev(iplon,nlay-l+1) - tz(l) = tlev(iplon,nlay-l+1) - wkl(1,l) = h2ovmr(iplon,nlay-l+1) - wkl(2,l) = co2vmr(iplon,nlay-l+1) - wkl(3,l) = o3vmr(iplon,nlay-l+1) - wkl(4,l) = n2ovmr(iplon,nlay-l+1) - wkl(6,l) = ch4vmr(iplon,nlay-l+1) - wkl(7,l) = o2vmr(iplon,nlay-l+1) - amm = (1._r8 - wkl(1,l)) * amd + wkl(1,l) * amw - coldry(l) = (pz(l-1)-pz(l)) * 1.e3_r8 * avogad / (1.e2_r8 * grav * amm * (1._r8 + wkl(1,l))) - wx(1,l) = ccl4vmr(iplon,nlay-l+1) - wx(2,l) = cfc11vmr(iplon,nlay-l+1) - wx(3,l) = cfc12vmr(iplon,nlay-l+1) - wx(4,l) = cfc22vmr(iplon,nlay-l+1) - enddo - coldry(nlay) = (pz(nlay-1)) * 1.e3_r8 * avogad / (1.e2_r8 * grav * amm * (1._r8 + wkl(1,nlay-1))) - do l = 1, nlay - summol = 0.0_r8 - do imol = 2, nmol - summol = summol + wkl(imol,l) - enddo - wbrodl(l) = coldry(l) * (1._r8 - summol) - do imol = 1, nmol - wkl(imol,l) = coldry(l) * wkl(imol,l) - enddo - amttl = amttl + coldry(l)+wkl(1,l) - wvttl = wvttl + wkl(1,l) - do ix = 1,maxxsec - if (ixindx(ix) .ne. 0) then - wx(ixindx(ix),l) = coldry(l) * wx(ix,l) * 1.e-20_r8 - endif - enddo - enddo - wvsh = (amw * wvttl) / (amd * amttl) - pwvcm = wvsh * (1.e3_r8 * pz(0)) / (1.e2_r8 * grav) - do n=1,nbndlw - semiss(n) = emis(iplon,n) - enddo - if (iaer .ge. 1) then - do l = 1, nlay-1 - do ib = 1, nbndlw - taua(l,ib) = tauaer(iplon,nlay-l,ib) - enddo - enddo - endif - if (icld .ge. 1) then - inflag = inflglw - iceflag = iceflglw - liqflag = liqflglw - do l = 1, nlay-1 - do ig = 1, ngptlw - cldfmc(ig,l) = cldfmcl(ig,iplon,nlay-l) - taucmc(ig,l) = taucmcl(ig,iplon,nlay-l) - ciwpmc(ig,l) = ciwpmcl(ig,iplon,nlay-l) - clwpmc(ig,l) = clwpmcl(ig,iplon,nlay-l) - enddo - reicmc(l) = reicmcl(iplon,nlay-l) - if (iceflag .eq. 3) then - dgesmc(l) = 1.5396_r8 * reicmcl(iplon,nlay-l) - endif - relqmc(l) = relqmcl(iplon,nlay-l) - enddo - cldfmc(:,nlay) = 0.0_r8 - taucmc(:,nlay) = 0.0_r8 - ciwpmc(:,nlay) = 0.0_r8 - clwpmc(:,nlay) = 0.0_r8 - reicmc(nlay) = 0.0_r8 - dgesmc(nlay) = 0.0_r8 - relqmc(nlay) = 0.0_r8 - taua(nlay,:) = 0.0_r8 - endif - end subroutine inatm - - - END SUBROUTINE kernel_driver - - - ! RESOLVER SUBPROGRAMS - - FUNCTION kgen_get_newunit(seed) RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - INTEGER, INTENT(IN) :: seed - - new_unit = -1 - - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - END MODULE - - PROGRAM kernel_inatm - USE resolvers - USE subprograms - - IMPLICIT NONE - - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(1), PARAMETER :: kgen_mpi_rank_at = (/ 0 /) - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(1), PARAMETER :: kgen_counter_at = (/ 1 /) - CHARACTER(LEN=1024) :: kgen_filepath - INTEGER, DIMENSION(2,10) :: kgen_bound - - ! DRIVER SPECS - REAL(KIND = r8), ALLOCATABLE :: taucmcl(:, :, :) - REAL(KIND = r8), ALLOCATABLE :: ch4vmr(:, :) - INTEGER :: icld - REAL(KIND = r8), ALLOCATABLE :: emis(:, :) - REAL(KIND = r8), ALLOCATABLE :: tlay(:, :) - REAL(KIND = r8), ALLOCATABLE :: reicmcl(:, :) - INTEGER :: nlay - REAL(KIND = r8), ALLOCATABLE :: cfc11vmr(:, :) - REAL(KIND = r8), ALLOCATABLE :: tsfc(:) - REAL(KIND = r8), ALLOCATABLE :: relqmcl(:, :) - REAL(KIND = r8), ALLOCATABLE :: o3vmr(:, :) - REAL(KIND = r8), ALLOCATABLE :: n2ovmr(:, :) - REAL(KIND = r8), ALLOCATABLE :: plev(:, :) - REAL(KIND = r8), ALLOCATABLE :: play(:, :) - REAL(KIND = r8), ALLOCATABLE :: tauaer(:, :, :) - REAL(KIND = r8), ALLOCATABLE :: clwpmcl(:, :, :) - REAL(KIND = r8), ALLOCATABLE :: o2vmr(:, :) - REAL(KIND = r8), ALLOCATABLE :: co2vmr(:, :) - REAL(KIND = r8), ALLOCATABLE :: ccl4vmr(:, :) - INTEGER :: iceflglw - REAL(KIND = r8), ALLOCATABLE :: cfc12vmr(:, :) - REAL(KIND = r8), ALLOCATABLE :: tlev(:, :) - REAL(KIND = r8), ALLOCATABLE :: h2ovmr(:, :) - INTEGER :: inflglw - REAL(KIND = r8), ALLOCATABLE :: ciwpmcl(:, :, :) - REAL(KIND = r8), ALLOCATABLE :: cldfmcl(:, :, :) - INTEGER :: liqflglw - REAL(KIND = r8), ALLOCATABLE :: cfc22vmr(:, :) - - - DO kgen_repeat_counter = 1, 1 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 1)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 1)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - - - kgen_filepath = "../data/inatm." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit(kgen_mpi_rank+kgen_counter) - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) "Kernel output is being verified against " // trim(adjustl(kgen_filepath)) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - - - ! READ DRIVER INSTATE - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(taucmcl(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) taucmcl - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(ch4vmr(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) ch4vmr - READ(UNIT = kgen_unit) icld - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(emis(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) emis - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(tlay(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) tlay - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(reicmcl(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) reicmcl - READ(UNIT = kgen_unit) nlay - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(cfc11vmr(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) cfc11vmr - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(tsfc(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) tsfc - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(relqmcl(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) relqmcl - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(o3vmr(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) o3vmr - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(n2ovmr(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) n2ovmr - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(plev(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) plev - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(play(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) play - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(tauaer(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) tauaer - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(clwpmcl(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) clwpmcl - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(o2vmr(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) o2vmr - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(co2vmr(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) co2vmr - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(ccl4vmr(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) ccl4vmr - READ(UNIT = kgen_unit) iceflglw - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(cfc12vmr(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) cfc12vmr - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(tlev(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) tlev - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(h2ovmr(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) h2ovmr - READ(UNIT = kgen_unit) inflglw - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(ciwpmcl(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) ciwpmcl - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(cldfmcl(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) cldfmcl - READ(UNIT = kgen_unit) liqflglw - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(cfc22vmr(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) cfc22vmr - - - ! KERNEL DRIVER RUN - CALL kernel_driver(taucmcl, ch4vmr, icld, emis, tlay, reicmcl, nlay, cfc11vmr, tsfc, relqmcl, o3vmr, n2ovmr, plev, play, tauaer, clwpmcl, o2vmr, co2vmr, ccl4vmr, iceflglw, cfc12vmr, tlev, h2ovmr, inflglw, ciwpmcl, cldfmcl, liqflglw, cfc22vmr, kgen_unit) - - CLOSE (UNIT=kgen_unit) - - WRITE (*,*) - END DO - - END PROGRAM kernel_inatm diff --git a/test/ncar_kernels/PORT_inatm/src/kernel_inatm.F90_orig b/test/ncar_kernels/PORT_inatm/src/kernel_inatm.F90_orig deleted file mode 100644 index b8133ace78..0000000000 --- a/test/ncar_kernels/PORT_inatm/src/kernel_inatm.F90_orig +++ /dev/null @@ -1,912 +0,0 @@ - MODULE resolvers - - ! RESOLVER SPECS - INTEGER, PARAMETER :: r8 = selected_real_kind(12) - INTEGER, PARAMETER :: nmol = 7 - INTEGER, PARAMETER :: maxxsec = 4 - INTEGER, PARAMETER :: nbndlw = 16 - INTEGER, PARAMETER :: ngptlw = 140 - INTEGER, PARAMETER :: mxmol = 38 - INTEGER, PARAMETER :: maxinpx = 38 - - END MODULE - - MODULE subprograms - - CONTAINS - - - ! KERNEL DRIVER SUBROUTINE - SUBROUTINE kernel_driver(taucmcl, ch4vmr, icld, emis, tlay, reicmcl, nlay, cfc11vmr, tsfc, relqmcl, o3vmr, n2ovmr, plev, play, tauaer, clwpmcl, o2vmr, co2vmr, ccl4vmr, iceflglw, cfc12vmr, tlev, h2ovmr, inflglw, ciwpmcl, cldfmcl, liqflglw, cfc22vmr, kgen_unit) - USE resolvers - - IMPLICIT NONE - INTEGER, INTENT(IN) :: kgen_unit - INTEGER, DIMENSION(2,10) :: kgen_bound - - - ! STATE SPECS - REAL(KIND = r8), INTENT(IN) :: taucmcl(:, :, :) - INTEGER :: iceflag - REAL(KIND = r8) :: wkl(mxmol, nlay) - REAL(KIND = r8) :: coldry(nlay) - REAL(KIND = r8), INTENT(IN) :: ch4vmr(:, :) - REAL(KIND = r8) :: clwpmc(ngptlw, nlay) - INTEGER, INTENT(INOUT) :: icld - REAL(KIND = r8), INTENT(IN) :: emis(:, :) - REAL(KIND = r8) :: avogad - REAL(KIND = r8) :: cldfmc(ngptlw, nlay) - REAL(KIND = r8) :: relqmc(nlay) - REAL(KIND = r8) :: ciwpmc(ngptlw, nlay) - REAL(KIND = r8) :: wbrodl(nlay) - REAL(KIND = r8), INTENT(IN) :: tlay(:, :) - REAL(KIND = r8), INTENT(IN) :: reicmcl(:, :) - INTEGER, INTENT(IN) :: nlay - REAL(KIND = r8) :: tavel(nlay) - INTEGER :: liqflag - REAL(KIND = r8) :: tz(0 : nlay) - REAL(KIND = r8), INTENT(IN) :: cfc11vmr(:, :) - REAL(KIND = r8), INTENT(IN) :: tsfc(:) - REAL(KIND = r8) :: pz(0 : nlay) - REAL(KIND = r8), INTENT(IN) :: relqmcl(:, :) - REAL(KIND = r8), INTENT(IN) :: o3vmr(:, :) - REAL(KIND = r8) :: tbound - INTEGER :: iaer - REAL(KIND = r8), INTENT(IN) :: n2ovmr(:, :) - REAL(KIND = r8) :: reicmc(nlay) - REAL(KIND = r8), INTENT(IN) :: plev(:, :) - REAL(KIND = r8), INTENT(IN) :: play(:, :) - REAL(KIND = r8), INTENT(IN) :: tauaer(:, :, :) - REAL(KIND = r8) :: semiss(nbndlw) - REAL(KIND = r8) :: pavel(nlay) - REAL(KIND = r8), INTENT(IN) :: clwpmcl(:, :, :) - REAL(KIND = r8), INTENT(IN) :: o2vmr(:, :) - REAL(KIND = r8) :: dgesmc(nlay) - REAL(KIND = r8) :: pwvcm - REAL(KIND = r8), INTENT(IN) :: co2vmr(:, :) - INTEGER :: inflag - REAL(KIND = r8) :: wx(maxxsec, nlay) - REAL(KIND = r8), INTENT(IN) :: ccl4vmr(:, :) - REAL(KIND = r8) :: taua(nlay, nbndlw) - INTEGER, INTENT(IN) :: iceflglw - REAL(KIND = r8), INTENT(IN) :: cfc12vmr(:, :) - REAL(KIND = r8), INTENT(IN) :: tlev(:, :) - REAL(KIND = r8) :: grav - REAL(KIND = r8) :: taucmc(ngptlw, nlay) - REAL(KIND = r8), INTENT(IN) :: h2ovmr(:, :) - INTEGER :: iplon - INTEGER, INTENT(IN) :: inflglw - REAL(KIND = r8), INTENT(IN) :: ciwpmcl(:, :, :) - INTEGER :: ixindx(maxinpx) - REAL(KIND = r8), INTENT(IN) :: cldfmcl(:, :, :) - INTEGER, INTENT(IN) :: liqflglw - REAL(KIND = r8), INTENT(IN) :: cfc22vmr(:, :) - INTEGER :: outstate_iceflag - REAL(KIND = r8) :: outstate_wkl(mxmol, nlay) - REAL(KIND = r8) :: outstate_coldry(nlay) - REAL(KIND = r8) :: outstate_clwpmc(ngptlw, nlay) - REAL(KIND = r8) :: outstate_cldfmc(ngptlw, nlay) - REAL(KIND = r8) :: outstate_relqmc(nlay) - REAL(KIND = r8) :: outstate_ciwpmc(ngptlw, nlay) - REAL(KIND = r8) :: outstate_wbrodl(nlay) - REAL(KIND = r8) :: outstate_tavel(nlay) - INTEGER :: outstate_liqflag - REAL(KIND = r8) :: outstate_tz(0 : nlay) - REAL(KIND = r8) :: outstate_pz(0 : nlay) - REAL(KIND = r8) :: outstate_tbound - REAL(KIND = r8) :: outstate_reicmc(nlay) - REAL(KIND = r8) :: outstate_semiss(nbndlw) - REAL(KIND = r8) :: outstate_pavel(nlay) - REAL(KIND = r8) :: outstate_dgesmc(nlay) - REAL(KIND = r8) :: outstate_pwvcm - INTEGER :: outstate_inflag - REAL(KIND = r8) :: outstate_wx(maxxsec, nlay) - REAL(KIND = r8) :: outstate_taua(nlay, nbndlw) - REAL(KIND = r8) :: outstate_taucmc(ngptlw, nlay) - - - ! READ CALLER INSTATE - READ(UNIT = kgen_unit) iaer - READ(UNIT = kgen_unit) iplon - - - ! READ CALLEE INSTATE - READ(UNIT = kgen_unit) avogad - READ(UNIT = kgen_unit) grav - READ(UNIT = kgen_unit) ixindx - - - ! READ CALLEE OUTSTATE - - - ! READ CALLER OUTSTATE - READ(UNIT = kgen_unit) outstate_iceflag - READ(UNIT = kgen_unit) outstate_wkl - READ(UNIT = kgen_unit) outstate_coldry - READ(UNIT = kgen_unit) outstate_clwpmc - READ(UNIT = kgen_unit) outstate_cldfmc - READ(UNIT = kgen_unit) outstate_relqmc - READ(UNIT = kgen_unit) outstate_ciwpmc - READ(UNIT = kgen_unit) outstate_wbrodl - READ(UNIT = kgen_unit) outstate_tavel - READ(UNIT = kgen_unit) outstate_liqflag - READ(UNIT = kgen_unit) outstate_tz - READ(UNIT = kgen_unit) outstate_pz - READ(UNIT = kgen_unit) outstate_tbound - READ(UNIT = kgen_unit) outstate_reicmc - READ(UNIT = kgen_unit) outstate_semiss - READ(UNIT = kgen_unit) outstate_pavel - READ(UNIT = kgen_unit) outstate_dgesmc - READ(UNIT = kgen_unit) outstate_pwvcm - READ(UNIT = kgen_unit) outstate_inflag - READ(UNIT = kgen_unit) outstate_wx - READ(UNIT = kgen_unit) outstate_taua - READ(UNIT = kgen_unit) outstate_taucmc - - - ! KERNEL RUN - CALL inatm(iplon, nlay, icld, iaer, play, plev, tlay, tlev, tsfc, h2ovmr, o3vmr, co2vmr, ch4vmr, o2vmr, n2ovmr, cfc11vmr, cfc12vmr, cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, cldfmcl, taucmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, tauaer, pavel, pz, tavel, tz, tbound, semiss, coldry, wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag, cldfmc, taucmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, taua) - - - ! STATE VERIFICATION - IF ( outstate_iceflag == iceflag ) THEN - WRITE(*,*) "iceflag is IDENTICAL( ", outstate_iceflag, " )." - ELSE - WRITE(*,*) "iceflag is NOT IDENTICAL." - WRITE(*,*) "STATE : ", outstate_iceflag - WRITE(*,*) "KERNEL: ", iceflag - END IF - IF ( ALL( outstate_wkl == wkl ) ) THEN - WRITE(*,*) "All elements of wkl are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_wkl - !WRITE(*,*) "KERNEL: ", wkl - IF ( ALL( outstate_wkl == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "wkl is NOT IDENTICAL." - WRITE(*,*) count( outstate_wkl /= wkl), " of ", size( wkl ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_wkl - wkl)**2)/real(size(outstate_wkl))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_wkl - wkl)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_wkl - wkl)) - WRITE(*,*) "Mean value of kernel-generated outstate_wkl is ", sum(wkl)/real(size(wkl)) - WRITE(*,*) "Mean value of original outstate_wkl is ", sum(outstate_wkl)/real(size(outstate_wkl)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_coldry == coldry ) ) THEN - WRITE(*,*) "All elements of coldry are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_coldry - !WRITE(*,*) "KERNEL: ", coldry - IF ( ALL( outstate_coldry == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "coldry is NOT IDENTICAL." - WRITE(*,*) count( outstate_coldry /= coldry), " of ", size( coldry ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_coldry - coldry)**2)/real(size(outstate_coldry))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_coldry - coldry)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_coldry - coldry)) - WRITE(*,*) "Mean value of kernel-generated outstate_coldry is ", sum(coldry)/real(size(coldry)) - WRITE(*,*) "Mean value of original outstate_coldry is ", sum(outstate_coldry)/real(size(outstate_coldry)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_clwpmc == clwpmc ) ) THEN - WRITE(*,*) "All elements of clwpmc are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_clwpmc - !WRITE(*,*) "KERNEL: ", clwpmc - IF ( ALL( outstate_clwpmc == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "clwpmc is NOT IDENTICAL." - WRITE(*,*) count( outstate_clwpmc /= clwpmc), " of ", size( clwpmc ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_clwpmc - clwpmc)**2)/real(size(outstate_clwpmc))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_clwpmc - clwpmc)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_clwpmc - clwpmc)) - WRITE(*,*) "Mean value of kernel-generated outstate_clwpmc is ", sum(clwpmc)/real(size(clwpmc)) - WRITE(*,*) "Mean value of original outstate_clwpmc is ", sum(outstate_clwpmc)/real(size(outstate_clwpmc)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_cldfmc == cldfmc ) ) THEN - WRITE(*,*) "All elements of cldfmc are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_cldfmc - !WRITE(*,*) "KERNEL: ", cldfmc - IF ( ALL( outstate_cldfmc == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "cldfmc is NOT IDENTICAL." - WRITE(*,*) count( outstate_cldfmc /= cldfmc), " of ", size( cldfmc ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_cldfmc - cldfmc)**2)/real(size(outstate_cldfmc))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_cldfmc - cldfmc)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_cldfmc - cldfmc)) - WRITE(*,*) "Mean value of kernel-generated outstate_cldfmc is ", sum(cldfmc)/real(size(cldfmc)) - WRITE(*,*) "Mean value of original outstate_cldfmc is ", sum(outstate_cldfmc)/real(size(outstate_cldfmc)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_relqmc == relqmc ) ) THEN - WRITE(*,*) "All elements of relqmc are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_relqmc - !WRITE(*,*) "KERNEL: ", relqmc - IF ( ALL( outstate_relqmc == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "relqmc is NOT IDENTICAL." - WRITE(*,*) count( outstate_relqmc /= relqmc), " of ", size( relqmc ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_relqmc - relqmc)**2)/real(size(outstate_relqmc))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_relqmc - relqmc)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_relqmc - relqmc)) - WRITE(*,*) "Mean value of kernel-generated outstate_relqmc is ", sum(relqmc)/real(size(relqmc)) - WRITE(*,*) "Mean value of original outstate_relqmc is ", sum(outstate_relqmc)/real(size(outstate_relqmc)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_ciwpmc == ciwpmc ) ) THEN - WRITE(*,*) "All elements of ciwpmc are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_ciwpmc - !WRITE(*,*) "KERNEL: ", ciwpmc - IF ( ALL( outstate_ciwpmc == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "ciwpmc is NOT IDENTICAL." - WRITE(*,*) count( outstate_ciwpmc /= ciwpmc), " of ", size( ciwpmc ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_ciwpmc - ciwpmc)**2)/real(size(outstate_ciwpmc))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_ciwpmc - ciwpmc)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_ciwpmc - ciwpmc)) - WRITE(*,*) "Mean value of kernel-generated outstate_ciwpmc is ", sum(ciwpmc)/real(size(ciwpmc)) - WRITE(*,*) "Mean value of original outstate_ciwpmc is ", sum(outstate_ciwpmc)/real(size(outstate_ciwpmc)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_wbrodl == wbrodl ) ) THEN - WRITE(*,*) "All elements of wbrodl are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_wbrodl - !WRITE(*,*) "KERNEL: ", wbrodl - IF ( ALL( outstate_wbrodl == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "wbrodl is NOT IDENTICAL." - WRITE(*,*) count( outstate_wbrodl /= wbrodl), " of ", size( wbrodl ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_wbrodl - wbrodl)**2)/real(size(outstate_wbrodl))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_wbrodl - wbrodl)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_wbrodl - wbrodl)) - WRITE(*,*) "Mean value of kernel-generated outstate_wbrodl is ", sum(wbrodl)/real(size(wbrodl)) - WRITE(*,*) "Mean value of original outstate_wbrodl is ", sum(outstate_wbrodl)/real(size(outstate_wbrodl)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_tavel == tavel ) ) THEN - WRITE(*,*) "All elements of tavel are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_tavel - !WRITE(*,*) "KERNEL: ", tavel - IF ( ALL( outstate_tavel == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "tavel is NOT IDENTICAL." - WRITE(*,*) count( outstate_tavel /= tavel), " of ", size( tavel ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_tavel - tavel)**2)/real(size(outstate_tavel))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_tavel - tavel)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_tavel - tavel)) - WRITE(*,*) "Mean value of kernel-generated outstate_tavel is ", sum(tavel)/real(size(tavel)) - WRITE(*,*) "Mean value of original outstate_tavel is ", sum(outstate_tavel)/real(size(outstate_tavel)) - WRITE(*,*) "" - END IF - IF ( outstate_liqflag == liqflag ) THEN - WRITE(*,*) "liqflag is IDENTICAL( ", outstate_liqflag, " )." - ELSE - WRITE(*,*) "liqflag is NOT IDENTICAL." - WRITE(*,*) "STATE : ", outstate_liqflag - WRITE(*,*) "KERNEL: ", liqflag - END IF - IF ( ALL( outstate_tz == tz ) ) THEN - WRITE(*,*) "All elements of tz are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_tz - !WRITE(*,*) "KERNEL: ", tz - IF ( ALL( outstate_tz == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "tz is NOT IDENTICAL." - WRITE(*,*) count( outstate_tz /= tz), " of ", size( tz ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_tz - tz)**2)/real(size(outstate_tz))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_tz - tz)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_tz - tz)) - WRITE(*,*) "Mean value of kernel-generated outstate_tz is ", sum(tz)/real(size(tz)) - WRITE(*,*) "Mean value of original outstate_tz is ", sum(outstate_tz)/real(size(outstate_tz)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_pz == pz ) ) THEN - WRITE(*,*) "All elements of pz are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_pz - !WRITE(*,*) "KERNEL: ", pz - IF ( ALL( outstate_pz == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "pz is NOT IDENTICAL." - WRITE(*,*) count( outstate_pz /= pz), " of ", size( pz ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_pz - pz)**2)/real(size(outstate_pz))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_pz - pz)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_pz - pz)) - WRITE(*,*) "Mean value of kernel-generated outstate_pz is ", sum(pz)/real(size(pz)) - WRITE(*,*) "Mean value of original outstate_pz is ", sum(outstate_pz)/real(size(outstate_pz)) - WRITE(*,*) "" - END IF - IF ( outstate_tbound == tbound ) THEN - WRITE(*,*) "tbound is IDENTICAL( ", outstate_tbound, " )." - ELSE - WRITE(*,*) "tbound is NOT IDENTICAL." - WRITE(*,*) "STATE : ", outstate_tbound - WRITE(*,*) "KERNEL: ", tbound - END IF - IF ( ALL( outstate_reicmc == reicmc ) ) THEN - WRITE(*,*) "All elements of reicmc are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_reicmc - !WRITE(*,*) "KERNEL: ", reicmc - IF ( ALL( outstate_reicmc == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "reicmc is NOT IDENTICAL." - WRITE(*,*) count( outstate_reicmc /= reicmc), " of ", size( reicmc ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_reicmc - reicmc)**2)/real(size(outstate_reicmc))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_reicmc - reicmc)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_reicmc - reicmc)) - WRITE(*,*) "Mean value of kernel-generated outstate_reicmc is ", sum(reicmc)/real(size(reicmc)) - WRITE(*,*) "Mean value of original outstate_reicmc is ", sum(outstate_reicmc)/real(size(outstate_reicmc)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_semiss == semiss ) ) THEN - WRITE(*,*) "All elements of semiss are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_semiss - !WRITE(*,*) "KERNEL: ", semiss - IF ( ALL( outstate_semiss == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "semiss is NOT IDENTICAL." - WRITE(*,*) count( outstate_semiss /= semiss), " of ", size( semiss ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_semiss - semiss)**2)/real(size(outstate_semiss))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_semiss - semiss)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_semiss - semiss)) - WRITE(*,*) "Mean value of kernel-generated outstate_semiss is ", sum(semiss)/real(size(semiss)) - WRITE(*,*) "Mean value of original outstate_semiss is ", sum(outstate_semiss)/real(size(outstate_semiss)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_pavel == pavel ) ) THEN - WRITE(*,*) "All elements of pavel are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_pavel - !WRITE(*,*) "KERNEL: ", pavel - IF ( ALL( outstate_pavel == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "pavel is NOT IDENTICAL." - WRITE(*,*) count( outstate_pavel /= pavel), " of ", size( pavel ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_pavel - pavel)**2)/real(size(outstate_pavel))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_pavel - pavel)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_pavel - pavel)) - WRITE(*,*) "Mean value of kernel-generated outstate_pavel is ", sum(pavel)/real(size(pavel)) - WRITE(*,*) "Mean value of original outstate_pavel is ", sum(outstate_pavel)/real(size(outstate_pavel)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_dgesmc == dgesmc ) ) THEN - WRITE(*,*) "All elements of dgesmc are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_dgesmc - !WRITE(*,*) "KERNEL: ", dgesmc - IF ( ALL( outstate_dgesmc == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "dgesmc is NOT IDENTICAL." - WRITE(*,*) count( outstate_dgesmc /= dgesmc), " of ", size( dgesmc ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_dgesmc - dgesmc)**2)/real(size(outstate_dgesmc))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_dgesmc - dgesmc)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_dgesmc - dgesmc)) - WRITE(*,*) "Mean value of kernel-generated outstate_dgesmc is ", sum(dgesmc)/real(size(dgesmc)) - WRITE(*,*) "Mean value of original outstate_dgesmc is ", sum(outstate_dgesmc)/real(size(outstate_dgesmc)) - WRITE(*,*) "" - END IF - IF ( outstate_pwvcm == pwvcm ) THEN - WRITE(*,*) "pwvcm is IDENTICAL( ", outstate_pwvcm, " )." - ELSE - WRITE(*,*) "pwvcm is NOT IDENTICAL." - WRITE(*,*) "STATE : ", outstate_pwvcm - WRITE(*,*) "KERNEL: ", pwvcm - END IF - IF ( outstate_inflag == inflag ) THEN - WRITE(*,*) "inflag is IDENTICAL( ", outstate_inflag, " )." - ELSE - WRITE(*,*) "inflag is NOT IDENTICAL." - WRITE(*,*) "STATE : ", outstate_inflag - WRITE(*,*) "KERNEL: ", inflag - END IF - IF ( ALL( outstate_wx == wx ) ) THEN - WRITE(*,*) "All elements of wx are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_wx - !WRITE(*,*) "KERNEL: ", wx - IF ( ALL( outstate_wx == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "wx is NOT IDENTICAL." - WRITE(*,*) count( outstate_wx /= wx), " of ", size( wx ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_wx - wx)**2)/real(size(outstate_wx))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_wx - wx)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_wx - wx)) - WRITE(*,*) "Mean value of kernel-generated outstate_wx is ", sum(wx)/real(size(wx)) - WRITE(*,*) "Mean value of original outstate_wx is ", sum(outstate_wx)/real(size(outstate_wx)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_taua == taua ) ) THEN - WRITE(*,*) "All elements of taua are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_taua - !WRITE(*,*) "KERNEL: ", taua - IF ( ALL( outstate_taua == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "taua is NOT IDENTICAL." - WRITE(*,*) count( outstate_taua /= taua), " of ", size( taua ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_taua - taua)**2)/real(size(outstate_taua))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_taua - taua)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_taua - taua)) - WRITE(*,*) "Mean value of kernel-generated outstate_taua is ", sum(taua)/real(size(taua)) - WRITE(*,*) "Mean value of original outstate_taua is ", sum(outstate_taua)/real(size(outstate_taua)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_taucmc == taucmc ) ) THEN - WRITE(*,*) "All elements of taucmc are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_taucmc - !WRITE(*,*) "KERNEL: ", taucmc - IF ( ALL( outstate_taucmc == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - WRITE(*,*) "taucmc is NOT IDENTICAL." - WRITE(*,*) count( outstate_taucmc /= taucmc), " of ", size( taucmc ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_taucmc - taucmc)**2)/real(size(outstate_taucmc))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_taucmc - taucmc)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_taucmc - taucmc)) - WRITE(*,*) "Mean value of kernel-generated outstate_taucmc is ", sum(taucmc)/real(size(taucmc)) - WRITE(*,*) "Mean value of original outstate_taucmc is ", sum(outstate_taucmc)/real(size(outstate_taucmc)) - WRITE(*,*) "" - END IF - - - ! DEALLOCATE INSTATE - - - ! DEALLOCATE OUTSTATE - - - ! DEALLOCATE CALLEE INSTATE - ! DEALLOCATE INSTATE - - - ! DEALLOCATE CALEE OUTSTATE - ! DEALLOCATE OUTSTATE - - - CONTAINS - - - ! KERNEL SUBPROGRAM - subroutine inatm (iplon, nlay, icld, iaer, play, plev, tlay, tlev, tsfc, h2ovmr, o3vmr, co2vmr, ch4vmr, o2vmr, n2ovmr, cfc11vmr, cfc12vmr, cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, cldfmcl, taucmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, tauaer, pavel, pz, tavel, tz, tbound, semiss, coldry, wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag, cldfmc, taucmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, taua) - integer, intent(in) :: iplon - integer, intent(in) :: nlay - integer, intent(in) :: icld - integer, intent(in) :: iaer - real(kind=r8), intent(in) :: play(:,:) - real(kind=r8), intent(in) :: plev(:,:) - real(kind=r8), intent(in) :: tlay(:,:) - real(kind=r8), intent(in) :: tlev(:,:) - real(kind=r8), intent(in) :: tsfc(:) - real(kind=r8), intent(in) :: h2ovmr(:,:) - real(kind=r8), intent(in) :: o3vmr(:,:) - real(kind=r8), intent(in) :: co2vmr(:,:) - real(kind=r8), intent(in) :: ch4vmr(:,:) - real(kind=r8), intent(in) :: o2vmr(:,:) - real(kind=r8), intent(in) :: n2ovmr(:,:) - real(kind=r8), intent(in) :: cfc11vmr(:,:) - real(kind=r8), intent(in) :: cfc12vmr(:,:) - real(kind=r8), intent(in) :: cfc22vmr(:,:) - real(kind=r8), intent(in) :: ccl4vmr(:,:) - real(kind=r8), intent(in) :: emis(:,:) - integer, intent(in) :: inflglw - integer, intent(in) :: iceflglw - integer, intent(in) :: liqflglw - real(kind=r8), intent(in) :: cldfmcl(:,:,:) - real(kind=r8), intent(in) :: ciwpmcl(:,:,:) - real(kind=r8), intent(in) :: clwpmcl(:,:,:) - real(kind=r8), intent(in) :: reicmcl(:,:) - real(kind=r8), intent(in) :: relqmcl(:,:) - real(kind=r8), intent(in) :: taucmcl(:,:,:) - real(kind=r8), intent(in) :: tauaer(:,:,:) - real(kind=r8), intent(out) :: pavel(:) - real(kind=r8), intent(out) :: tavel(:) - real(kind=r8), intent(out) :: pz(0:) - real(kind=r8), intent(out) :: tz(0:) - real(kind=r8), intent(out) :: tbound - real(kind=r8), intent(out) :: coldry(:) - real(kind=r8), intent(out) :: wbrodl(:) - real(kind=r8), intent(out) :: wkl(:,:) - real(kind=r8), intent(out) :: wx(:,:) - real(kind=r8), intent(out) :: pwvcm - real(kind=r8), intent(out) :: semiss(:) - integer, intent(out) :: inflag - integer, intent(out) :: iceflag - integer, intent(out) :: liqflag - real(kind=r8), intent(out) :: cldfmc(:,:) - real(kind=r8), intent(out) :: ciwpmc(:,:) - real(kind=r8), intent(out) :: clwpmc(:,:) - real(kind=r8), intent(out) :: relqmc(:) - real(kind=r8), intent(out) :: reicmc(:) - real(kind=r8), intent(out) :: dgesmc(:) - real(kind=r8), intent(out) :: taucmc(:,:) - real(kind=r8), intent(out) :: taua(:,:) - real(kind=r8), parameter :: amd = 28.9660_r8 - real(kind=r8), parameter :: amw = 18.0160_r8 - real(kind=r8), parameter :: amdw = 1.607793_r8 - real(kind=r8), parameter :: amdc = 0.658114_r8 - real(kind=r8), parameter :: amdo = 0.603428_r8 - real(kind=r8), parameter :: amdm = 1.805423_r8 - real(kind=r8), parameter :: amdn = 0.658090_r8 - real(kind=r8), parameter :: amdc1 = 0.210852_r8 - real(kind=r8), parameter :: amdc2 = 0.239546_r8 - real(kind=r8), parameter :: sbc = 5.67e-08_r8 - integer :: isp, l, ix, n, imol, ib, ig - real(kind=r8) :: amm, amttl, wvttl, wvsh, summol - wkl(:,:) = 0.0_r8 - wx(:,:) = 0.0_r8 - cldfmc(:,:) = 0.0_r8 - taucmc(:,:) = 0.0_r8 - ciwpmc(:,:) = 0.0_r8 - clwpmc(:,:) = 0.0_r8 - reicmc(:) = 0.0_r8 - dgesmc(:) = 0.0_r8 - relqmc(:) = 0.0_r8 - taua(:,:) = 0.0_r8 - amttl = 0.0_r8 - wvttl = 0.0_r8 - tbound = tsfc(iplon) - pz(0) = plev(iplon,nlay+1) - tz(0) = tlev(iplon,nlay+1) - do l = 1, nlay - pavel(l) = play(iplon,nlay-l+1) - tavel(l) = tlay(iplon,nlay-l+1) - pz(l) = plev(iplon,nlay-l+1) - tz(l) = tlev(iplon,nlay-l+1) - wkl(1,l) = h2ovmr(iplon,nlay-l+1) - wkl(2,l) = co2vmr(iplon,nlay-l+1) - wkl(3,l) = o3vmr(iplon,nlay-l+1) - wkl(4,l) = n2ovmr(iplon,nlay-l+1) - wkl(6,l) = ch4vmr(iplon,nlay-l+1) - wkl(7,l) = o2vmr(iplon,nlay-l+1) - amm = (1._r8 - wkl(1,l)) * amd + wkl(1,l) * amw - coldry(l) = (pz(l-1)-pz(l)) * 1.e3_r8 * avogad / (1.e2_r8 * grav * amm * (1._r8 + wkl(1,l))) - wx(1,l) = ccl4vmr(iplon,nlay-l+1) - wx(2,l) = cfc11vmr(iplon,nlay-l+1) - wx(3,l) = cfc12vmr(iplon,nlay-l+1) - wx(4,l) = cfc22vmr(iplon,nlay-l+1) - enddo - coldry(nlay) = (pz(nlay-1)) * 1.e3_r8 * avogad / (1.e2_r8 * grav * amm * (1._r8 + wkl(1,nlay-1))) - do l = 1, nlay - summol = 0.0_r8 - do imol = 2, nmol - summol = summol + wkl(imol,l) - enddo - wbrodl(l) = coldry(l) * (1._r8 - summol) - do imol = 1, nmol - wkl(imol,l) = coldry(l) * wkl(imol,l) - enddo - amttl = amttl + coldry(l)+wkl(1,l) - wvttl = wvttl + wkl(1,l) - do ix = 1,maxxsec - if (ixindx(ix) .ne. 0) then - wx(ixindx(ix),l) = coldry(l) * wx(ix,l) * 1.e-20_r8 - endif - enddo - enddo - wvsh = (amw * wvttl) / (amd * amttl) - pwvcm = wvsh * (1.e3_r8 * pz(0)) / (1.e2_r8 * grav) - do n=1,nbndlw - semiss(n) = emis(iplon,n) - enddo - if (iaer .ge. 1) then - do l = 1, nlay-1 - do ib = 1, nbndlw - taua(l,ib) = tauaer(iplon,nlay-l,ib) - enddo - enddo - endif - if (icld .ge. 1) then - inflag = inflglw - iceflag = iceflglw - liqflag = liqflglw - do l = 1, nlay-1 - do ig = 1, ngptlw - cldfmc(ig,l) = cldfmcl(ig,iplon,nlay-l) - taucmc(ig,l) = taucmcl(ig,iplon,nlay-l) - ciwpmc(ig,l) = ciwpmcl(ig,iplon,nlay-l) - clwpmc(ig,l) = clwpmcl(ig,iplon,nlay-l) - enddo - reicmc(l) = reicmcl(iplon,nlay-l) - if (iceflag .eq. 3) then - dgesmc(l) = 1.5396_r8 * reicmcl(iplon,nlay-l) - endif - relqmc(l) = relqmcl(iplon,nlay-l) - enddo - cldfmc(:,nlay) = 0.0_r8 - taucmc(:,nlay) = 0.0_r8 - ciwpmc(:,nlay) = 0.0_r8 - clwpmc(:,nlay) = 0.0_r8 - reicmc(nlay) = 0.0_r8 - dgesmc(nlay) = 0.0_r8 - relqmc(nlay) = 0.0_r8 - taua(nlay,:) = 0.0_r8 - endif - end subroutine inatm - - - END SUBROUTINE kernel_driver - - - ! RESOLVER SUBPROGRAMS - - FUNCTION kgen_get_newunit(seed) RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - INTEGER, INTENT(IN) :: seed - - new_unit = -1 - - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - END MODULE - - PROGRAM kernel_inatm - USE resolvers - USE subprograms - - IMPLICIT NONE - - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(1), PARAMETER :: kgen_mpi_rank_at = (/ 0 /) - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(1), PARAMETER :: kgen_counter_at = (/ 1 /) - CHARACTER(LEN=1024) :: kgen_filepath - INTEGER, DIMENSION(2,10) :: kgen_bound - - ! DRIVER SPECS - REAL(KIND = r8), ALLOCATABLE :: taucmcl(:, :, :) - REAL(KIND = r8), ALLOCATABLE :: ch4vmr(:, :) - INTEGER :: icld - REAL(KIND = r8), ALLOCATABLE :: emis(:, :) - REAL(KIND = r8), ALLOCATABLE :: tlay(:, :) - REAL(KIND = r8), ALLOCATABLE :: reicmcl(:, :) - INTEGER :: nlay - REAL(KIND = r8), ALLOCATABLE :: cfc11vmr(:, :) - REAL(KIND = r8), ALLOCATABLE :: tsfc(:) - REAL(KIND = r8), ALLOCATABLE :: relqmcl(:, :) - REAL(KIND = r8), ALLOCATABLE :: o3vmr(:, :) - REAL(KIND = r8), ALLOCATABLE :: n2ovmr(:, :) - REAL(KIND = r8), ALLOCATABLE :: plev(:, :) - REAL(KIND = r8), ALLOCATABLE :: play(:, :) - REAL(KIND = r8), ALLOCATABLE :: tauaer(:, :, :) - REAL(KIND = r8), ALLOCATABLE :: clwpmcl(:, :, :) - REAL(KIND = r8), ALLOCATABLE :: o2vmr(:, :) - REAL(KIND = r8), ALLOCATABLE :: co2vmr(:, :) - REAL(KIND = r8), ALLOCATABLE :: ccl4vmr(:, :) - INTEGER :: iceflglw - REAL(KIND = r8), ALLOCATABLE :: cfc12vmr(:, :) - REAL(KIND = r8), ALLOCATABLE :: tlev(:, :) - REAL(KIND = r8), ALLOCATABLE :: h2ovmr(:, :) - INTEGER :: inflglw - REAL(KIND = r8), ALLOCATABLE :: ciwpmcl(:, :, :) - REAL(KIND = r8), ALLOCATABLE :: cldfmcl(:, :, :) - INTEGER :: liqflglw - REAL(KIND = r8), ALLOCATABLE :: cfc22vmr(:, :) - - - DO kgen_repeat_counter = 1, 1 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 1)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 1)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - - - kgen_filepath = "../data/inatm." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit(kgen_mpi_rank+kgen_counter) - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) "Kernel output is being verified against " // trim(adjustl(kgen_filepath)) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - - - ! READ DRIVER INSTATE - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(taucmcl(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) taucmcl - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(ch4vmr(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) ch4vmr - READ(UNIT = kgen_unit) icld - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(emis(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) emis - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(tlay(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) tlay - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(reicmcl(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) reicmcl - READ(UNIT = kgen_unit) nlay - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(cfc11vmr(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) cfc11vmr - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(tsfc(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) tsfc - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(relqmcl(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) relqmcl - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(o3vmr(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) o3vmr - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(n2ovmr(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) n2ovmr - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(plev(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) plev - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(play(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) play - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(tauaer(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) tauaer - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(clwpmcl(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) clwpmcl - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(o2vmr(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) o2vmr - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(co2vmr(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) co2vmr - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(ccl4vmr(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) ccl4vmr - READ(UNIT = kgen_unit) iceflglw - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(cfc12vmr(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) cfc12vmr - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(tlev(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) tlev - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(h2ovmr(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) h2ovmr - READ(UNIT = kgen_unit) inflglw - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(ciwpmcl(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) ciwpmcl - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(cldfmcl(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) cldfmcl - READ(UNIT = kgen_unit) liqflglw - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(cfc22vmr(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) cfc22vmr - - - ! KERNEL DRIVER RUN - CALL kernel_driver(taucmcl, ch4vmr, icld, emis, tlay, reicmcl, nlay, cfc11vmr, tsfc, relqmcl, o3vmr, n2ovmr, plev, play, tauaer, clwpmcl, o2vmr, co2vmr, ccl4vmr, iceflglw, cfc12vmr, tlev, h2ovmr, inflglw, ciwpmcl, cldfmcl, liqflglw, cfc22vmr, kgen_unit) - - CLOSE (UNIT=kgen_unit) - - WRITE (*,*) - END DO - - END PROGRAM kernel_inatm diff --git a/test/ncar_kernels/PORT_inatm/src/rrtmg_lw_rad.f90 b/test/ncar_kernels/PORT_inatm/src/rrtmg_lw_rad.f90 deleted file mode 100644 index 7536f2fe8e..0000000000 --- a/test/ncar_kernels/PORT_inatm/src/rrtmg_lw_rad.f90 +++ /dev/null @@ -1,590 +0,0 @@ - module rrtmg_lw_rad - use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only: pcols, begchunk, endchunk - use rrlw_vsn - use mcica_subcol_gen_lw, only: mcica_subcol_lw - use rrtmg_lw_cldprmc, only: cldprmc - use rrtmg_lw_rtrnmc, only: rtrnmc - use rrtmg_lw_setcoef, only: setcoef - use rrtmg_lw_taumol, only: taumol - implicit none - public :: rrtmg_lw, inatm - contains - ! START OF STATE GENERATION BLOCK - subroutine rrtmg_lw (lchnk ,ncol ,nlay ,icld , play ,plev ,tlay ,tlev ,tsfc ,h2ovmr , o3vmr ,co2vmr ,ch4vmr ,o2vmr ,n2ovmr , cfc11vmr,cfc12vmr, cfc22vmr,ccl4vmr ,emis ,inflglw ,iceflglw,liqflglw, cldfmcl ,taucmcl ,ciwpmcl ,clwpmcl ,reicmcl ,relqmcl , tauaer , uflx ,dflx ,hr ,uflxc ,dflxc, hrc, uflxs, dflxs ) - USE mpi - use parrrtm, only : nbndlw, ngptlw, maxxsec, mxmol - use rrlw_con, only: fluxfac, heatfac, oneminus, pi - use rrlw_wvn, only: ng, ngb, nspa, nspb, wavenum1, wavenum2, delwave - ! START OF SPECIFICATION PART OF STATE GENERATION BLOCK - INTEGER :: kgen_mpi_rank, kgen_mpi_size, kgen_cur_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(1), PARAMETER :: kgen_mpi_rank_at = (/ 0 /) - INTEGER :: kgen_ierr, kgen_unit - INTEGER, SAVE :: kgen_counter = 1 - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(1), PARAMETER :: kgen_counter_at = (/ 1 /) - CHARACTER(LEN=1024) :: kgen_filepath - integer, intent(in) :: lchnk - integer, intent(in) :: ncol - integer, intent(in) :: nlay - integer, intent(inout) :: icld - real(kind=r8), intent(in) :: play(:,:) - real(kind=r8), intent(in) :: plev(:,:) - real(kind=r8), intent(in) :: tlay(:,:) - real(kind=r8), intent(in) :: tlev(:,:) - real(kind=r8), intent(in) :: tsfc(:) - real(kind=r8), intent(in) :: h2ovmr(:,:) - real(kind=r8), intent(in) :: o3vmr(:,:) - real(kind=r8), intent(in) :: co2vmr(:,:) - real(kind=r8), intent(in) :: ch4vmr(:,:) - real(kind=r8), intent(in) :: o2vmr(:,:) - real(kind=r8), intent(in) :: n2ovmr(:,:) - real(kind=r8), intent(in) :: cfc11vmr(:,:) - real(kind=r8), intent(in) :: cfc12vmr(:,:) - real(kind=r8), intent(in) :: cfc22vmr(:,:) - real(kind=r8), intent(in) :: ccl4vmr(:,:) - real(kind=r8), intent(in) :: emis(:,:) - integer, intent(in) :: inflglw - integer, intent(in) :: iceflglw - integer, intent(in) :: liqflglw - real(kind=r8), intent(in) :: cldfmcl(:,:,:) - real(kind=r8), intent(in) :: ciwpmcl(:,:,:) - real(kind=r8), intent(in) :: clwpmcl(:,:,:) - real(kind=r8), intent(in) :: reicmcl(:,:) - real(kind=r8), intent(in) :: relqmcl(:,:) - real(kind=r8), intent(in) :: taucmcl(:,:,:) - real(kind=r8), intent(in) :: tauaer(:,:,:) - real(kind=r8), intent(out) :: uflx(:,:) - real(kind=r8), intent(out) :: dflx(:,:) - real(kind=r8), intent(out) :: hr(:,:) - real(kind=r8), intent(out) :: uflxc(:,:) - real(kind=r8), intent(out) :: dflxc(:,:) - real(kind=r8), intent(out) :: hrc(:,:) - real(kind=r8), intent(out) :: uflxs(:,:,:) - real(kind=r8), intent(out) :: dflxs(:,:,:) - integer :: istart - integer :: iend - integer :: iout - integer :: iaer - integer :: iplon - integer :: imca - integer :: ims - integer :: k - integer :: ig - real(kind=r8) :: pavel(nlay) - real(kind=r8) :: tavel(nlay) - real(kind=r8) :: pz(0:nlay) - real(kind=r8) :: tz(0:nlay) - real(kind=r8) :: tbound - real(kind=r8) :: coldry(nlay) - real(kind=r8) :: wbrodl(nlay) - real(kind=r8) :: wkl(mxmol,nlay) - real(kind=r8) :: wx(maxxsec,nlay) - real(kind=r8) :: pwvcm - real(kind=r8) :: semiss(nbndlw) - real(kind=r8) :: fracs(nlay,ngptlw) - real(kind=r8) :: taug(nlay,ngptlw) - real(kind=r8) :: taut(nlay,ngptlw) - real(kind=r8) :: taua(nlay,nbndlw) - integer :: laytrop - integer :: jp(nlay) - integer :: jt(nlay) - integer :: jt1(nlay) - real(kind=r8) :: planklay(nlay,nbndlw) - real(kind=r8) :: planklev(0:nlay,nbndlw) - real(kind=r8) :: plankbnd(nbndlw) - real(kind=r8) :: colh2o(nlay) - real(kind=r8) :: colco2(nlay) - real(kind=r8) :: colo3(nlay) - real(kind=r8) :: coln2o(nlay) - real(kind=r8) :: colco(nlay) - real(kind=r8) :: colch4(nlay) - real(kind=r8) :: colo2(nlay) - real(kind=r8) :: colbrd(nlay) - integer :: indself(nlay) - integer :: indfor(nlay) - real(kind=r8) :: selffac(nlay) - real(kind=r8) :: selffrac(nlay) - real(kind=r8) :: forfac(nlay) - real(kind=r8) :: forfrac(nlay) - integer :: indminor(nlay) - real(kind=r8) :: minorfrac(nlay) - real(kind=r8) :: scaleminor(nlay) - real(kind=r8) :: scaleminorn2(nlay) - real(kind=r8) :: fac00(nlay), fac01(nlay), fac10(nlay), fac11(nlay) - real(kind=r8) :: rat_h2oco2(nlay),rat_h2oco2_1(nlay), rat_h2oo3(nlay),rat_h2oo3_1(nlay), rat_h2on2o(nlay),rat_h2on2o_1(nlay), rat_h2och4(nlay),rat_h2och4_1(nlay), rat_n2oco2(nlay),rat_n2oco2_1(nlay), rat_o3co2(nlay),rat_o3co2_1(nlay) - integer :: ncbands - integer :: inflag - integer :: iceflag - integer :: liqflag - real(kind=r8) :: cldfmc(ngptlw,nlay) - real(kind=r8) :: ciwpmc(ngptlw,nlay) - real(kind=r8) :: clwpmc(ngptlw,nlay) - real(kind=r8) :: relqmc(nlay) - real(kind=r8) :: reicmc(nlay) - real(kind=r8) :: dgesmc(nlay) - real(kind=r8) :: taucmc(ngptlw,nlay) - real(kind=r8) :: totuflux(0:nlay) - real(kind=r8) :: totdflux(0:nlay) - real(kind=r8) :: totufluxs(nbndlw,0:nlay) - real(kind=r8) :: totdfluxs(nbndlw,0:nlay) - real(kind=r8) :: fnet(0:nlay) - real(kind=r8) :: htr(0:nlay) - real(kind=r8) :: totuclfl(0:nlay) - real(kind=r8) :: totdclfl(0:nlay) - real(kind=r8) :: fnetc(0:nlay) - real(kind=r8) :: htrc(0:nlay) - ! START OF EXECUTION PART OF STATE GENERATION BLOCK - oneminus = 1._r8 - 1.e-6_r8 - pi = 2._r8 * asin(1._r8) - fluxfac = pi * 2.e4_r8 - istart = 1 - iend = 16 - iout = 0 - ims = 1 - if (icld.lt.0.or.icld.gt.3) icld = 2 - iaer = 10 - do iplon = 1, ncol - ! START OF STATE GENERATION - !$OMP MASTER - CALL mpi_comm_rank ( MPI_COMM_WORLD, kgen_mpi_rank, kgen_ierr ) - IF ( kgen_ierr /= mpi_success ) THEN - CALL kgen_error_stop( "MPI ERROR" ) - END IF - CALL mpi_comm_size ( MPI_COMM_WORLD, kgen_mpi_size, kgen_ierr ) - IF ( kgen_ierr /= mpi_success ) THEN - CALL kgen_error_stop( "MPI ERROR" ) - END IF - kgen_cur_rank = 0 - kgen_unit = -1 - DO WHILE(kgen_cur_rank < kgen_mpi_size) - IF ( ANY(kgen_mpi_rank == kgen_mpi_rank_at) .AND. kgen_cur_rank == kgen_mpi_rank ) THEN - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - IF ( ANY(kgen_counter == kgen_counter_at) ) THEN - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_filepath = "../data/inatm." // TRIM(ADJUSTL(kgen_counter_conv)) // "." // TRIM(ADJUSTL(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit(kgen_mpi_rank+kgen_counter) - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="REPLACE", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="WRITE", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // TRIM(ADJUSTL(kgen_filepath)) ) - END IF - PRINT *, "KGEN writes input state variables at count = ", kgen_counter, " on mpirank = ", kgen_mpi_rank - WRITE(UNIT = kgen_unit) lbound(taucmcl, 1) - WRITE(UNIT = kgen_unit) ubound(taucmcl, 1) - WRITE(UNIT = kgen_unit) lbound(taucmcl, 2) - WRITE(UNIT = kgen_unit) ubound(taucmcl, 2) - WRITE(UNIT = kgen_unit) lbound(taucmcl, 3) - WRITE(UNIT = kgen_unit) ubound(taucmcl, 3) - WRITE(UNIT = kgen_unit) taucmcl - WRITE(UNIT = kgen_unit) lbound(ch4vmr, 1) - WRITE(UNIT = kgen_unit) ubound(ch4vmr, 1) - WRITE(UNIT = kgen_unit) lbound(ch4vmr, 2) - WRITE(UNIT = kgen_unit) ubound(ch4vmr, 2) - WRITE(UNIT = kgen_unit) ch4vmr - WRITE(UNIT = kgen_unit) icld - WRITE(UNIT = kgen_unit) lbound(emis, 1) - WRITE(UNIT = kgen_unit) ubound(emis, 1) - WRITE(UNIT = kgen_unit) lbound(emis, 2) - WRITE(UNIT = kgen_unit) ubound(emis, 2) - WRITE(UNIT = kgen_unit) emis - WRITE(UNIT = kgen_unit) lbound(tlay, 1) - WRITE(UNIT = kgen_unit) ubound(tlay, 1) - WRITE(UNIT = kgen_unit) lbound(tlay, 2) - WRITE(UNIT = kgen_unit) ubound(tlay, 2) - WRITE(UNIT = kgen_unit) tlay - WRITE(UNIT = kgen_unit) lbound(reicmcl, 1) - WRITE(UNIT = kgen_unit) ubound(reicmcl, 1) - WRITE(UNIT = kgen_unit) lbound(reicmcl, 2) - WRITE(UNIT = kgen_unit) ubound(reicmcl, 2) - WRITE(UNIT = kgen_unit) reicmcl - WRITE(UNIT = kgen_unit) nlay - WRITE(UNIT = kgen_unit) lbound(cfc11vmr, 1) - WRITE(UNIT = kgen_unit) ubound(cfc11vmr, 1) - WRITE(UNIT = kgen_unit) lbound(cfc11vmr, 2) - WRITE(UNIT = kgen_unit) ubound(cfc11vmr, 2) - WRITE(UNIT = kgen_unit) cfc11vmr - WRITE(UNIT = kgen_unit) lbound(tsfc, 1) - WRITE(UNIT = kgen_unit) ubound(tsfc, 1) - WRITE(UNIT = kgen_unit) tsfc - WRITE(UNIT = kgen_unit) lbound(relqmcl, 1) - WRITE(UNIT = kgen_unit) ubound(relqmcl, 1) - WRITE(UNIT = kgen_unit) lbound(relqmcl, 2) - WRITE(UNIT = kgen_unit) ubound(relqmcl, 2) - WRITE(UNIT = kgen_unit) relqmcl - WRITE(UNIT = kgen_unit) lbound(o3vmr, 1) - WRITE(UNIT = kgen_unit) ubound(o3vmr, 1) - WRITE(UNIT = kgen_unit) lbound(o3vmr, 2) - WRITE(UNIT = kgen_unit) ubound(o3vmr, 2) - WRITE(UNIT = kgen_unit) o3vmr - WRITE(UNIT = kgen_unit) lbound(n2ovmr, 1) - WRITE(UNIT = kgen_unit) ubound(n2ovmr, 1) - WRITE(UNIT = kgen_unit) lbound(n2ovmr, 2) - WRITE(UNIT = kgen_unit) ubound(n2ovmr, 2) - WRITE(UNIT = kgen_unit) n2ovmr - WRITE(UNIT = kgen_unit) lbound(plev, 1) - WRITE(UNIT = kgen_unit) ubound(plev, 1) - WRITE(UNIT = kgen_unit) lbound(plev, 2) - WRITE(UNIT = kgen_unit) ubound(plev, 2) - WRITE(UNIT = kgen_unit) plev - WRITE(UNIT = kgen_unit) lbound(play, 1) - WRITE(UNIT = kgen_unit) ubound(play, 1) - WRITE(UNIT = kgen_unit) lbound(play, 2) - WRITE(UNIT = kgen_unit) ubound(play, 2) - WRITE(UNIT = kgen_unit) play - WRITE(UNIT = kgen_unit) lbound(tauaer, 1) - WRITE(UNIT = kgen_unit) ubound(tauaer, 1) - WRITE(UNIT = kgen_unit) lbound(tauaer, 2) - WRITE(UNIT = kgen_unit) ubound(tauaer, 2) - WRITE(UNIT = kgen_unit) lbound(tauaer, 3) - WRITE(UNIT = kgen_unit) ubound(tauaer, 3) - WRITE(UNIT = kgen_unit) tauaer - WRITE(UNIT = kgen_unit) lbound(clwpmcl, 1) - WRITE(UNIT = kgen_unit) ubound(clwpmcl, 1) - WRITE(UNIT = kgen_unit) lbound(clwpmcl, 2) - WRITE(UNIT = kgen_unit) ubound(clwpmcl, 2) - WRITE(UNIT = kgen_unit) lbound(clwpmcl, 3) - WRITE(UNIT = kgen_unit) ubound(clwpmcl, 3) - WRITE(UNIT = kgen_unit) clwpmcl - WRITE(UNIT = kgen_unit) lbound(o2vmr, 1) - WRITE(UNIT = kgen_unit) ubound(o2vmr, 1) - WRITE(UNIT = kgen_unit) lbound(o2vmr, 2) - WRITE(UNIT = kgen_unit) ubound(o2vmr, 2) - WRITE(UNIT = kgen_unit) o2vmr - WRITE(UNIT = kgen_unit) lbound(co2vmr, 1) - WRITE(UNIT = kgen_unit) ubound(co2vmr, 1) - WRITE(UNIT = kgen_unit) lbound(co2vmr, 2) - WRITE(UNIT = kgen_unit) ubound(co2vmr, 2) - WRITE(UNIT = kgen_unit) co2vmr - WRITE(UNIT = kgen_unit) lbound(ccl4vmr, 1) - WRITE(UNIT = kgen_unit) ubound(ccl4vmr, 1) - WRITE(UNIT = kgen_unit) lbound(ccl4vmr, 2) - WRITE(UNIT = kgen_unit) ubound(ccl4vmr, 2) - WRITE(UNIT = kgen_unit) ccl4vmr - WRITE(UNIT = kgen_unit) iceflglw - WRITE(UNIT = kgen_unit) lbound(cfc12vmr, 1) - WRITE(UNIT = kgen_unit) ubound(cfc12vmr, 1) - WRITE(UNIT = kgen_unit) lbound(cfc12vmr, 2) - WRITE(UNIT = kgen_unit) ubound(cfc12vmr, 2) - WRITE(UNIT = kgen_unit) cfc12vmr - WRITE(UNIT = kgen_unit) lbound(tlev, 1) - WRITE(UNIT = kgen_unit) ubound(tlev, 1) - WRITE(UNIT = kgen_unit) lbound(tlev, 2) - WRITE(UNIT = kgen_unit) ubound(tlev, 2) - WRITE(UNIT = kgen_unit) tlev - WRITE(UNIT = kgen_unit) lbound(h2ovmr, 1) - WRITE(UNIT = kgen_unit) ubound(h2ovmr, 1) - WRITE(UNIT = kgen_unit) lbound(h2ovmr, 2) - WRITE(UNIT = kgen_unit) ubound(h2ovmr, 2) - WRITE(UNIT = kgen_unit) h2ovmr - WRITE(UNIT = kgen_unit) inflglw - WRITE(UNIT = kgen_unit) lbound(ciwpmcl, 1) - WRITE(UNIT = kgen_unit) ubound(ciwpmcl, 1) - WRITE(UNIT = kgen_unit) lbound(ciwpmcl, 2) - WRITE(UNIT = kgen_unit) ubound(ciwpmcl, 2) - WRITE(UNIT = kgen_unit) lbound(ciwpmcl, 3) - WRITE(UNIT = kgen_unit) ubound(ciwpmcl, 3) - WRITE(UNIT = kgen_unit) ciwpmcl - WRITE(UNIT = kgen_unit) lbound(cldfmcl, 1) - WRITE(UNIT = kgen_unit) ubound(cldfmcl, 1) - WRITE(UNIT = kgen_unit) lbound(cldfmcl, 2) - WRITE(UNIT = kgen_unit) ubound(cldfmcl, 2) - WRITE(UNIT = kgen_unit) lbound(cldfmcl, 3) - WRITE(UNIT = kgen_unit) ubound(cldfmcl, 3) - WRITE(UNIT = kgen_unit) cldfmcl - WRITE(UNIT = kgen_unit) liqflglw - WRITE(UNIT = kgen_unit) lbound(cfc22vmr, 1) - WRITE(UNIT = kgen_unit) ubound(cfc22vmr, 1) - WRITE(UNIT = kgen_unit) lbound(cfc22vmr, 2) - WRITE(UNIT = kgen_unit) ubound(cfc22vmr, 2) - WRITE(UNIT = kgen_unit) cfc22vmr - WRITE(UNIT = kgen_unit) iaer - WRITE(UNIT = kgen_unit) iplon - CALL sleep(1) - END IF - END IF - kgen_cur_rank = kgen_cur_rank + 1 - call mpi_barrier( MPI_COMM_WORLD, kgen_ierr ) - END DO - !$OMP END MASTER - !$OMP BARRIER - - IF ( kgen_unit > 0 ) THEN - CALL inatm(iplon, nlay, icld, iaer, play, plev, tlay, tlev, tsfc, h2ovmr, o3vmr, co2vmr, ch4vmr, o2vmr, n2ovmr, cfc11vmr, cfc12vmr, cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, cldfmcl, taucmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, tauaer, pavel, pz, tavel, tz, tbound, semiss, coldry, wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag, cldfmc, taucmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, taua, kgen_unit) - ELSE - call inatm (iplon, nlay, icld, iaer, play, plev, tlay, tlev, tsfc, h2ovmr, o3vmr, co2vmr, ch4vmr, o2vmr, n2ovmr, cfc11vmr, cfc12vmr, cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, cldfmcl, taucmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, tauaer, pavel, pz, tavel, tz, tbound, semiss, coldry, wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag, cldfmc, taucmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, taua) - END IF - - !$OMP BARRIER - !$OMP MASTER - kgen_cur_rank = 0 - DO WHILE(kgen_cur_rank < kgen_mpi_size) - IF ( ANY(kgen_mpi_rank == kgen_mpi_rank_at) .AND. kgen_cur_rank == kgen_mpi_rank ) THEN - IF ( ANY(kgen_counter == kgen_counter_at) ) THEN - PRINT *, "KGEN writes output state variables at count = ", kgen_counter, " on mpirank = ", kgen_mpi_rank - WRITE(UNIT = kgen_unit) iceflag - WRITE(UNIT = kgen_unit) wkl - WRITE(UNIT = kgen_unit) coldry - WRITE(UNIT = kgen_unit) clwpmc - WRITE(UNIT = kgen_unit) cldfmc - WRITE(UNIT = kgen_unit) relqmc - WRITE(UNIT = kgen_unit) ciwpmc - WRITE(UNIT = kgen_unit) wbrodl - WRITE(UNIT = kgen_unit) tavel - WRITE(UNIT = kgen_unit) liqflag - WRITE(UNIT = kgen_unit) tz - WRITE(UNIT = kgen_unit) pz - WRITE(UNIT = kgen_unit) tbound - WRITE(UNIT = kgen_unit) reicmc - WRITE(UNIT = kgen_unit) semiss - WRITE(UNIT = kgen_unit) pavel - WRITE(UNIT = kgen_unit) dgesmc - WRITE(UNIT = kgen_unit) pwvcm - WRITE(UNIT = kgen_unit) inflag - WRITE(UNIT = kgen_unit) wx - WRITE(UNIT = kgen_unit) taua - WRITE(UNIT = kgen_unit) taucmc - ENDFILE kgen_unit - CALL sleep(1) - CLOSE (UNIT=kgen_unit) - END IF - END IF - kgen_cur_rank = kgen_cur_rank + 1 - CALL mpi_barrier( MPI_COMM_WORLD, kgen_ierr ) - END DO - PRINT *, "kgen_counter = ", kgen_counter, " at rank ", kgen_mpi_rank - IF ( kgen_counter > maxval(kgen_counter_at) ) THEN - CALL sleep(2) - PRINT *, "kgen_counter is larger than maximum counter. Exit program..." - CALL mpi_abort( MPI_COMM_WORLD, 1, kgen_ierr) - END IF - kgen_counter = kgen_counter + 1 - !$OMP END MASTER - ! END OF STATE GENERATION - call cldprmc(nlay, inflag, iceflag, liqflag, cldfmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, ncbands, taucmc) - call setcoef(nlay, istart, pavel, tavel, tz, tbound, semiss, coldry, wkl, wbrodl, laytrop, jp, jt, jt1, planklay, planklev, plankbnd, colh2o, colco2, colo3, coln2o, colco, colch4, colo2, colbrd, fac00, fac01, fac10, fac11, rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, selffac, selffrac, indself, forfac, forfrac, indfor, minorfrac, scaleminor, scaleminorn2, indminor) - call taumol(nlay, pavel, wx, coldry, laytrop, jp, jt, jt1, planklay, planklev, plankbnd, colh2o, colco2, colo3, coln2o, colco, colch4, colo2, colbrd, fac00, fac01, fac10, fac11, rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, selffac, selffrac, indself, forfac, forfrac, indfor, minorfrac, scaleminor, scaleminorn2, indminor, fracs, taug) - if (iaer .eq. 0) then - do k = 1, nlay - do ig = 1, ngptlw - taut(k,ig) = taug(k,ig) - enddo - enddo - elseif (iaer .eq. 10) then - do k = 1, nlay - do ig = 1, ngptlw - taut(k,ig) = taug(k,ig) + taua(k,ngb(ig)) - enddo - enddo - endif - call rtrnmc(nlay, istart, iend, iout, pz, semiss, ncbands, cldfmc, taucmc, planklay, planklev, plankbnd, pwvcm, fracs, taut, totuflux, totdflux, fnet, htr, totuclfl, totdclfl, fnetc, htrc, totufluxs, totdfluxs ) - do k = 0, nlay - uflx(iplon,k+1) = totuflux(k) - dflx(iplon,k+1) = totdflux(k) - uflxc(iplon,k+1) = totuclfl(k) - dflxc(iplon,k+1) = totdclfl(k) - uflxs(:,iplon,k+1) = totufluxs(:,k) - dflxs(:,iplon,k+1) = totdfluxs(:,k) - enddo - do k = 0, nlay-1 - hr(iplon,k+1) = htr(k) - hrc(iplon,k+1) = htrc(k) - enddo - enddo - CONTAINS - ! END OF STATE GENERATION BLOCK - - - FUNCTION kgen_get_newunit(seed) RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - INTEGER, INTENT(IN) :: seed - - new_unit = -1 - - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - end subroutine rrtmg_lw - SUBROUTINE inatm(iplon, nlay, icld, iaer, play, plev, tlay, tlev, tsfc, h2ovmr, o3vmr, co2vmr, ch4vmr, o2vmr, n2ovmr, cfc11vmr, cfc12vmr, cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, cldfmcl, taucmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, tauaer, pavel, pz, tavel, tz, tbound, semiss, coldry, wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag, cldfmc, taucmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, taua, kgen_unit) - use parrrtm, only : nbndlw, ngptlw, nmol, maxxsec, mxmol - use rrlw_con, only: fluxfac, heatfac, oneminus, pi, grav, avogad - use rrlw_wvn, only: ng, nspa, nspb, wavenum1, wavenum2, delwave, ixindx - INTEGER, OPTIONAL, INTENT(IN) :: kgen_unit - integer, intent(in) :: iplon - integer, intent(in) :: nlay - integer, intent(in) :: icld - integer, intent(in) :: iaer - real(kind=r8), intent(in) :: play(:,:) - real(kind=r8), intent(in) :: plev(:,:) - real(kind=r8), intent(in) :: tlay(:,:) - real(kind=r8), intent(in) :: tlev(:,:) - real(kind=r8), intent(in) :: tsfc(:) - real(kind=r8), intent(in) :: h2ovmr(:,:) - real(kind=r8), intent(in) :: o3vmr(:,:) - real(kind=r8), intent(in) :: co2vmr(:,:) - real(kind=r8), intent(in) :: ch4vmr(:,:) - real(kind=r8), intent(in) :: o2vmr(:,:) - real(kind=r8), intent(in) :: n2ovmr(:,:) - real(kind=r8), intent(in) :: cfc11vmr(:,:) - real(kind=r8), intent(in) :: cfc12vmr(:,:) - real(kind=r8), intent(in) :: cfc22vmr(:,:) - real(kind=r8), intent(in) :: ccl4vmr(:,:) - real(kind=r8), intent(in) :: emis(:,:) - integer, intent(in) :: inflglw - integer, intent(in) :: iceflglw - integer, intent(in) :: liqflglw - real(kind=r8), intent(in) :: cldfmcl(:,:,:) - real(kind=r8), intent(in) :: ciwpmcl(:,:,:) - real(kind=r8), intent(in) :: clwpmcl(:,:,:) - real(kind=r8), intent(in) :: reicmcl(:,:) - real(kind=r8), intent(in) :: relqmcl(:,:) - real(kind=r8), intent(in) :: taucmcl(:,:,:) - real(kind=r8), intent(in) :: tauaer(:,:,:) - real(kind=r8), intent(out) :: pavel(:) - real(kind=r8), intent(out) :: tavel(:) - real(kind=r8), intent(out) :: pz(0:) - real(kind=r8), intent(out) :: tz(0:) - real(kind=r8), intent(out) :: tbound - real(kind=r8), intent(out) :: coldry(:) - real(kind=r8), intent(out) :: wbrodl(:) - real(kind=r8), intent(out) :: wkl(:,:) - real(kind=r8), intent(out) :: wx(:,:) - real(kind=r8), intent(out) :: pwvcm - real(kind=r8), intent(out) :: semiss(:) - integer, intent(out) :: inflag - integer, intent(out) :: iceflag - integer, intent(out) :: liqflag - real(kind=r8), intent(out) :: cldfmc(:,:) - real(kind=r8), intent(out) :: ciwpmc(:,:) - real(kind=r8), intent(out) :: clwpmc(:,:) - real(kind=r8), intent(out) :: relqmc(:) - real(kind=r8), intent(out) :: reicmc(:) - real(kind=r8), intent(out) :: dgesmc(:) - real(kind=r8), intent(out) :: taucmc(:,:) - real(kind=r8), intent(out) :: taua(:,:) - real(kind=r8), parameter :: amd = 28.9660_r8 - real(kind=r8), parameter :: amw = 18.0160_r8 - real(kind=r8), parameter :: amdw = 1.607793_r8 - real(kind=r8), parameter :: amdc = 0.658114_r8 - real(kind=r8), parameter :: amdo = 0.603428_r8 - real(kind=r8), parameter :: amdm = 1.805423_r8 - real(kind=r8), parameter :: amdn = 0.658090_r8 - real(kind=r8), parameter :: amdc1 = 0.210852_r8 - real(kind=r8), parameter :: amdc2 = 0.239546_r8 - real(kind=r8), parameter :: sbc = 5.67e-08_r8 - integer :: isp, l, ix, n, imol, ib, ig - real(kind=r8) :: amm, amttl, wvttl, wvsh, summol - IF ( present(kgen_unit) ) THEN - WRITE(UNIT = kgen_unit) avogad - WRITE(UNIT = kgen_unit) grav - WRITE(UNIT = kgen_unit) ixindx - END IF - wkl(:,:) = 0.0_r8 - wx(:,:) = 0.0_r8 - cldfmc(:,:) = 0.0_r8 - taucmc(:,:) = 0.0_r8 - ciwpmc(:,:) = 0.0_r8 - clwpmc(:,:) = 0.0_r8 - reicmc(:) = 0.0_r8 - dgesmc(:) = 0.0_r8 - relqmc(:) = 0.0_r8 - taua(:,:) = 0.0_r8 - amttl = 0.0_r8 - wvttl = 0.0_r8 - tbound = tsfc(iplon) - pz(0) = plev(iplon,nlay+1) - tz(0) = tlev(iplon,nlay+1) - do l = 1, nlay - pavel(l) = play(iplon,nlay-l+1) - tavel(l) = tlay(iplon,nlay-l+1) - pz(l) = plev(iplon,nlay-l+1) - tz(l) = tlev(iplon,nlay-l+1) - wkl(1,l) = h2ovmr(iplon,nlay-l+1) - wkl(2,l) = co2vmr(iplon,nlay-l+1) - wkl(3,l) = o3vmr(iplon,nlay-l+1) - wkl(4,l) = n2ovmr(iplon,nlay-l+1) - wkl(6,l) = ch4vmr(iplon,nlay-l+1) - wkl(7,l) = o2vmr(iplon,nlay-l+1) - amm = (1._r8 - wkl(1,l)) * amd + wkl(1,l) * amw - coldry(l) = (pz(l-1)-pz(l)) * 1.e3_r8 * avogad / (1.e2_r8 * grav * amm * (1._r8 + wkl(1,l))) - wx(1,l) = ccl4vmr(iplon,nlay-l+1) - wx(2,l) = cfc11vmr(iplon,nlay-l+1) - wx(3,l) = cfc12vmr(iplon,nlay-l+1) - wx(4,l) = cfc22vmr(iplon,nlay-l+1) - enddo - coldry(nlay) = (pz(nlay-1)) * 1.e3_r8 * avogad / (1.e2_r8 * grav * amm * (1._r8 + wkl(1,nlay-1))) - do l = 1, nlay - summol = 0.0_r8 - do imol = 2, nmol - summol = summol + wkl(imol,l) - enddo - wbrodl(l) = coldry(l) * (1._r8 - summol) - do imol = 1, nmol - wkl(imol,l) = coldry(l) * wkl(imol,l) - enddo - amttl = amttl + coldry(l)+wkl(1,l) - wvttl = wvttl + wkl(1,l) - do ix = 1,maxxsec - if (ixindx(ix) .ne. 0) then - wx(ixindx(ix),l) = coldry(l) * wx(ix,l) * 1.e-20_r8 - endif - enddo - enddo - wvsh = (amw * wvttl) / (amd * amttl) - pwvcm = wvsh * (1.e3_r8 * pz(0)) / (1.e2_r8 * grav) - do n=1,nbndlw - semiss(n) = emis(iplon,n) - enddo - if (iaer .ge. 1) then - do l = 1, nlay-1 - do ib = 1, nbndlw - taua(l,ib) = tauaer(iplon,nlay-l,ib) - enddo - enddo - endif - if (icld .ge. 1) then - inflag = inflglw - iceflag = iceflglw - liqflag = liqflglw - do l = 1, nlay-1 - do ig = 1, ngptlw - cldfmc(ig,l) = cldfmcl(ig,iplon,nlay-l) - taucmc(ig,l) = taucmcl(ig,iplon,nlay-l) - ciwpmc(ig,l) = ciwpmcl(ig,iplon,nlay-l) - clwpmc(ig,l) = clwpmcl(ig,iplon,nlay-l) - enddo - reicmc(l) = reicmcl(iplon,nlay-l) - if (iceflag .eq. 3) then - dgesmc(l) = 1.5396_r8 * reicmcl(iplon,nlay-l) - endif - relqmc(l) = relqmcl(iplon,nlay-l) - enddo - cldfmc(:,nlay) = 0.0_r8 - taucmc(:,nlay) = 0.0_r8 - ciwpmc(:,nlay) = 0.0_r8 - clwpmc(:,nlay) = 0.0_r8 - reicmc(nlay) = 0.0_r8 - dgesmc(nlay) = 0.0_r8 - relqmc(nlay) = 0.0_r8 - taua(nlay,:) = 0.0_r8 - endif - IF ( present(kgen_unit) ) THEN - END IF - end subroutine inatm -end module rrtmg_lw_rad diff --git a/test/ncar_kernels/PORT_lw_cldprmc/CESM_license.txt b/test/ncar_kernels/PORT_lw_cldprmc/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/PORT_lw_cldprmc/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.1.1 b/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.1.1 deleted file mode 100644 index 71fb53cbd9..0000000000 Binary files a/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.1.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.1.4 b/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.1.4 deleted file mode 100644 index a9c3d6a6fc..0000000000 Binary files a/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.1.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.1.8 b/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.1.8 deleted file mode 100644 index 66033f8a75..0000000000 Binary files a/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.1.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.10.1 b/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.10.1 deleted file mode 100644 index 4d14bc3562..0000000000 Binary files a/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.10.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.10.4 b/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.10.4 deleted file mode 100644 index 69827747ae..0000000000 Binary files a/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.10.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.10.8 b/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.10.8 deleted file mode 100644 index 3cee8622bc..0000000000 Binary files a/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.10.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.5.1 b/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.5.1 deleted file mode 100644 index 3960ab01dd..0000000000 Binary files a/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.5.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.5.4 b/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.5.4 deleted file mode 100644 index 2adcad418f..0000000000 Binary files a/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.5.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.5.8 b/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.5.8 deleted file mode 100644 index 3e6977ed83..0000000000 Binary files a/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.5.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_cldprmc/inc/t1.mk b/test/ncar_kernels/PORT_lw_cldprmc/inc/t1.mk deleted file mode 100644 index a6da24fb78..0000000000 --- a/test/ncar_kernels/PORT_lw_cldprmc/inc/t1.mk +++ /dev/null @@ -1,77 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# - -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# Intel default flags -# -# FC_FLAGS := -O2 -fp-model source -convert big_endian -assume byterecl -ftz -traceback -assume realloc_lhs -xAVX -# -# -FC_FLAGS := $(OPT) - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - -ALL_OBJS := kernel_driver.o rrtmg_lw_rad.o kgen_utils.o rrtmg_lw_cldprmc.o shr_kind_mod.o rrlw_vsn.o parrrtm.o rrlw_wvn.o rrlw_cld.o - - -all: build run verify - -verify: - @(grep "verification.FAIL" $(TEST).rslt && echo "FAILED") || (grep "verification.PASS" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 rrtmg_lw_rad.o kgen_utils.o rrtmg_lw_cldprmc.o shr_kind_mod.o rrlw_vsn.o parrrtm.o rrlw_wvn.o rrlw_cld.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_lw_rad.o: $(SRC_DIR)/rrtmg_lw_rad.f90 kgen_utils.o rrtmg_lw_cldprmc.o shr_kind_mod.o parrrtm.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_lw_cldprmc.o: $(SRC_DIR)/rrtmg_lw_cldprmc.f90 kgen_utils.o shr_kind_mod.o parrrtm.o rrlw_vsn.o rrlw_cld.o rrlw_wvn.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_kind_mod.o: $(SRC_DIR)/shr_kind_mod.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_vsn.o: $(SRC_DIR)/rrlw_vsn.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -parrrtm.o: $(SRC_DIR)/parrrtm.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_wvn.o: $(SRC_DIR)/rrlw_wvn.f90 kgen_utils.o parrrtm.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_cld.o: $(SRC_DIR)/rrlw_cld.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -kgen_utils.o: $(SRC_DIR)/kgen_utils.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f *.exe *.mod *.o *.rslt diff --git a/test/ncar_kernels/PORT_lw_cldprmc/lit/runmake b/test/ncar_kernels/PORT_lw_cldprmc/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/PORT_lw_cldprmc/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/PORT_lw_cldprmc/lit/t1.sh b/test/ncar_kernels/PORT_lw_cldprmc/lit/t1.sh deleted file mode 100644 index 33c953a156..0000000000 --- a/test/ncar_kernels/PORT_lw_cldprmc/lit/t1.sh +++ /dev/null @@ -1,9 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -# Shared lit script for each tests. Run bash commands that run tests with make. - -# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t -# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/PORT_lw_cldprmc/makefile b/test/ncar_kernels/PORT_lw_cldprmc/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/PORT_lw_cldprmc/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/PORT_lw_cldprmc/src/kernel_driver.f90 b/test/ncar_kernels/PORT_lw_cldprmc/src/kernel_driver.f90 deleted file mode 100644 index 4f5f2f96b9..0000000000 --- a/test/ncar_kernels/PORT_lw_cldprmc/src/kernel_driver.f90 +++ /dev/null @@ -1,85 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-07-26 20:16:59 -! KGEN version: 0.4.13 - - -PROGRAM kernel_driver - USE rrtmg_lw_rad, ONLY : rrtmg_lw - USE rrlw_cld, ONLY : kgen_read_externs_rrlw_cld - USE rrlw_wvn, ONLY : kgen_read_externs_rrlw_wvn - USE rrlw_vsn, ONLY : kgen_read_externs_rrlw_vsn - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - - IMPLICIT NONE - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_mpi_rank_at = (/ 1, 4, 8 /) - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_counter_at = (/ 1, 10, 5 /) - CHARACTER(LEN=1024) :: kgen_filepath - INTEGER :: ncol - INTEGER :: nlay - - DO kgen_repeat_counter = 0, 8 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - kgen_filepath = "../data/cldprmc." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "** Verification against '" // trim(adjustl(kgen_filepath)) // "' **" - - CALL kgen_read_externs_rrlw_cld(kgen_unit) - CALL kgen_read_externs_rrlw_wvn(kgen_unit) - CALL kgen_read_externs_rrlw_vsn(kgen_unit) - - ! driver variables - READ(UNIT=kgen_unit) ncol - READ(UNIT=kgen_unit) nlay - - call rrtmg_lw(ncol, nlay, kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! write subroutines - ! No subroutines - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/PORT_lw_cldprmc/src/kgen_utils.f90 b/test/ncar_kernels/PORT_lw_cldprmc/src/kgen_utils.f90 deleted file mode 100644 index cfa8d114e0..0000000000 --- a/test/ncar_kernels/PORT_lw_cldprmc/src/kgen_utils.f90 +++ /dev/null @@ -1,61 +0,0 @@ -module kgen_utils_mod - -INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - -type check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - real(kind=kgen_dp) :: minvalue -end type check_t - -public kgen_dp, check_t, kgen_init_check, kgen_print_check - -contains - -subroutine kgen_init_check(check, tolerance, minvalue) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - real(kind=kgen_dp), intent(in), optional :: minvalue - - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.0D-15 - endif - if(present(minvalue)) then - check%minvalue = minvalue - else - check%minvalue = 1.0D-15 - endif -end subroutine kgen_init_check - -subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif -end subroutine kgen_print_check - -end module diff --git a/test/ncar_kernels/PORT_lw_cldprmc/src/parrrtm.f90 b/test/ncar_kernels/PORT_lw_cldprmc/src/parrrtm.f90 deleted file mode 100644 index 11ccbf65fe..0000000000 --- a/test/ncar_kernels/PORT_lw_cldprmc/src/parrrtm.f90 +++ /dev/null @@ -1,75 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : parrrtm.f90 -! Generated at: 2015-07-26 20:16:59 -! KGEN version: 0.4.13 - - - - MODULE parrrtm - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_lw main parameters - ! - ! Initial version: JJMorcrette, ECMWF, Jul 1998 - ! Revised: MJIacono, AER, Jun 2006 - ! Revised: MJIacono, AER, Aug 2007 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! mxlay : integer: maximum number of layers - ! mg : integer: number of original g-intervals per spectral band - ! nbndlw : integer: number of spectral bands - ! maxxsec: integer: maximum number of cross-section molecules - ! (e.g. cfcs) - ! maxinpx: integer: - ! ngptlw : integer: total number of reduced g-intervals for rrtmg_lw - ! ngNN : integer: number of reduced g-intervals per spectral band - ! ngsNN : integer: cumulative number of g-intervals per band - !------------------------------------------------------------------ - ! Use for 140 g-point model - INTEGER, parameter :: ngptlw = 140 - ! Use for 256 g-point model - ! integer, parameter :: ngptlw = 256 - ! Use for 140 g-point model - ! Use for 256 g-point model - ! integer, parameter :: ng1 = 16 - ! integer, parameter :: ng2 = 16 - ! integer, parameter :: ng3 = 16 - ! integer, parameter :: ng4 = 16 - ! integer, parameter :: ng5 = 16 - ! integer, parameter :: ng6 = 16 - ! integer, parameter :: ng7 = 16 - ! integer, parameter :: ng8 = 16 - ! integer, parameter :: ng9 = 16 - ! integer, parameter :: ng10 = 16 - ! integer, parameter :: ng11 = 16 - ! integer, parameter :: ng12 = 16 - ! integer, parameter :: ng13 = 16 - ! integer, parameter :: ng14 = 16 - ! integer, parameter :: ng15 = 16 - ! integer, parameter :: ng16 = 16 - ! integer, parameter :: ngs1 = 16 - ! integer, parameter :: ngs2 = 32 - ! integer, parameter :: ngs3 = 48 - ! integer, parameter :: ngs4 = 64 - ! integer, parameter :: ngs5 = 80 - ! integer, parameter :: ngs6 = 96 - ! integer, parameter :: ngs7 = 112 - ! integer, parameter :: ngs8 = 128 - ! integer, parameter :: ngs9 = 144 - ! integer, parameter :: ngs10 = 160 - ! integer, parameter :: ngs11 = 176 - ! integer, parameter :: ngs12 = 192 - ! integer, parameter :: ngs13 = 208 - ! integer, parameter :: ngs14 = 224 - ! integer, parameter :: ngs15 = 240 - ! integer, parameter :: ngs16 = 256 - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE parrrtm diff --git a/test/ncar_kernels/PORT_lw_cldprmc/src/rrlw_cld.f90 b/test/ncar_kernels/PORT_lw_cldprmc/src/rrlw_cld.f90 deleted file mode 100644 index 1d668e13d0..0000000000 --- a/test/ncar_kernels/PORT_lw_cldprmc/src/rrlw_cld.f90 +++ /dev/null @@ -1,52 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_cld.f90 -! Generated at: 2015-07-26 20:16:59 -! KGEN version: 0.4.13 - - - - MODULE rrlw_cld - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_lw cloud property coefficients - ! Revised: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! abscld1: real : - ! absice0: real : - ! absice1: real : - ! absice2: real : - ! absice3: real : - ! absliq0: real : - ! absliq1: real : - !------------------------------------------------------------------ - REAL(KIND=r8), dimension(2) :: absice0 - REAL(KIND=r8), dimension(2,5) :: absice1 - REAL(KIND=r8), dimension(43,16) :: absice2 - REAL(KIND=r8), dimension(46,16) :: absice3 - REAL(KIND=r8) :: absliq0 - REAL(KIND=r8), dimension(58,16) :: absliq1 - PUBLIC kgen_read_externs_rrlw_cld - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_cld(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) absice0 - READ(UNIT=kgen_unit) absice1 - READ(UNIT=kgen_unit) absice2 - READ(UNIT=kgen_unit) absice3 - READ(UNIT=kgen_unit) absliq0 - READ(UNIT=kgen_unit) absliq1 - END SUBROUTINE kgen_read_externs_rrlw_cld - - END MODULE rrlw_cld diff --git a/test/ncar_kernels/PORT_lw_cldprmc/src/rrlw_vsn.f90 b/test/ncar_kernels/PORT_lw_cldprmc/src/rrlw_vsn.f90 deleted file mode 100644 index 93b46bafb4..0000000000 --- a/test/ncar_kernels/PORT_lw_cldprmc/src/rrlw_vsn.f90 +++ /dev/null @@ -1,63 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_vsn.f90 -! Generated at: 2015-07-26 20:16:59 -! KGEN version: 0.4.13 - - - - MODULE rrlw_vsn - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_lw version information - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - !hnamrtm :character: - !hnamini :character: - !hnamcld :character: - !hnamclc :character: - !hnamrtr :character: - !hnamrtx :character: - !hnamrtc :character: - !hnamset :character: - !hnamtau :character: - !hnamatm :character: - !hnamutl :character: - !hnamext :character: - !hnamkg :character: - ! - ! hvrrtm :character: - ! hvrini :character: - ! hvrcld :character: - ! hvrclc :character: - ! hvrrtr :character: - ! hvrrtx :character: - ! hvrrtc :character: - ! hvrset :character: - ! hvrtau :character: - ! hvratm :character: - ! hvrutl :character: - ! hvrext :character: - ! hvrkg :character: - !------------------------------------------------------------------ - CHARACTER(LEN=18) :: hvrclc - PUBLIC kgen_read_externs_rrlw_vsn - CONTAINS - - ! write subroutines - ! No subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_vsn(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) hvrclc - END SUBROUTINE kgen_read_externs_rrlw_vsn - - END MODULE rrlw_vsn diff --git a/test/ncar_kernels/PORT_lw_cldprmc/src/rrlw_wvn.f90 b/test/ncar_kernels/PORT_lw_cldprmc/src/rrlw_wvn.f90 deleted file mode 100644 index 99fdff57b8..0000000000 --- a/test/ncar_kernels/PORT_lw_cldprmc/src/rrlw_wvn.f90 +++ /dev/null @@ -1,67 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_wvn.f90 -! Generated at: 2015-07-26 20:16:59 -! KGEN version: 0.4.13 - - - - MODULE rrlw_wvn - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind, only : jpim, jprb - USE parrrtm, ONLY: ngptlw - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_lw spectral information - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! ng : integer: Number of original g-intervals in each spectral band - ! nspa : integer: For the lower atmosphere, the number of reference - ! atmospheres that are stored for each spectral band - ! per pressure level and temperature. Each of these - ! atmospheres has different relative amounts of the - ! key species for the band (i.e. different binary - ! species parameters). - ! nspb : integer: Same as nspa for the upper atmosphere - !wavenum1: real : Spectral band lower boundary in wavenumbers - !wavenum2: real : Spectral band upper boundary in wavenumbers - ! delwave: real : Spectral band width in wavenumbers - ! totplnk: real : Integrated Planck value for each band; (band 16 - ! includes total from 2600 cm-1 to infinity) - ! Used for calculation across total spectrum - !totplk16: real : Integrated Planck value for band 16 (2600-3250 cm-1) - ! Used for calculation in band 16 only if - ! individual band output requested - ! - ! ngc : integer: The number of new g-intervals in each band - ! ngs : integer: The cumulative sum of new g-intervals for each band - ! ngm : integer: The index of each new g-interval relative to the - ! original 16 g-intervals in each band - ! ngn : integer: The number of original g-intervals that are - ! combined to make each new g-intervals in each band - ! ngb : integer: The band index for each new g-interval - ! wt : real : RRTM weights for the original 16 g-intervals - ! rwgt : real : Weights for combining original 16 g-intervals - ! (256 total) into reduced set of g-intervals - ! (140 total) - ! nxmol : integer: Number of cross-section molecules - ! ixindx : integer: Flag for active cross-sections in calculation - !------------------------------------------------------------------ - INTEGER :: ngb(ngptlw) - PUBLIC kgen_read_externs_rrlw_wvn - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_wvn(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) ngb - END SUBROUTINE kgen_read_externs_rrlw_wvn - - END MODULE rrlw_wvn diff --git a/test/ncar_kernels/PORT_lw_cldprmc/src/rrtmg_lw_cldprmc.f90 b/test/ncar_kernels/PORT_lw_cldprmc/src/rrtmg_lw_cldprmc.f90 deleted file mode 100644 index 3451ec536d..0000000000 --- a/test/ncar_kernels/PORT_lw_cldprmc/src/rrtmg_lw_cldprmc.f90 +++ /dev/null @@ -1,245 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_lw_cldprmc.f90 -! Generated at: 2015-07-26 20:16:59 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_lw_cldprmc - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! --------- Modules ---------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE parrrtm, ONLY: ngptlw - USE rrlw_cld, ONLY: absice0 - USE rrlw_cld, ONLY: absice1 - USE rrlw_cld, ONLY: absice2 - USE rrlw_cld, ONLY: absice3 - USE rrlw_cld, ONLY: absliq0 - USE rrlw_cld, ONLY: absliq1 - USE rrlw_wvn, ONLY: ngb - USE rrlw_vsn, ONLY: hvrclc - IMPLICIT NONE - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - ! ------------------------------------------------------------------------------ - - SUBROUTINE cldprmc(ncol, nlayers, inflag, iceflag, liqflag, cldfmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, ncbands, & - taucmc) - ! ------------------------------------------------------------------------------ - ! Purpose: Compute the cloud optical depth(s) for each cloudy layer. - ! ------- Input ------- - INTEGER, intent(in) :: ncol ! total number of columns - INTEGER, intent(in) :: nlayers ! total number of layers - INTEGER, intent(in) :: inflag ! see definitions - INTEGER, intent(in) :: iceflag ! see definitions - INTEGER, intent(in) :: liqflag ! see definitions - ! Dimensions: (ncol) - REAL(KIND=r8), intent(in) :: cldfmc(:,:,:) ! cloud fraction [mcica] - ! Dimensions: (ncol,ngptlw,nlayers) - REAL(KIND=r8), intent(in) :: ciwpmc(:,:,:) ! cloud ice water path [mcica] - ! Dimensions: (ncol,ngptlw,nlayers) - REAL(KIND=r8), intent(in) :: clwpmc(:,:,:) ! cloud liquid water path [mcica] - ! Dimensions: (ncol,ngptlw,nlayers) - REAL(KIND=r8), intent(in) :: relqmc(:,:) ! liquid particle effective radius (microns) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: reicmc(:,:) ! ice particle effective radius (microns) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: dgesmc(:,:) ! ice particle generalized effective size (microns) - ! Dimensions: (ncol,nlayers) - ! ------- Output ------- - INTEGER, intent(out) :: ncbands(:) ! number of cloud spectral bands - ! Dimensions: (ncol) - REAL(KIND=r8), intent(inout) :: taucmc(:,:,:) ! cloud optical depth [mcica] - ! Dimensions: (ncol,ngptlw,nlayers) - ! ------- Local ------- - INTEGER :: lay ! Layer index - INTEGER :: ib ! spectral band index - INTEGER :: ig ! g-point interval index - REAL(KIND=r8) :: abscoice(ngptlw) ! ice absorption coefficients - REAL(KIND=r8) :: abscoliq(ngptlw) ! liquid absorption coefficients - REAL(KIND=r8) :: cwp ! cloud water path - REAL(KIND=r8) :: radice ! cloud ice effective radius (microns) - REAL(KIND=r8) :: dgeice ! cloud ice generalized effective size - REAL(KIND=r8) :: factor ! - REAL(KIND=r8) :: fint ! - REAL(KIND=r8) :: radliq ! cloud liquid droplet radius (microns) - ! epsilon - REAL(KIND=r8), parameter :: cldmin = 1.e-80_r8 ! minimum value for cloud quantities - ! ------- Definitions ------- - ! Explanation of the method for each value of INFLAG. Values of - ! 0 or 1 for INFLAG do not distingish being liquid and ice clouds. - ! INFLAG = 2 does distinguish between liquid and ice clouds, and - ! requires further user input to specify the method to be used to - ! compute the aborption due to each. - ! INFLAG = 0: For each cloudy layer, the cloud fraction and (gray) - ! optical depth are input. - ! INFLAG = 1: For each cloudy layer, the cloud fraction and cloud - ! water path (g/m2) are input. The (gray) cloud optical - ! depth is computed as in CAM3. - ! INFLAG = 2: For each cloudy layer, the cloud fraction, cloud - ! water path (g/m2), and cloud ice fraction are input. - ! ICEFLAG = 0: The ice effective radius (microns) is input and the - ! optical depths due to ice clouds are computed as in CAM3. - ! ICEFLAG = 1: The ice effective radius (microns) is input and the - ! optical depths due to ice clouds are computed as in - ! Ebert and Curry, JGR, 97, 3831-3836 (1992). The - ! spectral regions in this work have been matched with - ! the spectral bands in RRTM to as great an extent - ! as possible: - ! E&C 1 IB = 5 RRTM bands 9-16 - ! E&C 2 IB = 4 RRTM bands 6-8 - ! E&C 3 IB = 3 RRTM bands 3-5 - ! E&C 4 IB = 2 RRTM band 2 - ! E&C 5 IB = 1 RRTM band 1 - ! ICEFLAG = 2: The ice effective radius (microns) is input and the - ! optical properties due to ice clouds are computed from - ! the optical properties stored in the RT code, - ! STREAMER v3.0 (Reference: Key. J., Streamer - ! User's Guide, Cooperative Institute for - ! Meteorological Satellite Studies, 2001, 96 pp.). - ! Valid range of values for re are between 5.0 and - ! 131.0 micron. - ! ICEFLAG = 3: The ice generalized effective size (dge) is input - ! and the optical properties, are calculated as in - ! Q. Fu, J. Climate, (1998). Q. Fu provided high resolution - ! tables which were appropriately averaged for the - ! bands in RRTM_LW. Linear interpolation is used to - ! get the coefficients from the stored tables. - ! Valid range of values for dge are between 5.0 and - ! 140.0 micron. - ! LIQFLAG = 0: The optical depths due to water clouds are computed as - ! in CAM3. - ! LIQFLAG = 1: The water droplet effective radius (microns) is input - ! and the optical depths due to water clouds are computed - ! as in Hu and Stamnes, J., Clim., 6, 728-742, (1993). - ! The values for absorption coefficients appropriate for - ! the spectral bands in RRTM have been obtained for a - ! range of effective radii by an averaging procedure - ! based on the work of J. Pinto (private communication). - ! Linear interpolation is used to get the absorption - ! coefficients for the input effective radius. - INTEGER :: iplon,index - hvrclc = '$Revision: 1.5 $' - ncbands = 1 - ! This initialization is done in rrtmg_lw_subcol.F90. - ! do lay = 1, nlayers - ! do ig = 1, ngptlw - ! taucmc(ig,lay) = 0.0_r8 - ! enddo - ! enddo - ! Main layer loop - do iplon=1,ncol - do lay = 1, nlayers - do ig = 1, ngptlw - cwp = ciwpmc(iplon,ig,lay) + clwpmc(iplon,ig,lay) - if (cldfmc(iplon,ig,lay) .ge. cldmin .and. & - (cwp .ge. cldmin .or. taucmc(iplon,ig,lay) .ge. cldmin)) then - ! Ice clouds and water clouds combined. - if (inflag .eq. 0) then - ! Cloud optical depth already defined in taucmc, return to main program - return - elseif(inflag .eq. 1) then - stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA' - ! cwp = ciwpmc(ig,lay) + clwpmc(ig,lay) - ! taucmc(ig,lay) = abscld1 * cwp - ! Separate treatement of ice clouds and water clouds. - elseif(inflag .eq. 2) then - radice = reicmc(iplon,lay) - ! Calculation of absorption coefficients due to ice clouds. - if (ciwpmc(iplon,ig,lay) .eq. 0.0_r8) then - abscoice(ig) = 0.0_r8 - elseif (iceflag .eq. 0) then - if (radice .lt. 10.0_r8) stop 'ICE RADIUS TOO SMALL' - abscoice(ig) = absice0(1) + absice0(2)/radice - elseif (iceflag .eq. 1) then - ! mji - turn off limits to mimic CAM3 - ! if (radice .lt. 13.0_r8 .or. radice .gt. 130._r8) stop & - ! 'ICE RADIUS OUT OF BOUNDS' - ncbands(iplon) = 5 - ib = ngb(ig) - abscoice(ig) = absice1(1,ib) + absice1(2,ib)/radice - ! For iceflag=2 option, combine with iceflag=0 option to handle out of bounds - ! particle sizes. - ! Use iceflag=2 option for ice particle effective radii from 5.0 and 131.0 microns - ! and use iceflag=0 option for ice particles greater than 131.0 microns. - ! *** NOTE: Transition between two methods has not been smoothed. - elseif (iceflag .eq. 2) then - if (radice .lt. 5.0_r8) stop 'ICE RADIUS OUT OF BOUNDS' - if (radice .ge. 5.0_r8 .and. radice .le. 131._r8) then - ncbands(iplon) = 16 - factor = (radice - 2._r8)/3._r8 - index = int(factor) - if (index .eq. 43) index = 42 - fint = factor - float(index) - ib = ngb(ig) - abscoice(ig) = & - absice2(index,ib) + fint * & - (absice2(index+1,ib) - (absice2(index,ib))) - elseif (radice .gt. 131._r8) then - abscoice(ig) = absice0(1) + absice0(2)/radice - endif - ! For iceflag=3 option, combine with iceflag=0 option to handle large particle sizes. - ! Use iceflag=3 option for ice particle effective radii from 3.2 and 91.0 microns - ! (generalized effective size, dge, from 5 to 140 microns), and use iceflag=0 option - ! for ice particle effective radii greater than 91.0 microns (dge = 140 microns). - ! *** NOTE: Fu parameterization requires particle size in generalized effective size. - ! *** NOTE: Transition between two methods has not been smoothed. - elseif (iceflag .eq. 3) then - dgeice = dgesmc(iplon,lay) - if (dgeice .lt. 5.0_r8) stop 'ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' - if (dgeice .ge. 5.0_r8 .and. dgeice .le. 140._r8) then - ncbands(iplon) = 16 - factor = (dgeice - 2._r8)/3._r8 - index = int(factor) - if (index .eq. 46) index = 45 - fint = factor - float(index) - ib = ngb(ig) - abscoice(ig) = & - absice3(index,ib) + fint * & - (absice3(index+1,ib) - (absice3(index,ib))) - elseif (dgeice .gt. 140._r8) then - abscoice(ig) = absice0(1) + absice0(2)/radice - endif - endif - ! Calculation of absorption coefficients due to water clouds. - if (clwpmc(iplon,ig,lay) .eq. 0.0_r8) then - abscoliq(ig) = 0.0_r8 - elseif (liqflag .eq. 0) then - abscoliq(ig) = absliq0 - elseif (liqflag .eq. 1) then - radliq = relqmc(iplon,lay) - if (radliq .lt. 1.5_r8 .or. radliq .gt. 60._r8) stop & - 'LIQUID EFFECTIVE RADIUS OUT OF BOUNDS' - index = radliq - 1.5_r8 - if (index .eq. 58) index = 57 - if (index .eq. 0) index = 1 - fint = radliq - 1.5_r8 - index - ib = ngb(ig) - abscoliq(ig) = & - absliq1(index,ib) + fint * & - (absliq1(index+1,ib) - (absliq1(index,ib))) - endif - taucmc(iplon,ig,lay) = ciwpmc(iplon,ig,lay) * abscoice(ig) + & - clwpmc(iplon,ig,lay) * abscoliq(ig) - endif - endif - enddo - enddo - enddo - END SUBROUTINE cldprmc - END MODULE rrtmg_lw_cldprmc diff --git a/test/ncar_kernels/PORT_lw_cldprmc/src/rrtmg_lw_rad.f90 b/test/ncar_kernels/PORT_lw_cldprmc/src/rrtmg_lw_rad.f90 deleted file mode 100644 index 90b36b6b2e..0000000000 --- a/test/ncar_kernels/PORT_lw_cldprmc/src/rrtmg_lw_rad.f90 +++ /dev/null @@ -1,551 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_lw_rad.f90 -! Generated at: 2015-07-26 20:16:59 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_lw_rad - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! - ! **************************************************************************** - ! * * - ! * RRTMG_LW * - ! * * - ! * * - ! * * - ! * a rapid radiative transfer model * - ! * for the longwave region * - ! * for application to general circulation models * - ! * * - ! * * - ! * Atmospheric and Environmental Research, Inc. * - ! * 131 Hartwell Avenue * - ! * Lexington, MA 02421 * - ! * * - ! * * - ! * Eli J. Mlawer * - ! * Jennifer S. Delamere * - ! * Michael J. Iacono * - ! * Shepard A. Clough * - ! * * - ! * * - ! * * - ! * * - ! * * - ! * * - ! * email: miacono@aer.com * - ! * email: emlawer@aer.com * - ! * email: jdelamer@aer.com * - ! * * - ! * The authors wish to acknowledge the contributions of the * - ! * following people: Steven J. Taubman, Karen Cady-Pereira, * - ! * Patrick D. Brown, Ronald E. Farren, Luke Chen, Robert Bergstrom. * - ! * * - ! **************************************************************************** - ! -------- Modules -------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE rrtmg_lw_cldprmc, ONLY: cldprmc - ! Move call to rrtmg_lw_ini and following use association to - ! GCM initialization area - ! use rrtmg_lw_init, only: rrtmg_lw_ini - IMPLICIT NONE - ! public interfaces/functions/subroutines - PUBLIC rrtmg_lw - !------------------------------------------------------------------ - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !------------------------------------------------------------------ - !------------------------------------------------------------------ - ! Public subroutines - !------------------------------------------------------------------ - - SUBROUTINE rrtmg_lw(ncol, nlay, kgen_unit) - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------- Description -------- - ! This program is the driver subroutine for RRTMG_LW, the AER LW radiation - ! model for application to GCMs, that has been adapted from RRTM_LW for - ! improved efficiency. - ! - ! NOTE: The call to RRTMG_LW_INI should be moved to the GCM initialization - ! area, since this has to be called only once. - ! - ! This routine: - ! a) calls INATM to read in the atmospheric profile from GCM; - ! all layering in RRTMG is ordered from surface to toa. - ! b) calls CLDPRMC to set cloud optical depth for McICA based - ! on input cloud properties - ! c) calls SETCOEF to calculate various quantities needed for - ! the radiative transfer algorithm - ! d) calls TAUMOL to calculate gaseous optical depths for each - ! of the 16 spectral bands - ! e) calls RTRNMC (for both clear and cloudy profiles) to perform the - ! radiative transfer calculation using McICA, the Monte-Carlo - ! Independent Column Approximation, to represent sub-grid scale - ! cloud variability - ! f) passes the necessary fluxes and cooling rates back to GCM - ! - ! Two modes of operation are possible: - ! The mode is chosen by using either rrtmg_lw.nomcica.f90 (to not use - ! McICA) or rrtmg_lw.f90 (to use McICA) to interface with a GCM. - ! - ! 1) Standard, single forward model calculation (imca = 0) - ! 2) Monte Carlo Independent Column Approximation (McICA, Pincus et al., - ! JC, 2003) method is applied to the forward model calculation (imca = 1) - ! - ! This call to RRTMG_LW must be preceeded by a call to the module - ! mcica_subcol_gen_lw.f90 to run the McICA sub-column cloud generator, - ! which will provide the cloud physical or cloud optical properties - ! on the RRTMG quadrature point (ngpt) dimension. - ! - ! Two methods of cloud property input are possible: - ! Cloud properties can be input in one of two ways (controlled by input - ! flags inflglw, iceflglw, and liqflglw; see text file rrtmg_lw_instructions - ! and subroutine rrtmg_lw_cldprop.f90 for further details): - ! - ! 1) Input cloud fraction and cloud optical depth directly (inflglw = 0) - ! 2) Input cloud fraction and cloud physical properties (inflglw = 1 or 2); - ! cloud optical properties are calculated by cldprop or cldprmc based - ! on input settings of iceflglw and liqflglw - ! - ! One method of aerosol property input is possible: - ! Aerosol properties can be input in only one way (controlled by input - ! flag iaer, see text file rrtmg_lw_instructions for further details): - ! - ! 1) Input aerosol optical depth directly by layer and spectral band (iaer=10); - ! band average optical depth at the mid-point of each spectral band. - ! RRTMG_LW currently treats only aerosol absorption; - ! scattering capability is not presently available. - ! - ! - ! ------- Modifications ------- - ! - ! This version of RRTMG_LW has been modified from RRTM_LW to use a reduced - ! set of g-points for application to GCMs. - ! - !-- Original version (derived from RRTM_LW), reduction of g-points, other - ! revisions for use with GCMs. - ! 1999: M. J. Iacono, AER, Inc. - !-- Adapted for use with NCAR/CAM. - ! May 2004: M. J. Iacono, AER, Inc. - !-- Revised to add McICA capability. - ! Nov 2005: M. J. Iacono, AER, Inc. - !-- Conversion to F90 formatting for consistency with rrtmg_sw. - ! Feb 2007: M. J. Iacono, AER, Inc. - !-- Modifications to formatting to use assumed-shape arrays. - ! Aug 2007: M. J. Iacono, AER, Inc. - !-- Modified to add longwave aerosol absorption. - ! Apr 2008: M. J. Iacono, AER, Inc. - ! --------- Modules ---------- - USE parrrtm, ONLY: ngptlw - ! ------- Declarations ------- - ! ----- Input ----- - integer, intent(in) :: kgen_unit - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - ! chunk identifier - INTEGER, intent(in) :: ncol ! Number of horizontal columns - INTEGER, intent(in) :: nlay ! Number of model layers - ! Cloud overlap method - ! 0: Clear only - ! 1: Random - ! 2: Maximum/random - ! 3: Maximum - ! Layer pressures (hPa, mb) - ! Dimensions: (ncol,nlay) - ! Interface pressures (hPa, mb) - ! Dimensions: (ncol,nlay+1) - ! Layer temperatures (K) - ! Dimensions: (ncol,nlay) - ! Interface temperatures (K) - ! Dimensions: (ncol,nlay+1) - ! Surface temperature (K) - ! Dimensions: (ncol) - ! H2O volume mixing ratio - ! Dimensions: (ncol,nlay) - ! O3 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! CO2 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! Methane volume mixing ratio - ! Dimensions: (ncol,nlay) - ! O2 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! Nitrous oxide volume mixing ratio - ! Dimensions: (ncol,nlay) - ! CFC11 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! CFC12 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! CFC22 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! CCL4 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! Surface emissivity - ! Dimensions: (ncol,nbndlw) - ! Flag for cloud optical properties - ! Flag for ice particle specification - ! Flag for liquid droplet specification - ! Cloud fraction - ! Dimensions: (ngptlw,ncol,nlay) - ! Cloud ice water path (g/m2) - ! Dimensions: (ngptlw,ncol,nlay) - ! Cloud liquid water path (g/m2) - ! Dimensions: (ngptlw,ncol,nlay) - ! Cloud ice effective radius (microns) - ! Dimensions: (ncol,nlay) - ! Cloud water drop effective radius (microns) - ! Dimensions: (ncol,nlay) - ! Cloud optical depth - ! Dimensions: (ngptlw,ncol,nlay) - ! real(kind=r8), intent(in) :: ssacmcl(:,:,:) ! Cloud single scattering albedo - ! Dimensions: (ngptlw,ncol,nlay) - ! for future expansion - ! lw scattering not yet available - ! real(kind=r8), intent(in) :: asmcmcl(:,:,:) ! Cloud asymmetry parameter - ! Dimensions: (ngptlw,ncol,nlay) - ! for future expansion - ! lw scattering not yet available - ! aerosol optical depth - ! at mid-point of LW spectral bands - ! Dimensions: (ncol,nlay,nbndlw) - ! real(kind=r8), intent(in) :: ssaaer(:,:,:) ! aerosol single scattering albedo - ! Dimensions: (ncol,nlay,nbndlw) - ! for future expansion - ! (lw aerosols/scattering not yet available) - ! real(kind=r8), intent(in) :: asmaer(:,:,:) ! aerosol asymmetry parameter - ! Dimensions: (ncol,nlay,nbndlw) - ! for future expansion - ! (lw aerosols/scattering not yet available) - ! ----- Output ----- - ! Total sky longwave upward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Total sky longwave downward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Total sky longwave radiative heating rate (K/d) - ! Dimensions: (ncol,nlay) - ! Clear sky longwave upward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Clear sky longwave downward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Clear sky longwave radiative heating rate (K/d) - ! Dimensions: (ncol,nlay) - ! Total sky longwave upward flux spectral (W/m2) - ! Dimensions: (nbndlw,ncol,nlay+1) - ! Total sky longwave downward flux spectral (W/m2) - ! Dimensions: (nbndlw,ncol,nlay+1) - ! ----- Local ----- - ! Control - ! beginning band of calculation - ! ending band of calculation - ! output option flag (inactive) - ! aerosol option flag - ! column loop index - ! flag for mcica [0=off, 1=on] - ! value for changing mcica permute seed - ! layer loop index - ! g-point loop index - ! Atmosphere - ! layer pressures (mb) - ! layer temperatures (K) - ! level (interface) pressures (hPa, mb) - ! level (interface) temperatures (K) - ! surface temperature (K) - ! dry air column density (mol/cm2) - ! broadening gas column density (mol/cm2) - ! molecular amounts (mol/cm-2) - ! cross-section amounts (mol/cm-2) - ! precipitable water vapor (cm) - ! lw surface emissivity - ! - ! gaseous optical depths - ! gaseous + aerosol optical depths - ! aerosol optical depth - ! real(kind=r8) :: ssaa(nlay,nbndlw) ! aerosol single scattering albedo - ! for future expansion - ! (lw aerosols/scattering not yet available) - ! real(kind=r8) :: asma(nlay+1,nbndlw) ! aerosol asymmetry parameter - ! for future expansion - ! (lw aerosols/scattering not yet available) - ! Atmosphere - setcoef - ! tropopause layer index - ! lookup table index - ! lookup table index - ! lookup table index - ! - ! - ! - ! column amount (h2o) - ! column amount (co2) - ! column amount (o3) - ! column amount (n2o) - ! column amount (co) - ! column amount (ch4) - ! column amount (o2) - ! column amount (broadening gases) - ! - ! - ! Atmosphere/clouds - cldprop - INTEGER :: ncbands(ncol) - INTEGER :: ref_ncbands(ncol) ! number of cloud spectral bands - INTEGER :: inflag ! flag for cloud property method - INTEGER :: iceflag ! flag for ice cloud properties - INTEGER :: liqflag ! flag for liquid cloud properties - ! Atmosphere/clouds - cldprmc [mcica] - REAL(KIND=r8) :: cldfmc(ncol,ngptlw,nlay) ! cloud fraction [mcica] - REAL(KIND=r8) :: ciwpmc(ncol,ngptlw,nlay) ! cloud ice water path [mcica] - REAL(KIND=r8) :: clwpmc(ncol,ngptlw,nlay) ! cloud liquid water path [mcica] - REAL(KIND=r8) :: relqmc(ncol,nlay) ! liquid particle size (microns) - REAL(KIND=r8) :: reicmc(ncol,nlay) ! ice particle effective radius (microns) - REAL(KIND=r8) :: dgesmc(ncol,nlay) ! ice particle generalized effective size (microns) - REAL(KIND=r8) :: taucmc(ncol,ngptlw,nlay) - REAL(KIND=r8) :: ref_taucmc(ncol,ngptlw,nlay) ! cloud optical depth [mcica] - ! real(kind=r8) :: ssacmc(ngptlw,nlay) ! cloud single scattering albedo [mcica] - ! for future expansion - ! (lw scattering not yet available) - ! real(kind=r8) :: asmcmc(ngptlw,nlay) ! cloud asymmetry parameter [mcica] - ! for future expansion - ! (lw scattering not yet available) - ! Output - ! upward longwave flux (w/m2) - ! downward longwave flux (w/m2) - ! upward longwave flux spectral (w/m2) - ! downward longwave flux spectral (w/m2) - ! net longwave flux (w/m2) - ! longwave heating rate (k/day) - ! clear sky upward longwave flux (w/m2) - ! clear sky downward longwave flux (w/m2) - ! clear sky net longwave flux (w/m2) - ! clear sky longwave heating rate (k/day) - ! Initializations - ! orig: fluxfac = pi * 2.d4 ! orig: fluxfac = pi * 2.d4 - ! Set imca to select calculation type: - ! imca = 0, use standard forward model calculation - ! imca = 1, use McICA for Monte Carlo treatment of sub-grid cloud variability - ! *** This version uses McICA (imca = 1) *** - ! Set icld to select of clear or cloud calculation and cloud overlap method - ! icld = 0, clear only - ! icld = 1, with clouds using random cloud overlap - ! icld = 2, with clouds using maximum/random cloud overlap - ! icld = 3, with clouds using maximum cloud overlap (McICA only) - ! Set iaer to select aerosol option - ! iaer = 0, no aerosols - ! iaer = 10, input total aerosol optical depth (tauaer) directly - !Call model and data initialization, compute lookup tables, perform - ! reduction of g-points from 256 to 140 for input absorption coefficient - ! data and other arrays. - ! - ! In a GCM this call should be placed in the model initialization - ! area, since this has to be called only once. - ! call rrtmg_lw_ini - ! This is the main longitude/column loop within RRTMG. - ! Prepare atmospheric profile from GCM for use in RRTMG, and define - ! other input parameters. - ! For cloudy atmosphere, use cldprop to set cloud optical properties based on - ! input cloud physical properties. Select method based on choices described - ! in cldprop. Cloud fraction, water path, liquid droplet and ice particle - ! effective radius must be passed into cldprop. Cloud fraction and cloud - ! optical depth are transferred to rrtmg_lw arrays in cldprop. - tolerance = 1.E-14 - CALL kgen_init_check(check_status, tolerance) - READ(UNIT=kgen_unit) ncbands - READ(UNIT=kgen_unit) inflag - READ(UNIT=kgen_unit) iceflag - READ(UNIT=kgen_unit) liqflag - READ(UNIT=kgen_unit) cldfmc - READ(UNIT=kgen_unit) ciwpmc - READ(UNIT=kgen_unit) clwpmc - READ(UNIT=kgen_unit) relqmc - READ(UNIT=kgen_unit) reicmc - READ(UNIT=kgen_unit) dgesmc - READ(UNIT=kgen_unit) taucmc - - READ(UNIT=kgen_unit) ref_ncbands - READ(UNIT=kgen_unit) ref_taucmc - - - ! call to kernel - call cldprmc(ncol,nlay, inflag, iceflag, liqflag, cldfmc, ciwpmc, & - clwpmc, reicmc, dgesmc, relqmc, ncbands, taucmc) - ! kernel verification for output variables - CALL kgen_verify_integer_4_dim1( "ncbands", check_status, ncbands, ref_ncbands) - CALL kgen_verify_real_r8_dim3( "taucmc", check_status, taucmc, ref_taucmc) - CALL kgen_print_check("cldprmc", check_status) - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,10 - CALL cldprmc(ncol, nlay, inflag, iceflag, liqflag, cldfmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, ncbands, taucmc) - END DO - CALL system_clock(stop_clock, rate_clock) - WRITE(*,*) - PRINT *, "Elapsed time (sec): ", (stop_clock - start_clock)/REAL(rate_clock*10) - ! Calculate information needed by the radiative transfer routine - ! that is specific to this atmosphere, especially some of the - ! coefficients and indices needed to compute the optical depths - ! by interpolating data from stored reference atmospheres. - ! Call the radiative transfer routine. - ! Either routine can be called to do clear sky calculation. If clouds - ! are present, then select routine based on cloud overlap assumption - ! to be used. Clear sky calculation is done simultaneously. - ! For McICA, RTRNMC is called for clear and cloudy calculations. - ! Transfer up and down fluxes and heating rate to output arrays. - ! Vertical indexing goes from bottom to top - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_integer_4_dim1(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - integer(KIND=4), INTENT(OUT), ALLOCATABLE, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_integer_4_dim1 - - SUBROUTINE kgen_read_real_r8_dim3(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2,idx3 - INTEGER, DIMENSION(2,3) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim3 - - - ! verify subroutines - SUBROUTINE kgen_verify_integer_4_dim1( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in), DIMENSION(:) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - end if - - check_status%numFatal = check_status%numFatal+1 - END IF - END SUBROUTINE kgen_verify_integer_4_dim1 - - SUBROUTINE kgen_verify_real_r8_dim3( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim3 - - END SUBROUTINE rrtmg_lw - !*************************************************************************** - - END MODULE rrtmg_lw_rad diff --git a/test/ncar_kernels/PORT_lw_cldprmc/src/shr_kind_mod.f90 b/test/ncar_kernels/PORT_lw_cldprmc/src/shr_kind_mod.f90 deleted file mode 100644 index c725fa8aef..0000000000 --- a/test/ncar_kernels/PORT_lw_cldprmc/src/shr_kind_mod.f90 +++ /dev/null @@ -1,26 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : shr_kind_mod.f90 -! Generated at: 2015-07-26 20:16:59 -! KGEN version: 0.4.13 - - - - MODULE shr_kind_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - PUBLIC - INTEGER, parameter :: shr_kind_r8 = selected_real_kind(12) ! 8 byte real - ! 4 byte real - ! native real - ! 8 byte integer - ! 4 byte integer - ! native integer - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE shr_kind_mod diff --git a/test/ncar_kernels/PORT_lw_inatm/CESM_license.txt b/test/ncar_kernels/PORT_lw_inatm/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/PORT_lw_inatm/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/PORT_lw_inatm/data/inatm.1.1 b/test/ncar_kernels/PORT_lw_inatm/data/inatm.1.1 deleted file mode 100644 index 4d26621755..0000000000 Binary files a/test/ncar_kernels/PORT_lw_inatm/data/inatm.1.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_inatm/data/inatm.1.4 b/test/ncar_kernels/PORT_lw_inatm/data/inatm.1.4 deleted file mode 100644 index 93102f2bb3..0000000000 Binary files a/test/ncar_kernels/PORT_lw_inatm/data/inatm.1.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_inatm/data/inatm.1.8 b/test/ncar_kernels/PORT_lw_inatm/data/inatm.1.8 deleted file mode 100644 index bbe26b684f..0000000000 Binary files a/test/ncar_kernels/PORT_lw_inatm/data/inatm.1.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_inatm/data/inatm.10.1 b/test/ncar_kernels/PORT_lw_inatm/data/inatm.10.1 deleted file mode 100644 index 73664596d9..0000000000 Binary files a/test/ncar_kernels/PORT_lw_inatm/data/inatm.10.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_inatm/data/inatm.10.4 b/test/ncar_kernels/PORT_lw_inatm/data/inatm.10.4 deleted file mode 100644 index cd274e51c4..0000000000 Binary files a/test/ncar_kernels/PORT_lw_inatm/data/inatm.10.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_inatm/data/inatm.10.8 b/test/ncar_kernels/PORT_lw_inatm/data/inatm.10.8 deleted file mode 100644 index 2c18a3751f..0000000000 Binary files a/test/ncar_kernels/PORT_lw_inatm/data/inatm.10.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_inatm/data/inatm.5.1 b/test/ncar_kernels/PORT_lw_inatm/data/inatm.5.1 deleted file mode 100644 index b469141461..0000000000 Binary files a/test/ncar_kernels/PORT_lw_inatm/data/inatm.5.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_inatm/data/inatm.5.4 b/test/ncar_kernels/PORT_lw_inatm/data/inatm.5.4 deleted file mode 100644 index 01f6b01727..0000000000 Binary files a/test/ncar_kernels/PORT_lw_inatm/data/inatm.5.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_inatm/data/inatm.5.8 b/test/ncar_kernels/PORT_lw_inatm/data/inatm.5.8 deleted file mode 100644 index 469c8a221e..0000000000 Binary files a/test/ncar_kernels/PORT_lw_inatm/data/inatm.5.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_inatm/inc/t1.mk b/test/ncar_kernels/PORT_lw_inatm/inc/t1.mk deleted file mode 100644 index 8f04de7281..0000000000 --- a/test/ncar_kernels/PORT_lw_inatm/inc/t1.mk +++ /dev/null @@ -1,69 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# - -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# Intel default flags -# -# FC_FLAGS := -O2 -fp-model source -convert big_endian -assume byterecl -ftz -traceback -assume realloc_lhs -xAVX -# -# -FC_FLAGS := $(OPT) - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - -ALL_OBJS := kernel_driver.o rrtmg_lw_rad.o kgen_utils.o parrrtm.o shr_kind_mod.o rrlw_wvn.o rrlw_con.o - -all: build run verify - -verify: - @(grep "verification.FAIL" $(TEST).rslt && echo "FAILED") || (grep "verification.PASS" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 rrtmg_lw_rad.o kgen_utils.o parrrtm.o shr_kind_mod.o rrlw_wvn.o rrlw_con.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_lw_rad.o: $(SRC_DIR)/rrtmg_lw_rad.f90 kgen_utils.o shr_kind_mod.o rrlw_con.o parrrtm.o rrlw_wvn.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -parrrtm.o: $(SRC_DIR)/parrrtm.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_kind_mod.o: $(SRC_DIR)/shr_kind_mod.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_wvn.o: $(SRC_DIR)/rrlw_wvn.f90 kgen_utils.o parrrtm.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_con.o: $(SRC_DIR)/rrlw_con.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -kgen_utils.o: $(SRC_DIR)/kgen_utils.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.oo *.rslt diff --git a/test/ncar_kernels/PORT_lw_inatm/lit/runmake b/test/ncar_kernels/PORT_lw_inatm/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/PORT_lw_inatm/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/PORT_lw_inatm/lit/t1.sh b/test/ncar_kernels/PORT_lw_inatm/lit/t1.sh deleted file mode 100644 index 33c953a156..0000000000 --- a/test/ncar_kernels/PORT_lw_inatm/lit/t1.sh +++ /dev/null @@ -1,9 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -# Shared lit script for each tests. Run bash commands that run tests with make. - -# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t -# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/PORT_lw_inatm/makefile b/test/ncar_kernels/PORT_lw_inatm/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/PORT_lw_inatm/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/PORT_lw_inatm/src/kernel_driver.f90 b/test/ncar_kernels/PORT_lw_inatm/src/kernel_driver.f90 deleted file mode 100644 index 3f40d7175c..0000000000 --- a/test/ncar_kernels/PORT_lw_inatm/src/kernel_driver.f90 +++ /dev/null @@ -1,208 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-07-26 18:45:57 -! KGEN version: 0.4.13 - - -PROGRAM kernel_driver - USE rrtmg_lw_rad, ONLY : rrtmg_lw - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - USE rrlw_wvn, ONLY : kgen_read_externs_rrlw_wvn - USE rrlw_con, ONLY : kgen_read_externs_rrlw_con - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - - IMPLICIT NONE - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_mpi_rank_at = (/ 1, 4, 8 /) - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_counter_at = (/ 1, 10, 5 /) - CHARACTER(LEN=1024) :: kgen_filepath - REAL(KIND=r8), allocatable :: tauaer(:,:,:) - REAL(KIND=r8), allocatable :: play(:,:) - REAL(KIND=r8), allocatable :: ciwpmcl(:,:,:) - REAL(KIND=r8), allocatable :: plev(:,:) - INTEGER :: nlay - REAL(KIND=r8), allocatable :: tlev(:,:) - REAL(KIND=r8), allocatable :: tsfc(:) - REAL(KIND=r8), allocatable :: o3vmr(:,:) - REAL(KIND=r8), allocatable :: co2vmr(:,:) - REAL(KIND=r8), allocatable :: ch4vmr(:,:) - REAL(KIND=r8), allocatable :: o2vmr(:,:) - REAL(KIND=r8), allocatable :: tlay(:,:) - INTEGER :: ncol - REAL(KIND=r8), allocatable :: cfc11vmr(:,:) - REAL(KIND=r8), allocatable :: cfc12vmr(:,:) - REAL(KIND=r8), allocatable :: cldfmcl(:,:,:) - REAL(KIND=r8), allocatable :: n2ovmr(:,:) - REAL(KIND=r8), allocatable :: cfc22vmr(:,:) - REAL(KIND=r8), allocatable :: relqmcl(:,:) - REAL(KIND=r8), allocatable :: ccl4vmr(:,:) - REAL(KIND=r8), allocatable :: emis(:,:) - REAL(KIND=r8), allocatable :: h2ovmr(:,:) - INTEGER :: inflglw - REAL(KIND=r8), allocatable :: reicmcl(:,:) - INTEGER :: iceflglw - INTEGER :: liqflglw - REAL(KIND=r8), allocatable :: clwpmcl(:,:,:) - INTEGER :: icld - REAL(KIND=r8), allocatable :: taucmcl(:,:,:) - - DO kgen_repeat_counter = 0, 8 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - kgen_filepath = "../data/inatm." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "** Verification against '" // trim(adjustl(kgen_filepath)) // "' **" - - CALL kgen_read_externs_rrlw_wvn(kgen_unit) - CALL kgen_read_externs_rrlw_con(kgen_unit) - - ! driver variables - READ(UNIT=kgen_unit) ncol - READ(UNIT=kgen_unit) nlay - READ(UNIT=kgen_unit) icld - CALL kgen_read_real_r8_dim2(play, kgen_unit) - CALL kgen_read_real_r8_dim2(plev, kgen_unit) - CALL kgen_read_real_r8_dim2(tlay, kgen_unit) - CALL kgen_read_real_r8_dim2(tlev, kgen_unit) - CALL kgen_read_real_r8_dim1(tsfc, kgen_unit) - CALL kgen_read_real_r8_dim2(h2ovmr, kgen_unit) - CALL kgen_read_real_r8_dim2(o3vmr, kgen_unit) - CALL kgen_read_real_r8_dim2(co2vmr, kgen_unit) - CALL kgen_read_real_r8_dim2(ch4vmr, kgen_unit) - CALL kgen_read_real_r8_dim2(o2vmr, kgen_unit) - CALL kgen_read_real_r8_dim2(n2ovmr, kgen_unit) - CALL kgen_read_real_r8_dim2(cfc11vmr, kgen_unit) - CALL kgen_read_real_r8_dim2(cfc12vmr, kgen_unit) - CALL kgen_read_real_r8_dim2(cfc22vmr, kgen_unit) - CALL kgen_read_real_r8_dim2(ccl4vmr, kgen_unit) - CALL kgen_read_real_r8_dim2(emis, kgen_unit) - READ(UNIT=kgen_unit) inflglw - READ(UNIT=kgen_unit) iceflglw - READ(UNIT=kgen_unit) liqflglw - CALL kgen_read_real_r8_dim3(cldfmcl, kgen_unit) - CALL kgen_read_real_r8_dim3(ciwpmcl, kgen_unit) - CALL kgen_read_real_r8_dim3(clwpmcl, kgen_unit) - CALL kgen_read_real_r8_dim2(reicmcl, kgen_unit) - CALL kgen_read_real_r8_dim2(relqmcl, kgen_unit) - CALL kgen_read_real_r8_dim3(taucmcl, kgen_unit) - CALL kgen_read_real_r8_dim3(tauaer, kgen_unit) - - call rrtmg_lw(ncol, nlay, icld, play, plev, tlay, tlev, tsfc, h2ovmr, o3vmr, co2vmr, ch4vmr, o2vmr, & -n2ovmr, cfc11vmr, cfc12vmr, cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, cldfmcl, ciwpmcl, clwpmcl, & -reicmcl, relqmcl, taucmcl, tauaer, kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_r8_dim2(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim2 - - SUBROUTINE kgen_read_real_r8_dim1(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim1 - - SUBROUTINE kgen_read_real_r8_dim3(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2,idx3 - INTEGER, DIMENSION(2,3) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim3 - - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/PORT_lw_inatm/src/kgen_utils.f90 b/test/ncar_kernels/PORT_lw_inatm/src/kgen_utils.f90 deleted file mode 100644 index cfa8d114e0..0000000000 --- a/test/ncar_kernels/PORT_lw_inatm/src/kgen_utils.f90 +++ /dev/null @@ -1,61 +0,0 @@ -module kgen_utils_mod - -INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - -type check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - real(kind=kgen_dp) :: minvalue -end type check_t - -public kgen_dp, check_t, kgen_init_check, kgen_print_check - -contains - -subroutine kgen_init_check(check, tolerance, minvalue) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - real(kind=kgen_dp), intent(in), optional :: minvalue - - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.0D-15 - endif - if(present(minvalue)) then - check%minvalue = minvalue - else - check%minvalue = 1.0D-15 - endif -end subroutine kgen_init_check - -subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif -end subroutine kgen_print_check - -end module diff --git a/test/ncar_kernels/PORT_lw_inatm/src/parrrtm.f90 b/test/ncar_kernels/PORT_lw_inatm/src/parrrtm.f90 deleted file mode 100644 index eebd63bf8e..0000000000 --- a/test/ncar_kernels/PORT_lw_inatm/src/parrrtm.f90 +++ /dev/null @@ -1,80 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : parrrtm.f90 -! Generated at: 2015-07-26 18:45:57 -! KGEN version: 0.4.13 - - - - MODULE parrrtm - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_lw main parameters - ! - ! Initial version: JJMorcrette, ECMWF, Jul 1998 - ! Revised: MJIacono, AER, Jun 2006 - ! Revised: MJIacono, AER, Aug 2007 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! mxlay : integer: maximum number of layers - ! mg : integer: number of original g-intervals per spectral band - ! nbndlw : integer: number of spectral bands - ! maxxsec: integer: maximum number of cross-section molecules - ! (e.g. cfcs) - ! maxinpx: integer: - ! ngptlw : integer: total number of reduced g-intervals for rrtmg_lw - ! ngNN : integer: number of reduced g-intervals per spectral band - ! ngsNN : integer: cumulative number of g-intervals per band - !------------------------------------------------------------------ - INTEGER, parameter :: nbndlw = 16 - INTEGER, parameter :: maxxsec= 4 - INTEGER, parameter :: mxmol = 38 - INTEGER, parameter :: maxinpx= 38 - INTEGER, parameter :: nmol = 7 - ! Use for 140 g-point model - INTEGER, parameter :: ngptlw = 140 - ! Use for 256 g-point model - ! integer, parameter :: ngptlw = 256 - ! Use for 140 g-point model - ! Use for 256 g-point model - ! integer, parameter :: ng1 = 16 - ! integer, parameter :: ng2 = 16 - ! integer, parameter :: ng3 = 16 - ! integer, parameter :: ng4 = 16 - ! integer, parameter :: ng5 = 16 - ! integer, parameter :: ng6 = 16 - ! integer, parameter :: ng7 = 16 - ! integer, parameter :: ng8 = 16 - ! integer, parameter :: ng9 = 16 - ! integer, parameter :: ng10 = 16 - ! integer, parameter :: ng11 = 16 - ! integer, parameter :: ng12 = 16 - ! integer, parameter :: ng13 = 16 - ! integer, parameter :: ng14 = 16 - ! integer, parameter :: ng15 = 16 - ! integer, parameter :: ng16 = 16 - ! integer, parameter :: ngs1 = 16 - ! integer, parameter :: ngs2 = 32 - ! integer, parameter :: ngs3 = 48 - ! integer, parameter :: ngs4 = 64 - ! integer, parameter :: ngs5 = 80 - ! integer, parameter :: ngs6 = 96 - ! integer, parameter :: ngs7 = 112 - ! integer, parameter :: ngs8 = 128 - ! integer, parameter :: ngs9 = 144 - ! integer, parameter :: ngs10 = 160 - ! integer, parameter :: ngs11 = 176 - ! integer, parameter :: ngs12 = 192 - ! integer, parameter :: ngs13 = 208 - ! integer, parameter :: ngs14 = 224 - ! integer, parameter :: ngs15 = 240 - ! integer, parameter :: ngs16 = 256 - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE parrrtm diff --git a/test/ncar_kernels/PORT_lw_inatm/src/rrlw_con.f90 b/test/ncar_kernels/PORT_lw_inatm/src/rrlw_con.f90 deleted file mode 100644 index ec7b08ec99..0000000000 --- a/test/ncar_kernels/PORT_lw_inatm/src/rrlw_con.f90 +++ /dev/null @@ -1,51 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_con.f90 -! Generated at: 2015-07-26 18:45:57 -! KGEN version: 0.4.13 - - - - MODULE rrlw_con - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_lw constants - ! Initial version: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! fluxfac: real : radiance to flux conversion factor - ! heatfac: real : flux to heating rate conversion factor - !oneminus: real : 1.-1.e-6 - ! pi : real : pi - ! grav : real : acceleration of gravity (m/s2) - ! planck : real : planck constant - ! boltz : real : boltzman constant - ! clight : real : speed of light - ! avogad : real : avogadro's constant - ! alosmt : real : - ! gascon : real : gas constant - ! radcn1 : real : - ! radcn2 : real : - !------------------------------------------------------------------ - REAL(KIND=r8) :: grav - REAL(KIND=r8) :: avogad - PUBLIC kgen_read_externs_rrlw_con - CONTAINS - - ! write subroutines - ! No subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_con(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) grav - READ(UNIT=kgen_unit) avogad - END SUBROUTINE kgen_read_externs_rrlw_con - - END MODULE rrlw_con diff --git a/test/ncar_kernels/PORT_lw_inatm/src/rrlw_wvn.f90 b/test/ncar_kernels/PORT_lw_inatm/src/rrlw_wvn.f90 deleted file mode 100644 index e273f0427b..0000000000 --- a/test/ncar_kernels/PORT_lw_inatm/src/rrlw_wvn.f90 +++ /dev/null @@ -1,67 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_wvn.f90 -! Generated at: 2015-07-26 18:45:57 -! KGEN version: 0.4.13 - - - - MODULE rrlw_wvn - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind, only : jpim, jprb - USE parrrtm, ONLY: maxinpx - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_lw spectral information - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! ng : integer: Number of original g-intervals in each spectral band - ! nspa : integer: For the lower atmosphere, the number of reference - ! atmospheres that are stored for each spectral band - ! per pressure level and temperature. Each of these - ! atmospheres has different relative amounts of the - ! key species for the band (i.e. different binary - ! species parameters). - ! nspb : integer: Same as nspa for the upper atmosphere - !wavenum1: real : Spectral band lower boundary in wavenumbers - !wavenum2: real : Spectral band upper boundary in wavenumbers - ! delwave: real : Spectral band width in wavenumbers - ! totplnk: real : Integrated Planck value for each band; (band 16 - ! includes total from 2600 cm-1 to infinity) - ! Used for calculation across total spectrum - !totplk16: real : Integrated Planck value for band 16 (2600-3250 cm-1) - ! Used for calculation in band 16 only if - ! individual band output requested - ! - ! ngc : integer: The number of new g-intervals in each band - ! ngs : integer: The cumulative sum of new g-intervals for each band - ! ngm : integer: The index of each new g-interval relative to the - ! original 16 g-intervals in each band - ! ngn : integer: The number of original g-intervals that are - ! combined to make each new g-intervals in each band - ! ngb : integer: The band index for each new g-interval - ! wt : real : RRTM weights for the original 16 g-intervals - ! rwgt : real : Weights for combining original 16 g-intervals - ! (256 total) into reduced set of g-intervals - ! (140 total) - ! nxmol : integer: Number of cross-section molecules - ! ixindx : integer: Flag for active cross-sections in calculation - !------------------------------------------------------------------ - INTEGER :: ixindx(maxinpx) - PUBLIC kgen_read_externs_rrlw_wvn - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_wvn(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) ixindx - END SUBROUTINE kgen_read_externs_rrlw_wvn - - END MODULE rrlw_wvn diff --git a/test/ncar_kernels/PORT_lw_inatm/src/rrtmg_lw_rad.f90 b/test/ncar_kernels/PORT_lw_inatm/src/rrtmg_lw_rad.f90 deleted file mode 100644 index 5a82becb5b..0000000000 --- a/test/ncar_kernels/PORT_lw_inatm/src/rrtmg_lw_rad.f90 +++ /dev/null @@ -1,1057 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_lw_rad.f90 -! Generated at: 2015-07-26 18:45:57 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_lw_rad - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! - ! **************************************************************************** - ! * * - ! * RRTMG_LW * - ! * * - ! * * - ! * * - ! * a rapid radiative transfer model * - ! * for the longwave region * - ! * for application to general circulation models * - ! * * - ! * * - ! * Atmospheric and Environmental Research, Inc. * - ! * 131 Hartwell Avenue * - ! * Lexington, MA 02421 * - ! * * - ! * * - ! * Eli J. Mlawer * - ! * Jennifer S. Delamere * - ! * Michael J. Iacono * - ! * Shepard A. Clough * - ! * * - ! * * - ! * * - ! * * - ! * * - ! * * - ! * email: miacono@aer.com * - ! * email: emlawer@aer.com * - ! * email: jdelamer@aer.com * - ! * * - ! * The authors wish to acknowledge the contributions of the * - ! * following people: Steven J. Taubman, Karen Cady-Pereira, * - ! * Patrick D. Brown, Ronald E. Farren, Luke Chen, Robert Bergstrom. * - ! * * - ! **************************************************************************** - ! -------- Modules -------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - ! Move call to rrtmg_lw_ini and following use association to - ! GCM initialization area - ! use rrtmg_lw_init, only: rrtmg_lw_ini - IMPLICIT NONE - ! public interfaces/functions/subroutines - PUBLIC inatm - PUBLIC rrtmg_lw - !------------------------------------------------------------------ - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !------------------------------------------------------------------ - !------------------------------------------------------------------ - ! Public subroutines - !------------------------------------------------------------------ - - SUBROUTINE rrtmg_lw(ncol, nlay, icld, play, plev, tlay, tlev, tsfc, h2ovmr, o3vmr, co2vmr, ch4vmr, o2vmr, n2ovmr, & - cfc11vmr, cfc12vmr, cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, cldfmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, & - taucmcl, tauaer, kgen_unit) - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------- Description -------- - ! This program is the driver subroutine for RRTMG_LW, the AER LW radiation - ! model for application to GCMs, that has been adapted from RRTM_LW for - ! improved efficiency. - ! - ! NOTE: The call to RRTMG_LW_INI should be moved to the GCM initialization - ! area, since this has to be called only once. - ! - ! This routine: - ! a) calls INATM to read in the atmospheric profile from GCM; - ! all layering in RRTMG is ordered from surface to toa. - ! b) calls CLDPRMC to set cloud optical depth for McICA based - ! on input cloud properties - ! c) calls SETCOEF to calculate various quantities needed for - ! the radiative transfer algorithm - ! d) calls TAUMOL to calculate gaseous optical depths for each - ! of the 16 spectral bands - ! e) calls RTRNMC (for both clear and cloudy profiles) to perform the - ! radiative transfer calculation using McICA, the Monte-Carlo - ! Independent Column Approximation, to represent sub-grid scale - ! cloud variability - ! f) passes the necessary fluxes and cooling rates back to GCM - ! - ! Two modes of operation are possible: - ! The mode is chosen by using either rrtmg_lw.nomcica.f90 (to not use - ! McICA) or rrtmg_lw.f90 (to use McICA) to interface with a GCM. - ! - ! 1) Standard, single forward model calculation (imca = 0) - ! 2) Monte Carlo Independent Column Approximation (McICA, Pincus et al., - ! JC, 2003) method is applied to the forward model calculation (imca = 1) - ! - ! This call to RRTMG_LW must be preceeded by a call to the module - ! mcica_subcol_gen_lw.f90 to run the McICA sub-column cloud generator, - ! which will provide the cloud physical or cloud optical properties - ! on the RRTMG quadrature point (ngpt) dimension. - ! - ! Two methods of cloud property input are possible: - ! Cloud properties can be input in one of two ways (controlled by input - ! flags inflglw, iceflglw, and liqflglw; see text file rrtmg_lw_instructions - ! and subroutine rrtmg_lw_cldprop.f90 for further details): - ! - ! 1) Input cloud fraction and cloud optical depth directly (inflglw = 0) - ! 2) Input cloud fraction and cloud physical properties (inflglw = 1 or 2); - ! cloud optical properties are calculated by cldprop or cldprmc based - ! on input settings of iceflglw and liqflglw - ! - ! One method of aerosol property input is possible: - ! Aerosol properties can be input in only one way (controlled by input - ! flag iaer, see text file rrtmg_lw_instructions for further details): - ! - ! 1) Input aerosol optical depth directly by layer and spectral band (iaer=10); - ! band average optical depth at the mid-point of each spectral band. - ! RRTMG_LW currently treats only aerosol absorption; - ! scattering capability is not presently available. - ! - ! - ! ------- Modifications ------- - ! - ! This version of RRTMG_LW has been modified from RRTM_LW to use a reduced - ! set of g-points for application to GCMs. - ! - !-- Original version (derived from RRTM_LW), reduction of g-points, other - ! revisions for use with GCMs. - ! 1999: M. J. Iacono, AER, Inc. - !-- Adapted for use with NCAR/CAM. - ! May 2004: M. J. Iacono, AER, Inc. - !-- Revised to add McICA capability. - ! Nov 2005: M. J. Iacono, AER, Inc. - !-- Conversion to F90 formatting for consistency with rrtmg_sw. - ! Feb 2007: M. J. Iacono, AER, Inc. - !-- Modifications to formatting to use assumed-shape arrays. - ! Aug 2007: M. J. Iacono, AER, Inc. - !-- Modified to add longwave aerosol absorption. - ! Apr 2008: M. J. Iacono, AER, Inc. - ! --------- Modules ---------- - USE parrrtm, ONLY: ngptlw - USE parrrtm, ONLY: maxxsec - USE parrrtm, ONLY: nbndlw - USE parrrtm, ONLY: mxmol - ! ------- Declarations ------- - ! ----- Input ----- - integer, intent(in) :: kgen_unit - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - ! chunk identifier - INTEGER, intent(in) :: ncol ! Number of horizontal columns - INTEGER, intent(in) :: nlay ! Number of model layers - INTEGER, intent(inout) :: icld ! Cloud overlap method - ! 0: Clear only - ! 1: Random - ! 2: Maximum/random - ! 3: Maximum - REAL(KIND=r8), intent(in) :: play(:,:) ! Layer pressures (hPa, mb) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: plev(:,:) ! Interface pressures (hPa, mb) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(in) :: tlay(:,:) ! Layer temperatures (K) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: tlev(:,:) ! Interface temperatures (K) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(in) :: tsfc(:) ! Surface temperature (K) - ! Dimensions: (ncol) - REAL(KIND=r8), intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: o2vmr(:,:) ! O2 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: cfc11vmr(:,:) ! CFC11 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: cfc12vmr(:,:) ! CFC12 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: cfc22vmr(:,:) ! CFC22 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: ccl4vmr(:,:) ! CCL4 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: emis(:,:) ! Surface emissivity - ! Dimensions: (ncol,nbndlw) - INTEGER, intent(in) :: inflglw ! Flag for cloud optical properties - INTEGER, intent(in) :: iceflglw ! Flag for ice particle specification - INTEGER, intent(in) :: liqflglw ! Flag for liquid droplet specification - REAL(KIND=r8), intent(in) :: cldfmcl(:,:,:) ! Cloud fraction - ! Dimensions: (ngptlw,ncol,nlay) - REAL(KIND=r8), intent(in) :: ciwpmcl(:,:,:) ! Cloud ice water path (g/m2) - ! Dimensions: (ngptlw,ncol,nlay) - REAL(KIND=r8), intent(in) :: clwpmcl(:,:,:) ! Cloud liquid water path (g/m2) - ! Dimensions: (ngptlw,ncol,nlay) - REAL(KIND=r8), intent(in) :: reicmcl(:,:) ! Cloud ice effective radius (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: taucmcl(:,:,:) ! Cloud optical depth - ! Dimensions: (ngptlw,ncol,nlay) - ! real(kind=r8), intent(in) :: ssacmcl(:,:,:) ! Cloud single scattering albedo - ! Dimensions: (ngptlw,ncol,nlay) - ! for future expansion - ! lw scattering not yet available - ! real(kind=r8), intent(in) :: asmcmcl(:,:,:) ! Cloud asymmetry parameter - ! Dimensions: (ngptlw,ncol,nlay) - ! for future expansion - ! lw scattering not yet available - REAL(KIND=r8), intent(in) :: tauaer(:,:,:) ! aerosol optical depth - ! at mid-point of LW spectral bands - ! Dimensions: (ncol,nlay,nbndlw) - ! real(kind=r8), intent(in) :: ssaaer(:,:,:) ! aerosol single scattering albedo - ! Dimensions: (ncol,nlay,nbndlw) - ! for future expansion - ! (lw aerosols/scattering not yet available) - ! real(kind=r8), intent(in) :: asmaer(:,:,:) ! aerosol asymmetry parameter - ! Dimensions: (ncol,nlay,nbndlw) - ! for future expansion - ! (lw aerosols/scattering not yet available) - ! ----- Output ----- - ! Total sky longwave upward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Total sky longwave downward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Total sky longwave radiative heating rate (K/d) - ! Dimensions: (ncol,nlay) - ! Clear sky longwave upward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Clear sky longwave downward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Clear sky longwave radiative heating rate (K/d) - ! Dimensions: (ncol,nlay) - ! Total sky longwave upward flux spectral (W/m2) - ! Dimensions: (nbndlw,ncol,nlay+1) - ! Total sky longwave downward flux spectral (W/m2) - ! Dimensions: (nbndlw,ncol,nlay+1) - ! ----- Local ----- - ! Control - ! beginning band of calculation - ! ending band of calculation - ! output option flag (inactive) - INTEGER :: iaer ! aerosol option flag - ! column loop index - ! flag for mcica [0=off, 1=on] - ! value for changing mcica permute seed - ! layer loop index - ! g-point loop index - ! Atmosphere - REAL(KIND=r8) :: pavel(ncol,nlay) - REAL(KIND=r8) :: ref_pavel(ncol,nlay) ! layer pressures (mb) - REAL(KIND=r8) :: tavel(ncol,nlay) - REAL(KIND=r8) :: ref_tavel(ncol,nlay) ! layer temperatures (K) - REAL(KIND=r8) :: pz(ncol,0:nlay) - REAL(KIND=r8) :: ref_pz(ncol,0:nlay) ! level (interface) pressures (hPa, mb) - REAL(KIND=r8) :: tz(ncol,0:nlay) - REAL(KIND=r8) :: ref_tz(ncol,0:nlay) ! level (interface) temperatures (K) - REAL(KIND=r8) :: tbound(ncol) - REAL(KIND=r8) :: ref_tbound(ncol) ! surface temperature (K) - REAL(KIND=r8) :: coldry(ncol,nlay) - REAL(KIND=r8) :: ref_coldry(ncol,nlay) ! dry air column density (mol/cm2) - REAL(KIND=r8) :: wbrodl(ncol,nlay) - REAL(KIND=r8) :: ref_wbrodl(ncol,nlay) ! broadening gas column density (mol/cm2) - REAL(KIND=r8) :: wkl(ncol,mxmol,nlay) - REAL(KIND=r8) :: ref_wkl(ncol,mxmol,nlay) ! molecular amounts (mol/cm-2) - REAL(KIND=r8) :: wx(ncol,maxxsec,nlay) - REAL(KIND=r8) :: ref_wx(ncol,maxxsec,nlay) ! cross-section amounts (mol/cm-2) - REAL(KIND=r8) :: pwvcm(ncol) - REAL(KIND=r8) :: ref_pwvcm(ncol) ! precipitable water vapor (cm) - REAL(KIND=r8) :: semiss(ncol,nbndlw) - REAL(KIND=r8) :: ref_semiss(ncol,nbndlw) ! lw surface emissivity - ! - ! gaseous optical depths - ! gaseous + aerosol optical depths - REAL(KIND=r8) :: taua(ncol,nlay,nbndlw) - REAL(KIND=r8) :: ref_taua(ncol,nlay,nbndlw) ! aerosol optical depth - ! real(kind=r8) :: ssaa(nlay,nbndlw) ! aerosol single scattering albedo - ! for future expansion - ! (lw aerosols/scattering not yet available) - ! real(kind=r8) :: asma(nlay+1,nbndlw) ! aerosol asymmetry parameter - ! for future expansion - ! (lw aerosols/scattering not yet available) - ! Atmosphere - setcoef - ! tropopause layer index - ! lookup table index - ! lookup table index - ! lookup table index - ! - ! - ! - ! column amount (h2o) - ! column amount (co2) - ! column amount (o3) - ! column amount (n2o) - ! column amount (co) - ! column amount (ch4) - ! column amount (o2) - ! column amount (broadening gases) - ! - ! - ! Atmosphere/clouds - cldprop - ! number of cloud spectral bands - INTEGER :: inflag - INTEGER :: ref_inflag ! flag for cloud property method - INTEGER :: iceflag - INTEGER :: ref_iceflag ! flag for ice cloud properties - INTEGER :: liqflag - INTEGER :: ref_liqflag ! flag for liquid cloud properties - ! Atmosphere/clouds - cldprmc [mcica] - REAL(KIND=r8) :: cldfmc(ncol,ngptlw,nlay) - REAL(KIND=r8) :: ref_cldfmc(ncol,ngptlw,nlay) ! cloud fraction [mcica] - REAL(KIND=r8) :: ciwpmc(ncol,ngptlw,nlay) - REAL(KIND=r8) :: ref_ciwpmc(ncol,ngptlw,nlay) ! cloud ice water path [mcica] - REAL(KIND=r8) :: clwpmc(ncol,ngptlw,nlay) - REAL(KIND=r8) :: ref_clwpmc(ncol,ngptlw,nlay) ! cloud liquid water path [mcica] - REAL(KIND=r8) :: relqmc(ncol,nlay) - REAL(KIND=r8) :: ref_relqmc(ncol,nlay) ! liquid particle size (microns) - REAL(KIND=r8) :: reicmc(ncol,nlay) - REAL(KIND=r8) :: ref_reicmc(ncol,nlay) ! ice particle effective radius (microns) - REAL(KIND=r8) :: dgesmc(ncol,nlay) - REAL(KIND=r8) :: ref_dgesmc(ncol,nlay) ! ice particle generalized effective size (microns) - REAL(KIND=r8) :: taucmc(ncol,ngptlw,nlay) - REAL(KIND=r8) :: ref_taucmc(ncol,ngptlw,nlay) ! cloud optical depth [mcica] - ! real(kind=r8) :: ssacmc(ngptlw,nlay) ! cloud single scattering albedo [mcica] - ! for future expansion - ! (lw scattering not yet available) - ! real(kind=r8) :: asmcmc(ngptlw,nlay) ! cloud asymmetry parameter [mcica] - ! for future expansion - ! (lw scattering not yet available) - ! Output - ! upward longwave flux (w/m2) - ! downward longwave flux (w/m2) - ! upward longwave flux spectral (w/m2) - ! downward longwave flux spectral (w/m2) - ! net longwave flux (w/m2) - ! longwave heating rate (k/day) - ! clear sky upward longwave flux (w/m2) - ! clear sky downward longwave flux (w/m2) - ! clear sky net longwave flux (w/m2) - ! clear sky longwave heating rate (k/day) - !DIR$ ATTRIBUTES ALIGN : 64 :: pz - ! Initializations - ! orig: fluxfac = pi * 2.d4 ! orig: fluxfac = pi * 2.d4 - ! Set imca to select calculation type: - ! imca = 0, use standard forward model calculation - ! imca = 1, use McICA for Monte Carlo treatment of sub-grid cloud variability - ! *** This version uses McICA (imca = 1) *** - ! Set icld to select of clear or cloud calculation and cloud overlap method - ! icld = 0, clear only - ! icld = 1, with clouds using random cloud overlap - ! icld = 2, with clouds using maximum/random cloud overlap - ! icld = 3, with clouds using maximum cloud overlap (McICA only) - ! Set iaer to select aerosol option - ! iaer = 0, no aerosols - ! iaer = 10, input total aerosol optical depth (tauaer) directly - !Call model and data initialization, compute lookup tables, perform - ! reduction of g-points from 256 to 140 for input absorption coefficient - ! data and other arrays. - ! - ! In a GCM this call should be placed in the model initialization - ! area, since this has to be called only once. - ! call rrtmg_lw_ini - ! This is the main longitude/column loop within RRTMG. - ! Prepare atmospheric profile from GCM for use in RRTMG, and define - ! other input parameters. - tolerance = 1.E-14 - CALL kgen_init_check(check_status, tolerance) - READ(UNIT=kgen_unit) iaer - READ(UNIT=kgen_unit) pavel - READ(UNIT=kgen_unit) tavel - READ(UNIT=kgen_unit) pz - READ(UNIT=kgen_unit) tz - READ(UNIT=kgen_unit) tbound - READ(UNIT=kgen_unit) coldry - READ(UNIT=kgen_unit) wbrodl - READ(UNIT=kgen_unit) wkl - READ(UNIT=kgen_unit) wx - READ(UNIT=kgen_unit) pwvcm - READ(UNIT=kgen_unit) semiss - READ(UNIT=kgen_unit) taua - READ(UNIT=kgen_unit) inflag - READ(UNIT=kgen_unit) iceflag - READ(UNIT=kgen_unit) liqflag - READ(UNIT=kgen_unit) cldfmc - READ(UNIT=kgen_unit) ciwpmc - READ(UNIT=kgen_unit) clwpmc - READ(UNIT=kgen_unit) relqmc - READ(UNIT=kgen_unit) reicmc - READ(UNIT=kgen_unit) dgesmc - READ(UNIT=kgen_unit) taucmc - - READ(UNIT=kgen_unit) ref_pavel - READ(UNIT=kgen_unit) ref_tavel - READ(UNIT=kgen_unit) ref_pz - READ(UNIT=kgen_unit) ref_tz - READ(UNIT=kgen_unit) ref_tbound - READ(UNIT=kgen_unit) ref_coldry - READ(UNIT=kgen_unit) ref_wbrodl - READ(UNIT=kgen_unit) ref_wkl - READ(UNIT=kgen_unit) ref_wx - READ(UNIT=kgen_unit) ref_pwvcm - READ(UNIT=kgen_unit) ref_semiss - READ(UNIT=kgen_unit) ref_taua - READ(UNIT=kgen_unit) ref_inflag - READ(UNIT=kgen_unit) ref_iceflag - READ(UNIT=kgen_unit) ref_liqflag - READ(UNIT=kgen_unit) ref_cldfmc - READ(UNIT=kgen_unit) ref_ciwpmc - READ(UNIT=kgen_unit) ref_clwpmc - READ(UNIT=kgen_unit) ref_relqmc - READ(UNIT=kgen_unit) ref_reicmc - READ(UNIT=kgen_unit) ref_dgesmc - READ(UNIT=kgen_unit) ref_taucmc - - - ! call to kernel - call inatm (ncol, nlay, icld, iaer, & - play, plev, tlay, tlev, tsfc, h2ovmr, & - o3vmr, co2vmr, ch4vmr, o2vmr, n2ovmr, cfc11vmr, cfc12vmr, & - cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, & - cldfmcl, taucmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, tauaer, & - pavel, pz, tavel, tz, tbound, semiss, coldry, & - wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag, & - cldfmc, taucmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, taua) - ! kernel verification for output variables - CALL kgen_verify_real_r8_dim2( "pavel", check_status, pavel, ref_pavel) - CALL kgen_verify_real_r8_dim2( "tavel", check_status, tavel, ref_tavel) - CALL kgen_verify_real_r8_dim2( "pz", check_status, pz, ref_pz) - CALL kgen_verify_real_r8_dim2( "tz", check_status, tz, ref_tz) - CALL kgen_verify_real_r8_dim1( "tbound", check_status, tbound, ref_tbound) - CALL kgen_verify_real_r8_dim2( "coldry", check_status, coldry, ref_coldry) - CALL kgen_verify_real_r8_dim2( "wbrodl", check_status, wbrodl, ref_wbrodl) - CALL kgen_verify_real_r8_dim3( "wkl", check_status, wkl, ref_wkl) - CALL kgen_verify_real_r8_dim3( "wx", check_status, wx, ref_wx) - CALL kgen_verify_real_r8_dim1( "pwvcm", check_status, pwvcm, ref_pwvcm) - CALL kgen_verify_real_r8_dim2( "semiss", check_status, semiss, ref_semiss) - CALL kgen_verify_real_r8_dim3( "taua", check_status, taua, ref_taua) - CALL kgen_verify_integer( "inflag", check_status, inflag, ref_inflag) - CALL kgen_verify_integer( "iceflag", check_status, iceflag, ref_iceflag) - CALL kgen_verify_integer( "liqflag", check_status, liqflag, ref_liqflag) - CALL kgen_verify_real_r8_dim3( "cldfmc", check_status, cldfmc, ref_cldfmc) - CALL kgen_verify_real_r8_dim3( "ciwpmc", check_status, ciwpmc, ref_ciwpmc) - CALL kgen_verify_real_r8_dim3( "clwpmc", check_status, clwpmc, ref_clwpmc) - CALL kgen_verify_real_r8_dim2( "relqmc", check_status, relqmc, ref_relqmc) - CALL kgen_verify_real_r8_dim2( "reicmc", check_status, reicmc, ref_reicmc) - CALL kgen_verify_real_r8_dim2( "dgesmc", check_status, dgesmc, ref_dgesmc) - CALL kgen_verify_real_r8_dim3( "taucmc", check_status, taucmc, ref_taucmc) - CALL kgen_print_check("inatm", check_status) - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,10 - CALL inatm(ncol, nlay, icld, iaer, play, plev, tlay, tlev, tsfc, h2ovmr, o3vmr, co2vmr, ch4vmr, & -o2vmr, n2ovmr, cfc11vmr, cfc12vmr, cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, cldfmcl, taucmcl, & -ciwpmcl, clwpmcl, reicmcl, relqmcl, tauaer, pavel, pz, tavel, tz, tbound, semiss, coldry, wkl, wbrodl, wx, & -pwvcm, inflag, iceflag, liqflag, cldfmc, taucmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, taua) - END DO - CALL system_clock(stop_clock, rate_clock) - WRITE(*,*) - PRINT *, "Elapsed time (sec): ", (stop_clock - start_clock)/REAL(rate_clock*10) - ! For cloudy atmosphere, use cldprop to set cloud optical properties based on - ! input cloud physical properties. Select method based on choices described - ! in cldprop. Cloud fraction, water path, liquid droplet and ice particle - ! effective radius must be passed into cldprop. Cloud fraction and cloud - ! optical depth are transferred to rrtmg_lw arrays in cldprop. - ! Calculate information needed by the radiative transfer routine - ! that is specific to this atmosphere, especially some of the - ! coefficients and indices needed to compute the optical depths - ! by interpolating data from stored reference atmospheres. - ! Call the radiative transfer routine. - ! Either routine can be called to do clear sky calculation. If clouds - ! are present, then select routine based on cloud overlap assumption - ! to be used. Clear sky calculation is done simultaneously. - ! For McICA, RTRNMC is called for clear and cloudy calculations. - ! Transfer up and down fluxes and heating rate to output arrays. - ! Vertical indexing goes from bottom to top - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_r8_dim2(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim2 - - SUBROUTINE kgen_read_real_r8_dim1(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim1 - - SUBROUTINE kgen_read_real_r8_dim3(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2,idx3 - INTEGER, DIMENSION(2,3) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim3 - - - ! verify subroutines - SUBROUTINE kgen_verify_real_r8_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim2 - - SUBROUTINE kgen_verify_real_r8_dim1( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1))) - allocate(temp2(SIZE(var,dim=1))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim1 - - SUBROUTINE kgen_verify_real_r8_dim3( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim3 - - SUBROUTINE kgen_verify_integer( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - END SUBROUTINE kgen_verify_integer - - END SUBROUTINE rrtmg_lw - !*************************************************************************** - - SUBROUTINE inatm(ncol, nlay, icld, iaer, play, plev, tlay, tlev, tsfc, h2ovmr, o3vmr, co2vmr, ch4vmr, o2vmr, n2ovmr, & - cfc11vmr, cfc12vmr, cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, cldfmcl, taucmcl, ciwpmcl, clwpmcl, reicmcl, & - relqmcl, tauaer, pavel, pz, tavel, tz, tbound, semiss, coldry, wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag, cldfmc, & - taucmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, taua) - !*************************************************************************** - ! - ! Input atmospheric profile from GCM, and prepare it for use in RRTMG_LW. - ! Set other RRTMG_LW input parameters. - ! - !*************************************************************************** - ! --------- Modules ---------- - USE parrrtm, ONLY: nmol - USE parrrtm, ONLY: maxxsec - USE parrrtm, ONLY: nbndlw - USE parrrtm, ONLY: ngptlw - USE rrlw_con, ONLY: grav - USE rrlw_con, ONLY: avogad - USE rrlw_wvn, ONLY: ixindx - ! ------- Declarations ------- - ! ----- Input ----- - INTEGER, intent(in) :: ncol ! total number of columns - INTEGER, intent(in) :: nlay ! Number of model layers - INTEGER, intent(in) :: icld ! clear/cloud and cloud overlap flag - INTEGER, intent(in) :: iaer ! aerosol option flag - REAL(KIND=r8), intent(in) :: play(:,:) ! Layer pressures (hPa, mb) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: plev(:,:) ! Interface pressures (hPa, mb) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(in) :: tlay(:,:) ! Layer temperatures (K) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: tlev(:,:) ! Interface temperatures (K) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(in) :: tsfc(:) ! Surface temperature (K) - ! Dimensions: (ncol) - REAL(KIND=r8), intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: o2vmr(:,:) ! O2 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: cfc11vmr(:,:) ! CFC11 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: cfc12vmr(:,:) ! CFC12 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: cfc22vmr(:,:) ! CFC22 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: ccl4vmr(:,:) ! CCL4 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: emis(:,:) ! Surface emissivity - ! Dimensions: (ncol,nbndlw) - INTEGER, intent(in) :: inflglw ! Flag for cloud optical properties - INTEGER, intent(in) :: iceflglw ! Flag for ice particle specification - INTEGER, intent(in) :: liqflglw ! Flag for liquid droplet specification - REAL(KIND=r8), intent(in) :: cldfmcl(:,:,:) ! Cloud fraction - ! Dimensions: (ngptlw,ncol,nlay) - REAL(KIND=r8), intent(in) :: ciwpmcl(:,:,:) ! Cloud ice water path (g/m2) - ! Dimensions: (ngptlw,ncol,nlay) - REAL(KIND=r8), intent(in) :: clwpmcl(:,:,:) ! Cloud liquid water path (g/m2) - ! Dimensions: (ngptlw,ncol,nlay) - REAL(KIND=r8), intent(in) :: reicmcl(:,:) ! Cloud ice effective radius (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: taucmcl(:,:,:) ! Cloud optical depth - ! Dimensions: (ngptlw,ncol,nlay) - REAL(KIND=r8), intent(in) :: tauaer(:,:,:) ! Aerosol optical depth - ! Dimensions: (ncol,nlay,nbndlw) - ! ----- Output ----- - ! Atmosphere - REAL(KIND=r8), intent(out) :: pavel(:,:) ! layer pressures (mb) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: tavel(:,:) ! layer temperatures (K) - ! Dimensions: (ncol, nlay) - REAL(KIND=r8), intent(out) :: pz(ncol,0:nlay) ! level (interface) pressures (hPa, mb) - ! Dimensions: (ncol,0:nlay) - REAL(KIND=r8), intent(out) :: tz(ncol,0:nlay) ! level (interface) temperatures (K) - ! Dimensions: (ncol,0:nlay) - REAL(KIND=r8), intent(out) :: tbound(:) ! surface temperature (K) - ! Dimensions: (ncol) - REAL(KIND=r8), intent(out) :: coldry(ncol,nlay) ! dry air column density (mol/cm2) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: wbrodl(:,:) ! broadening gas column density (mol/cm2) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: wkl(:,:,:) ! molecular amounts (mol/cm-2) - ! Dimensions: (ncol,mxmol,nlay) - REAL(KIND=r8), intent(out) :: wx(:,:,:) ! cross-section amounts (mol/cm-2) - ! Dimensions: (ncol,maxxsec,nlay) - REAL(KIND=r8), intent(out) :: pwvcm(:) ! precipitable water vapor (cm) - ! Dimensions: (ncol) - REAL(KIND=r8), intent(out) :: semiss(:,:) ! lw surface emissivity - ! Dimensions: (ncol,nbndlw) - ! Atmosphere/clouds - cldprop - INTEGER, intent(out) :: inflag ! flag for cloud property method - INTEGER, intent(out) :: iceflag ! flag for ice cloud properties - INTEGER, intent(out) :: liqflag ! flag for liquid cloud properties - REAL(KIND=r8), intent(out) :: cldfmc(:,:,:) ! cloud fraction [mcica] - ! Dimensions: (ncol,ngptlw,nlay) - REAL(KIND=r8), intent(out) :: ciwpmc(:,:,:) ! cloud ice water path [mcica] - ! Dimensions: (ncol,ngptlw,nlay) - REAL(KIND=r8), intent(out) :: clwpmc(:,:,:) ! cloud liquid water path [mcica] - ! Dimensions: (ncol,ngptlw,nlay) - REAL(KIND=r8), intent(out) :: relqmc(:,:) ! liquid particle effective radius (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: reicmc(:,:) ! ice particle effective radius (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: dgesmc(:,:) ! ice particle generalized effective size (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: taucmc(:,:,:) ! cloud optical depth [mcica] - ! Dimensions: (ncol,ngptlw,nlay) - REAL(KIND=r8), intent(out) :: taua(:,:,:) ! Aerosol optical depth - ! Dimensions: (ncol,nlay,nbndlw) - ! ----- Local ----- - REAL(KIND=r8), parameter :: amd = 28.9660_r8 ! Effective molecular weight of dry air (g/mol) - REAL(KIND=r8), parameter :: amw = 18.0160_r8 ! Molecular weight of water vapor (g/mol) - ! real(kind=r8), parameter :: amc = 44.0098_r8 ! Molecular weight of carbon dioxide (g/mol) - ! real(kind=r8), parameter :: amo = 47.9998_r8 ! Molecular weight of ozone (g/mol) - ! real(kind=r8), parameter :: amo2 = 31.9999_r8 ! Molecular weight of oxygen (g/mol) - ! real(kind=r8), parameter :: amch4 = 16.0430_r8 ! Molecular weight of methane (g/mol) - ! real(kind=r8), parameter :: amn2o = 44.0128_r8 ! Molecular weight of nitrous oxide (g/mol) - ! real(kind=r8), parameter :: amc11 = 137.3684_r8 ! Molecular weight of CFC11 (g/mol) - CCL3F - ! real(kind=r8), parameter :: amc12 = 120.9138_r8 ! Molecular weight of CFC12 (g/mol) - CCL2F2 - ! real(kind=r8), parameter :: amc22 = 86.4688_r8 ! Molecular weight of CFC22 (g/mol) - CHCLF2 - ! real(kind=r8), parameter :: amcl4 = 153.823_r8 ! Molecular weight of CCL4 (g/mol) - CCL4 - ! Set molecular weight ratios (for converting mmr to vmr) - ! e.g. h2ovmr = h2ommr * amdw) - ! Molecular weight of dry air / water vapor - ! Molecular weight of dry air / carbon dioxide - ! Molecular weight of dry air / ozone - ! Molecular weight of dry air / methane - ! Molecular weight of dry air / nitrous oxide - ! Molecular weight of dry air / CFC11 - ! Molecular weight of dry air / CFC12 - ! Stefan-Boltzmann constant (W/m2K4) - INTEGER :: l, iplon - INTEGER :: imol - INTEGER :: ix - INTEGER :: n - INTEGER :: ib - INTEGER :: ig ! Loop indices - REAL(KIND=r8) :: amttl - REAL(KIND=r8) :: wvttl - REAL(KIND=r8) :: summol - REAL(KIND=r8) :: wvsh - ! promote temporary scalars to vectors - REAL(KIND=r8) :: amm(ncol,nlay) ! pr - ! Initialize all molecular amounts and cloud properties to zero here, then pass input amounts - ! into RRTM arrays below. - !JMD !DIR$ ASSUME_ALIGNED pz:64 - ! Set surface temperature. - tbound = tsfc - ! Install input GCM arrays into RRTMG_LW arrays for pressure, temperature, - ! and molecular amounts. - ! Pressures are input in mb, or are converted to mb here. - ! Molecular amounts are input in volume mixing ratio, or are converted from - ! mass mixing ratio (or specific humidity for h2o) to volume mixing ratio - ! here. These are then converted to molecular amount (molec/cm2) below. - ! The dry air column COLDRY (in molec/cm2) is calculated from the level - ! pressures, pz (in mb), based on the hydrostatic equation and includes a - ! correction to account for h2o in the layer. The molecular weight of moist - ! air (amm) is calculated for each layer. - ! Note: In RRTMG, layer indexing goes from bottom to top, and coding below - ! assumes GCM input fields are also bottom to top. Input layer indexing - ! from GCM fields should be reversed here if necessary. - pz(:,0) = plev(:,nlay+1) - tz(:,0) = tlev(:,nlay+1) - do l = 1, nlay - do iplon=1,ncol - pavel(iplon,l) = play(iplon,nlay-l+1) - tavel(iplon,l) = tlay(iplon,nlay-l+1) - pz(iplon,l) = plev(iplon,nlay-l+1) - tz(iplon,l) = tlev(iplon,nlay-l+1) - ! For h2o input in vmr: - wkl(iplon,1,l) = h2ovmr(iplon,nlay-l+1) - ! For h2o input in mmr: - ! wkl(1,l) = h2o(iplon,nlay-l)*amdw - ! For h2o input in specific humidity; - ! wkl(1,l) = (h2o(iplon,nlay-l)/(1._r8 - h2o(iplon,nlay-l)))*amdw - wkl(iplon,2,l) = co2vmr(iplon,nlay-l+1) - wkl(iplon,3,l) = o3vmr(iplon,nlay-l+1) - wkl(iplon,4,l) = n2ovmr(iplon,nlay-l+1) - wkl(iplon,5,l) = 0._r8 - wkl(iplon,6,l) = ch4vmr(iplon,nlay-l+1) - wkl(iplon,7,l) = o2vmr(iplon,nlay-l+1) - amm(iplon,l) = (1._r8 - wkl(iplon,1,l)) * amd + wkl(iplon,1,l) * amw - coldry(iplon,l) = (pz(iplon,l-1)-pz(iplon,l)) * 1.e3_r8 * avogad / & - (1.e2_r8 * grav * amm(iplon,l) * (1._r8 + wkl(iplon,1,l))) - ! Set cross section molecule amounts from input; convert to vmr if necessary - wx(iplon,1,l) = ccl4vmr(iplon,nlay-l+1) - wx(iplon,2,l) = cfc11vmr(iplon,nlay-l+1) - wx(iplon,3,l) = cfc12vmr(iplon,nlay-l+1) - wx(iplon,4,l) = cfc22vmr(iplon,nlay-l+1) - enddo - enddo - coldry(:,nlay) = (pz(:,nlay-1)) * 1.e3_r8 * avogad / & - (1.e2_r8 * grav * amm(:,nlay) * (1._r8 + wkl(:,1,nlay-1))) - ! At this point all molecular amounts in wkl and wx are in volume mixing ratio; - ! convert to molec/cm2 based on coldry for use in rrtm. also, compute precipitable - ! water vapor for diffusivity angle adjustments in rtrn and rtrnmr. - do iplon = 1,ncol - amttl = 0.0_r8 - wvttl = 0.0_r8 - do l = 1, nlay - summol = 0.0_r8 - do imol = 2, nmol - summol = summol + wkl(iplon,imol,l) - enddo - wbrodl(iplon,l) = coldry(iplon,l) * (1._r8 - summol) - do imol = 1, nmol - wkl(iplon,imol,l) = coldry(iplon,l) * wkl(iplon,imol,l) - enddo - amttl = amttl + coldry(iplon,l)+wkl(iplon,1,l) - wvttl = wvttl + wkl(iplon,1,l) - do ix = 1,maxxsec - if (ixindx(ix) .ne. 0) then - wx(iplon,ixindx(ix),l) = coldry(iplon,l) * wx(iplon,ix,l) * 1.e-20_r8 - endif - enddo - enddo - wvsh = (amw * wvttl) / (amd * amttl) - pwvcm(iplon) = wvsh * (1.e3_r8 * pz(iplon,0)) / (1.e2_r8 * grav) - ! Set spectral surface emissivity for each longwave band. - do n=1,nbndlw - semiss(iplon,n) = emis(iplon,n) - ! semiss(n) = 1.0_r8 - enddo - enddo - ! Transfer aerosol optical properties to RRTM variable; - ! modify to reverse layer indexing here if necessary. - if (iaer .ge. 1) then - do ib = 1, nbndlw - do l = 1, nlay-1 - do iplon=1,ncol - taua(iplon,l,ib) = tauaer(iplon,nlay-l,ib) - enddo - enddo - enddo - endif - ! Transfer cloud fraction and cloud optical properties to RRTM variables, - ! modify to reverse layer indexing here if necessary. - if (icld .ge. 1) then - inflag = inflglw - iceflag = iceflglw - liqflag = liqflglw - ! Move incoming GCM cloud arrays to RRTMG cloud arrays. - ! For GCM input, incoming reice is in effective radius; for Fu parameterization (iceflag = 3) - ! convert effective radius to generalized effective size using method of Mitchell, JAS, 2002: - do l = 1, nlay-1 - do ig = 1, ngptlw - do iplon=1,ncol - cldfmc(iplon,ig,l) = cldfmcl(ig,iplon,nlay-l) - taucmc(iplon,ig,l) = taucmcl(ig,iplon,nlay-l) - ciwpmc(iplon,ig,l) = ciwpmcl(ig,iplon,nlay-l) - clwpmc(iplon,ig,l) = clwpmcl(ig,iplon,nlay-l) - enddo - enddo - do iplon=1,ncol - reicmc(iplon,l) = reicmcl(iplon,nlay-l) - relqmc(iplon,l) = relqmcl(iplon,nlay-l) - enddo - if (iceflag .eq. 3) then - do iplon=1,ncol - dgesmc(iplon,l) = 1.5396_r8 * reicmcl(iplon,nlay-l) - enddo - endif - enddo - ! If an extra layer is being used in RRTMG, set all cloud properties to zero in the extra layer. - do iplon=1,ncol - cldfmc(iplon,:,nlay) = 0.0_r8 - taucmc(iplon,:,nlay) = 0.0_r8 - ciwpmc(iplon,:,nlay) = 0.0_r8 - clwpmc(iplon,:,nlay) = 0.0_r8 - reicmc(iplon,nlay) = 0.0_r8 - dgesmc(iplon,nlay) = 0.0_r8 - relqmc(iplon,nlay) = 0.0_r8 - taua(iplon,nlay,:) = 0.0_r8 - enddo - endif - END SUBROUTINE inatm - END MODULE rrtmg_lw_rad diff --git a/test/ncar_kernels/PORT_lw_inatm/src/shr_kind_mod.f90 b/test/ncar_kernels/PORT_lw_inatm/src/shr_kind_mod.f90 deleted file mode 100644 index f8f8ddacee..0000000000 --- a/test/ncar_kernels/PORT_lw_inatm/src/shr_kind_mod.f90 +++ /dev/null @@ -1,26 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : shr_kind_mod.f90 -! Generated at: 2015-07-26 18:45:57 -! KGEN version: 0.4.13 - - - - MODULE shr_kind_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - PUBLIC - INTEGER, parameter :: shr_kind_r8 = selected_real_kind(12) ! 8 byte real - ! 4 byte real - ! native real - ! 8 byte integer - ! 4 byte integer - ! native integer - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE shr_kind_mod diff --git a/test/ncar_kernels/PORT_lw_rad/CESM_license.txt b/test/ncar_kernels/PORT_lw_rad/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/PORT_lw_rad/data/rrtmg_lw.10 b/test/ncar_kernels/PORT_lw_rad/data/rrtmg_lw.10 deleted file mode 100644 index fef797ac5a..0000000000 Binary files a/test/ncar_kernels/PORT_lw_rad/data/rrtmg_lw.10 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_rad/data/rrtmg_lw.15 b/test/ncar_kernels/PORT_lw_rad/data/rrtmg_lw.15 deleted file mode 100644 index 83ef5b54f3..0000000000 Binary files a/test/ncar_kernels/PORT_lw_rad/data/rrtmg_lw.15 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_rad/data/rrtmg_lw.5 b/test/ncar_kernels/PORT_lw_rad/data/rrtmg_lw.5 deleted file mode 100644 index ac845e3c52..0000000000 Binary files a/test/ncar_kernels/PORT_lw_rad/data/rrtmg_lw.5 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_rad/inc/t1.mk b/test/ncar_kernels/PORT_lw_rad/inc/t1.mk deleted file mode 100644 index 3a0c79e71c..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/inc/t1.mk +++ /dev/null @@ -1,158 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# - -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# -# Intel default flags -# -# CPPDEFINES := -DOLD_SETCOEF -DOLD_RTRNMC -DOLD_CLDPRMC -# #CPPDEFINES := -DOLD_RTRNMC -DOLD_CLDPRMC -# #CPPDEFINES := -DOLD_RTRNMC -# #CPPDEFINES := -DOLD_SETCOEF -# #CPPDEFINES := -# #FC_FLAGS := ${CPPDEFINES} -xCORE-AVX2 -qopt-report=5 -no-opt-dynamic-align -O3 -fp-model fast=2 -# FC_FLAGS := ${CPPDEFINES} -xHost -no-opt-dynamic-align -O3 -fp-model fast=2 - -# -FC_FLAGS := $(OPT) - -ifeq ("$(FC)", "pgf90") -FC_FLAGS += -Mnofma -endif -ifeq ("$(FC)", "pgfortran") -FC_FLAGS += -Mnofma -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - -ALL_OBJS := kernel_driver.o radlw.o kgen_utils.o rrlw_kg08.o rrlw_kg15.o parrrtm.o rrlw_kg01.o rrlw_kg10.o rrlw_ref.o rrtmg_state.o rrlw_wvn.o rrtmg_lw_setcoef.o rrlw_kg16.o rrlw_kg02.o rrtmg_lw_cldprmc.o shr_kind_mod.o rrtmg_lw_rad.o rrtmg_lw_taumol.o rrlw_vsn.o rrlw_tbl.o rrlw_kg03.o ppgrid.o rrlw_kg07.o rrlw_kg14.o rrlw_kg04.o rrlw_kg12.o rrlw_kg13.o rrtmg_lw_rtrnmc.o rrlw_kg06.o rrlw_kg05.o rrlw_kg11.o rrlw_con.o rrlw_cld.o rrlw_kg09.o - -verify: - @(grep "verification.FAIL" $(TEST).rslt && echo "FAILED") || (grep "verification.PASS" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 radlw.o kgen_utils.o rrlw_kg08.o rrlw_kg15.o parrrtm.o rrlw_kg01.o rrlw_kg10.o rrlw_ref.o rrtmg_state.o rrlw_wvn.o rrtmg_lw_setcoef.o rrlw_kg16.o rrlw_kg02.o rrtmg_lw_cldprmc.o shr_kind_mod.o rrtmg_lw_rad.o rrtmg_lw_taumol.o rrlw_vsn.o rrlw_tbl.o rrlw_kg03.o ppgrid.o rrlw_kg07.o rrlw_kg14.o rrlw_kg04.o rrlw_kg12.o rrlw_kg13.o rrtmg_lw_rtrnmc.o rrlw_kg06.o rrlw_kg05.o rrlw_kg11.o rrlw_con.o rrlw_cld.o rrlw_kg09.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -radlw.o: $(SRC_DIR)/radlw.F90 kgen_utils.o rrtmg_lw_rad.o rrtmg_state.o shr_kind_mod.o ppgrid.o parrrtm.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_kg08.o: $(SRC_DIR)/rrlw_kg08.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_kg15.o: $(SRC_DIR)/rrlw_kg15.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -parrrtm.o: $(SRC_DIR)/parrrtm.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_kg01.o: $(SRC_DIR)/rrlw_kg01.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_kg10.o: $(SRC_DIR)/rrlw_kg10.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_ref.o: $(SRC_DIR)/rrlw_ref.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_state.o: $(SRC_DIR)/rrtmg_state.F90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_wvn.o: $(SRC_DIR)/rrlw_wvn.f90 kgen_utils.o parrrtm.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_lw_setcoef.o: $(SRC_DIR)/rrtmg_lw_setcoef.F90 kgen_utils.o shr_kind_mod.o rrlw_vsn.o rrlw_wvn.o rrlw_ref.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_kg16.o: $(SRC_DIR)/rrlw_kg16.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_kg02.o: $(SRC_DIR)/rrlw_kg02.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_lw_cldprmc.o: $(SRC_DIR)/rrtmg_lw_cldprmc.F90 kgen_utils.o shr_kind_mod.o parrrtm.o rrlw_vsn.o rrlw_cld.o rrlw_wvn.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_kind_mod.o: $(SRC_DIR)/shr_kind_mod.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_lw_rad.o: $(SRC_DIR)/rrtmg_lw_rad.F90 kgen_utils.o shr_kind_mod.o parrrtm.o rrlw_con.o rrlw_wvn.o rrtmg_lw_cldprmc.o rrtmg_lw_setcoef.o rrtmg_lw_taumol.o rrtmg_lw_rtrnmc.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_lw_taumol.o: $(SRC_DIR)/rrtmg_lw_taumol.f90 kgen_utils.o shr_kind_mod.o rrlw_vsn.o rrlw_wvn.o parrrtm.o rrlw_kg01.o rrlw_kg02.o rrlw_ref.o rrlw_con.o rrlw_kg03.o rrlw_kg04.o rrlw_kg05.o rrlw_kg06.o rrlw_kg07.o rrlw_kg08.o rrlw_kg09.o rrlw_kg10.o rrlw_kg11.o rrlw_kg12.o rrlw_kg13.o rrlw_kg14.o rrlw_kg15.o rrlw_kg16.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_vsn.o: $(SRC_DIR)/rrlw_vsn.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_tbl.o: $(SRC_DIR)/rrlw_tbl.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_kg03.o: $(SRC_DIR)/rrlw_kg03.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -ppgrid.o: $(SRC_DIR)/ppgrid.F90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_kg07.o: $(SRC_DIR)/rrlw_kg07.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_kg14.o: $(SRC_DIR)/rrlw_kg14.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_kg04.o: $(SRC_DIR)/rrlw_kg04.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_kg12.o: $(SRC_DIR)/rrlw_kg12.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_kg13.o: $(SRC_DIR)/rrlw_kg13.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_lw_rtrnmc.o: $(SRC_DIR)/rrtmg_lw_rtrnmc.F90 kgen_utils.o shr_kind_mod.o parrrtm.o rrlw_vsn.o rrlw_wvn.o rrlw_tbl.o rrlw_con.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_kg06.o: $(SRC_DIR)/rrlw_kg06.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_kg05.o: $(SRC_DIR)/rrlw_kg05.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_kg11.o: $(SRC_DIR)/rrlw_kg11.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_con.o: $(SRC_DIR)/rrlw_con.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_cld.o: $(SRC_DIR)/rrlw_cld.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_kg09.o: $(SRC_DIR)/rrlw_kg09.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -kgen_utils.o: $(SRC_DIR)/kgen_utils.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.oo *.rslt diff --git a/test/ncar_kernels/PORT_lw_rad/lit/runmake b/test/ncar_kernels/PORT_lw_rad/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/PORT_lw_rad/lit/t1.sh b/test/ncar_kernels/PORT_lw_rad/lit/t1.sh deleted file mode 100644 index 33c953a156..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/lit/t1.sh +++ /dev/null @@ -1,9 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -# Shared lit script for each tests. Run bash commands that run tests with make. - -# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t -# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/PORT_lw_rad/makefile b/test/ncar_kernels/PORT_lw_rad/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/PORT_lw_rad/src/kernel_driver.f90 b/test/ncar_kernels/PORT_lw_rad/src/kernel_driver.f90 deleted file mode 100644 index d567869a91..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/kernel_driver.f90 +++ /dev/null @@ -1,124 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-07-06 23:28:43 -! KGEN version: 0.4.13 - - -PROGRAM kernel_driver - USE radlw, ONLY : rad_rrtmg_lw - USE rrtmg_state, ONLY: rrtmg_state_t - USE rrlw_cld, ONLY : kgen_read_externs_rrlw_cld - USE rrlw_vsn, ONLY : kgen_read_externs_rrlw_vsn - USE rrlw_kg13, ONLY : kgen_read_externs_rrlw_kg13 - USE rrlw_kg10, ONLY : kgen_read_externs_rrlw_kg10 - USE rrlw_kg11, ONLY : kgen_read_externs_rrlw_kg11 - USE rrlw_kg16, ONLY : kgen_read_externs_rrlw_kg16 - USE rrlw_kg14, ONLY : kgen_read_externs_rrlw_kg14 - USE rrlw_kg15, ONLY : kgen_read_externs_rrlw_kg15 - USE rrlw_ref, ONLY : kgen_read_externs_rrlw_ref - USE rrlw_kg12, ONLY : kgen_read_externs_rrlw_kg12 - USE rrlw_wvn, ONLY : kgen_read_externs_rrlw_wvn - USE rrlw_kg01, ONLY : kgen_read_externs_rrlw_kg01 - USE rrlw_tbl, ONLY : kgen_read_externs_rrlw_tbl - USE rrlw_kg03, ONLY : kgen_read_externs_rrlw_kg03 - USE rrlw_kg02, ONLY : kgen_read_externs_rrlw_kg02 - USE rrlw_kg05, ONLY : kgen_read_externs_rrlw_kg05 - USE rrlw_kg04, ONLY : kgen_read_externs_rrlw_kg04 - USE rrlw_kg07, ONLY : kgen_read_externs_rrlw_kg07 - USE rrlw_kg06, ONLY : kgen_read_externs_rrlw_kg06 - USE rrlw_kg09, ONLY : kgen_read_externs_rrlw_kg09 - USE rrlw_kg08, ONLY : kgen_read_externs_rrlw_kg08 - USE rrlw_con, ONLY : kgen_read_externs_rrlw_con - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE rrtmg_state, ONLY : kgen_read_mod31 => kgen_read - USE rrtmg_state, ONLY : kgen_verify_mod31 => kgen_verify - - IMPLICIT NONE - - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_counter_at = (/ 10, 15, 5 /) - CHARACTER(LEN=1024) :: kgen_filepath - INTEGER :: lchnk - INTEGER :: ncol - TYPE(rrtmg_state_t) :: r_state - INTEGER :: rrtmg_levs - - DO kgen_repeat_counter = 0, 2 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_filepath = "../data/rrtmg_lw." // trim(adjustl(kgen_counter_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "** Verification against '" // trim(adjustl(kgen_filepath)) // "' **" - - CALL kgen_read_externs_rrlw_cld(kgen_unit) - CALL kgen_read_externs_rrlw_vsn(kgen_unit) - CALL kgen_read_externs_rrlw_kg13(kgen_unit) - CALL kgen_read_externs_rrlw_kg10(kgen_unit) - CALL kgen_read_externs_rrlw_kg11(kgen_unit) - CALL kgen_read_externs_rrlw_kg16(kgen_unit) - CALL kgen_read_externs_rrlw_kg14(kgen_unit) - CALL kgen_read_externs_rrlw_kg15(kgen_unit) - CALL kgen_read_externs_rrlw_ref(kgen_unit) - CALL kgen_read_externs_rrlw_kg12(kgen_unit) - CALL kgen_read_externs_rrlw_wvn(kgen_unit) - CALL kgen_read_externs_rrlw_kg01(kgen_unit) - CALL kgen_read_externs_rrlw_tbl(kgen_unit) - CALL kgen_read_externs_rrlw_kg03(kgen_unit) - CALL kgen_read_externs_rrlw_kg02(kgen_unit) - CALL kgen_read_externs_rrlw_kg05(kgen_unit) - CALL kgen_read_externs_rrlw_kg04(kgen_unit) - CALL kgen_read_externs_rrlw_kg07(kgen_unit) - CALL kgen_read_externs_rrlw_kg06(kgen_unit) - CALL kgen_read_externs_rrlw_kg09(kgen_unit) - CALL kgen_read_externs_rrlw_kg08(kgen_unit) - CALL kgen_read_externs_rrlw_con(kgen_unit) - - ! driver variables - READ(UNIT=kgen_unit) lchnk - READ(UNIT=kgen_unit) ncol - READ(UNIT=kgen_unit) rrtmg_levs - CALL kgen_read_mod31(r_state, kgen_unit) - - call rad_rrtmg_lw(lchnk, ncol, rrtmg_levs, r_state, kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! write subroutines - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/PORT_lw_rad/src/kgen_utils.f90 b/test/ncar_kernels/PORT_lw_rad/src/kgen_utils.f90 deleted file mode 100644 index cfa8d114e0..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/kgen_utils.f90 +++ /dev/null @@ -1,61 +0,0 @@ -module kgen_utils_mod - -INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - -type check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - real(kind=kgen_dp) :: minvalue -end type check_t - -public kgen_dp, check_t, kgen_init_check, kgen_print_check - -contains - -subroutine kgen_init_check(check, tolerance, minvalue) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - real(kind=kgen_dp), intent(in), optional :: minvalue - - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.0D-15 - endif - if(present(minvalue)) then - check%minvalue = minvalue - else - check%minvalue = 1.0D-15 - endif -end subroutine kgen_init_check - -subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif -end subroutine kgen_print_check - -end module diff --git a/test/ncar_kernels/PORT_lw_rad/src/parrrtm.f90 b/test/ncar_kernels/PORT_lw_rad/src/parrrtm.f90 deleted file mode 100644 index 7015f4c795..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/parrrtm.f90 +++ /dev/null @@ -1,111 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : parrrtm.f90 -! Generated at: 2015-07-06 23:28:43 -! KGEN version: 0.4.13 - - - - MODULE parrrtm - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_lw main parameters - ! - ! Initial version: JJMorcrette, ECMWF, Jul 1998 - ! Revised: MJIacono, AER, Jun 2006 - ! Revised: MJIacono, AER, Aug 2007 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! mxlay : integer: maximum number of layers - ! mg : integer: number of original g-intervals per spectral band - ! nbndlw : integer: number of spectral bands - ! maxxsec: integer: maximum number of cross-section molecules - ! (e.g. cfcs) - ! maxinpx: integer: - ! ngptlw : integer: total number of reduced g-intervals for rrtmg_lw - ! ngNN : integer: number of reduced g-intervals per spectral band - ! ngsNN : integer: cumulative number of g-intervals per band - !------------------------------------------------------------------ - INTEGER, parameter :: nbndlw = 16 - INTEGER, parameter :: maxxsec= 4 - INTEGER, parameter :: mxmol = 38 - INTEGER, parameter :: maxinpx= 38 - INTEGER, parameter :: nmol = 7 - ! Use for 140 g-point model - INTEGER, parameter :: ngptlw = 140 - ! Use for 256 g-point model - ! integer, parameter :: ngptlw = 256 - ! Use for 140 g-point model - INTEGER, parameter :: ng1 = 10 - INTEGER, parameter :: ng2 = 12 - INTEGER, parameter :: ng3 = 16 - INTEGER, parameter :: ng4 = 14 - INTEGER, parameter :: ng5 = 16 - INTEGER, parameter :: ng6 = 8 - INTEGER, parameter :: ng7 = 12 - INTEGER, parameter :: ng8 = 8 - INTEGER, parameter :: ng9 = 12 - INTEGER, parameter :: ng10 = 6 - INTEGER, parameter :: ng11 = 8 - INTEGER, parameter :: ng12 = 8 - INTEGER, parameter :: ng13 = 4 - INTEGER, parameter :: ng14 = 2 - INTEGER, parameter :: ng15 = 2 - INTEGER, parameter :: ng16 = 2 - INTEGER, parameter :: ngs1 = 10 - INTEGER, parameter :: ngs2 = 22 - INTEGER, parameter :: ngs3 = 38 - INTEGER, parameter :: ngs4 = 52 - INTEGER, parameter :: ngs5 = 68 - INTEGER, parameter :: ngs6 = 76 - INTEGER, parameter :: ngs7 = 88 - INTEGER, parameter :: ngs8 = 96 - INTEGER, parameter :: ngs9 = 108 - INTEGER, parameter :: ngs10 = 114 - INTEGER, parameter :: ngs11 = 122 - INTEGER, parameter :: ngs12 = 130 - INTEGER, parameter :: ngs13 = 134 - INTEGER, parameter :: ngs14 = 136 - INTEGER, parameter :: ngs15 = 138 - ! Use for 256 g-point model - ! integer, parameter :: ng1 = 16 - ! integer, parameter :: ng2 = 16 - ! integer, parameter :: ng3 = 16 - ! integer, parameter :: ng4 = 16 - ! integer, parameter :: ng5 = 16 - ! integer, parameter :: ng6 = 16 - ! integer, parameter :: ng7 = 16 - ! integer, parameter :: ng8 = 16 - ! integer, parameter :: ng9 = 16 - ! integer, parameter :: ng10 = 16 - ! integer, parameter :: ng11 = 16 - ! integer, parameter :: ng12 = 16 - ! integer, parameter :: ng13 = 16 - ! integer, parameter :: ng14 = 16 - ! integer, parameter :: ng15 = 16 - ! integer, parameter :: ng16 = 16 - ! integer, parameter :: ngs1 = 16 - ! integer, parameter :: ngs2 = 32 - ! integer, parameter :: ngs3 = 48 - ! integer, parameter :: ngs4 = 64 - ! integer, parameter :: ngs5 = 80 - ! integer, parameter :: ngs6 = 96 - ! integer, parameter :: ngs7 = 112 - ! integer, parameter :: ngs8 = 128 - ! integer, parameter :: ngs9 = 144 - ! integer, parameter :: ngs10 = 160 - ! integer, parameter :: ngs11 = 176 - ! integer, parameter :: ngs12 = 192 - ! integer, parameter :: ngs13 = 208 - ! integer, parameter :: ngs14 = 224 - ! integer, parameter :: ngs15 = 240 - ! integer, parameter :: ngs16 = 256 - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE parrrtm diff --git a/test/ncar_kernels/PORT_lw_rad/src/ppgrid.F90 b/test/ncar_kernels/PORT_lw_rad/src/ppgrid.F90 deleted file mode 100644 index 3c40de3f6a..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/ppgrid.F90 +++ /dev/null @@ -1,42 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : ppgrid.F90 -! Generated at: 2015-07-06 23:28:45 -! KGEN version: 0.4.13 - - - - MODULE ppgrid - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !----------------------------------------------------------------------- - ! - ! Purpose: - ! Initialize physics grid resolution parameters - ! for a chunked data structure - ! - ! Author: - ! - !----------------------------------------------------------------------- - IMPLICIT NONE - PRIVATE - PUBLIC pcols - PUBLIC pverp - ! Grid point resolution parameters - INTEGER :: pcols ! number of columns (max) - ! number of sub-columns (max) - ! number of vertical levels - INTEGER :: pverp ! pver + 1 - PARAMETER (pcols = 16) - PARAMETER (pverp = 30 + 1) - ! - ! start, end indices for chunks owned by a given MPI task - ! (set in phys_grid_init). - ! - ! - ! - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE ppgrid diff --git a/test/ncar_kernels/PORT_lw_rad/src/radlw.F90 b/test/ncar_kernels/PORT_lw_rad/src/radlw.F90 deleted file mode 100644 index 3f849be60c..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/radlw.F90 +++ /dev/null @@ -1,463 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : radlw.F90 -! Generated at: 2015-07-06 23:28:43 -! KGEN version: 0.4.13 - - - - MODULE radlw - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE rrtmg_state, ONLY : kgen_read_mod31 => kgen_read - USE rrtmg_state, ONLY : kgen_verify_mod31 => kgen_verify - !----------------------------------------------------------------------- - ! - ! Purpose: Longwave radiation calculations. - ! - !----------------------------------------------------------------------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - USE ppgrid, ONLY: pcols - USE ppgrid, ONLY: pverp - USE parrrtm, ONLY: ngptlw - USE parrrtm, ONLY: nbndlw - USE rrtmg_lw_rad, ONLY: rrtmg_lw - IMPLICIT NONE - PRIVATE - PUBLIC rad_rrtmg_lw - integer, parameter :: maxiter = 100 - character(len=80), parameter :: kname = "rrtmg_lw" - ! Public methods - ! initialize constants - ! driver for longwave radiation code - ! Private data - ! top level to solve for longwave cooling - !=============================================================================== - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !=============================================================================== - - SUBROUTINE rad_rrtmg_lw(lchnk, ncol, rrtmg_levs, r_state, kgen_unit) - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !----------------------------------------------------------------------- - USE rrtmg_state, ONLY: rrtmg_state_t - !------------------------------Arguments-------------------------------- - ! - ! Input arguments - ! - integer, intent(in) :: kgen_unit - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - INTEGER, intent(in) :: lchnk ! chunk identifier - INTEGER, intent(in) :: ncol ! number of atmospheric columns - INTEGER, intent(in) :: rrtmg_levs ! number of levels rad is applied - ! - ! Input arguments which are only passed to other routines - ! - TYPE(rrtmg_state_t), intent(in) :: r_state - ! Level pressure (Pascals) - ! aerosol absorption optics depth (LW) - ! Cloud cover - ! Cloud longwave optical depth by band - ! - ! Output arguments - ! - ! Longwave heating rate - ! Clearsky longwave heating rate - ! Surface cooling flux - ! Net outgoing flux - ! Upward flux at top of model - ! Clear sky surface cooing - ! Net clear sky outgoing flux - ! Upward clear-sky flux at top of model - ! Down longwave flux at surface - ! Down longwave clear flux at surface - ! clear sky net flux at interfaces - ! net flux at interfaces - ! longwave spectral flux up - ! longwave spectral flux down - ! - !---------------------------Local variables----------------------------- - ! - ! indices - ! Total upwards longwave flux - ! Clear sky upwards longwave flux - ! Total downwards longwave flux - ! Clear sky downwards longwv flux - INTEGER :: inflglw ! Flag for cloud parameterization method - INTEGER :: iceflglw ! Flag for ice cloud param method - INTEGER :: liqflglw ! Flag for liquid cloud param method - INTEGER :: icld - INTEGER :: ref_icld ! Flag for cloud overlap method - ! 0=clear, 1=random, 2=maximum/random, 3=maximum - REAL(KIND=r8) :: tsfc(pcols) ! surface temperature - REAL(KIND=r8) :: emis(pcols,nbndlw) ! surface emissivity - REAL(KIND=r8) :: taua_lw(pcols,rrtmg_levs-1,nbndlw) ! aerosol optical depth by band - ! Inverse of seconds per day - ! Cloud arrays for McICA - INTEGER, parameter :: nsubclw = ngptlw ! rrtmg_lw g-point (quadrature point) dimension - ! permute seed for sub-column generator - ! in-cloud cloud ice water path - ! in-cloud cloud liquid water path - REAL(KIND=r8) :: rei(pcols,rrtmg_levs-1) ! ice particle effective radius (microns) - REAL(KIND=r8) :: rel(pcols,rrtmg_levs-1) ! liquid particle radius (micron) - REAL(KIND=r8) :: cld_stolw(nsubclw, pcols, rrtmg_levs-1) ! cloud fraction (mcica) - REAL(KIND=r8) :: cicewp_stolw(nsubclw, pcols, rrtmg_levs-1) ! cloud ice water path (mcica) - REAL(KIND=r8) :: cliqwp_stolw(nsubclw, pcols, rrtmg_levs-1) ! cloud liquid water path (mcica) - ! ice particle size (mcica) - ! liquid particle size (mcica) - REAL(KIND=r8) :: tauc_stolw(nsubclw, pcols, rrtmg_levs-1) ! cloud optical depth (mcica - optional) - ! Includes extra layer above model top - REAL(KIND=r8) :: uflx(pcols,rrtmg_levs+1) - REAL(KIND=r8) :: ref_uflx(pcols,rrtmg_levs+1) ! Total upwards longwave flux - REAL(KIND=r8) :: uflxc(pcols,rrtmg_levs+1) - REAL(KIND=r8) :: ref_uflxc(pcols,rrtmg_levs+1) ! Clear sky upwards longwave flux - REAL(KIND=r8) :: dflx(pcols,rrtmg_levs+1) - REAL(KIND=r8) :: ref_dflx(pcols,rrtmg_levs+1) ! Total downwards longwave flux - REAL(KIND=r8) :: dflxc(pcols,rrtmg_levs+1) - REAL(KIND=r8) :: ref_dflxc(pcols,rrtmg_levs+1) ! Clear sky downwards longwv flux - REAL(KIND=r8) :: hr(pcols,rrtmg_levs) - REAL(KIND=r8) :: ref_hr(pcols,rrtmg_levs) ! Longwave heating rate (K/d) - REAL(KIND=r8) :: hrc(pcols,rrtmg_levs) - REAL(KIND=r8) :: ref_hrc(pcols,rrtmg_levs) ! Clear sky longwave heating rate (K/d) - REAL(KIND=r8) :: lwuflxs(nbndlw,pcols,pverp+1) - REAL(KIND=r8) :: ref_lwuflxs(nbndlw,pcols,pverp+1) ! Longwave spectral flux up - REAL(KIND=r8) :: lwdflxs(nbndlw,pcols,pverp+1) - REAL(KIND=r8) :: ref_lwdflxs(nbndlw,pcols,pverp+1) ! Longwave spectral flux down - !----------------------------------------------------------------------- - ! mji/rrtmg - ! Calculate cloud optical properties here if using CAM method, or if using one of the - ! methods in RRTMG_LW, then pass in cloud physical properties and zero out cloud optical - ! properties here - ! Zero optional cloud optical depth input array tauc_lw, - ! if inputting cloud physical properties into RRTMG_LW - ! tauc_lw(:,:,:) = 0. - ! Or, pass in CAM cloud longwave optical depth to RRTMG_LW - ! do nbnd = 1, nbndlw - ! tauc_lw(nbnd,:ncol,:pver) = cldtau(:ncol,:pver) - ! end do - ! Call mcica sub-column generator for RRTMG_LW - ! Call sub-column generator for McICA in radiation - ! Select cloud overlap approach (1=random, 2=maximum-random, 3=maximum) - ! Set permute seed (must be offset between LW and SW by at least 140 to insure - ! effective randomization) - ! These fields are no longer supplied by CAM. - ! - ! Call RRTMG_LW model - ! - ! Set input flags for cloud parameterizations - ! Use separate specification of ice and liquid cloud optical depth. - ! Use either Ebert and Curry ice parameterization (iceflglw = 0 or 1), - ! or use Key (Streamer) approach (iceflglw = 2), or use Fu method - ! (iceflglw = 3), and Hu/Stamnes for liquid (liqflglw = 1). - ! For use in Fu method (iceflglw = 3), rei is converted in RRTMG_LW - ! from effective radius to generalized effective size using the - ! conversion of D. Mitchell, JAS, 2002. For ice particles outside - ! the effective range of either the Key or Fu approaches, the - ! Ebert and Curry method is applied. - ! Input CAM cloud optical depth directly - ! Use E&C approach for ice to mimic CAM3 - ! inflglw = 2 - ! iceflglw = 1 - ! liqflglw = 1 - ! Use merged Fu and E&C params for ice - ! inflglw = 2 - ! iceflglw = 3 - ! liqflglw = 1 - ! Convert incoming water amounts from specific humidity to vmr as needed; - ! Convert other incoming molecular amounts from mmr to vmr as needed; - ! Convert pressures from Pa to hPa; - ! Set surface emissivity to 1.0 here, this is treated in land surface model; - ! Set surface temperature - ! Set aerosol optical depth to zero for now - tolerance = 5.E-13 - CALL kgen_init_check(check_status, tolerance) - READ(UNIT=kgen_unit) inflglw - READ(UNIT=kgen_unit) iceflglw - READ(UNIT=kgen_unit) liqflglw - READ(UNIT=kgen_unit) icld - READ(UNIT=kgen_unit) tsfc - READ(UNIT=kgen_unit) emis - READ(UNIT=kgen_unit) taua_lw - READ(UNIT=kgen_unit) rei - READ(UNIT=kgen_unit) rel - READ(UNIT=kgen_unit) cld_stolw - READ(UNIT=kgen_unit) cicewp_stolw - READ(UNIT=kgen_unit) cliqwp_stolw - READ(UNIT=kgen_unit) tauc_stolw - READ(UNIT=kgen_unit) uflx - READ(UNIT=kgen_unit) uflxc - READ(UNIT=kgen_unit) dflx - READ(UNIT=kgen_unit) dflxc - READ(UNIT=kgen_unit) hr - READ(UNIT=kgen_unit) hrc - READ(UNIT=kgen_unit) lwuflxs - READ(UNIT=kgen_unit) lwdflxs - - READ(UNIT=kgen_unit) ref_icld - READ(UNIT=kgen_unit) ref_uflx - READ(UNIT=kgen_unit) ref_uflxc - READ(UNIT=kgen_unit) ref_dflx - READ(UNIT=kgen_unit) ref_dflxc - READ(UNIT=kgen_unit) ref_hr - READ(UNIT=kgen_unit) ref_hrc - READ(UNIT=kgen_unit) ref_lwuflxs - READ(UNIT=kgen_unit) ref_lwdflxs - - - ! call to kernel - print *,'lchnk: ',lchnk - print *,'ncol: ',ncol - print *,'nbndlw: ',nbndlw - print *,'ngptw: ',ngptlw - print *,'rrtmg_levs: ',rrtmg_levs - call rrtmg_lw(lchnk ,ncol ,rrtmg_levs ,icld , & - r_state%pmidmb ,r_state%pintmb ,r_state%tlay ,r_state%tlev ,tsfc ,r_state%h2ovmr, & - r_state%o3vmr ,r_state%co2vmr ,r_state%ch4vmr ,r_state%o2vmr ,r_state%n2ovmr ,r_state%cfc11vmr,r_state%cfc12vmr, & - r_state%cfc22vmr,r_state%ccl4vmr ,emis ,inflglw ,iceflglw,liqflglw, & - cld_stolw,tauc_stolw,cicewp_stolw,cliqwp_stolw ,rei, rel, & - taua_lw, & - uflx ,dflx ,hr ,uflxc ,dflxc ,hrc, & - lwuflxs, lwdflxs) - ! kernel verification for output variables - CALL kgen_verify_integer( "icld", check_status, icld, ref_icld) - CALL kgen_verify_real_r8_dim2( "uflx", check_status, uflx, ref_uflx) - CALL kgen_verify_real_r8_dim2( "uflxc", check_status, uflxc, ref_uflxc) - CALL kgen_verify_real_r8_dim2( "dflx", check_status, dflx, ref_dflx) - CALL kgen_verify_real_r8_dim2( "dflxc", check_status, dflxc, ref_dflxc) - CALL kgen_verify_real_r8_dim2( "hr", check_status, hr, ref_hr) - CALL kgen_verify_real_r8_dim2( "hrc", check_status, hrc, ref_hrc) - CALL kgen_verify_real_r8_dim3( "lwuflxs", check_status, lwuflxs, ref_lwuflxs) - CALL kgen_verify_real_r8_dim3( "lwdflxs", check_status, lwdflxs, ref_lwdflxs) - CALL kgen_print_check("rrtmg_lw", check_status) - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,maxiter - CALL rrtmg_lw(lchnk, ncol, rrtmg_levs, icld, r_state % pmidmb, r_state % pintmb, r_state % tlay, & -r_state % tlev, tsfc, r_state % h2ovmr, r_state % o3vmr, r_state % co2vmr, r_state % ch4vmr, r_state % o2vmr, & -r_state % n2ovmr, r_state % cfc11vmr, r_state % cfc12vmr, r_state % cfc22vmr, r_state % ccl4vmr, emis, inflglw, & -iceflglw, liqflglw, cld_stolw, tauc_stolw, cicewp_stolw, cliqwp_stolw, rei, rel, taua_lw, uflx, dflx, hr, uflxc, & -dflxc, hrc, lwuflxs, lwdflxs) - END DO - CALL system_clock(stop_clock, rate_clock) - WRITE(*,*) - PRINT *, TRIM(kname), ": Elapsed time (usec): ", 1.0e6*(stop_clock - start_clock)/REAL(rate_clock*maxiter) - ! - !---------------------------------------------------------------------- - ! All longitudes: store history tape quantities - ! Flux units are in W/m2 on output from rrtmg_lw and contain output for - ! extra layer above model top with vertical indexing from bottom to top. - ! Heating units are in K/d on output from RRTMG and contain output for - ! extra layer above model top with vertical indexing from bottom to top. - ! Heating units are converted to J/kg/s below for use in CAM. - ! - ! Reverse vertical indexing here for CAM arrays to go from top to bottom. - ! - ! mji/ cam excluded this? - ! Pass longwave heating to CAM arrays and convert from K/d to J/kg/s - ! Return 0 above solution domain - ! Pass spectral fluxes, reverse layering - ! order=(/3,1,2/) maps the first index of lwuflxs to the third index of lu. - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_r8_dim2(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim2 - - SUBROUTINE kgen_read_real_r8_dim3(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2,idx3 - INTEGER, DIMENSION(2,3) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim3 - - - ! verify subroutines - SUBROUTINE kgen_verify_integer( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - END SUBROUTINE kgen_verify_integer - - SUBROUTINE kgen_verify_real_r8_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim2 - - SUBROUTINE kgen_verify_real_r8_dim3( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim3 - - END SUBROUTINE rad_rrtmg_lw - !------------------------------------------------------------------------------- - - !------------------------------------------------------------------------------- - END MODULE radlw diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrlw_cld.f90 b/test/ncar_kernels/PORT_lw_rad/src/rrlw_cld.f90 deleted file mode 100644 index cb7d927d63..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrlw_cld.f90 +++ /dev/null @@ -1,52 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_cld.f90 -! Generated at: 2015-07-06 23:28:45 -! KGEN version: 0.4.13 - - - - MODULE rrlw_cld - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_lw cloud property coefficients - ! Revised: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! abscld1: real : - ! absice0: real : - ! absice1: real : - ! absice2: real : - ! absice3: real : - ! absliq0: real : - ! absliq1: real : - !------------------------------------------------------------------ - REAL(KIND=r8), dimension(2) :: absice0 - REAL(KIND=r8), dimension(2,5) :: absice1 - REAL(KIND=r8), dimension(43,16) :: absice2 - REAL(KIND=r8), dimension(46,16) :: absice3 - REAL(KIND=r8) :: absliq0 - REAL(KIND=r8), dimension(58,16) :: absliq1 - PUBLIC kgen_read_externs_rrlw_cld - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_cld(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) absice0 - READ(UNIT=kgen_unit) absice1 - READ(UNIT=kgen_unit) absice2 - READ(UNIT=kgen_unit) absice3 - READ(UNIT=kgen_unit) absliq0 - READ(UNIT=kgen_unit) absliq1 - END SUBROUTINE kgen_read_externs_rrlw_cld - - END MODULE rrlw_cld diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrlw_con.f90 b/test/ncar_kernels/PORT_lw_rad/src/rrlw_con.f90 deleted file mode 100644 index f45b43842d..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrlw_con.f90 +++ /dev/null @@ -1,59 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_con.f90 -! Generated at: 2015-07-06 23:28:45 -! KGEN version: 0.4.13 - - - - MODULE rrlw_con - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_lw constants - ! Initial version: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! fluxfac: real : radiance to flux conversion factor - ! heatfac: real : flux to heating rate conversion factor - !oneminus: real : 1.-1.e-6 - ! pi : real : pi - ! grav : real : acceleration of gravity (m/s2) - ! planck : real : planck constant - ! boltz : real : boltzman constant - ! clight : real : speed of light - ! avogad : real : avogadro's constant - ! alosmt : real : - ! gascon : real : gas constant - ! radcn1 : real : - ! radcn2 : real : - !------------------------------------------------------------------ - REAL(KIND=r8) :: fluxfac - REAL(KIND=r8) :: heatfac - REAL(KIND=r8) :: oneminus - REAL(KIND=r8) :: pi - REAL(KIND=r8) :: grav - REAL(KIND=r8) :: avogad - PUBLIC kgen_read_externs_rrlw_con - CONTAINS - - ! write subroutines - ! No subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_con(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) fluxfac - READ(UNIT=kgen_unit) heatfac - READ(UNIT=kgen_unit) oneminus - READ(UNIT=kgen_unit) pi - READ(UNIT=kgen_unit) grav - READ(UNIT=kgen_unit) avogad - END SUBROUTINE kgen_read_externs_rrlw_con - - END MODULE rrlw_con diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg01.f90 b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg01.f90 deleted file mode 100644 index 71ca1039e3..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg01.f90 +++ /dev/null @@ -1,83 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_kg01.f90 -! Generated at: 2015-07-06 23:28:43 -! KGEN version: 0.4.13 - - - - MODULE rrlw_kg01 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_lw ORIGINAL abs. coefficients for interval 1 - ! band 1: 10-250 cm-1 (low - h2o; high - h2o) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefao: real - !fracrefbo: real - ! kao : real - ! kbo : real - ! kao_mn2 : real - ! kbo_mn2 : real - ! selfrefo: real - ! forrefo : real - !----------------------------------------------------------------- - !----------------------------------------------------------------- - ! rrtmg_lw COMBINED abs. coefficients for interval 1 - ! band 1: 10-250 cm-1 (low - h2o; high - h2o) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefa : real - !fracrefb : real - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! ka_mn2 : real - ! kb_mn2 : real - ! selfref : real - ! forref : real - !----------------------------------------------------------------- - INTEGER, parameter :: ng1 = 10 - REAL(KIND=r8) :: fracrefa(ng1) - REAL(KIND=r8) :: fracrefb(ng1) - REAL(KIND=r8) :: absa(65,ng1) - REAL(KIND=r8) :: absb(235,ng1) - REAL(KIND=r8) :: ka_mn2(19,ng1) - REAL(KIND=r8) :: kb_mn2(19,ng1) - REAL(KIND=r8) :: selfref(10,ng1) - REAL(KIND=r8) :: forref(4,ng1) - PUBLIC kgen_read_externs_rrlw_kg01 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_kg01(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mn2 - READ(UNIT=kgen_unit) kb_mn2 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE kgen_read_externs_rrlw_kg01 - - END MODULE rrlw_kg01 diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg02.f90 b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg02.f90 deleted file mode 100644 index 256ef9f4b3..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg02.f90 +++ /dev/null @@ -1,77 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_kg02.f90 -! Generated at: 2015-07-06 23:28:44 -! KGEN version: 0.4.13 - - - - MODULE rrlw_kg02 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_lw ORIGINAL abs. coefficients for interval 2 - ! band 2: 250-500 cm-1 (low - h2o; high - h2o) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefao: real - !fracrefbo: real - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !----------------------------------------------------------------- - !----------------------------------------------------------------- - ! rrtmg_lw COMBINED abs. coefficients for interval 2 - ! band 2: 250-500 cm-1 (low - h2o; high - h2o) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefa : real - !fracrefb : real - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! - ! refparam: real - !----------------------------------------------------------------- - INTEGER, parameter :: ng2 = 12 - REAL(KIND=r8) :: fracrefa(ng2) - REAL(KIND=r8) :: fracrefb(ng2) - REAL(KIND=r8) :: absa(65,ng2) - REAL(KIND=r8) :: absb(235,ng2) - REAL(KIND=r8) :: selfref(10,ng2) - REAL(KIND=r8) :: forref(4,ng2) - PUBLIC kgen_read_externs_rrlw_kg02 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_kg02(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE kgen_read_externs_rrlw_kg02 - - END MODULE rrlw_kg02 diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg03.f90 b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg03.f90 deleted file mode 100644 index bfbf22f98d..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg03.f90 +++ /dev/null @@ -1,84 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_kg03.f90 -! Generated at: 2015-07-06 23:28:44 -! KGEN version: 0.4.13 - - - - MODULE rrlw_kg03 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_lw ORIGINAL abs. coefficients for interval 3 - ! band 3: 500-630 cm-1 (low - h2o,co2; high - h2o,co2) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefao: real - !fracrefbo: real - ! kao : real - ! kbo : real - ! kao_mn2o: real - ! kbo_mn2o: real - ! selfrefo: real - ! forrefo : real - !----------------------------------------------------------------- - !----------------------------------------------------------------- - ! rrtmg_lw COMBINED abs. coefficients for interval 3 - ! band 3: 500-630 cm-1 (low - h2o,co2; high - h2o,co2) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefa : real - !fracrefb : real - ! ka : real - ! kb : real - ! ka_mn2o : real - ! kb_mn2o : real - ! selfref : real - ! forref : real - ! - ! absa : real - ! absb : real - !----------------------------------------------------------------- - INTEGER, parameter :: ng3 = 16 - REAL(KIND=r8) :: fracrefa(ng3,10) - REAL(KIND=r8) :: fracrefb(ng3,5) - REAL(KIND=r8) :: absa(585,ng3) - REAL(KIND=r8) :: absb(1175,ng3) - REAL(KIND=r8) :: ka_mn2o(9,19,ng3) - REAL(KIND=r8) :: kb_mn2o(5,19,ng3) - REAL(KIND=r8) :: selfref(10,ng3) - REAL(KIND=r8) :: forref(4,ng3) - PUBLIC kgen_read_externs_rrlw_kg03 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_kg03(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mn2o - READ(UNIT=kgen_unit) kb_mn2o - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE kgen_read_externs_rrlw_kg03 - - END MODULE rrlw_kg03 diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg04.f90 b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg04.f90 deleted file mode 100644 index c5faed3083..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg04.f90 +++ /dev/null @@ -1,75 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_kg04.f90 -! Generated at: 2015-07-06 23:28:45 -! KGEN version: 0.4.13 - - - - MODULE rrlw_kg04 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_lw ORIGINAL abs. coefficients for interval 4 - ! band 4: 630-700 cm-1 (low - h2o,co2; high - o3,co2) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefao: real - !fracrefbo: real - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !----------------------------------------------------------------- - !----------------------------------------------------------------- - ! rrtmg_lw COMBINED abs. coefficients for interval 4 - ! band 4: 630-700 cm-1 (low - h2o,co2; high - o3,co2) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! absa : real - ! absb : real - !fracrefa : real - !fracrefb : real - ! ka : real - ! kb : real - ! selfref : real - ! forref : real - !----------------------------------------------------------------- - INTEGER, parameter :: ng4 = 14 - REAL(KIND=r8) :: fracrefa(ng4,9) - REAL(KIND=r8) :: fracrefb(ng4,6) - REAL(KIND=r8) :: absa(585,ng4) - REAL(KIND=r8) :: absb(1175,ng4) - REAL(KIND=r8) :: selfref(10,ng4) - REAL(KIND=r8) :: forref(4,ng4) - PUBLIC kgen_read_externs_rrlw_kg04 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_kg04(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE kgen_read_externs_rrlw_kg04 - - END MODULE rrlw_kg04 diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg05.f90 b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg05.f90 deleted file mode 100644 index 21e8345aa2..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg05.f90 +++ /dev/null @@ -1,84 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_kg05.f90 -! Generated at: 2015-07-06 23:28:45 -! KGEN version: 0.4.13 - - - - MODULE rrlw_kg05 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_lw ORIGINAL abs. coefficients for interval 5 - ! band 5: 700-820 cm-1 (low - h2o,co2; high - o3,co2) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefao: real - !fracrefbo: real - ! kao : real - ! kbo : real - ! kao_mo3 : real - ! selfrefo: real - ! forrefo : real - ! ccl4o : real - !----------------------------------------------------------------- - !----------------------------------------------------------------- - ! rrtmg_lw COMBINED abs. coefficients for interval 5 - ! band 5: 700-820 cm-1 (low - h2o,co2; high - o3,co2) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefa : real - !fracrefb : real - ! ka : real - ! kb : real - ! ka_mo3 : real - ! selfref : real - ! forref : real - ! ccl4 : real - ! - ! absa : real - ! absb : real - !----------------------------------------------------------------- - INTEGER, parameter :: ng5 = 16 - REAL(KIND=r8) :: fracrefa(ng5,9) - REAL(KIND=r8) :: fracrefb(ng5,5) - REAL(KIND=r8) :: absa(585,ng5) - REAL(KIND=r8) :: absb(1175,ng5) - REAL(KIND=r8) :: ka_mo3(9,19,ng5) - REAL(KIND=r8) :: selfref(10,ng5) - REAL(KIND=r8) :: forref(4,ng5) - REAL(KIND=r8) :: ccl4(ng5) - PUBLIC kgen_read_externs_rrlw_kg05 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_kg05(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mo3 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) ccl4 - END SUBROUTINE kgen_read_externs_rrlw_kg05 - - END MODULE rrlw_kg05 diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg06.f90 b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg06.f90 deleted file mode 100644 index 3c82a876c7..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg06.f90 +++ /dev/null @@ -1,79 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_kg06.f90 -! Generated at: 2015-07-06 23:28:45 -! KGEN version: 0.4.13 - - - - MODULE rrlw_kg06 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_lw ORIGINAL abs. coefficients for interval 6 - ! band 6: 820-980 cm-1 (low - h2o; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefao: real - ! kao : real - ! kao_mco2: real - ! selfrefo: real - ! forrefo : real - !cfc11adjo: real - ! cfc12o : real - !----------------------------------------------------------------- - !----------------------------------------------------------------- - ! rrtmg_lw COMBINED abs. coefficients for interval 6 - ! band 6: 820-980 cm-1 (low - h2o; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefa : real - ! ka : real - ! ka_mco2 : real - ! selfref : real - ! forref : real - !cfc11adj : real - ! cfc12 : real - ! - ! absa : real - !----------------------------------------------------------------- - INTEGER, parameter :: ng6 = 8 - REAL(KIND=r8), dimension(ng6) :: fracrefa - REAL(KIND=r8) :: absa(65,ng6) - REAL(KIND=r8) :: ka_mco2(19,ng6) - REAL(KIND=r8) :: selfref(10,ng6) - REAL(KIND=r8) :: forref(4,ng6) - REAL(KIND=r8), dimension(ng6) :: cfc11adj - REAL(KIND=r8), dimension(ng6) :: cfc12 - PUBLIC kgen_read_externs_rrlw_kg06 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_kg06(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) ka_mco2 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) cfc11adj - READ(UNIT=kgen_unit) cfc12 - END SUBROUTINE kgen_read_externs_rrlw_kg06 - - END MODULE rrlw_kg06 diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg07.f90 b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg07.f90 deleted file mode 100644 index 408391cad0..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg07.f90 +++ /dev/null @@ -1,83 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_kg07.f90 -! Generated at: 2015-07-06 23:28:45 -! KGEN version: 0.4.13 - - - - MODULE rrlw_kg07 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_lw ORIGINAL abs. coefficients for interval 7 - ! band 7: 980-1080 cm-1 (low - h2o,o3; high - o3) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefao: real - !fracrefbo: real - ! kao : real - ! kbo : real - ! kao_mco2: real - ! kbo_mco2: real - ! selfrefo: real - ! forrefo : real - !----------------------------------------------------------------- - !----------------------------------------------------------------- - ! rrtmg_lw COMBINED abs. coefficients for interval 7 - ! band 7: 980-1080 cm-1 (low - h2o,o3; high - o3) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefa : real - !fracrefb : real - ! ka : real - ! kb : real - ! ka_mco2 : real - ! kb_mco2 : real - ! selfref : real - ! forref : real - ! - ! absa : real - !----------------------------------------------------------------- - INTEGER, parameter :: ng7 = 12 - REAL(KIND=r8), dimension(ng7) :: fracrefb - REAL(KIND=r8) :: fracrefa(ng7,9) - REAL(KIND=r8) :: absa(585,ng7) - REAL(KIND=r8) :: absb(235,ng7) - REAL(KIND=r8) :: ka_mco2(9,19,ng7) - REAL(KIND=r8) :: kb_mco2(19,ng7) - REAL(KIND=r8) :: selfref(10,ng7) - REAL(KIND=r8) :: forref(4,ng7) - PUBLIC kgen_read_externs_rrlw_kg07 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_kg07(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mco2 - READ(UNIT=kgen_unit) kb_mco2 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE kgen_read_externs_rrlw_kg07 - - END MODULE rrlw_kg07 diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg08.f90 b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg08.f90 deleted file mode 100644 index b4d892ec44..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg08.f90 +++ /dev/null @@ -1,104 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_kg08.f90 -! Generated at: 2015-07-06 23:28:43 -! KGEN version: 0.4.13 - - - - MODULE rrlw_kg08 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_lw ORIGINAL abs. coefficients for interval 8 - ! band 8: 1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefao: real - !fracrefbo: real - ! kao : real - ! kbo : real - ! kao_mco2: real - ! kbo_mco2: real - ! kao_mn2o: real - ! kbo_mn2o: real - ! kao_mo3 : real - ! selfrefo: real - ! forrefo : real - ! cfc12o : real - !cfc22adjo: real - !----------------------------------------------------------------- - !----------------------------------------------------------------- - ! rrtmg_lw COMBINED abs. coefficients for interval 8 - ! band 8: 1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefa : real - !fracrefb : real - ! ka : real - ! kb : real - ! ka_mco2 : real - ! kb_mco2 : real - ! ka_mn2o : real - ! kb_mn2o : real - ! ka_mo3 : real - ! selfref : real - ! forref : real - ! cfc12 : real - ! cfc22adj: real - ! - ! absa : real - ! absb : real - !----------------------------------------------------------------- - INTEGER, parameter :: ng8 = 8 - REAL(KIND=r8), dimension(ng8) :: fracrefa - REAL(KIND=r8), dimension(ng8) :: fracrefb - REAL(KIND=r8), dimension(ng8) :: cfc12 - REAL(KIND=r8), dimension(ng8) :: cfc22adj - REAL(KIND=r8) :: absa(65,ng8) - REAL(KIND=r8) :: absb(235,ng8) - REAL(KIND=r8) :: ka_mco2(19,ng8) - REAL(KIND=r8) :: ka_mn2o(19,ng8) - REAL(KIND=r8) :: ka_mo3(19,ng8) - REAL(KIND=r8) :: kb_mco2(19,ng8) - REAL(KIND=r8) :: kb_mn2o(19,ng8) - REAL(KIND=r8) :: selfref(10,ng8) - REAL(KIND=r8) :: forref(4,ng8) - PUBLIC kgen_read_externs_rrlw_kg08 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_kg08(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) cfc12 - READ(UNIT=kgen_unit) cfc22adj - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mco2 - READ(UNIT=kgen_unit) ka_mn2o - READ(UNIT=kgen_unit) ka_mo3 - READ(UNIT=kgen_unit) kb_mco2 - READ(UNIT=kgen_unit) kb_mn2o - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE kgen_read_externs_rrlw_kg08 - - END MODULE rrlw_kg08 diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg09.f90 b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg09.f90 deleted file mode 100644 index 743255e589..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg09.f90 +++ /dev/null @@ -1,84 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_kg09.f90 -! Generated at: 2015-07-06 23:28:45 -! KGEN version: 0.4.13 - - - - MODULE rrlw_kg09 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_lw ORIGINAL abs. coefficients for interval 9 - ! band 9: 1180-1390 cm-1 (low - h2o,ch4; high - ch4) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefao: real - !fracrefbo: real - ! kao : real - ! kbo : real - ! kao_mn2o: real - ! kbo_mn2o: real - ! selfrefo: real - ! forrefo : real - !----------------------------------------------------------------- - !----------------------------------------------------------------- - ! rrtmg_lw COMBINED abs. coefficients for interval 9 - ! band 9: 1180-1390 cm-1 (low - h2o,ch4; high - ch4) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefa : real - !fracrefb : real - ! ka : real - ! kb : real - ! ka_mn2o : real - ! kb_mn2o : real - ! selfref : real - ! forref : real - ! - ! absa : real - ! absb : real - !----------------------------------------------------------------- - INTEGER, parameter :: ng9 = 12 - REAL(KIND=r8), dimension(ng9) :: fracrefb - REAL(KIND=r8) :: fracrefa(ng9,9) - REAL(KIND=r8) :: absa(585,ng9) - REAL(KIND=r8) :: absb(235,ng9) - REAL(KIND=r8) :: ka_mn2o(9,19,ng9) - REAL(KIND=r8) :: kb_mn2o(19,ng9) - REAL(KIND=r8) :: selfref(10,ng9) - REAL(KIND=r8) :: forref(4,ng9) - PUBLIC kgen_read_externs_rrlw_kg09 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_kg09(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mn2o - READ(UNIT=kgen_unit) kb_mn2o - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE kgen_read_externs_rrlw_kg09 - - END MODULE rrlw_kg09 diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg10.f90 b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg10.f90 deleted file mode 100644 index 40d6517b92..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg10.f90 +++ /dev/null @@ -1,76 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_kg10.f90 -! Generated at: 2015-07-06 23:28:43 -! KGEN version: 0.4.13 - - - - MODULE rrlw_kg10 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_lw ORIGINAL abs. coefficients for interval 10 - ! band 10: 1390-1480 cm-1 (low - h2o; high - h2o) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefao: real - !fracrefbo: real - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !----------------------------------------------------------------- - !----------------------------------------------------------------- - ! rrtmg_lw COMBINED abs. coefficients for interval 10 - ! band 10: 1390-1480 cm-1 (low - h2o; high - h2o) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefao: real - !fracrefbo: real - ! kao : real - ! kbo : real - ! selfref : real - ! forref : real - ! - ! absa : real - ! absb : real - !----------------------------------------------------------------- - INTEGER, parameter :: ng10 = 6 - REAL(KIND=r8), dimension(ng10) :: fracrefa - REAL(KIND=r8), dimension(ng10) :: fracrefb - REAL(KIND=r8) :: absa(65,ng10) - REAL(KIND=r8) :: absb(235,ng10) - REAL(KIND=r8) :: selfref(10,ng10) - REAL(KIND=r8) :: forref(4,ng10) - PUBLIC kgen_read_externs_rrlw_kg10 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_kg10(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE kgen_read_externs_rrlw_kg10 - - END MODULE rrlw_kg10 diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg11.f90 b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg11.f90 deleted file mode 100644 index aa300f60a3..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg11.f90 +++ /dev/null @@ -1,84 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_kg11.f90 -! Generated at: 2015-07-06 23:28:45 -! KGEN version: 0.4.13 - - - - MODULE rrlw_kg11 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_lw ORIGINAL abs. coefficients for interval 11 - ! band 11: 1480-1800 cm-1 (low - h2o; high - h2o) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefao: real - !fracrefbo: real - ! kao : real - ! kbo : real - ! kao_mo2 : real - ! kbo_mo2 : real - ! selfrefo: real - ! forrefo : real - !----------------------------------------------------------------- - !----------------------------------------------------------------- - ! rrtmg_lw COMBINED abs. coefficients for interval 11 - ! band 11: 1480-1800 cm-1 (low - h2o; high - h2o) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefa : real - !fracrefb : real - ! ka : real - ! kb : real - ! ka_mo2 : real - ! kb_mo2 : real - ! selfref : real - ! forref : real - ! - ! absa : real - ! absb : real - !----------------------------------------------------------------- - INTEGER, parameter :: ng11 = 8 - REAL(KIND=r8), dimension(ng11) :: fracrefa - REAL(KIND=r8), dimension(ng11) :: fracrefb - REAL(KIND=r8) :: absa(65,ng11) - REAL(KIND=r8) :: absb(235,ng11) - REAL(KIND=r8) :: ka_mo2(19,ng11) - REAL(KIND=r8) :: kb_mo2(19,ng11) - REAL(KIND=r8) :: selfref(10,ng11) - REAL(KIND=r8) :: forref(4,ng11) - PUBLIC kgen_read_externs_rrlw_kg11 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_kg11(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mo2 - READ(UNIT=kgen_unit) kb_mo2 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE kgen_read_externs_rrlw_kg11 - - END MODULE rrlw_kg11 diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg12.f90 b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg12.f90 deleted file mode 100644 index 0c4cab0dde..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg12.f90 +++ /dev/null @@ -1,67 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_kg12.f90 -! Generated at: 2015-07-06 23:28:45 -! KGEN version: 0.4.13 - - - - MODULE rrlw_kg12 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_lw ORIGINAL abs. coefficients for interval 12 - ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefao: real - ! kao : real - ! selfrefo: real - ! forrefo : real - !----------------------------------------------------------------- - !----------------------------------------------------------------- - ! rrtmg_lw COMBINED abs. coefficients for interval 12 - ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefa : real - ! ka : real - ! selfref : real - ! forref : real - ! - ! absa : real - !----------------------------------------------------------------- - INTEGER, parameter :: ng12 = 8 - REAL(KIND=r8) :: fracrefa(ng12,9) - REAL(KIND=r8) :: absa(585,ng12) - REAL(KIND=r8) :: selfref(10,ng12) - REAL(KIND=r8) :: forref(4,ng12) - PUBLIC kgen_read_externs_rrlw_kg12 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_kg12(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE kgen_read_externs_rrlw_kg12 - - END MODULE rrlw_kg12 diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg13.f90 b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg13.f90 deleted file mode 100644 index fa7f344359..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg13.f90 +++ /dev/null @@ -1,81 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_kg13.f90 -! Generated at: 2015-07-06 23:28:45 -! KGEN version: 0.4.13 - - - - MODULE rrlw_kg13 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_lw ORIGINAL abs. coefficients for interval 13 - ! band 13: 2080-2250 cm-1 (low - h2o,n2o; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefao: real - ! kao : real - ! kao_mco2: real - ! kao_mco : real - ! kbo_mo3 : real - ! selfrefo: real - ! forrefo : real - !----------------------------------------------------------------- - !----------------------------------------------------------------- - ! rrtmg_lw COMBINED abs. coefficients for interval 13 - ! band 13: 2080-2250 cm-1 (low - h2o,n2o; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefa : real - ! ka : real - ! ka_mco2 : real - ! ka_mco : real - ! kb_mo3 : real - ! selfref : real - ! forref : real - ! - ! absa : real - !----------------------------------------------------------------- - INTEGER, parameter :: ng13 = 4 - REAL(KIND=r8), dimension(ng13) :: fracrefb - REAL(KIND=r8) :: fracrefa(ng13,9) - REAL(KIND=r8) :: absa(585,ng13) - REAL(KIND=r8) :: ka_mco2(9,19,ng13) - REAL(KIND=r8) :: ka_mco(9,19,ng13) - REAL(KIND=r8) :: kb_mo3(19,ng13) - REAL(KIND=r8) :: selfref(10,ng13) - REAL(KIND=r8) :: forref(4,ng13) - PUBLIC kgen_read_externs_rrlw_kg13 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_kg13(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) ka_mco2 - READ(UNIT=kgen_unit) ka_mco - READ(UNIT=kgen_unit) kb_mo3 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE kgen_read_externs_rrlw_kg13 - - END MODULE rrlw_kg13 diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg14.f90 b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg14.f90 deleted file mode 100644 index b982f00e85..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg14.f90 +++ /dev/null @@ -1,76 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_kg14.f90 -! Generated at: 2015-07-06 23:28:45 -! KGEN version: 0.4.13 - - - - MODULE rrlw_kg14 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_lw ORIGINAL abs. coefficients for interval 14 - ! band 14: 2250-2380 cm-1 (low - co2; high - co2) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefao: real - !fracrefbo: real - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !----------------------------------------------------------------- - !----------------------------------------------------------------- - ! rrtmg_lw COMBINED abs. coefficients for interval 14 - ! band 14: 2250-2380 cm-1 (low - co2; high - co2) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefa : real - !fracrefb : real - ! ka : real - ! kb : real - ! selfref : real - ! forref : real - ! - ! absa : real - ! absb : real - !----------------------------------------------------------------- - INTEGER, parameter :: ng14 = 2 - REAL(KIND=r8), dimension(ng14) :: fracrefa - REAL(KIND=r8), dimension(ng14) :: fracrefb - REAL(KIND=r8) :: absa(65,ng14) - REAL(KIND=r8) :: absb(235,ng14) - REAL(KIND=r8) :: selfref(10,ng14) - REAL(KIND=r8) :: forref(4,ng14) - PUBLIC kgen_read_externs_rrlw_kg14 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_kg14(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE kgen_read_externs_rrlw_kg14 - - END MODULE rrlw_kg14 diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg15.f90 b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg15.f90 deleted file mode 100644 index 508f5e1b8a..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg15.f90 +++ /dev/null @@ -1,71 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_kg15.f90 -! Generated at: 2015-07-06 23:28:43 -! KGEN version: 0.4.13 - - - - MODULE rrlw_kg15 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, r8 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_lw ORIGINAL abs. coefficients for interval 15 - ! band 15: 2380-2600 cm-1 (low - n2o,co2; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefao: real - ! kao : real - ! kao_mn2 : real - ! selfrefo: real - ! forrefo : real - !----------------------------------------------------------------- - !----------------------------------------------------------------- - ! rrtmg_lw COMBINED abs. coefficients for interval 15 - ! band 15: 2380-2600 cm-1 (low - n2o,co2; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefa : real - ! ka : real - ! ka_mn2 : real - ! selfref : real - ! forref : real - ! - ! absa : real - !----------------------------------------------------------------- - INTEGER, parameter :: ng15 = 2 - REAL(KIND=r8) :: fracrefa(ng15,9) - REAL(KIND=r8) :: absa(585,ng15) - REAL(KIND=r8) :: ka_mn2(9,19,ng15) - REAL(KIND=r8) :: selfref(10,ng15) - REAL(KIND=r8) :: forref(4,ng15) - PUBLIC kgen_read_externs_rrlw_kg15 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_kg15(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) ka_mn2 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE kgen_read_externs_rrlw_kg15 - - END MODULE rrlw_kg15 diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg16.f90 b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg16.f90 deleted file mode 100644 index 6eb6cab0c2..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg16.f90 +++ /dev/null @@ -1,74 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_kg16.f90 -! Generated at: 2015-07-06 23:28:43 -! KGEN version: 0.4.13 - - - - MODULE rrlw_kg16 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_lw ORIGINAL abs. coefficients for interval 16 - ! band 16: 2600-3000 cm-1 (low - h2o,ch4; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefao: real - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !----------------------------------------------------------------- - !----------------------------------------------------------------- - ! rrtmg_lw COMBINED abs. coefficients for interval 16 - ! band 16: 2600-3000 cm-1 (low - h2o,ch4; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !fracrefa : real - ! ka : real - ! kb : real - ! selfref : real - ! forref : real - ! - ! absa : real - ! absb : real - !----------------------------------------------------------------- - INTEGER, parameter :: ng16 = 2 - REAL(KIND=r8), dimension(ng16) :: fracrefb - REAL(KIND=r8) :: fracrefa(ng16,9) - REAL(KIND=r8) :: absa(585,ng16) - REAL(KIND=r8) :: absb(235,ng16) - REAL(KIND=r8) :: selfref(10,ng16) - REAL(KIND=r8) :: forref(4,ng16) - PUBLIC kgen_read_externs_rrlw_kg16 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_kg16(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE kgen_read_externs_rrlw_kg16 - - END MODULE rrlw_kg16 diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrlw_ref.f90 b/test/ncar_kernels/PORT_lw_rad/src/rrlw_ref.f90 deleted file mode 100644 index 8c08925233..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrlw_ref.f90 +++ /dev/null @@ -1,46 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_ref.f90 -! Generated at: 2015-07-06 23:28:43 -! KGEN version: 0.4.13 - - - - MODULE rrlw_ref - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_lw reference atmosphere - ! Based on standard mid-latitude summer profile - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! pref : real : Reference pressure levels - ! preflog: real : Reference pressure levels, ln(pref) - ! tref : real : Reference temperature levels for MLS profile - ! chi_mls: real : - !------------------------------------------------------------------ - REAL(KIND=r8), dimension(59) :: preflog - REAL(KIND=r8), dimension(59) :: tref - REAL(KIND=r8) :: chi_mls(7,59) - PUBLIC kgen_read_externs_rrlw_ref - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_ref(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) preflog - READ(UNIT=kgen_unit) tref - READ(UNIT=kgen_unit) chi_mls - END SUBROUTINE kgen_read_externs_rrlw_ref - - END MODULE rrlw_ref diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrlw_tbl.f90 b/test/ncar_kernels/PORT_lw_rad/src/rrlw_tbl.f90 deleted file mode 100644 index 281afdbc8c..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrlw_tbl.f90 +++ /dev/null @@ -1,58 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_tbl.f90 -! Generated at: 2015-07-06 23:28:44 -! KGEN version: 0.4.13 - - - - MODULE rrlw_tbl - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_lw exponential lookup table arrays - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, Jun 2006 - ! Revised: MJIacono, AER, Aug 2007 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! ntbl : integer: Lookup table dimension - ! tblint : real : Lookup table conversion factor - ! tau_tbl: real : Clear-sky optical depth (used in cloudy radiative - ! transfer) - ! exp_tbl: real : Transmittance lookup table - ! tfn_tbl: real : Tau transition function; i.e. the transition of - ! the Planck function from that for the mean layer - ! temperature to that for the layer boundary - ! temperature as a function of optical depth. - ! The "linear in tau" method is used to make - ! the table. - ! pade : real : Pade constant - ! bpade : real : Inverse of Pade constant - !------------------------------------------------------------------ - INTEGER, parameter :: ntbl = 10000 - REAL(KIND=r8), parameter :: tblint = 10000.0_r8 - REAL(KIND=r8), dimension(0:ntbl) :: tau_tbl - REAL(KIND=r8), dimension(0:ntbl) :: exp_tbl - REAL(KIND=r8), dimension(0:ntbl) :: tfn_tbl - REAL(KIND=r8) :: bpade - PUBLIC kgen_read_externs_rrlw_tbl - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_tbl(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) tau_tbl - READ(UNIT=kgen_unit) exp_tbl - READ(UNIT=kgen_unit) tfn_tbl - READ(UNIT=kgen_unit) bpade - END SUBROUTINE kgen_read_externs_rrlw_tbl - - END MODULE rrlw_tbl diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrlw_vsn.f90 b/test/ncar_kernels/PORT_lw_rad/src/rrlw_vsn.f90 deleted file mode 100644 index 8a83d6ff64..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrlw_vsn.f90 +++ /dev/null @@ -1,69 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_vsn.f90 -! Generated at: 2015-07-06 23:28:44 -! KGEN version: 0.4.13 - - - - MODULE rrlw_vsn - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_lw version information - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - !hnamrtm :character: - !hnamini :character: - !hnamcld :character: - !hnamclc :character: - !hnamrtr :character: - !hnamrtx :character: - !hnamrtc :character: - !hnamset :character: - !hnamtau :character: - !hnamatm :character: - !hnamutl :character: - !hnamext :character: - !hnamkg :character: - ! - ! hvrrtm :character: - ! hvrini :character: - ! hvrcld :character: - ! hvrclc :character: - ! hvrrtr :character: - ! hvrrtx :character: - ! hvrrtc :character: - ! hvrset :character: - ! hvrtau :character: - ! hvratm :character: - ! hvrutl :character: - ! hvrext :character: - ! hvrkg :character: - !------------------------------------------------------------------ - CHARACTER(LEN=18) :: hvrclc - CHARACTER(LEN=18) :: hvrset - CHARACTER(LEN=18) :: hvrtau - CHARACTER(LEN=18) :: hvrrtc - PUBLIC kgen_read_externs_rrlw_vsn - CONTAINS - - ! write subroutines - ! No subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_vsn(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) hvrclc - READ(UNIT=kgen_unit) hvrset - READ(UNIT=kgen_unit) hvrtau - READ(UNIT=kgen_unit) hvrrtc - END SUBROUTINE kgen_read_externs_rrlw_vsn - - END MODULE rrlw_vsn diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrlw_wvn.f90 b/test/ncar_kernels/PORT_lw_rad/src/rrlw_wvn.f90 deleted file mode 100644 index d502f755ec..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrlw_wvn.f90 +++ /dev/null @@ -1,84 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_wvn.f90 -! Generated at: 2015-07-06 23:28:43 -! KGEN version: 0.4.13 - - - - MODULE rrlw_wvn - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE parrrtm, ONLY: maxinpx - USE parrrtm, ONLY: ngptlw - USE parrrtm, ONLY: nbndlw - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_lw spectral information - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! ng : integer: Number of original g-intervals in each spectral band - ! nspa : integer: For the lower atmosphere, the number of reference - ! atmospheres that are stored for each spectral band - ! per pressure level and temperature. Each of these - ! atmospheres has different relative amounts of the - ! key species for the band (i.e. different binary - ! species parameters). - ! nspb : integer: Same as nspa for the upper atmosphere - !wavenum1: real : Spectral band lower boundary in wavenumbers - !wavenum2: real : Spectral band upper boundary in wavenumbers - ! delwave: real : Spectral band width in wavenumbers - ! totplnk: real : Integrated Planck value for each band; (band 16 - ! includes total from 2600 cm-1 to infinity) - ! Used for calculation across total spectrum - !totplk16: real : Integrated Planck value for band 16 (2600-3250 cm-1) - ! Used for calculation in band 16 only if - ! individual band output requested - ! - ! ngc : integer: The number of new g-intervals in each band - ! ngs : integer: The cumulative sum of new g-intervals for each band - ! ngm : integer: The index of each new g-interval relative to the - ! original 16 g-intervals in each band - ! ngn : integer: The number of original g-intervals that are - ! combined to make each new g-intervals in each band - ! ngb : integer: The band index for each new g-interval - ! wt : real : RRTM weights for the original 16 g-intervals - ! rwgt : real : Weights for combining original 16 g-intervals - ! (256 total) into reduced set of g-intervals - ! (140 total) - ! nxmol : integer: Number of cross-section molecules - ! ixindx : integer: Flag for active cross-sections in calculation - !------------------------------------------------------------------ - INTEGER :: nspa(nbndlw) - INTEGER :: nspb(nbndlw) - REAL(KIND=r8) :: delwave(nbndlw) - REAL(KIND=r8) :: totplnk(181,nbndlw) - REAL(KIND=r8) :: totplk16(181) - INTEGER :: ngs(nbndlw) - INTEGER :: ngb(ngptlw) - INTEGER :: ixindx(maxinpx) - PUBLIC kgen_read_externs_rrlw_wvn - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_wvn(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) nspa - READ(UNIT=kgen_unit) nspb - READ(UNIT=kgen_unit) delwave - READ(UNIT=kgen_unit) totplnk - READ(UNIT=kgen_unit) totplk16 - READ(UNIT=kgen_unit) ngs - READ(UNIT=kgen_unit) ngb - READ(UNIT=kgen_unit) ixindx - END SUBROUTINE kgen_read_externs_rrlw_wvn - - END MODULE rrlw_wvn diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrtmg_lw_cldprmc.F90 b/test/ncar_kernels/PORT_lw_rad/src/rrtmg_lw_cldprmc.F90 deleted file mode 100644 index 0cbbb64918..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrtmg_lw_cldprmc.F90 +++ /dev/null @@ -1,443 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_lw_cldprmc.f90 -! Generated at: 2015-07-06 23:28:44 -! KGEN version: 0.4.13 - - - MODULE rrtmg_lw_cldprmc - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! --------- Modules ---------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE parrrtm, ONLY: ngptlw - USE rrlw_cld, ONLY: absice0 - USE rrlw_cld, ONLY: absice1 - USE rrlw_cld, ONLY: absice2 - USE rrlw_cld, ONLY: absice3 - USE rrlw_cld, ONLY: absliq0 - USE rrlw_cld, ONLY: absliq1 - USE rrlw_wvn, ONLY: ngb - USE rrlw_vsn, ONLY: hvrclc - IMPLICIT NONE - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - ! ------------------------------------------------------------------------------ - -#ifdef OLD_CLDPRMC - SUBROUTINE cldprmc_old(nlayers, inflag, iceflag, liqflag, cldfmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, ncbands, taucmc) - ! ------------------------------------------------------------------------------ - ! Purpose: Compute the cloud optical depth(s) for each cloudy layer. - ! ------- Input ------- - INTEGER, intent(in) :: nlayers ! total number of layers - INTEGER, intent(in) :: inflag ! see definitions - INTEGER, intent(in) :: iceflag ! see definitions - INTEGER, intent(in) :: liqflag ! see definitions - REAL(KIND=r8), intent(in) :: cldfmc(:,:) ! cloud fraction [mcica] - ! Dimensions: (ngptlw,nlayers) - REAL(KIND=r8), intent(in) :: ciwpmc(:,:) ! cloud ice water path [mcica] - ! Dimensions: (ngptlw,nlayers) - REAL(KIND=r8), intent(in) :: clwpmc(:,:) ! cloud liquid water path [mcica] - ! Dimensions: (ngptlw,nlayers) - REAL(KIND=r8), intent(in) :: relqmc(:) ! liquid particle effective radius (microns) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: reicmc(:) ! ice particle effective radius (microns) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: dgesmc(:) ! ice particle generalized effective size (microns) - ! Dimensions: (nlayers) - ! ------- Output ------- - INTEGER, intent(out) :: ncbands ! number of cloud spectral bands - REAL(KIND=r8), intent(inout) :: taucmc(:,:) ! cloud optical depth [mcica] - ! Dimensions: (ngptlw,nlayers) - ! ------- Local ------- - INTEGER :: lay, index ! Layer index - INTEGER :: ib ! spectral band index - INTEGER :: ig ! g-point interval index - REAL(KIND=r8) :: abscoice(ngptlw) ! ice absorption coefficients - REAL(KIND=r8) :: abscoliq(ngptlw) ! liquid absorption coefficients - REAL(KIND=r8) :: cwp ! cloud water path - REAL(KIND=r8) :: radice ! cloud ice effective radius (microns) - REAL(KIND=r8) :: dgeice ! cloud ice generalized effective size - REAL(KIND=r8) :: factor ! - REAL(KIND=r8) :: fint ! - REAL(KIND=r8) :: radliq ! cloud liquid droplet radius (microns) - ! epsilon - REAL(KIND=r8), parameter :: cldmin = 1.e-80_r8 ! minimum value for cloud quantities - ! ------- Definitions ------- - ! Explanation of the method for each value of INFLAG. Values of - ! 0 or 1 for INFLAG do not distingish being liquid and ice clouds. - ! INFLAG = 2 does distinguish between liquid and ice clouds, and - ! requires further user input to specify the method to be used to - ! compute the aborption due to each. - ! INFLAG = 0: For each cloudy layer, the cloud fraction and (gray) - ! optical depth are input. - ! INFLAG = 1: For each cloudy layer, the cloud fraction and cloud - ! water path (g/m2) are input. The (gray) cloud optical - ! depth is computed as in CAM3. - ! INFLAG = 2: For each cloudy layer, the cloud fraction, cloud - ! water path (g/m2), and cloud ice fraction are input. - ! ICEFLAG = 0: The ice effective radius (microns) is input and the - ! optical depths due to ice clouds are computed as in CAM3. - ! ICEFLAG = 1: The ice effective radius (microns) is input and the - ! optical depths due to ice clouds are computed as in - ! Ebert and Curry, JGR, 97, 3831-3836 (1992). The - ! spectral regions in this work have been matched with - ! the spectral bands in RRTM to as great an extent - ! as possible: - ! E&C 1 IB = 5 RRTM bands 9-16 - ! E&C 2 IB = 4 RRTM bands 6-8 - ! E&C 3 IB = 3 RRTM bands 3-5 - ! E&C 4 IB = 2 RRTM band 2 - ! E&C 5 IB = 1 RRTM band 1 - ! ICEFLAG = 2: The ice effective radius (microns) is input and the - ! optical properties due to ice clouds are computed from - ! the optical properties stored in the RT code, - ! STREAMER v3.0 (Reference: Key. J., Streamer - ! User's Guide, Cooperative Institute for - ! Meteorological Satellite Studies, 2001, 96 pp.). - ! Valid range of values for re are between 5.0 and - ! 131.0 micron. - ! ICEFLAG = 3: The ice generalized effective size (dge) is input - ! and the optical properties, are calculated as in - ! Q. Fu, J. Climate, (1998). Q. Fu provided high resolution - ! tables which were appropriately averaged for the - ! bands in RRTM_LW. Linear interpolation is used to - ! get the coefficients from the stored tables. - ! Valid range of values for dge are between 5.0 and - ! 140.0 micron. - ! LIQFLAG = 0: The optical depths due to water clouds are computed as - ! in CAM3. - ! LIQFLAG = 1: The water droplet effective radius (microns) is input - ! and the optical depths due to water clouds are computed - ! as in Hu and Stamnes, J., Clim., 6, 728-742, (1993). - ! The values for absorption coefficients appropriate for - ! the spectral bands in RRTM have been obtained for a - ! range of effective radii by an averaging procedure - ! based on the work of J. Pinto (private communication). - ! Linear interpolation is used to get the absorption - ! coefficients for the input effective radius. - hvrclc = '$Revision: 1.5 $' - ncbands = 1 - ! This initialization is done in rrtmg_lw_subcol.F90. - ! do lay = 1, nlayers - ! do ig = 1, ngptlw - ! taucmc(ig,lay) = 0.0_r8 - ! enddo - ! enddo - ! Main layer loop - do lay = 1, nlayers - do ig = 1, ngptlw - cwp = ciwpmc(ig,lay) + clwpmc(ig,lay) - if (cldfmc(ig,lay) .ge. cldmin .and. & - (cwp .ge. cldmin .or. taucmc(ig,lay) .ge. cldmin)) then - ! Ice clouds and water clouds combined. - if (inflag .eq. 0) then - ! Cloud optical depth already defined in taucmc, return to main program - return - elseif(inflag .eq. 1) then - stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA' - ! cwp = ciwpmc(ig,lay) + clwpmc(ig,lay) - ! taucmc(ig,lay) = abscld1 * cwp - ! Separate treatement of ice clouds and water clouds. - elseif(inflag .eq. 2) then - radice = reicmc(lay) - ! Calculation of absorption coefficients due to ice clouds. - if (ciwpmc(ig,lay) .eq. 0.0_r8) then - abscoice(ig) = 0.0_r8 - elseif (iceflag .eq. 0) then - if (radice .lt. 10.0_r8) stop 'ICE RADIUS TOO SMALL' - abscoice(ig) = absice0(1) + absice0(2)/radice - elseif (iceflag .eq. 1) then - ! mji - turn off limits to mimic CAM3 - ! if (radice .lt. 13.0_r8 .or. radice .gt. 130._r8) stop & - ! 'ICE RADIUS OUT OF BOUNDS' - ncbands = 5 - ib = ngb(ig) - abscoice(ig) = absice1(1,ib) + absice1(2,ib)/radice - ! For iceflag=2 option, combine with iceflag=0 option to handle out of bounds - ! particle sizes. - ! Use iceflag=2 option for ice particle effective radii from 5.0 and 131.0 microns - ! and use iceflag=0 option for ice particles greater than 131.0 microns. - ! *** NOTE: Transition between two methods has not been smoothed. - elseif (iceflag .eq. 2) then - if (radice .lt. 5.0_r8) stop 'ICE RADIUS OUT OF BOUNDS' - if (radice .ge. 5.0_r8 .and. radice .le. 131._r8) then - ncbands = 16 - factor = (radice - 2._r8)/3._r8 - index = int(factor) - if (index .eq. 43) index = 42 - fint = factor - float(index) - ib = ngb(ig) - abscoice(ig) = & - absice2(index,ib) + fint * & - (absice2(index+1,ib) - (absice2(index,ib))) - elseif (radice .gt. 131._r8) then - abscoice(ig) = absice0(1) + absice0(2)/radice - endif - ! For iceflag=3 option, combine with iceflag=0 option to handle large particle sizes. - ! Use iceflag=3 option for ice particle effective radii from 3.2 and 91.0 microns - ! (generalized effective size, dge, from 5 to 140 microns), and use iceflag=0 option - ! for ice particle effective radii greater than 91.0 microns (dge = 140 microns). - ! *** NOTE: Fu parameterization requires particle size in generalized effective size. - ! *** NOTE: Transition between two methods has not been smoothed. - elseif (iceflag .eq. 3) then - dgeice = dgesmc(lay) - if (dgeice .lt. 5.0_r8) stop 'ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' - if (dgeice .ge. 5.0_r8 .and. dgeice .le. 140._r8) then - ncbands = 16 - factor = (dgeice - 2._r8)/3._r8 - index = int(factor) - if (index .eq. 46) index = 45 - fint = factor - float(index) - ib = ngb(ig) - abscoice(ig) = & - absice3(index,ib) + fint * & - (absice3(index+1,ib) - (absice3(index,ib))) - elseif (dgeice .gt. 140._r8) then - abscoice(ig) = absice0(1) + absice0(2)/radice - endif - endif - ! Calculation of absorption coefficients due to water clouds. - if (clwpmc(ig,lay) .eq. 0.0_r8) then - abscoliq(ig) = 0.0_r8 - elseif (liqflag .eq. 0) then - abscoliq(ig) = absliq0 - elseif (liqflag .eq. 1) then - radliq = relqmc(lay) - if (radliq .lt. 1.5_r8 .or. radliq .gt. 60._r8) stop & - 'LIQUID EFFECTIVE RADIUS OUT OF BOUNDS' - index = radliq - 1.5_r8 - if (index .eq. 58) index = 57 - if (index .eq. 0) index = 1 - fint = radliq - 1.5_r8 - index - ib = ngb(ig) - abscoliq(ig) = & - absliq1(index,ib) + fint * & - (absliq1(index+1,ib) - (absliq1(index,ib))) - endif - taucmc(ig,lay) = ciwpmc(ig,lay) * abscoice(ig) + & - clwpmc(ig,lay) * abscoliq(ig) - endif - endif - enddo - enddo - END SUBROUTINE cldprmc_old -#else - SUBROUTINE cldprmc(ncol,nlayers, inflag, iceflag, liqflag, cldfmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, ncbands, taucmc) - ! ------------------------------------------------------------------------------ - ! Purpose: Compute the cloud optical depth(s) for each cloudy layer. - ! ------- Input ------- - INTEGER, intent(in) :: ncol ! total number of columns - INTEGER, intent(in) :: nlayers ! total number of layers - INTEGER, intent(in) :: inflag ! see definitions - INTEGER, intent(in) :: iceflag ! see definitions - INTEGER, intent(in) :: liqflag ! see definitions - ! Dimensions: (ncol) - REAL(KIND=r8), intent(in) :: cldfmc(:,:,:) ! cloud fraction [mcica] - ! Dimensions: (ncol,ngptlw,nlayers) - REAL(KIND=r8), intent(in) :: ciwpmc(:,:,:) ! cloud ice water path [mcica] - ! Dimensions: (ncol,ngptlw,nlayers) - REAL(KIND=r8), intent(in) :: clwpmc(:,:,:) ! cloud liquid water path [mcica] - ! Dimensions: (ncol,ngptlw,nlayers) - REAL(KIND=r8), intent(in) :: relqmc(:,:) ! liquid particle effective radius (microns) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: reicmc(:,:) ! ice particle effective radius (microns) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: dgesmc(:,:) ! ice particle generalized effective size (microns) - ! Dimensions: (ncol,nlayers) - ! ------- Output ------- - INTEGER, intent(out) :: ncbands(:) ! number of cloud spectral bands - ! Dimensions: (ncol) - REAL(KIND=r8), intent(inout) :: taucmc(:,:,:) ! cloud optical depth [mcica] - ! Dimensions: (ncol,ngptlw,nlayers) - ! ------- Local ------- - INTEGER :: lay, index ! Layer index - INTEGER :: ib ! spectral band index - INTEGER :: ig ! g-point interval index - REAL(KIND=r8) :: abscoice(ngptlw) ! ice absorption coefficients - REAL(KIND=r8) :: abscoliq(ngptlw) ! liquid absorption coefficients - REAL(KIND=r8) :: cwp ! cloud water path - REAL(KIND=r8) :: radice ! cloud ice effective radius (microns) - REAL(KIND=r8) :: dgeice ! cloud ice generalized effective size - REAL(KIND=r8) :: factor ! - REAL(KIND=r8) :: fint ! - REAL(KIND=r8) :: radliq ! cloud liquid droplet radius (microns) - ! epsilon - REAL(KIND=r8), parameter :: cldmin = 1.e-80_r8 ! minimum value for cloud quantities - ! ------- Definitions ------- - ! Explanation of the method for each value of INFLAG. Values of - ! 0 or 1 for INFLAG do not distingish being liquid and ice clouds. - ! INFLAG = 2 does distinguish between liquid and ice clouds, and - ! requires further user input to specify the method to be used to - ! compute the aborption due to each. - ! INFLAG = 0: For each cloudy layer, the cloud fraction and (gray) - ! optical depth are input. - ! INFLAG = 1: For each cloudy layer, the cloud fraction and cloud - ! water path (g/m2) are input. The (gray) cloud optical - ! depth is computed as in CAM3. - ! INFLAG = 2: For each cloudy layer, the cloud fraction, cloud - ! water path (g/m2), and cloud ice fraction are input. - ! ICEFLAG = 0: The ice effective radius (microns) is input and the - ! optical depths due to ice clouds are computed as in CAM3. - ! ICEFLAG = 1: The ice effective radius (microns) is input and the - ! optical depths due to ice clouds are computed as in - ! Ebert and Curry, JGR, 97, 3831-3836 (1992). The - ! spectral regions in this work have been matched with - ! the spectral bands in RRTM to as great an extent - ! as possible: - ! E&C 1 IB = 5 RRTM bands 9-16 - ! E&C 2 IB = 4 RRTM bands 6-8 - ! E&C 3 IB = 3 RRTM bands 3-5 - ! E&C 4 IB = 2 RRTM band 2 - ! E&C 5 IB = 1 RRTM band 1 - ! ICEFLAG = 2: The ice effective radius (microns) is input and the - ! optical properties due to ice clouds are computed from - ! the optical properties stored in the RT code, - ! STREAMER v3.0 (Reference: Key. J., Streamer - ! User's Guide, Cooperative Institute for - ! Meteorological Satellite Studies, 2001, 96 pp.). - ! Valid range of values for re are between 5.0 and - ! 131.0 micron. - ! ICEFLAG = 3: The ice generalized effective size (dge) is input - ! and the optical properties, are calculated as in - ! Q. Fu, J. Climate, (1998). Q. Fu provided high resolution - ! tables which were appropriately averaged for the - ! bands in RRTM_LW. Linear interpolation is used to - ! get the coefficients from the stored tables. - ! Valid range of values for dge are between 5.0 and - ! 140.0 micron. - ! LIQFLAG = 0: The optical depths due to water clouds are computed as - ! in CAM3. - ! LIQFLAG = 1: The water droplet effective radius (microns) is input - ! and the optical depths due to water clouds are computed - ! as in Hu and Stamnes, J., Clim., 6, 728-742, (1993). - ! The values for absorption coefficients appropriate for - ! the spectral bands in RRTM have been obtained for a - ! range of effective radii by an averaging procedure - ! based on the work of J. Pinto (private communication). - ! Linear interpolation is used to get the absorption - ! coefficients for the input effective radius. - integer :: iplon - hvrclc = '$Revision: 1.5 $' - ncbands = 1 - ! This initialization is done in rrtmg_lw_subcol.F90. - ! do lay = 1, nlayers - ! do ig = 1, ngptlw - ! taucmc(ig,lay) = 0.0_r8 - ! enddo - ! enddo - ! Main layer loop - do iplon=1,ncol - do lay = 1, nlayers - do ig = 1, ngptlw - cwp = ciwpmc(iplon,ig,lay) + clwpmc(iplon,ig,lay) - if (cldfmc(iplon,ig,lay) .ge. cldmin .and. & - (cwp .ge. cldmin .or. taucmc(iplon,ig,lay) .ge. cldmin)) then - ! Ice clouds and water clouds combined. - if (inflag .eq. 0) then - ! Cloud optical depth already defined in taucmc, return to main program - return - elseif(inflag .eq. 1) then - stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA' - ! cwp = ciwpmc(ig,lay) + clwpmc(ig,lay) - ! taucmc(ig,lay) = abscld1 * cwp - ! Separate treatement of ice clouds and water clouds. - elseif(inflag .eq. 2) then - radice = reicmc(iplon,lay) - ! Calculation of absorption coefficients due to ice clouds. - if (ciwpmc(iplon,ig,lay) .eq. 0.0_r8) then - abscoice(ig) = 0.0_r8 - elseif (iceflag .eq. 0) then - if (radice .lt. 10.0_r8) stop 'ICE RADIUS TOO SMALL' - abscoice(ig) = absice0(1) + absice0(2)/radice - elseif (iceflag .eq. 1) then - ! mji - turn off limits to mimic CAM3 - ! if (radice .lt. 13.0_r8 .or. radice .gt. 130._r8) stop & - ! 'ICE RADIUS OUT OF BOUNDS' - ncbands(iplon) = 5 - ib = ngb(ig) - abscoice(ig) = absice1(1,ib) + absice1(2,ib)/radice - ! For iceflag=2 option, combine with iceflag=0 option to handle out of bounds - ! particle sizes. - ! Use iceflag=2 option for ice particle effective radii from 5.0 and 131.0 microns - ! and use iceflag=0 option for ice particles greater than 131.0 microns. - ! *** NOTE: Transition between two methods has not been smoothed. - elseif (iceflag .eq. 2) then - if (radice .lt. 5.0_r8) stop 'ICE RADIUS OUT OF BOUNDS' - if (radice .ge. 5.0_r8 .and. radice .le. 131._r8) then - ncbands(iplon) = 16 - factor = (radice - 2._r8)/3._r8 - index = int(factor) - if (index .eq. 43) index = 42 - fint = factor - float(index) - ib = ngb(ig) - abscoice(ig) = & - absice2(index,ib) + fint * & - (absice2(index+1,ib) - (absice2(index,ib))) - elseif (radice .gt. 131._r8) then - abscoice(ig) = absice0(1) + absice0(2)/radice - endif - ! For iceflag=3 option, combine with iceflag=0 option to handle large particle sizes. - ! Use iceflag=3 option for ice particle effective radii from 3.2 and 91.0 microns - ! (generalized effective size, dge, from 5 to 140 microns), and use iceflag=0 option - ! for ice particle effective radii greater than 91.0 microns (dge = 140 microns). - ! *** NOTE: Fu parameterization requires particle size in generalized effective size. - ! *** NOTE: Transition between two methods has not been smoothed. - elseif (iceflag .eq. 3) then - dgeice = dgesmc(iplon,lay) - if (dgeice .lt. 5.0_r8) stop 'ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' - if (dgeice .ge. 5.0_r8 .and. dgeice .le. 140._r8) then - ncbands(iplon) = 16 - factor = (dgeice - 2._r8)/3._r8 - index = int(factor) - if (index .eq. 46) index = 45 - fint = factor - float(index) - ib = ngb(ig) - abscoice(ig) = & - absice3(index,ib) + fint * & - (absice3(index+1,ib) - (absice3(index,ib))) - elseif (dgeice .gt. 140._r8) then - abscoice(ig) = absice0(1) + absice0(2)/radice - endif - endif - ! Calculation of absorption coefficients due to water clouds. - if (clwpmc(iplon,ig,lay) .eq. 0.0_r8) then - abscoliq(ig) = 0.0_r8 - elseif (liqflag .eq. 0) then - abscoliq(ig) = absliq0 - elseif (liqflag .eq. 1) then - radliq = relqmc(iplon,lay) - if (radliq .lt. 1.5_r8 .or. radliq .gt. 60._r8) stop & - 'LIQUID EFFECTIVE RADIUS OUT OF BOUNDS' - index = radliq - 1.5_r8 - if (index .eq. 58) index = 57 - if (index .eq. 0) index = 1 - fint = radliq - 1.5_r8 - index - ib = ngb(ig) - abscoliq(ig) = & - absliq1(index,ib) + fint * & - (absliq1(index+1,ib) - (absliq1(index,ib))) - endif - taucmc(iplon,ig,lay) = ciwpmc(iplon,ig,lay) * abscoice(ig) + & - clwpmc(iplon,ig,lay) * abscoliq(ig) - endif - endif - enddo - enddo - enddo - END SUBROUTINE cldprmc -#endif - END MODULE rrtmg_lw_cldprmc diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrtmg_lw_rad.F90 b/test/ncar_kernels/PORT_lw_rad/src/rrtmg_lw_rad.F90 deleted file mode 100644 index 2649ae3b0e..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrtmg_lw_rad.F90 +++ /dev/null @@ -1,843 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_lw_rad.f90 -! Generated at: 2015-07-06 23:28:44 -! KGEN version: 0.4.13 - - MODULE rrtmg_lw_rad - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! - ! **************************************************************************** - ! * * - ! * RRTMG_LW * - ! * * - ! * * - ! * * - ! * a rapid radiative transfer model * - ! * for the longwave region * - ! * for application to general circulation models * - ! * * - ! * * - ! * Atmospheric and Environmental Research, Inc. * - ! * 131 Hartwell Avenue * - ! * Lexington, MA 02421 * - ! * * - ! * * - ! * Eli J. Mlawer * - ! * Jennifer S. Delamere * - ! * Michael J. Iacono * - ! * Shepard A. Clough * - ! * * - ! * * - ! * * - ! * * - ! * * - ! * * - ! * email: miacono@aer.com * - ! * email: emlawer@aer.com * - ! * email: jdelamer@aer.com * - ! * * - ! * The authors wish to acknowledge the contributions of the * - ! * following people: Steven J. Taubman, Karen Cady-Pereira, * - ! * Patrick D. Brown, Ronald E. Farren, Luke Chen, Robert Bergstrom. * - ! * * - ! **************************************************************************** - ! -------- Modules -------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb -#ifdef OLD_CLDPRMC - USE rrtmg_lw_cldprmc, ONLY: cldprmc_old -#else - USE rrtmg_lw_cldprmc, ONLY: cldprmc -#endif - ! Move call to rrtmg_lw_ini and following use association to - ! GCM initialization area - ! use rrtmg_lw_init, only: rrtmg_lw_ini -#ifdef OLD_RTRNMC - USE rrtmg_lw_rtrnmc, ONLY: rtrnmc_old -#else - USE rrtmg_lw_rtrnmc, ONLY: rtrnmc -#endif -#ifdef OLD_SETCOEF - USE rrtmg_lw_setcoef, ONLY: setcoef_old -#else - USE rrtmg_lw_setcoef, ONLY: setcoef -#endif - USE rrtmg_lw_taumol, ONLY: taumol - IMPLICIT NONE - ! public interfaces/functions/subroutines - PUBLIC rrtmg_lw, inatm - !------------------------------------------------------------------ - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !------------------------------------------------------------------ - !------------------------------------------------------------------ - ! Public subroutines - !------------------------------------------------------------------ - - SUBROUTINE rrtmg_lw(lchnk, ncol, nlay, icld, play, plev, tlay, tlev, tsfc, h2ovmr, o3vmr, co2vmr, ch4vmr, o2vmr, n2ovmr, & - cfc11vmr, cfc12vmr, cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, cldfmcl, taucmcl, ciwpmcl, clwpmcl, reicmcl, & - relqmcl, tauaer, uflx, dflx, hr, uflxc, dflxc, hrc, uflxs, dflxs) - ! -------- Description -------- - ! This program is the driver subroutine for RRTMG_LW, the AER LW radiation - ! model for application to GCMs, that has been adapted from RRTM_LW for - ! improved efficiency. - ! - ! NOTE: The call to RRTMG_LW_INI should be moved to the GCM initialization - ! area, since this has to be called only once. - ! - ! This routine: - ! a) calls INATM to read in the atmospheric profile from GCM; - ! all layering in RRTMG is ordered from surface to toa. - ! b) calls CLDPRMC to set cloud optical depth for McICA based - ! on input cloud properties - ! c) calls SETCOEF to calculate various quantities needed for - ! the radiative transfer algorithm - ! d) calls TAUMOL to calculate gaseous optical depths for each - ! of the 16 spectral bands - ! e) calls RTRNMC (for both clear and cloudy profiles) to perform the - ! radiative transfer calculation using McICA, the Monte-Carlo - ! Independent Column Approximation, to represent sub-grid scale - ! cloud variability - ! f) passes the necessary fluxes and cooling rates back to GCM - ! - ! Two modes of operation are possible: - ! The mode is chosen by using either rrtmg_lw.nomcica.f90 (to not use - ! McICA) or rrtmg_lw.f90 (to use McICA) to interface with a GCM. - ! - ! 1) Standard, single forward model calculation (imca = 0) - ! 2) Monte Carlo Independent Column Approximation (McICA, Pincus et al., - ! JC, 2003) method is applied to the forward model calculation (imca = 1) - ! - ! This call to RRTMG_LW must be preceeded by a call to the module - ! mcica_subcol_gen_lw.f90 to run the McICA sub-column cloud generator, - ! which will provide the cloud physical or cloud optical properties - ! on the RRTMG quadrature point (ngpt) dimension. - ! - ! Two methods of cloud property input are possible: - ! Cloud properties can be input in one of two ways (controlled by input - ! flags inflglw, iceflglw, and liqflglw; see text file rrtmg_lw_instructions - ! and subroutine rrtmg_lw_cldprop.f90 for further details): - ! - ! 1) Input cloud fraction and cloud optical depth directly (inflglw = 0) - ! 2) Input cloud fraction and cloud physical properties (inflglw = 1 or 2); - ! cloud optical properties are calculated by cldprop or cldprmc based - ! on input settings of iceflglw and liqflglw - ! - ! One method of aerosol property input is possible: - ! Aerosol properties can be input in only one way (controlled by input - ! flag iaer, see text file rrtmg_lw_instructions for further details): - ! - ! 1) Input aerosol optical depth directly by layer and spectral band (iaer=10); - ! band average optical depth at the mid-point of each spectral band. - ! RRTMG_LW currently treats only aerosol absorption; - ! scattering capability is not presently available. - ! - ! - ! ------- Modifications ------- - ! - ! This version of RRTMG_LW has been modified from RRTM_LW to use a reduced - ! set of g-points for application to GCMs. - ! - !-- Original version (derived from RRTM_LW), reduction of g-points, other - ! revisions for use with GCMs. - ! 1999: M. J. Iacono, AER, Inc. - !-- Adapted for use with NCAR/CAM. - ! May 2004: M. J. Iacono, AER, Inc. - !-- Revised to add McICA capability. - ! Nov 2005: M. J. Iacono, AER, Inc. - !-- Conversion to F90 formatting for consistency with rrtmg_sw. - ! Feb 2007: M. J. Iacono, AER, Inc. - !-- Modifications to formatting to use assumed-shape arrays. - ! Aug 2007: M. J. Iacono, AER, Inc. - !-- Modified to add longwave aerosol absorption. - ! Apr 2008: M. J. Iacono, AER, Inc. - ! --------- Modules ---------- - USE parrrtm, ONLY: mxmol - USE parrrtm, ONLY: maxxsec - USE parrrtm, ONLY: nbndlw - USE parrrtm, ONLY: ngptlw - USE rrlw_con, ONLY: oneminus - USE rrlw_con, ONLY: pi - USE rrlw_con, ONLY: fluxfac - USE rrlw_wvn, ONLY: ngb - ! ------- Declarations ------- - ! ----- Input ----- - INTEGER, intent(in) :: lchnk ! chunk identifier - INTEGER, intent(in) :: ncol ! Number of horizontal columns - INTEGER, intent(in) :: nlay ! Number of model layers - INTEGER, intent(inout) :: icld ! Cloud overlap method - ! 0: Clear only - ! 1: Random - ! 2: Maximum/random - ! 3: Maximum - REAL(KIND=r8), intent(in) :: play(:,:) ! Layer pressures (hPa, mb) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: plev(:,:) ! Interface pressures (hPa, mb) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(in) :: tlay(:,:) ! Layer temperatures (K) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: tlev(:,:) ! Interface temperatures (K) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(in) :: tsfc(:) ! Surface temperature (K) - ! Dimensions: (ncol) - REAL(KIND=r8), intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: o2vmr(:,:) ! O2 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: cfc11vmr(:,:) ! CFC11 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: cfc12vmr(:,:) ! CFC12 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: cfc22vmr(:,:) ! CFC22 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: ccl4vmr(:,:) ! CCL4 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: emis(:,:) ! Surface emissivity - ! Dimensions: (ncol,nbndlw) - INTEGER, intent(in) :: inflglw ! Flag for cloud optical properties - INTEGER, intent(in) :: iceflglw ! Flag for ice particle specification - INTEGER, intent(in) :: liqflglw ! Flag for liquid droplet specification - REAL(KIND=r8), intent(in) :: cldfmcl(:,:,:) ! Cloud fraction - ! Dimensions: (ngptlw,ncol,nlay) - REAL(KIND=r8), intent(in) :: ciwpmcl(:,:,:) ! Cloud ice water path (g/m2) - ! Dimensions: (ngptlw,ncol,nlay) - REAL(KIND=r8), intent(in) :: clwpmcl(:,:,:) ! Cloud liquid water path (g/m2) - ! Dimensions: (ngptlw,ncol,nlay) - REAL(KIND=r8), intent(in) :: reicmcl(:,:) ! Cloud ice effective radius (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: taucmcl(:,:,:) ! Cloud optical depth - ! Dimensions: (ngptlw,ncol,nlay) - ! real(kind=r8), intent(in) :: ssacmcl(:,:,:) ! Cloud single scattering albedo - ! Dimensions: (ngptlw,ncol,nlay) - ! for future expansion - ! lw scattering not yet available - ! real(kind=r8), intent(in) :: asmcmcl(:,:,:) ! Cloud asymmetry parameter - ! Dimensions: (ngptlw,ncol,nlay) - ! for future expansion - ! lw scattering not yet available - REAL(KIND=r8), intent(in) :: tauaer(:,:,:) ! aerosol optical depth - ! at mid-point of LW spectral bands - ! Dimensions: (ncol,nlay,nbndlw) - ! real(kind=r8), intent(in) :: ssaaer(:,:,:) ! aerosol single scattering albedo - ! Dimensions: (ncol,nlay,nbndlw) - ! for future expansion - ! (lw aerosols/scattering not yet available) - ! real(kind=r8), intent(in) :: asmaer(:,:,:) ! aerosol asymmetry parameter - ! Dimensions: (ncol,nlay,nbndlw) - ! for future expansion - ! (lw aerosols/scattering not yet available) - ! ----- Output ----- - REAL(KIND=r8), intent(out) :: uflx(:,:) ! Total sky longwave upward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(out) :: dflx(:,:) ! Total sky longwave downward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(out) :: hr(:,:) ! Total sky longwave radiative heating rate (K/d) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: uflxc(:,:) ! Clear sky longwave upward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(out) :: dflxc(:,:) ! Clear sky longwave downward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(out) :: hrc(:,:) ! Clear sky longwave radiative heating rate (K/d) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: uflxs(:,:,:) ! Total sky longwave upward flux spectral (W/m2) - ! Dimensions: (nbndlw,ncol,nlay+1) - REAL(KIND=r8), intent(out) :: dflxs(:,:,:) ! Total sky longwave downward flux spectral (W/m2) - ! Dimensions: (nbndlw,ncol,nlay+1) - ! ----- Local ----- - ! Control - INTEGER :: istart ! beginning band of calculation - INTEGER :: iend ! ending band of calculation - INTEGER :: iout ! output option flag (inactive) - INTEGER :: iaer ! aerosol option flag - INTEGER :: iplon ! column loop index - ! flag for mcica [0=off, 1=on] - INTEGER :: ims ! value for changing mcica permute seed - INTEGER :: k ! layer loop index - INTEGER :: ig ! g-point loop index - ! Atmosphere - REAL(KIND=r8) :: pavel(ncol,nlay) ! layer pressures (mb) - REAL(KIND=r8) :: tavel(ncol,nlay) ! layer temperatures (K) - REAL(KIND=r8) :: pz(ncol,0:nlay) ! level (interface) pressures (hPa, mb) - REAL(KIND=r8) :: tz(ncol,0:nlay) ! level (interface) temperatures (K) - REAL(KIND=r8) :: tbound(ncol) ! surface temperature (K) - REAL(KIND=r8) :: coldry(ncol,nlay) ! dry air column density (mol/cm2) - REAL(KIND=r8) :: wbrodl(ncol,nlay) ! broadening gas column density (mol/cm2) - REAL(KIND=r8) :: wkl(ncol,mxmol,nlay) ! molecular amounts (mol/cm-2) - REAL(KIND=r8) :: wx(ncol,maxxsec,nlay) ! cross-section amounts (mol/cm-2) - REAL(KIND=r8) :: pwvcm(ncol) ! precipitable water vapor (cm) - REAL(KIND=r8) :: semiss(ncol,nbndlw) ! lw surface emissivity - REAL(KIND=r8) :: fracs(ncol,nlay,ngptlw) ! - REAL(KIND=r8) :: taug(ncol,nlay,ngptlw) ! gaseous optical depths - REAL(KIND=r8) :: taut(ncol,nlay,ngptlw) ! gaseous + aerosol optical depths - REAL(KIND=r8) :: taua(ncol,nlay,nbndlw) ! aerosol optical depth - ! real(kind=r8) :: ssaa(nlay,nbndlw) ! aerosol single scattering albedo - ! for future expansion - ! (lw aerosols/scattering not yet available) - ! real(kind=r8) :: asma(nlay+1,nbndlw) ! aerosol asymmetry parameter - ! for future expansion - ! (lw aerosols/scattering not yet available) - ! Atmosphere - setcoef - INTEGER :: laytrop(ncol) ! tropopause layer index - INTEGER :: jp(ncol,nlay) ! lookup table index - INTEGER :: jt(ncol,nlay) ! lookup table index - INTEGER :: jt1(ncol,nlay) ! lookup table index - REAL(KIND=r8) :: planklay(ncol,nlay,nbndlw) ! - REAL(KIND=r8) :: planklev(ncol,0:nlay,nbndlw) ! - REAL(KIND=r8) :: plankbnd(ncol,nbndlw) ! - REAL(KIND=r8) :: colh2o(ncol,nlay) ! column amount (h2o) - REAL(KIND=r8) :: colco2(ncol,nlay) ! column amount (co2) - REAL(KIND=r8) :: colo3(ncol,nlay) ! column amount (o3) - REAL(KIND=r8) :: coln2o(ncol,nlay) ! column amount (n2o) - REAL(KIND=r8) :: colco(ncol,nlay) ! column amount (co) - REAL(KIND=r8) :: colch4(ncol,nlay) ! column amount (ch4) - REAL(KIND=r8) :: colo2(ncol,nlay) ! column amount (o2) - REAL(KIND=r8) :: colbrd(ncol,nlay) ! column amount (broadening gases) - INTEGER :: indself(ncol,nlay) - INTEGER :: indfor(ncol,nlay) - REAL(KIND=r8) :: selffac(ncol,nlay) - REAL(KIND=r8) :: selffrac(ncol,nlay) - REAL(KIND=r8) :: forfac(ncol,nlay) - REAL(KIND=r8) :: forfrac(ncol,nlay) - INTEGER :: indminor(ncol,nlay) - REAL(KIND=r8) :: minorfrac(ncol,nlay) - REAL(KIND=r8) :: scaleminor(ncol,nlay) - REAL(KIND=r8) :: scaleminorn2(ncol,nlay) - REAL(KIND=r8) :: fac01(ncol,nlay) - REAL(KIND=r8) :: fac10(ncol,nlay) - REAL(KIND=r8) :: fac11(ncol,nlay) - REAL(KIND=r8) :: fac00(ncol,nlay) ! - REAL(KIND=r8) :: rat_o3co2_1(ncol,nlay) - REAL(KIND=r8) :: rat_o3co2(ncol,nlay) - REAL(KIND=r8) :: rat_h2och4(ncol,nlay) - REAL(KIND=r8) :: rat_h2oo3(ncol,nlay) - REAL(KIND=r8) :: rat_h2och4_1(ncol,nlay) - REAL(KIND=r8) :: rat_h2oo3_1(ncol,nlay) - REAL(KIND=r8) :: rat_h2oco2(ncol,nlay) - REAL(KIND=r8) :: rat_n2oco2(ncol,nlay) - REAL(KIND=r8) :: rat_h2on2o(ncol,nlay) - REAL(KIND=r8) :: rat_n2oco2_1(ncol,nlay) - REAL(KIND=r8) :: rat_h2oco2_1(ncol,nlay) - REAL(KIND=r8) :: rat_h2on2o_1(ncol,nlay) ! - ! Atmosphere/clouds - cldprop - INTEGER :: ncbands(ncol) ! number of cloud spectral bands - INTEGER :: inflag ! flag for cloud property method - INTEGER :: iceflag ! flag for ice cloud properties - INTEGER :: liqflag ! flag for liquid cloud properties - ! Atmosphere/clouds - cldprmc [mcica] - REAL(KIND=r8) :: cldfmc(ncol,ngptlw,nlay) ! cloud fraction [mcica] - REAL(KIND=r8) :: ciwpmc(ncol,ngptlw,nlay) ! cloud ice water path [mcica] - REAL(KIND=r8) :: clwpmc(ncol,ngptlw,nlay) ! cloud liquid water path [mcica] - REAL(KIND=r8) :: relqmc(ncol,nlay) ! liquid particle size (microns) - REAL(KIND=r8) :: reicmc(ncol,nlay) ! ice particle effective radius (microns) - REAL(KIND=r8) :: dgesmc(ncol,nlay) ! ice particle generalized effective size (microns) - REAL(KIND=r8) :: taucmc(ncol,ngptlw,nlay) ! cloud optical depth [mcica] - ! real(kind=r8) :: ssacmc(ngptlw,nlay) ! cloud single scattering albedo [mcica] - ! for future expansion - ! (lw scattering not yet available) - ! real(kind=r8) :: asmcmc(ngptlw,nlay) ! cloud asymmetry parameter [mcica] - ! for future expansion - ! (lw scattering not yet available) - ! Output - REAL(KIND=r8) :: totuflux(ncol,0:nlay) ! upward longwave flux (w/m2) - REAL(KIND=r8) :: totdflux(ncol,0:nlay) ! downward longwave flux (w/m2) - REAL(KIND=r8) :: totufluxs(ncol,nbndlw,0:nlay) ! upward longwave flux spectral (w/m2) - REAL(KIND=r8) :: totdfluxs(ncol,nbndlw,0:nlay) ! downward longwave flux spectral (w/m2) - REAL(KIND=r8) :: fnet(ncol,0:nlay) ! net longwave flux (w/m2) - REAL(KIND=r8) :: htr(ncol,0:nlay) ! longwave heating rate (k/day) - REAL(KIND=r8) :: totuclfl(ncol,0:nlay) ! clear sky upward longwave flux (w/m2) - REAL(KIND=r8) :: totdclfl(ncol,0:nlay) ! clear sky downward longwave flux (w/m2) - REAL(KIND=r8) :: fnetc(ncol,0:nlay) ! clear sky net longwave flux (w/m2) - REAL(KIND=r8) :: htrc(ncol,0:nlay) ! clear sky longwave heating rate (k/day) -!DIR$ ATTRIBUTES ALIGN : 64 :: pz - ! Initializations - oneminus = 1._r8 - 1.e-6_r8 - pi = 2._r8 * asin(1._r8) - fluxfac = pi * 2.e4_r8 ! orig: fluxfac = pi * 2.d4 ! orig: fluxfac = pi * 2.d4 - istart = 1 - iend = 16 - iout = 0 - ims = 1 - ! Set imca to select calculation type: - ! imca = 0, use standard forward model calculation - ! imca = 1, use McICA for Monte Carlo treatment of sub-grid cloud variability - ! *** This version uses McICA (imca = 1) *** - ! Set icld to select of clear or cloud calculation and cloud overlap method - ! icld = 0, clear only - ! icld = 1, with clouds using random cloud overlap - ! icld = 2, with clouds using maximum/random cloud overlap - ! icld = 3, with clouds using maximum cloud overlap (McICA only) - if (icld.lt.0.or.icld.gt.3) icld = 2 - ! Set iaer to select aerosol option - ! iaer = 0, no aerosols - ! iaer = 10, input total aerosol optical depth (tauaer) directly - iaer = 10 - !Call model and data initialization, compute lookup tables, perform - ! reduction of g-points from 256 to 140 for input absorption coefficient - ! data and other arrays. - ! - ! In a GCM this call should be placed in the model initialization - ! area, since this has to be called only once. - ! call rrtmg_lw_ini - ! This is the main longitude/column loop within RRTMG. - ! Prepare atmospheric profile from GCM for use in RRTMG, and define - ! other input parameters. - call inatm (ncol, nlay, icld, iaer, & - play, plev, tlay, tlev, tsfc, h2ovmr, & - o3vmr, co2vmr, ch4vmr, o2vmr, n2ovmr, cfc11vmr, cfc12vmr, & - cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, & - cldfmcl, taucmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, tauaer, & - pavel, pz, tavel, tz, tbound, semiss, coldry, & - wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag, & - cldfmc, taucmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, taua) - -#ifdef OLD_CLDPRMC - do iplon = 1, ncol - ! For cloudy atmosphere, use cldprop to set cloud optical properties based on - ! input cloud physical properties. Select method based on choices described - ! in cldprop. Cloud fraction, water path, liquid droplet and ice particle - ! effective radius must be passed into cldprop. Cloud fraction and cloud - ! optical depth are transferred to rrtmg_lw arrays in cldprop. - call cldprmc_old(nlay, inflag, iceflag, liqflag, cldfmc(iplon,:,:), ciwpmc(iplon,:,:), & - clwpmc(iplon,:,:), reicmc(iplon,:), dgesmc(iplon,:), relqmc(iplon,:), ncbands(iplon), taucmc(iplon,:,:)) - ! Calculate information needed by the radiative transfer routine - ! that is specific to this atmosphere, especially some of the - ! coefficients and indices needed to compute the optical depths - ! by interpolating data from stored reference atmospheres. - end do -#else - ! For cloudy atmosphere, use cldprop to set cloud optical properties based on - ! input cloud physical properties. Select method based on choices described - ! in cldprop. Cloud fraction, water path, liquid droplet and ice particle - ! effective radius must be passed into cldprop. Cloud fraction and cloud - ! optical depth are transferred to rrtmg_lw arrays in cldprop. - call cldprmc(ncol,nlay, inflag, iceflag, liqflag, cldfmc, ciwpmc, & - clwpmc, reicmc, dgesmc, relqmc, ncbands, taucmc) - ! Calculate information needed by the radiative transfer routine - ! that is specific to this atmosphere, especially some of the - ! coefficients and indices needed to compute the optical depths - ! by interpolating data from stored reference atmospheres. - -#endif -#ifdef OLD_SETCOEF - do iplon = 1, ncol - call setcoef_old(nlay, istart, pavel(iplon,:), tavel(iplon,:), tz(iplon,:), tbound(iplon), semiss(iplon,:), & - coldry(iplon,:), wkl(iplon,:,:), wbrodl(iplon,:), & - laytrop(iplon), jp(iplon,:), jt(iplon,:), jt1(iplon,:), planklay(iplon,:,:), planklev(iplon,:,:), plankbnd(iplon,:), & - colh2o(iplon,:), colco2(iplon,:), colo3(iplon,:), coln2o(iplon,:), colco(iplon,:), colch4(iplon,:), colo2(iplon,:), & - colbrd(iplon,:), fac00(iplon,:), fac01(iplon,:), fac10(iplon,:), fac11(iplon,:), & - rat_h2oco2(iplon,:), rat_h2oco2_1(iplon,:), rat_h2oo3(iplon,:), rat_h2oo3_1(iplon,:), & - rat_h2on2o(iplon,:), rat_h2on2o_1(iplon,:), rat_h2och4(iplon,:), rat_h2och4_1(iplon,:), & - rat_n2oco2(iplon,:), rat_n2oco2_1(iplon,:), rat_o3co2(iplon,:), rat_o3co2_1(iplon,:), & - selffac(iplon,:), selffrac(iplon,:), indself(iplon,:), forfac(iplon,:), forfrac(iplon,:), indfor(iplon,:), & - minorfrac(iplon,:), scaleminor(iplon,:), scaleminorn2(iplon,:), indminor(iplon,:)) - ! Calculate the gaseous optical depths and Planck fractions for - ! each longwave spectral band. - end do -#else - call setcoef(ncol,nlay, istart, pavel, tavel, tz, tbound, semiss, & - coldry, wkl, wbrodl, & - laytrop, jp, jt, jt1, planklay, planklev, plankbnd, & - colh2o, colco2, colo3, coln2o, colco, colch4, colo2, & - colbrd, fac00, fac01, fac10, fac11, & - rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, & - rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, & - rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, & - selffac, selffrac, indself, forfac, forfrac, indfor, & - minorfrac, scaleminor, scaleminorn2, indminor) -#endif - do iplon = 1, ncol - call taumol(nlay, pavel(iplon,:), wx(iplon,:,:), coldry(iplon,:), & - laytrop(iplon), jp(iplon,:), jt(iplon,:), jt1(iplon,:), planklay(iplon,:,:), planklev(iplon,:,:), plankbnd(iplon,:), & - colh2o(iplon,:), colco2(iplon,:), colo3(iplon,:), coln2o(iplon,:), colco(iplon,:), colch4(iplon,:), colo2(iplon,:), & - colbrd(iplon,:), fac00(iplon,:), fac01(iplon,:), fac10(iplon,:), fac11(iplon,:), & - rat_h2oco2(iplon,:), rat_h2oco2_1(iplon,:), rat_h2oo3(iplon,:), rat_h2oo3_1(iplon,:), & - rat_h2on2o(iplon,:), rat_h2on2o_1(iplon,:), rat_h2och4(iplon,:), rat_h2och4_1(iplon,:), & - rat_n2oco2(iplon,:), rat_n2oco2_1(iplon,:), rat_o3co2(iplon,:), rat_o3co2_1(iplon,:), & - selffac(iplon,:), selffrac(iplon,:), indself(iplon,:), forfac(iplon,:), forfrac(iplon,:), indfor(iplon,:), & - minorfrac(iplon,:), scaleminor(iplon,:), scaleminorn2(iplon,:), indminor(iplon,:), & - fracs(iplon,:,:), taug(iplon,:,:)) - ! Combine gaseous and aerosol optical depths, if aerosol active - end do - if (iaer .eq. 0) then - do ig = 1, ngptlw - do k = 1, nlay - do iplon = 1, ncol - taut(iplon,k,ig) = taug(iplon,k,ig) - enddo - enddo - enddo - elseif (iaer .eq. 10) then - do ig = 1, ngptlw - do k = 1, nlay - do iplon = 1, ncol - taut(iplon,k,ig) = taug(iplon,k,ig) + taua(iplon,k,ngb(ig)) - enddo - enddo - enddo - endif -#ifdef OLD_RTRNMC - do iplon = 1, ncol - ! Call the radiative transfer routine. - ! Either routine can be called to do clear sky calculation. If clouds - ! are present, then select routine based on cloud overlap assumption - ! to be used. Clear sky calculation is done simultaneously. - ! For McICA, RTRNMC is called for clear and cloudy calculations. - call rtrnmc_old(nlay, istart, iend, iout, pz(iplon,:), semiss(iplon,:), ncbands(iplon), & - cldfmc(iplon,:,:), taucmc(iplon,:,:), planklay(iplon,:,:), planklev(iplon,:,:), plankbnd(iplon,:), & - pwvcm(iplon), fracs(iplon,:,:), taut(iplon,:,:), & - totuflux(iplon,:), totdflux(iplon,:), fnet(iplon,:), htr(iplon,:), & - totuclfl(iplon,:), totdclfl(iplon,:), fnetc(iplon,:), htrc(iplon,:), totufluxs(iplon,:,:), totdfluxs(iplon,:,:) ) - ! Transfer up and down fluxes and heating rate to output arrays. - ! Vertical indexing goes from bottom to top -#else - ! Call the radiative transfer routine. - ! Either routine can be called to do clear sky calculation. If clouds - ! are present, then select routine based on cloud overlap assumption - ! to be used. Clear sky calculation is done simultaneously. - ! For McICA, RTRNMC is called for clear and cloudy calculations. - call rtrnmc(ncol, nlay, istart, iend, iout, pz, semiss, ncbands, & - cldfmc, taucmc, planklay, planklev, plankbnd, & - pwvcm, fracs, taut, & - totuflux, totdflux, fnet, htr, & - totuclfl, totdclfl, fnetc, htrc, totufluxs, totdfluxs ) - ! Transfer up and down fluxes and heating rate to output arrays. - ! Vertical indexing goes from bottom to top - do iplon = 1, ncol -#endif - do k = 0, nlay - uflx(iplon,k+1) = totuflux(iplon,k) - dflx(iplon,k+1) = totdflux(iplon,k) - uflxc(iplon,k+1) = totuclfl(iplon,k) - dflxc(iplon,k+1) = totdclfl(iplon,k) - uflxs(:,iplon,k+1) = totufluxs(iplon,:,k) - dflxs(:,iplon,k+1) = totdfluxs(iplon,:,k) - enddo - do k = 0, nlay-1 - hr(iplon,k+1) = htr(iplon,k) - hrc(iplon,k+1) = htrc(iplon,k) - enddo - enddo - END SUBROUTINE rrtmg_lw - !*************************************************************************** - - SUBROUTINE inatm(ncol, nlay, icld, iaer, play, plev, tlay, tlev, tsfc, h2ovmr, o3vmr, co2vmr, ch4vmr, o2vmr, n2ovmr, & - cfc11vmr, cfc12vmr, cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, cldfmcl, taucmcl, ciwpmcl, clwpmcl, reicmcl, & - relqmcl, tauaer, pavel, pz, tavel, tz, tbound, semiss, coldry, wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag, cldfmc, & - taucmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, taua) - !*************************************************************************** - ! - ! Input atmospheric profile from GCM, and prepare it for use in RRTMG_LW. - ! Set other RRTMG_LW input parameters. - ! - !*************************************************************************** - ! --------- Modules ---------- - USE parrrtm, ONLY: nmol - USE parrrtm, ONLY: maxxsec - USE parrrtm, ONLY: nbndlw - USE parrrtm, ONLY: ngptlw - USE rrlw_con, ONLY: grav - USE rrlw_con, ONLY: avogad - USE rrlw_wvn, ONLY: ixindx - ! ------- Declarations ------- - ! ----- Input ----- - INTEGER, intent(in) :: ncol ! total number of columns - INTEGER, intent(in) :: nlay ! Number of model layers - INTEGER, intent(in) :: icld ! clear/cloud and cloud overlap flag - INTEGER, intent(in) :: iaer ! aerosol option flag - REAL(KIND=r8), intent(in) :: play(:,:) ! Layer pressures (hPa, mb) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: plev(:,:) ! Interface pressures (hPa, mb) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(in) :: tlay(:,:) ! Layer temperatures (K) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: tlev(:,:) ! Interface temperatures (K) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(in) :: tsfc(:) ! Surface temperature (K) - ! Dimensions: (ncol) - REAL(KIND=r8), intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: o2vmr(:,:) ! O2 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: cfc11vmr(:,:) ! CFC11 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: cfc12vmr(:,:) ! CFC12 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: cfc22vmr(:,:) ! CFC22 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: ccl4vmr(:,:) ! CCL4 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: emis(:,:) ! Surface emissivity - ! Dimensions: (ncol,nbndlw) - INTEGER, intent(in) :: inflglw ! Flag for cloud optical properties - INTEGER, intent(in) :: iceflglw ! Flag for ice particle specification - INTEGER, intent(in) :: liqflglw ! Flag for liquid droplet specification - REAL(KIND=r8), intent(in) :: cldfmcl(:,:,:) ! Cloud fraction - ! Dimensions: (ngptlw,ncol,nlay) - REAL(KIND=r8), intent(in) :: ciwpmcl(:,:,:) ! Cloud ice water path (g/m2) - ! Dimensions: (ngptlw,ncol,nlay) - REAL(KIND=r8), intent(in) :: clwpmcl(:,:,:) ! Cloud liquid water path (g/m2) - ! Dimensions: (ngptlw,ncol,nlay) - REAL(KIND=r8), intent(in) :: reicmcl(:,:) ! Cloud ice effective radius (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: taucmcl(:,:,:) ! Cloud optical depth - ! Dimensions: (ngptlw,ncol,nlay) - REAL(KIND=r8), intent(in) :: tauaer(:,:,:) ! Aerosol optical depth - ! Dimensions: (ncol,nlay,nbndlw) - ! ----- Output ----- - ! Atmosphere - REAL(KIND=r8), intent(out) :: pavel(:,:) ! layer pressures (mb) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: tavel(:,:) ! layer temperatures (K) - ! Dimensions: (ncol, nlay) - REAL(KIND=r8), intent(out) :: pz(ncol,0:nlay) ! level (interface) pressures (hPa, mb) - ! Dimensions: (ncol,0:nlay) - REAL(KIND=r8), intent(out) :: tz(ncol,0:nlay) ! level (interface) temperatures (K) - ! Dimensions: (ncol,0:nlay) - REAL(KIND=r8), intent(out) :: tbound(:) ! surface temperature (K) - ! Dimensions: (ncol) - REAL(KIND=r8), intent(out) :: coldry(ncol,nlay) ! dry air column density (mol/cm2) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: wbrodl(:,:) ! broadening gas column density (mol/cm2) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: wkl(:,:,:) ! molecular amounts (mol/cm-2) - ! Dimensions: (ncol,mxmol,nlay) - REAL(KIND=r8), intent(out) :: wx(:,:,:) ! cross-section amounts (mol/cm-2) - ! Dimensions: (ncol,maxxsec,nlay) - REAL(KIND=r8), intent(out) :: pwvcm(:) ! precipitable water vapor (cm) - ! Dimensions: (ncol) - REAL(KIND=r8), intent(out) :: semiss(:,:) ! lw surface emissivity - ! Dimensions: (ncol,nbndlw) - ! Atmosphere/clouds - cldprop - INTEGER, intent(out) :: inflag ! flag for cloud property method - INTEGER, intent(out) :: iceflag ! flag for ice cloud properties - INTEGER, intent(out) :: liqflag ! flag for liquid cloud properties - REAL(KIND=r8), intent(out) :: cldfmc(:,:,:) ! cloud fraction [mcica] - ! Dimensions: (ncol,ngptlw,nlay) - REAL(KIND=r8), intent(out) :: ciwpmc(:,:,:) ! cloud ice water path [mcica] - ! Dimensions: (ncol,ngptlw,nlay) - REAL(KIND=r8), intent(out) :: clwpmc(:,:,:) ! cloud liquid water path [mcica] - ! Dimensions: (ncol,ngptlw,nlay) - REAL(KIND=r8), intent(out) :: relqmc(:,:) ! liquid particle effective radius (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: reicmc(:,:) ! ice particle effective radius (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: dgesmc(:,:) ! ice particle generalized effective size (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: taucmc(:,:,:) ! cloud optical depth [mcica] - ! Dimensions: (ncol,ngptlw,nlay) - REAL(KIND=r8), intent(out) :: taua(:,:,:) ! Aerosol optical depth - ! Dimensions: (ncol,nlay,nbndlw) - ! ----- Local ----- - REAL(KIND=r8), parameter :: amd = 28.9660_r8 ! Effective molecular weight of dry air (g/mol) - REAL(KIND=r8), parameter :: amw = 18.0160_r8 ! Molecular weight of water vapor (g/mol) - ! real(kind=r8), parameter :: amc = 44.0098_r8 ! Molecular weight of carbon dioxide (g/mol) - ! real(kind=r8), parameter :: amo = 47.9998_r8 ! Molecular weight of ozone (g/mol) - ! real(kind=r8), parameter :: amo2 = 31.9999_r8 ! Molecular weight of oxygen (g/mol) - ! real(kind=r8), parameter :: amch4 = 16.0430_r8 ! Molecular weight of methane (g/mol) - ! real(kind=r8), parameter :: amn2o = 44.0128_r8 ! Molecular weight of nitrous oxide (g/mol) - ! real(kind=r8), parameter :: amc11 = 137.3684_r8 ! Molecular weight of CFC11 (g/mol) - CCL3F - ! real(kind=r8), parameter :: amc12 = 120.9138_r8 ! Molecular weight of CFC12 (g/mol) - CCL2F2 - ! real(kind=r8), parameter :: amc22 = 86.4688_r8 ! Molecular weight of CFC22 (g/mol) - CHCLF2 - ! real(kind=r8), parameter :: amcl4 = 153.823_r8 ! Molecular weight of CCL4 (g/mol) - CCL4 - ! Set molecular weight ratios (for converting mmr to vmr) - ! e.g. h2ovmr = h2ommr * amdw) - ! Molecular weight of dry air / water vapor - ! Molecular weight of dry air / carbon dioxide - ! Molecular weight of dry air / ozone - ! Molecular weight of dry air / methane - ! Molecular weight of dry air / nitrous oxide - ! Molecular weight of dry air / CFC11 - ! Molecular weight of dry air / CFC12 - ! Stefan-Boltzmann constant (W/m2K4) - INTEGER :: l,iplon - INTEGER :: imol - INTEGER :: ix - INTEGER :: n - INTEGER :: ib - INTEGER :: ig ! Loop indices - REAL(KIND=r8) :: amttl - REAL(KIND=r8) :: wvttl - REAL(KIND=r8) :: summol - REAL(KIND=r8) :: wvsh - ! promote temporary scalars to vectors - REAL(KIND=r8) :: amm(ncol,nlay) ! pr - ! Initialize all molecular amounts and cloud properties to zero here, then pass input amounts - ! into RRTM arrays below. -!JMD !DIR$ ASSUME_ALIGNED pz:64 -#if 0 - wkl(:,:,:) = 0.0_r8 - wx(:,:,:) = 0.0_r8 - cldfmc(:,:,:) = 0.0_r8 - taucmc(:,:,:) = 0.0_r8 - ciwpmc(:,:,:) = 0.0_r8 - clwpmc(:,:,:) = 0.0_r8 - reicmc(:,:) = 0.0_r8 - dgesmc(:,:) = 0.0_r8 - relqmc(:,:) = 0.0_r8 - taua(:,:,:) = 0.0_r8 -#endif - ! Set surface temperature. - tbound = tsfc - ! Install input GCM arrays into RRTMG_LW arrays for pressure, temperature, - ! and molecular amounts. - ! Pressures are input in mb, or are converted to mb here. - ! Molecular amounts are input in volume mixing ratio, or are converted from - ! mass mixing ratio (or specific humidity for h2o) to volume mixing ratio - ! here. These are then converted to molecular amount (molec/cm2) below. - ! The dry air column COLDRY (in molec/cm2) is calculated from the level - ! pressures, pz (in mb), based on the hydrostatic equation and includes a - ! correction to account for h2o in the layer. The molecular weight of moist - ! air (amm) is calculated for each layer. - ! Note: In RRTMG, layer indexing goes from bottom to top, and coding below - ! assumes GCM input fields are also bottom to top. Input layer indexing - ! from GCM fields should be reversed here if necessary. - pz(:,0) = plev(:,nlay+1) - tz(:,0) = tlev(:,nlay+1) - do l = 1, nlay - do iplon=1,ncol - pavel(iplon,l) = play(iplon,nlay-l+1) - tavel(iplon,l) = tlay(iplon,nlay-l+1) - pz(iplon,l) = plev(iplon,nlay-l+1) - tz(iplon,l) = tlev(iplon,nlay-l+1) - ! For h2o input in vmr: - wkl(iplon,1,l) = h2ovmr(iplon,nlay-l+1) - ! For h2o input in mmr: - ! wkl(1,l) = h2o(iplon,nlay-l)*amdw - ! For h2o input in specific humidity; - ! wkl(1,l) = (h2o(iplon,nlay-l)/(1._r8 - h2o(iplon,nlay-l)))*amdw - wkl(iplon,2,l) = co2vmr(iplon,nlay-l+1) - wkl(iplon,3,l) = o3vmr(iplon,nlay-l+1) - wkl(iplon,4,l) = n2ovmr(iplon,nlay-l+1) - wkl(iplon,5,l) = 0._r8 - wkl(iplon,6,l) = ch4vmr(iplon,nlay-l+1) - wkl(iplon,7,l) = o2vmr(iplon,nlay-l+1) - amm(iplon,l) = (1._r8 - wkl(iplon,1,l)) * amd + wkl(iplon,1,l) * amw - coldry(iplon,l) = (pz(iplon,l-1)-pz(iplon,l)) * 1.e3_r8 * avogad / & - (1.e2_r8 * grav * amm(iplon,l) * (1._r8 + wkl(iplon,1,l))) - ! Set cross section molecule amounts from input; convert to vmr if necessary - wx(iplon,1,l) = ccl4vmr(iplon,nlay-l+1) - wx(iplon,2,l) = cfc11vmr(iplon,nlay-l+1) - wx(iplon,3,l) = cfc12vmr(iplon,nlay-l+1) - wx(iplon,4,l) = cfc22vmr(iplon,nlay-l+1) - enddo - enddo - coldry(:,nlay) = (pz(:,nlay-1)) * 1.e3_r8 * avogad / & - (1.e2_r8 * grav * amm(:,nlay) * (1._r8 + wkl(:,1,nlay-1))) - ! At this point all molecular amounts in wkl and wx are in volume mixing ratio; - ! convert to molec/cm2 based on coldry for use in rrtm. also, compute precipitable - ! water vapor for diffusivity angle adjustments in rtrn and rtrnmr. - do iplon = 1,ncol - amttl = 0.0_r8 - wvttl = 0.0_r8 - do l = 1, nlay - summol = 0.0_r8 - do imol = 2, nmol - summol = summol + wkl(iplon,imol,l) - enddo - wbrodl(iplon,l) = coldry(iplon,l) * (1._r8 - summol) - do imol = 1, nmol - wkl(iplon,imol,l) = coldry(iplon,l) * wkl(iplon,imol,l) - enddo - amttl = amttl + coldry(iplon,l)+wkl(iplon,1,l) - wvttl = wvttl + wkl(iplon,1,l) - do ix = 1,maxxsec - if (ixindx(ix) .ne. 0) then - wx(iplon,ixindx(ix),l) = coldry(iplon,l) * wx(iplon,ix,l) * 1.e-20_r8 - endif - enddo - enddo - wvsh = (amw * wvttl) / (amd * amttl) - pwvcm(iplon) = wvsh * (1.e3_r8 * pz(iplon,0)) / (1.e2_r8 * grav) - ! Set spectral surface emissivity for each longwave band. - do n=1,nbndlw - semiss(iplon,n) = emis(iplon,n) - ! semiss(n) = 1.0_r8 - enddo - enddo - ! Transfer aerosol optical properties to RRTM variable; - ! modify to reverse layer indexing here if necessary. - if (iaer .ge. 1) then - do ib = 1, nbndlw - do l = 1, nlay-1 - do iplon=1,ncol - taua(iplon,l,ib) = tauaer(iplon,nlay-l,ib) - enddo - enddo - enddo - endif - ! Transfer cloud fraction and cloud optical properties to RRTM variables, - ! modify to reverse layer indexing here if necessary. - if (icld .ge. 1) then - inflag = inflglw - iceflag = iceflglw - liqflag = liqflglw - ! Move incoming GCM cloud arrays to RRTMG cloud arrays. - ! For GCM input, incoming reice is in effective radius; for Fu parameterization (iceflag = 3) - ! convert effective radius to generalized effective size using method of Mitchell, JAS, 2002: - do l = 1, nlay-1 - do ig = 1, ngptlw - do iplon=1,ncol - cldfmc(iplon,ig,l) = cldfmcl(ig,iplon,nlay-l) - taucmc(iplon,ig,l) = taucmcl(ig,iplon,nlay-l) - ciwpmc(iplon,ig,l) = ciwpmcl(ig,iplon,nlay-l) - clwpmc(iplon,ig,l) = clwpmcl(ig,iplon,nlay-l) - enddo - enddo - do iplon=1,ncol - reicmc(iplon,l) = reicmcl(iplon,nlay-l) - relqmc(iplon,l) = relqmcl(iplon,nlay-l) - enddo - if (iceflag .eq. 3) then - do iplon=1,ncol - dgesmc(iplon,l) = 1.5396_r8 * reicmcl(iplon,nlay-l) - enddo - endif - enddo - ! If an extra layer is being used in RRTMG, set all cloud properties to zero in the extra layer. - do iplon=1,ncol - cldfmc(iplon,:,nlay) = 0.0_r8 - taucmc(iplon,:,nlay) = 0.0_r8 - ciwpmc(iplon,:,nlay) = 0.0_r8 - clwpmc(iplon,:,nlay) = 0.0_r8 - reicmc(iplon,nlay) = 0.0_r8 - dgesmc(iplon,nlay) = 0.0_r8 - relqmc(iplon,nlay) = 0.0_r8 - taua(iplon,nlay,:) = 0.0_r8 - enddo - endif - END SUBROUTINE inatm - END MODULE rrtmg_lw_rad diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrtmg_lw_rtrnmc.F90 b/test/ncar_kernels/PORT_lw_rad/src/rrtmg_lw_rtrnmc.F90 deleted file mode 100644 index 10280b8462..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrtmg_lw_rtrnmc.F90 +++ /dev/null @@ -1,961 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_lw_rtrnmc.f90 -! Generated at: 2015-07-06 23:28:45 -! KGEN version: 0.4.13 - - MODULE rrtmg_lw_rtrnmc - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! --------- Modules ---------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE parrrtm, ONLY: ngptlw - USE parrrtm, ONLY: nbndlw - USE rrlw_con, ONLY: fluxfac - USE rrlw_con, ONLY: heatfac - USE rrlw_wvn, ONLY: ngb - USE rrlw_wvn, ONLY: ngs - USE rrlw_wvn, ONLY: delwave - USE rrlw_tbl, ONLY: bpade - USE rrlw_tbl, ONLY: tblint - USE rrlw_tbl, ONLY: tfn_tbl - USE rrlw_tbl, ONLY: exp_tbl - USE rrlw_tbl, ONLY: tau_tbl - USE rrlw_vsn, ONLY: hvrrtc - IMPLICIT NONE - -#ifdef OLD_RTRNMC - public :: rtrnmc_old -#else - public :: rtrnmc -#endif - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !----------------------------------------------------------------------------- - -#ifdef OLD_RTRNMC - SUBROUTINE rtrnmc_old(nlayers, istart, iend, iout, pz, semiss, ncbands, cldfmc, taucmc, planklay, planklev, plankbnd, pwvcm, & - fracs, taut, totuflux, totdflux, fnet, htr, totuclfl, totdclfl, fnetc, htrc, totufluxs, totdfluxs) - !----------------------------------------------------------------------------- - ! - ! Original version: E. J. Mlawer, et al. RRTM_V3.0 - ! Revision for GCMs: Michael J. Iacono; October, 2002 - ! Revision for F90: Michael J. Iacono; June, 2006 - ! - ! This program calculates the upward fluxes, downward fluxes, and - ! heating rates for an arbitrary clear or cloudy atmosphere. The input - ! to this program is the atmospheric profile, all Planck function - ! information, and the cloud fraction by layer. A variable diffusivity - ! angle (SECDIFF) is used for the angle integration. Bands 2-3 and 5-9 - ! use a value for SECDIFF that varies from 1.50 to 1.80 as a function of - ! the column water vapor, and other bands use a value of 1.66. The Gaussian - ! weight appropriate to this angle (WTDIFF=0.5) is applied here. Note that - ! use of the emissivity angle for the flux integration can cause errors of - ! 1 to 4 W/m2 within cloudy layers. - ! Clouds are treated with the McICA stochastic approach and maximum-random - ! cloud overlap. - !*************************************************************************** - ! ------- Declarations ------- - ! ----- Input ----- - INTEGER, intent(in) :: nlayers ! total number of layers - INTEGER, intent(in) :: istart ! beginning band of calculation - INTEGER, intent(in) :: iend ! ending band of calculation - INTEGER, intent(in) :: iout ! output option flag - ! Atmosphere - REAL(KIND=r8), intent(in) :: pz(0:) ! level (interface) pressures (hPa, mb) - ! Dimensions: (0:nlayers) - REAL(KIND=r8), intent(in) :: pwvcm ! precipitable water vapor (cm) - REAL(KIND=r8), intent(in) :: semiss(:) ! lw surface emissivity - ! Dimensions: (nbndlw) - REAL(KIND=r8), intent(in) :: planklay(:,:) ! - ! Dimensions: (nlayers,nbndlw) - REAL(KIND=r8), intent(in) :: planklev(0:,:) ! - ! Dimensions: (0:nlayers,nbndlw) - REAL(KIND=r8), intent(in) :: plankbnd(:) ! - ! Dimensions: (nbndlw) - REAL(KIND=r8), intent(in) :: fracs(:,:) ! - ! Dimensions: (nlayers,ngptw) - REAL(KIND=r8), intent(in) :: taut(:,:) ! gaseous + aerosol optical depths - ! Dimensions: (nlayers,ngptlw) - ! Clouds - INTEGER, intent(in) :: ncbands ! number of cloud spectral bands - REAL(KIND=r8), intent(in) :: cldfmc(:,:) ! layer cloud fraction [mcica] - ! Dimensions: (ngptlw,nlayers) - REAL(KIND=r8), intent(in) :: taucmc(:,:) ! layer cloud optical depth [mcica] - ! Dimensions: (ngptlw,nlayers) - ! ----- Output ----- - REAL(KIND=r8), intent(out) :: totuflux(0:) ! upward longwave flux (w/m2) - ! Dimensions: (0:nlayers) - REAL(KIND=r8), intent(out) :: totdflux(0:) ! downward longwave flux (w/m2) - ! Dimensions: (0:nlayers) - REAL(KIND=r8), intent(out) :: fnet(0:) ! net longwave flux (w/m2) - ! Dimensions: (0:nlayers) - REAL(KIND=r8), intent(out) :: htr(0:) ! longwave heating rate (k/day) - ! Dimensions: (0:nlayers) - REAL(KIND=r8), intent(out) :: totuclfl(0:) ! clear sky upward longwave flux (w/m2) - ! Dimensions: (0:nlayers) - REAL(KIND=r8), intent(out) :: totdclfl(0:) ! clear sky downward longwave flux (w/m2) - ! Dimensions: (0:nlayers) - REAL(KIND=r8), intent(out) :: fnetc(0:) ! clear sky net longwave flux (w/m2) - ! Dimensions: (0:nlayers) - REAL(KIND=r8), intent(out) :: htrc(0:) ! clear sky longwave heating rate (k/day) - ! Dimensions: (0:nlayers) - REAL(KIND=r8), intent(out) :: totufluxs(:,0:) ! upward longwave flux spectral (w/m2) - ! Dimensions: (nbndlw, 0:nlayers) - REAL(KIND=r8), intent(out) :: totdfluxs(:,0:) ! downward longwave flux spectral (w/m2) - ! Dimensions: (nbndlw, 0:nlayers) - ! ----- Local ----- - ! Declarations for radiative transfer - REAL(KIND=r8) :: abscld(nlayers,ngptlw) - REAL(KIND=r8) :: atot(nlayers) - REAL(KIND=r8) :: atrans(nlayers) - REAL(KIND=r8) :: bbugas(nlayers) - REAL(KIND=r8) :: bbutot(nlayers) - REAL(KIND=r8) :: clrurad(0:nlayers) - REAL(KIND=r8) :: clrdrad(0:nlayers) - REAL(KIND=r8) :: efclfrac(nlayers,ngptlw) - REAL(KIND=r8) :: uflux(0:nlayers) - REAL(KIND=r8) :: dflux(0:nlayers) - REAL(KIND=r8) :: urad(0:nlayers) - REAL(KIND=r8) :: drad(0:nlayers) - REAL(KIND=r8) :: uclfl(0:nlayers) - REAL(KIND=r8) :: dclfl(0:nlayers) - REAL(KIND=r8) :: odcld(nlayers,ngptlw) - REAL(KIND=r8) :: secdiff(nbndlw) ! secant of diffusivity angle - REAL(KIND=r8) :: a0(nbndlw) - REAL(KIND=r8) :: a1(nbndlw) - REAL(KIND=r8) :: a2(nbndlw) ! diffusivity angle adjustment coefficients - REAL(KIND=r8) :: wtdiff - REAL(KIND=r8) :: rec_6 - REAL(KIND=r8) :: transcld - REAL(KIND=r8) :: radld - REAL(KIND=r8) :: radclrd - REAL(KIND=r8) :: plfrac - REAL(KIND=r8) :: blay - REAL(KIND=r8) :: dplankup - REAL(KIND=r8) :: dplankdn - REAL(KIND=r8) :: odepth - REAL(KIND=r8) :: odtot - REAL(KIND=r8) :: odepth_rec - REAL(KIND=r8) :: gassrc - REAL(KIND=r8) :: odtot_rec - REAL(KIND=r8) :: bbdtot - REAL(KIND=r8) :: bbd - REAL(KIND=r8) :: tblind - REAL(KIND=r8) :: tfactot - REAL(KIND=r8) :: tfacgas - REAL(KIND=r8) :: transc - REAL(KIND=r8) :: tausfac - REAL(KIND=r8) :: rad0 - REAL(KIND=r8) :: reflect - REAL(KIND=r8) :: radlu - REAL(KIND=r8) :: radclru - INTEGER :: icldlyr(nlayers) ! flag for cloud in layer - INTEGER :: ibnd - INTEGER :: lay - INTEGER :: ig - INTEGER :: ib - INTEGER :: iband - INTEGER :: lev - INTEGER :: l ! loop indices - INTEGER :: igc ! g-point interval counter - INTEGER :: iclddn ! flag for cloud in down path - INTEGER :: ittot - INTEGER :: itgas - INTEGER :: itr ! lookup table indices - ! ------- Definitions ------- - ! input - ! nlayers ! number of model layers - ! ngptlw ! total number of g-point subintervals - ! nbndlw ! number of longwave spectral bands - ! ncbands ! number of spectral bands for clouds - ! secdiff ! diffusivity angle - ! wtdiff ! weight for radiance to flux conversion - ! pavel ! layer pressures (mb) - ! pz ! level (interface) pressures (mb) - ! tavel ! layer temperatures (k) - ! tz ! level (interface) temperatures(mb) - ! tbound ! surface temperature (k) - ! cldfrac ! layer cloud fraction - ! taucloud ! layer cloud optical depth - ! itr ! integer look-up table index - ! icldlyr ! flag for cloudy layers - ! iclddn ! flag for cloud in column at any layer - ! semiss ! surface emissivities for each band - ! reflect ! surface reflectance - ! bpade ! 1/(pade constant) - ! tau_tbl ! clear sky optical depth look-up table - ! exp_tbl ! exponential look-up table for transmittance - ! tfn_tbl ! tau transition function look-up table - ! local - ! atrans ! gaseous absorptivity - ! abscld ! cloud absorptivity - ! atot ! combined gaseous and cloud absorptivity - ! odclr ! clear sky (gaseous) optical depth - ! odcld ! cloud optical depth - ! odtot ! optical depth of gas and cloud - ! tfacgas ! gas-only pade factor, used for planck fn - ! tfactot ! gas and cloud pade factor, used for planck fn - ! bbdgas ! gas-only planck function for downward rt - ! bbugas ! gas-only planck function for upward rt - ! bbdtot ! gas and cloud planck function for downward rt - ! bbutot ! gas and cloud planck function for upward calc. - ! gassrc ! source radiance due to gas only - ! efclfrac ! effective cloud fraction - ! radlu ! spectrally summed upward radiance - ! radclru ! spectrally summed clear sky upward radiance - ! urad ! upward radiance by layer - ! clrurad ! clear sky upward radiance by layer - ! radld ! spectrally summed downward radiance - ! radclrd ! spectrally summed clear sky downward radiance - ! drad ! downward radiance by layer - ! clrdrad ! clear sky downward radiance by layer - ! output - ! totuflux ! upward longwave flux (w/m2) - ! totdflux ! downward longwave flux (w/m2) - ! fnet ! net longwave flux (w/m2) - ! htr ! longwave heating rate (k/day) - ! totuclfl ! clear sky upward longwave flux (w/m2) - ! totdclfl ! clear sky downward longwave flux (w/m2) - ! fnetc ! clear sky net longwave flux (w/m2) - ! htrc ! clear sky longwave heating rate (k/day) - ! This secant and weight corresponds to the standard diffusivity - ! angle. This initial value is redefined below for some bands. - data wtdiff /0.5_r8/ - data rec_6 /0.166667_r8/ - ! Reset diffusivity angle for Bands 2-3 and 5-9 to vary (between 1.50 - ! and 1.80) as a function of total column water vapor. The function - ! has been defined to minimize flux and cooling rate errors in these bands - ! over a wide range of precipitable water values. - data a0 / 1.66_r8, 1.55_r8, 1.58_r8, 1.66_r8, & - 1.54_r8, 1.454_r8, 1.89_r8, 1.33_r8, & - 1.668_r8, 1.66_r8, 1.66_r8, 1.66_r8, & - 1.66_r8, 1.66_r8, 1.66_r8, 1.66_r8 / - data a1 / 0.00_r8, 0.25_r8, 0.22_r8, 0.00_r8, & - 0.13_r8, 0.446_r8, -0.10_r8, 0.40_r8, & - -0.006_r8, 0.00_r8, 0.00_r8, 0.00_r8, & - 0.00_r8, 0.00_r8, 0.00_r8, 0.00_r8 / - data a2 / 0.00_r8, -12.0_r8, -11.7_r8, 0.00_r8, & - -0.72_r8,-0.243_r8, 0.19_r8,-0.062_r8, & - 0.414_r8, 0.00_r8, 0.00_r8, 0.00_r8, & - 0.00_r8, 0.00_r8, 0.00_r8, 0.00_r8 / - hvrrtc = '$Revision: 1.3 $' - do ibnd = 1,nbndlw - if (ibnd.eq.1 .or. ibnd.eq.4 .or. ibnd.ge.10) then - secdiff(ibnd) = 1.66_r8 - else - secdiff(ibnd) = a0(ibnd) + a1(ibnd)*exp(a2(ibnd)*pwvcm) - endif - enddo - if (pwvcm.lt.1.0) secdiff(6) = 1.80_r8 - if (pwvcm.gt.7.1) secdiff(7) = 1.50_r8 - urad(0) = 0.0_r8 - drad(0) = 0.0_r8 - totuflux(0) = 0.0_r8 - totdflux(0) = 0.0_r8 - clrurad(0) = 0.0_r8 - clrdrad(0) = 0.0_r8 - totuclfl(0) = 0.0_r8 - totdclfl(0) = 0.0_r8 - do lay = 1, nlayers - urad(lay) = 0.0_r8 - drad(lay) = 0.0_r8 - totuflux(lay) = 0.0_r8 - totdflux(lay) = 0.0_r8 - clrurad(lay) = 0.0_r8 - clrdrad(lay) = 0.0_r8 - totuclfl(lay) = 0.0_r8 - totdclfl(lay) = 0.0_r8 - icldlyr(lay) = 0 - ! Change to band loop? - do ig = 1, ngptlw - if (cldfmc(ig,lay) .eq. 1._r8) then - ib = ngb(ig) - odcld(lay,ig) = secdiff(ib) * taucmc(ig,lay) - transcld = exp(-odcld(lay,ig)) - abscld(lay,ig) = 1._r8 - transcld - efclfrac(lay,ig) = abscld(lay,ig) * cldfmc(ig,lay) - icldlyr(lay) = 1 - else - odcld(lay,ig) = 0.0_r8 - abscld(lay,ig) = 0.0_r8 - efclfrac(lay,ig) = 0.0_r8 - endif - enddo - enddo - igc = 1 - ! Loop over frequency bands. - do iband = istart, iend - ! Reinitialize g-point counter for each band if output for each band is requested. - if (iout.gt.0.and.iband.ge.2) igc = ngs(iband-1)+1 - ! Loop over g-channels. - 1000 continue - ! Radiative transfer starts here. - radld = 0._r8 - radclrd = 0._r8 - iclddn = 0 - ! Downward radiative transfer loop. - do lev = nlayers, 1, -1 - plfrac = fracs(lev,igc) - blay = planklay(lev,iband) - dplankup = planklev(lev,iband) - blay - dplankdn = planklev(lev-1,iband) - blay - odepth = secdiff(iband) * taut(lev,igc) - if (odepth .lt. 0.0_r8) odepth = 0.0_r8 - ! Cloudy layer - if (icldlyr(lev).eq.1) then - iclddn = 1 - odtot = odepth + odcld(lev,igc) - if (odtot .lt. 0.06_r8) then - atrans(lev) = odepth - 0.5_r8*odepth*odepth - odepth_rec = rec_6*odepth - gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev) - atot(lev) = odtot - 0.5_r8*odtot*odtot - odtot_rec = rec_6*odtot - bbdtot = plfrac * (blay+dplankdn*odtot_rec) - bbd = plfrac*(blay+dplankdn*odepth_rec) - radld = radld - radld * (atrans(lev) + & - efclfrac(lev,igc) * (1. - atrans(lev))) + & - gassrc + cldfmc(igc,lev) * & - (bbdtot * atot(lev) - gassrc) - drad(lev-1) = drad(lev-1) + radld - bbugas(lev) = plfrac * (blay+dplankup*odepth_rec) - bbutot(lev) = plfrac * (blay+dplankup*odtot_rec) - elseif (odepth .le. 0.06_r8) then - atrans(lev) = odepth - 0.5_r8*odepth*odepth - odepth_rec = rec_6*odepth - gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev) - odtot = odepth + odcld(lev,igc) - tblind = odtot/(bpade+odtot) - ittot = tblint*tblind + 0.5_r8 - tfactot = tfn_tbl(ittot) - bbdtot = plfrac * (blay + tfactot*dplankdn) - bbd = plfrac*(blay+dplankdn*odepth_rec) - atot(lev) = 1. - exp_tbl(ittot) - radld = radld - radld * (atrans(lev) + & - efclfrac(lev,igc) * (1._r8 - atrans(lev))) + & - gassrc + cldfmc(igc,lev) * & - (bbdtot * atot(lev) - gassrc) - drad(lev-1) = drad(lev-1) + radld - bbugas(lev) = plfrac * (blay + dplankup*odepth_rec) - bbutot(lev) = plfrac * (blay + tfactot * dplankup) - else - tblind = odepth/(bpade+odepth) - itgas = tblint*tblind+0.5_r8 - odepth = tau_tbl(itgas) - atrans(lev) = 1._r8 - exp_tbl(itgas) - tfacgas = tfn_tbl(itgas) - gassrc = atrans(lev) * plfrac * (blay + tfacgas*dplankdn) - odtot = odepth + odcld(lev,igc) - tblind = odtot/(bpade+odtot) - ittot = tblint*tblind + 0.5_r8 - tfactot = tfn_tbl(ittot) - bbdtot = plfrac * (blay + tfactot*dplankdn) - bbd = plfrac*(blay+tfacgas*dplankdn) - atot(lev) = 1._r8 - exp_tbl(ittot) - radld = radld - radld * (atrans(lev) + & - efclfrac(lev,igc) * (1._r8 - atrans(lev))) + & - gassrc + cldfmc(igc,lev) * & - (bbdtot * atot(lev) - gassrc) - drad(lev-1) = drad(lev-1) + radld - bbugas(lev) = plfrac * (blay + tfacgas * dplankup) - bbutot(lev) = plfrac * (blay + tfactot * dplankup) - endif - ! Clear layer - else - if (odepth .le. 0.06_r8) then - atrans(lev) = odepth-0.5_r8*odepth*odepth - odepth = rec_6*odepth - bbd = plfrac*(blay+dplankdn*odepth) - bbugas(lev) = plfrac*(blay+dplankup*odepth) - else - tblind = odepth/(bpade+odepth) - itr = tblint*tblind+0.5_r8 - transc = exp_tbl(itr) - atrans(lev) = 1._r8-transc - tausfac = tfn_tbl(itr) - bbd = plfrac*(blay+tausfac*dplankdn) - bbugas(lev) = plfrac * (blay + tausfac * dplankup) - endif - radld = radld + (bbd-radld)*atrans(lev) - drad(lev-1) = drad(lev-1) + radld - endif - ! Set clear sky stream to total sky stream as long as layers - ! remain clear. Streams diverge when a cloud is reached (iclddn=1), - ! and clear sky stream must be computed separately from that point. - if (iclddn.eq.1) then - radclrd = radclrd + (bbd-radclrd) * atrans(lev) - clrdrad(lev-1) = clrdrad(lev-1) + radclrd - else - radclrd = radld - clrdrad(lev-1) = drad(lev-1) - endif - enddo - ! Spectral emissivity & reflectance - ! Include the contribution of spectrally varying longwave emissivity - ! and reflection from the surface to the upward radiative transfer. - ! Note: Spectral and Lambertian reflection are identical for the - ! diffusivity angle flux integration used here. - rad0 = fracs(1,igc) * plankbnd(iband) - ! Add in specular reflection of surface downward radiance. - reflect = 1._r8 - semiss(iband) - radlu = rad0 + reflect * radld - radclru = rad0 + reflect * radclrd - ! Upward radiative transfer loop. - urad(0) = urad(0) + radlu - clrurad(0) = clrurad(0) + radclru - do lev = 1, nlayers - ! Cloudy layer - if (icldlyr(lev) .eq. 1) then - gassrc = bbugas(lev) * atrans(lev) - radlu = radlu - radlu * (atrans(lev) + & - efclfrac(lev,igc) * (1._r8 - atrans(lev))) + & - gassrc + cldfmc(igc,lev) * & - (bbutot(lev) * atot(lev) - gassrc) - urad(lev) = urad(lev) + radlu - ! Clear layer - else - radlu = radlu + (bbugas(lev)-radlu)*atrans(lev) - urad(lev) = urad(lev) + radlu - endif - ! Set clear sky stream to total sky stream as long as all layers - ! are clear (iclddn=0). Streams must be calculated separately at - ! all layers when a cloud is present (ICLDDN=1), because surface - ! reflectance is different for each stream. - if (iclddn.eq.1) then - radclru = radclru + (bbugas(lev)-radclru)*atrans(lev) - clrurad(lev) = clrurad(lev) + radclru - else - radclru = radlu - clrurad(lev) = urad(lev) - endif - enddo - ! Increment g-point counter - igc = igc + 1 - ! Return to continue radiative transfer for all g-channels in present band - if (igc .le. ngs(iband)) go to 1000 - ! Process longwave output from band for total and clear streams. - ! Calculate upward, downward, and net flux. - do lev = nlayers, 0, -1 - uflux(lev) = urad(lev)*wtdiff - dflux(lev) = drad(lev)*wtdiff - urad(lev) = 0.0_r8 - drad(lev) = 0.0_r8 - totuflux(lev) = totuflux(lev) + uflux(lev) * delwave(iband) - totdflux(lev) = totdflux(lev) + dflux(lev) * delwave(iband) - uclfl(lev) = clrurad(lev)*wtdiff - dclfl(lev) = clrdrad(lev)*wtdiff - clrurad(lev) = 0.0_r8 - clrdrad(lev) = 0.0_r8 - totuclfl(lev) = totuclfl(lev) + uclfl(lev) * delwave(iband) - totdclfl(lev) = totdclfl(lev) + dclfl(lev) * delwave(iband) - totufluxs(iband,lev) = uflux(lev) * delwave(iband) - totdfluxs(iband,lev) = dflux(lev) * delwave(iband) - enddo - ! End spectral band loop - enddo - ! Calculate fluxes at surface - totuflux(0) = totuflux(0) * fluxfac - totdflux(0) = totdflux(0) * fluxfac - totufluxs(:,0) = totufluxs(:,0) * fluxfac - totdfluxs(:,0) = totdfluxs(:,0) * fluxfac - fnet(0) = totuflux(0) - totdflux(0) - totuclfl(0) = totuclfl(0) * fluxfac - totdclfl(0) = totdclfl(0) * fluxfac - fnetc(0) = totuclfl(0) - totdclfl(0) - ! Calculate fluxes at model levels - do lev = 1, nlayers - totuflux(lev) = totuflux(lev) * fluxfac - totdflux(lev) = totdflux(lev) * fluxfac - totufluxs(:,lev) = totufluxs(:,lev) * fluxfac - totdfluxs(:,lev) = totdfluxs(:,lev) * fluxfac - fnet(lev) = totuflux(lev) - totdflux(lev) - totuclfl(lev) = totuclfl(lev) * fluxfac - totdclfl(lev) = totdclfl(lev) * fluxfac - fnetc(lev) = totuclfl(lev) - totdclfl(lev) - l = lev - 1 - ! Calculate heating rates at model layers - htr(l)=heatfac*(fnet(l)-fnet(lev))/(pz(l)-pz(lev)) - htrc(l)=heatfac*(fnetc(l)-fnetc(lev))/(pz(l)-pz(lev)) - enddo - ! Set heating rate to zero in top layer - htr(nlayers) = 0.0_r8 - htrc(nlayers) = 0.0_r8 - END SUBROUTINE rtrnmc_old -#else - SUBROUTINE rtrnmc(ncol,nlayers, istart, iend, iout, pz, semiss, ncbands, cldfmc, taucmc, planklay, planklev, plankbnd, pwvcm, & - fracs, taut, totuflux, totdflux, fnet, htr, totuclfl, totdclfl, fnetc, htrc, totufluxs, totdfluxs) - !----------------------------------------------------------------------------- - ! - ! Original version: E. J. Mlawer, et al. RRTM_V3.0 - ! Revision for GCMs: Michael J. Iacono; October, 2002 - ! Revision for F90: Michael J. Iacono; June, 2006 - ! - ! This program calculates the upward fluxes, downward fluxes, and - ! heating rates for an arbitrary clear or cloudy atmosphere. The input - ! to this program is the atmospheric profile, all Planck function - ! information, and the cloud fraction by layer. A variable diffusivity - ! angle (SECDIFF) is used for the angle integration. Bands 2-3 and 5-9 - ! use a value for SECDIFF that varies from 1.50 to 1.80 as a function of - ! the column water vapor, and other bands use a value of 1.66. The Gaussian - ! weight appropriate to this angle (WTDIFF=0.5) is applied here. Note that - ! use of the emissivity angle for the flux integration can cause errors of - ! 1 to 4 W/m2 within cloudy layers. - ! Clouds are treated with the McICA stochastic approach and maximum-random - ! cloud overlap. - !*************************************************************************** - ! ------- Declarations ------- - ! ----- Input ----- - INTEGER, intent(in) :: ncol ! total number of columns - INTEGER, intent(in) :: nlayers ! total number of layers - INTEGER, intent(in) :: istart ! beginning band of calculation - INTEGER, intent(in) :: iend ! ending band of calculation - INTEGER, intent(in) :: iout ! output option flag - ! Atmosphere - REAL(KIND=r8), intent(in) :: pz(:,0:) ! level (interface) pressures (hPa, mb) - ! Dimensions: (ncol,0:nlayers) - REAL(KIND=r8), intent(in) :: pwvcm(:) ! precipitable water vapor (cm) - ! Dimensions: (ncol) - REAL(KIND=r8), intent(in) :: semiss(:,:) ! lw surface emissivity - ! Dimensions: (ncol,nbndlw) - REAL(KIND=r8), intent(in) :: planklay(:,:,:) ! - ! Dimensions: (ncol,nlayers,nbndlw) - REAL(KIND=r8), intent(in) :: planklev(:,0:,:) ! - ! Dimensions: (ncol,0:nlayers,nbndlw) - REAL(KIND=r8), intent(in) :: plankbnd(:,:) ! - ! Dimensions: (ncol,nbndlw) - REAL(KIND=r8), intent(in) :: fracs(:,:,:) ! - ! Dimensions: (ncol,nlayers,ngptw) - REAL(KIND=r8), intent(in) :: taut(:,:,:) ! gaseous + aerosol optical depths - ! Dimensions: (ncol,nlayers,ngptlw) - ! Clouds - INTEGER, intent(in) :: ncbands(:) ! number of cloud spectral bands - ! Dimensions: (ncol) - REAL(KIND=r8), intent(in) :: cldfmc(:,:,:) ! layer cloud fraction [mcica] - ! Dimensions: (ncol,ngptlw,nlayers) - REAL(KIND=r8), intent(in) :: taucmc(:,:,:) ! layer cloud optical depth [mcica] - ! Dimensions: (ncol,ngptlw,nlayers) - ! ----- Output ----- - REAL(KIND=r8), intent(out) :: totuflux(:,0:) ! upward longwave flux (w/m2) - ! Dimensions: (ncol,0:nlayers) - REAL(KIND=r8), intent(out) :: totdflux(:,0:) ! downward longwave flux (w/m2) - ! Dimensions: (ncol,0:nlayers) - REAL(KIND=r8), intent(out) :: fnet(:,0:) ! net longwave flux (w/m2) - ! Dimensions: (ncol,0:nlayers) - REAL(KIND=r8), intent(out) :: htr(:,0:) ! longwave heating rate (k/day) - ! Dimensions: (ncol,0:nlayers) - REAL(KIND=r8), intent(out) :: totuclfl(:,0:) ! clear sky upward longwave flux (w/m2) - ! Dimensions: (ncol,0:nlayers) - REAL(KIND=r8), intent(out) :: totdclfl(:,0:) ! clear sky downward longwave flux (w/m2) - ! Dimensions: (ncol,0:nlayers) - REAL(KIND=r8), intent(out) :: fnetc(:,0:) ! clear sky net longwave flux (w/m2) - ! Dimensions: (ncol,0:nlayers) - REAL(KIND=r8), intent(out) :: htrc(:,0:) ! clear sky longwave heating rate (k/day) - ! Dimensions: (ncol,0:nlayers) - REAL(KIND=r8), intent(out) :: totufluxs(:,:,0:) ! upward longwave flux spectral (w/m2) - ! Dimensions: (ncol,nbndlw, 0:nlayers) - REAL(KIND=r8), intent(out) :: totdfluxs(:,:,0:) ! downward longwave flux spectral (w/m2) - ! Dimensions: (ncol,nbndlw, 0:nlayers) - ! ----- Local ----- - ! Declarations for radiative transfer - REAL(KIND=r8) :: abscld(nlayers,ngptlw) - REAL(KIND=r8) :: atot(nlayers) - REAL(KIND=r8) :: atrans(nlayers) - REAL(KIND=r8) :: bbugas(nlayers) - REAL(KIND=r8) :: bbutot(nlayers) - REAL(KIND=r8) :: clrurad(0:nlayers) - REAL(KIND=r8) :: clrdrad(0:nlayers) - REAL(KIND=r8) :: efclfrac(nlayers,ngptlw) - REAL(KIND=r8) :: uflux(0:nlayers) - REAL(KIND=r8) :: dflux(0:nlayers) - REAL(KIND=r8) :: urad(0:nlayers) - REAL(KIND=r8) :: drad(0:nlayers) - REAL(KIND=r8) :: uclfl(0:nlayers) - REAL(KIND=r8) :: dclfl(0:nlayers) - REAL(KIND=r8) :: odcld(nlayers,ngptlw) - REAL(KIND=r8) :: secdiff(nbndlw) ! secant of diffusivity angle - REAL(KIND=r8) :: a0(nbndlw) - REAL(KIND=r8) :: a1(nbndlw) - REAL(KIND=r8) :: a2(nbndlw) ! diffusivity angle adjustment coefficients - REAL(KIND=r8) :: wtdiff - REAL(KIND=r8) :: rec_6 - REAL(KIND=r8) :: transcld - REAL(KIND=r8) :: radld - REAL(KIND=r8) :: radclrd - REAL(KIND=r8) :: plfrac - REAL(KIND=r8) :: blay - REAL(KIND=r8) :: dplankup - REAL(KIND=r8) :: dplankdn - REAL(KIND=r8) :: odepth - REAL(KIND=r8) :: odtot - REAL(KIND=r8) :: odepth_rec - REAL(KIND=r8) :: gassrc - REAL(KIND=r8) :: odtot_rec - REAL(KIND=r8) :: bbdtot - REAL(KIND=r8) :: bbd - REAL(KIND=r8) :: tblind - REAL(KIND=r8) :: tfactot - REAL(KIND=r8) :: tfacgas - REAL(KIND=r8) :: transc - REAL(KIND=r8) :: tausfac - REAL(KIND=r8) :: rad0 - REAL(KIND=r8) :: reflect - REAL(KIND=r8) :: radlu - REAL(KIND=r8) :: radclru - INTEGER :: icldlyr(nlayers) ! flag for cloud in layer - INTEGER :: ibnd - INTEGER :: lay - INTEGER :: ig - INTEGER :: ib - INTEGER :: iband - INTEGER :: lev - INTEGER :: l ! loop indices - INTEGER :: igc ! g-point interval counter - INTEGER :: iclddn ! flag for cloud in down path - INTEGER :: ittot - INTEGER :: itgas - INTEGER :: itr ! lookup table indices - ! ------- Definitions ------- - ! input - ! nlayers ! number of model layers - ! ngptlw ! total number of g-point subintervals - ! nbndlw ! number of longwave spectral bands - ! ncbands ! number of spectral bands for clouds - ! secdiff ! diffusivity angle - ! wtdiff ! weight for radiance to flux conversion - ! pavel ! layer pressures (mb) - ! pz ! level (interface) pressures (mb) - ! tavel ! layer temperatures (k) - ! tz ! level (interface) temperatures(mb) - ! tbound ! surface temperature (k) - ! cldfrac ! layer cloud fraction - ! taucloud ! layer cloud optical depth - ! itr ! integer look-up table index - ! icldlyr ! flag for cloudy layers - ! iclddn ! flag for cloud in column at any layer - ! semiss ! surface emissivities for each band - ! reflect ! surface reflectance - ! bpade ! 1/(pade constant) - ! tau_tbl ! clear sky optical depth look-up table - ! exp_tbl ! exponential look-up table for transmittance - ! tfn_tbl ! tau transition function look-up table - ! local - ! atrans ! gaseous absorptivity - ! abscld ! cloud absorptivity - ! atot ! combined gaseous and cloud absorptivity - ! odclr ! clear sky (gaseous) optical depth - ! odcld ! cloud optical depth - ! odtot ! optical depth of gas and cloud - ! tfacgas ! gas-only pade factor, used for planck fn - ! tfactot ! gas and cloud pade factor, used for planck fn - ! bbdgas ! gas-only planck function for downward rt - ! bbugas ! gas-only planck function for upward rt - ! bbdtot ! gas and cloud planck function for downward rt - ! bbutot ! gas and cloud planck function for upward calc. - ! gassrc ! source radiance due to gas only - ! efclfrac ! effective cloud fraction - ! radlu ! spectrally summed upward radiance - ! radclru ! spectrally summed clear sky upward radiance - ! urad ! upward radiance by layer - ! clrurad ! clear sky upward radiance by layer - ! radld ! spectrally summed downward radiance - ! radclrd ! spectrally summed clear sky downward radiance - ! drad ! downward radiance by layer - ! clrdrad ! clear sky downward radiance by layer - ! output - ! totuflux ! upward longwave flux (w/m2) - ! totdflux ! downward longwave flux (w/m2) - ! fnet ! net longwave flux (w/m2) - ! htr ! longwave heating rate (k/day) - ! totuclfl ! clear sky upward longwave flux (w/m2) - ! totdclfl ! clear sky downward longwave flux (w/m2) - ! fnetc ! clear sky net longwave flux (w/m2) - ! htrc ! clear sky longwave heating rate (k/day) - ! This secant and weight corresponds to the standard diffusivity - ! angle. This initial value is redefined below for some bands. - data wtdiff /0.5_r8/ - data rec_6 /0.166667_r8/ - ! Reset diffusivity angle for Bands 2-3 and 5-9 to vary (between 1.50 - ! and 1.80) as a function of total column water vapor. The function - ! has been defined to minimize flux and cooling rate errors in these bands - ! over a wide range of precipitable water values. - data a0 / 1.66_r8, 1.55_r8, 1.58_r8, 1.66_r8, & - 1.54_r8, 1.454_r8, 1.89_r8, 1.33_r8, & - 1.668_r8, 1.66_r8, 1.66_r8, 1.66_r8, & - 1.66_r8, 1.66_r8, 1.66_r8, 1.66_r8 / - data a1 / 0.00_r8, 0.25_r8, 0.22_r8, 0.00_r8, & - 0.13_r8, 0.446_r8, -0.10_r8, 0.40_r8, & - -0.006_r8, 0.00_r8, 0.00_r8, 0.00_r8, & - 0.00_r8, 0.00_r8, 0.00_r8, 0.00_r8 / - data a2 / 0.00_r8, -12.0_r8, -11.7_r8, 0.00_r8, & - -0.72_r8,-0.243_r8, 0.19_r8,-0.062_r8, & - 0.414_r8, 0.00_r8, 0.00_r8, 0.00_r8, & - 0.00_r8, 0.00_r8, 0.00_r8, 0.00_r8 / - integer iplon - hvrrtc = '$Revision: 1.3 $' - do iplon=1,ncol - do ibnd = 1,nbndlw - if (ibnd.eq.1 .or. ibnd.eq.4 .or. ibnd.ge.10) then - secdiff(ibnd) = 1.66_r8 - else - secdiff(ibnd) = a0(ibnd) + a1(ibnd)*exp(a2(ibnd)*pwvcm(iplon)) - endif - enddo - if (pwvcm(iplon).lt.1.0) secdiff(6) = 1.80_r8 - if (pwvcm(iplon).gt.7.1) secdiff(7) = 1.50_r8 - urad(0) = 0.0_r8 - drad(0) = 0.0_r8 - totuflux(iplon,0) = 0.0_r8 - totdflux(iplon,0) = 0.0_r8 - clrurad(0) = 0.0_r8 - clrdrad(0) = 0.0_r8 - totuclfl(iplon,0) = 0.0_r8 - totdclfl(iplon,0) = 0.0_r8 - do lay = 1, nlayers - urad(lay) = 0.0_r8 - drad(lay) = 0.0_r8 - totuflux(iplon,lay) = 0.0_r8 - totdflux(iplon,lay) = 0.0_r8 - clrurad(lay) = 0.0_r8 - clrdrad(lay) = 0.0_r8 - totuclfl(iplon,lay) = 0.0_r8 - totdclfl(iplon,lay) = 0.0_r8 - icldlyr(lay) = 0 - ! Change to band loop? - do ig = 1, ngptlw - if (cldfmc(iplon,ig,lay) .eq. 1._r8) then - ib = ngb(ig) - odcld(lay,ig) = secdiff(ib) * taucmc(iplon,ig,lay) - transcld = exp(-odcld(lay,ig)) - abscld(lay,ig) = 1._r8 - transcld - efclfrac(lay,ig) = abscld(lay,ig) * cldfmc(iplon,ig,lay) - icldlyr(lay) = 1 - else - odcld(lay,ig) = 0.0_r8 - abscld(lay,ig) = 0.0_r8 - efclfrac(lay,ig) = 0.0_r8 - endif - enddo - enddo - igc = 1 - ! Loop over frequency bands. - do iband = istart, iend - ! Reinitialize g-point counter for each band if output for each band is requested. - if (iout.gt.0.and.iband.ge.2) igc = ngs(iband-1)+1 - ! Loop over g-channels. - 1000 continue - ! Radiative transfer starts here. - radld = 0._r8 - radclrd = 0._r8 - iclddn = 0 - ! Downward radiative transfer loop. - do lev = nlayers, 1, -1 - plfrac = fracs(iplon,lev,igc) - blay = planklay(iplon,lev,iband) - dplankup = planklev(iplon,lev,iband) - blay - dplankdn = planklev(iplon,lev-1,iband) - blay - odepth = secdiff(iband) * taut(iplon,lev,igc) - if (odepth .lt. 0.0_r8) odepth = 0.0_r8 - ! Cloudy layer - if (icldlyr(lev).eq.1) then - iclddn = 1 - odtot = odepth + odcld(lev,igc) - if (odtot .lt. 0.06_r8) then - atrans(lev) = odepth - 0.5_r8*odepth*odepth - odepth_rec = rec_6*odepth - gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev) - atot(lev) = odtot - 0.5_r8*odtot*odtot - odtot_rec = rec_6*odtot - bbdtot = plfrac * (blay+dplankdn*odtot_rec) - bbd = plfrac*(blay+dplankdn*odepth_rec) - radld = radld - radld * (atrans(lev) + & - efclfrac(lev,igc) * (1. - atrans(lev))) + & - gassrc + cldfmc(iplon,igc,lev) * & - (bbdtot * atot(lev) - gassrc) - drad( lev-1) = drad(lev-1) + radld - bbugas(lev) = plfrac * (blay+dplankup*odepth_rec) - bbutot(lev) = plfrac * (blay+dplankup*odtot_rec) - elseif (odepth .le. 0.06_r8) then - atrans(lev) = odepth - 0.5_r8*odepth*odepth - odepth_rec = rec_6*odepth - gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev) - odtot = odepth + odcld(lev,igc) - tblind = odtot/(bpade+odtot) - ittot = tblint*tblind + 0.5_r8 - tfactot = tfn_tbl(ittot) - bbdtot = plfrac * (blay + tfactot*dplankdn) - bbd = plfrac*(blay+dplankdn*odepth_rec) - atot(lev) = 1. - exp_tbl(ittot) - radld = radld - radld * (atrans(lev) + & - efclfrac(lev,igc) * (1._r8 - atrans(lev))) + & - gassrc + cldfmc(iplon,igc,lev) * & - (bbdtot * atot(lev) - gassrc) - drad(lev-1) = drad(lev-1) + radld - bbugas(lev) = plfrac * (blay + dplankup*odepth_rec) - bbutot(lev) = plfrac * (blay + tfactot * dplankup) - else - tblind = odepth/(bpade+odepth) - itgas = tblint*tblind+0.5_r8 - odepth = tau_tbl(itgas) - atrans(lev) = 1._r8 - exp_tbl(itgas) - tfacgas = tfn_tbl(itgas) - gassrc = atrans(lev) * plfrac * (blay + tfacgas*dplankdn) - odtot = odepth + odcld(lev,igc) - tblind = odtot/(bpade+odtot) - ittot = tblint*tblind + 0.5_r8 - tfactot = tfn_tbl(ittot) - bbdtot = plfrac * (blay + tfactot*dplankdn) - bbd = plfrac*(blay+tfacgas*dplankdn) - atot(lev) = 1._r8 - exp_tbl(ittot) - radld = radld - radld * (atrans(lev) + & - efclfrac(lev,igc) * (1._r8 - atrans(lev))) + & - gassrc + cldfmc(iplon,igc,lev) * & - (bbdtot * atot(lev) - gassrc) - drad(lev-1) = drad(lev-1) + radld - bbugas(lev) = plfrac * (blay + tfacgas * dplankup) - bbutot(lev) = plfrac * (blay + tfactot * dplankup) - endif - ! Clear layer - else - if (odepth .le. 0.06_r8) then - atrans(lev) = odepth-0.5_r8*odepth*odepth - odepth = rec_6*odepth - bbd = plfrac*(blay+dplankdn*odepth) - bbugas(lev) = plfrac*(blay+dplankup*odepth) - else - tblind = odepth/(bpade+odepth) - itr = tblint*tblind+0.5_r8 - transc = exp_tbl(itr) - atrans(lev) = 1._r8-transc - tausfac = tfn_tbl(itr) - bbd = plfrac*(blay+tausfac*dplankdn) - bbugas(lev) = plfrac * (blay + tausfac * dplankup) - endif - radld = radld + (bbd-radld)*atrans(lev) - drad(lev-1) = drad(lev-1) + radld - endif - ! Set clear sky stream to total sky stream as long as layers - ! remain clear. Streams diverge when a cloud is reached (iclddn=1), - ! and clear sky stream must be computed separately from that point. - if (iclddn.eq.1) then - radclrd = radclrd + (bbd-radclrd) * atrans(lev) - clrdrad(lev-1) = clrdrad(lev-1) + radclrd - else - radclrd = radld - clrdrad(lev-1) = drad(lev-1) - endif - enddo - ! Spectral emissivity & reflectance - ! Include the contribution of spectrally varying longwave emissivity - ! and reflection from the surface to the upward radiative transfer. - ! Note: Spectral and Lambertian reflection are identical for the - ! diffusivity angle flux integration used here. - rad0 = fracs(iplon,1,igc) * plankbnd(iplon,iband) - ! Add in specular reflection of surface downward radiance. - reflect = 1._r8 - semiss(iplon,iband) - radlu = rad0 + reflect * radld - radclru = rad0 + reflect * radclrd - ! Upward radiative transfer loop. - urad(0) = urad(0) + radlu - clrurad(0) = clrurad(0) + radclru - do lev = 1, nlayers - ! Cloudy layer - if (icldlyr(lev) .eq. 1) then - gassrc = bbugas(lev) * atrans(lev) - radlu = radlu - radlu * (atrans(lev) + & - efclfrac(lev,igc) * (1._r8 - atrans(lev))) + & - gassrc + cldfmc(iplon,igc,lev) * & - (bbutot(lev) * atot(lev) - gassrc) - urad(lev) = urad(lev) + radlu - ! Clear layer - else - radlu = radlu + (bbugas(lev)-radlu)*atrans(lev) - urad(lev) = urad(lev) + radlu - endif - ! Set clear sky stream to total sky stream as long as all layers - ! are clear (iclddn=0). Streams must be calculated separately at - ! all layers when a cloud is present (ICLDDN=1), because surface - ! reflectance is different for each stream. - if (iclddn.eq.1) then - radclru = radclru + (bbugas(lev)-radclru)*atrans(lev) - clrurad(lev) = clrurad(lev) + radclru - else - radclru = radlu - clrurad(lev) = urad(lev) - endif - enddo - ! Increment g-point counter - igc = igc + 1 - ! Return to continue radiative transfer for all g-channels in present band - if (igc .le. ngs(iband)) go to 1000 - ! Process longwave output from band for total and clear streams. - ! Calculate upward, downward, and net flux. - do lev = nlayers, 0, -1 - uflux(lev) = urad(lev)*wtdiff - dflux(lev) = drad(lev)*wtdiff - urad(lev) = 0.0_r8 - drad(lev) = 0.0_r8 - totuflux(iplon,lev) = totuflux(iplon,lev) + uflux(lev) * delwave(iband) - totdflux(iplon,lev) = totdflux(iplon,lev) + dflux(lev) * delwave(iband) - uclfl(lev) = clrurad(lev)*wtdiff - dclfl(lev) = clrdrad(lev)*wtdiff - clrurad(lev) = 0.0_r8 - clrdrad(lev) = 0.0_r8 - totuclfl(iplon,lev) = totuclfl(iplon,lev) + uclfl(lev) * delwave(iband) - totdclfl(iplon,lev) = totdclfl(iplon,lev) + dclfl(lev) * delwave(iband) - totufluxs(iplon,iband,lev) = uflux(lev) * delwave(iband) - totdfluxs(iplon,iband,lev) = dflux(lev) * delwave(iband) - enddo - ! End spectral band loop - enddo - enddo - do iplon=1,ncol - ! Calculate fluxes at surface - totuflux(iplon,0) = totuflux(iplon,0) * fluxfac - totdflux(iplon,0) = totdflux(iplon,0) * fluxfac - totufluxs(iplon,:,0) = totufluxs(iplon,:,0) * fluxfac - totdfluxs(iplon,:,0) = totdfluxs(iplon,:,0) * fluxfac - fnet(iplon,0) = totuflux(iplon,0) - totdflux(iplon,0) - totuclfl(iplon,0) = totuclfl(iplon,0) * fluxfac - totdclfl(iplon,0) = totdclfl(iplon,0) * fluxfac - fnetc(iplon,0) = totuclfl(iplon,0) - totdclfl(iplon,0) - enddo - ! Calculate fluxes at model levels - do lev = 1, nlayers - do iplon=1,ncol - totuflux(iplon,lev) = totuflux(iplon,lev) * fluxfac - totdflux(iplon,lev) = totdflux(iplon,lev) * fluxfac - totufluxs(iplon,:,lev) = totufluxs(iplon,:,lev) * fluxfac - totdfluxs(iplon,:,lev) = totdfluxs(iplon,:,lev) * fluxfac - fnet(iplon,lev) = totuflux(iplon,lev) - totdflux(iplon,lev) - totuclfl(iplon,lev) = totuclfl(iplon,lev) * fluxfac - totdclfl(iplon,lev) = totdclfl(iplon,lev) * fluxfac - fnetc(iplon,lev) = totuclfl(iplon,lev) - totdclfl(iplon,lev) - l = lev - 1 - ! Calculate heating rates at model layers - htr(iplon,l)=heatfac*(fnet(iplon,l)-fnet(iplon,lev))/(pz(iplon,l)-pz(iplon,lev)) - htrc(iplon,l)=heatfac*(fnetc(iplon,l)-fnetc(iplon,lev))/(pz(iplon,l)-pz(iplon,lev)) - enddo - enddo - ! Set heating rate to zero in top layer - do iplon=1,ncol - htr(iplon,nlayers) = 0.0_r8 - htrc(iplon,nlayers) = 0.0_r8 - enddo - END SUBROUTINE rtrnmc -#endif - - END MODULE rrtmg_lw_rtrnmc diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrtmg_lw_setcoef.F90 b/test/ncar_kernels/PORT_lw_rad/src/rrtmg_lw_setcoef.F90 deleted file mode 100644 index 75157592da..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrtmg_lw_setcoef.F90 +++ /dev/null @@ -1,864 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_lw_setcoef.f90 -! Generated at: 2015-07-06 23:28:43 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_lw_setcoef - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! ------- Modules ------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE rrlw_wvn, ONLY: totplnk - USE rrlw_wvn, ONLY: totplk16 - USE rrlw_ref, only : preflog - USE rrlw_ref, only : tref - USE rrlw_ref, only : chi_mls - USE rrlw_vsn, ONLY: hvrset - USE parrrtm, ONLY: mxmol - USE parrrtm, ONLY: maxxsec - USE parrrtm, ONLY: nbndlw - USE parrrtm, ONLY: ngptlw - - IMPLICIT NONE -#ifdef OLD_SETCOEF - public :: setcoef_old -#else - public :: setcoef -#endif - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !---------------------------------------------------------------------------- - -#ifdef OLD_SETCOEF - SUBROUTINE setcoef_old(nlayers, istart, pavel, tavel, tz, tbound, semiss, coldry, wkl, wbroad, laytrop, jp, jt, jt1, planklay,& - planklev, plankbnd, colh2o, colco2, colo3, coln2o, colco, colch4, colo2, colbrd, fac00, fac01, fac10, fac11, rat_h2oco2, & - rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, rat_n2oco2, rat_n2oco2_1, & - rat_o3co2, rat_o3co2_1, selffac, selffrac, indself, forfac, forfrac, indfor, minorfrac, scaleminor, scaleminorn2, & - indminor) - !---------------------------------------------------------------------------- - ! - ! Purpose: For a given atmosphere, calculate the indices and - ! fractions related to the pressure and temperature interpolations. - ! Also calculate the values of the integrated Planck functions - ! for each band at the level and layer temperatures. - ! ------- Declarations ------- - ! ----- Input ----- - INTEGER, intent(in) :: nlayers ! total number of layers - INTEGER, intent(in) :: istart ! beginning band of calculation - REAL(KIND=r8), intent(in) :: pavel(:) ! layer pressures (mb) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: tavel(:) ! layer temperatures (K) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: tz(0:) ! level (interface) temperatures (K) - ! Dimensions: (0:nlayers) - REAL(KIND=r8), intent(in) :: tbound ! surface temperature (K) - REAL(KIND=r8), intent(in) :: coldry(:) ! dry air column density (mol/cm2) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: wbroad(:) ! broadening gas column density (mol/cm2) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: wkl(:,:) ! molecular amounts (mol/cm-2) - ! Dimensions: (mxmol,nlayers) - REAL(KIND=r8), intent(in) :: semiss(:) ! lw surface emissivity - ! Dimensions: (nbndlw) - ! ----- Output ----- - INTEGER, intent(out) :: laytrop ! tropopause layer index - INTEGER, intent(out) :: jp(:) ! - ! Dimensions: (nlayers) - INTEGER, intent(out) :: jt(:) ! - ! Dimensions: (nlayers) - INTEGER, intent(out) :: jt1(:) ! - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: planklay(:,:) ! - ! Dimensions: (nlayers,nbndlw) - REAL(KIND=r8), intent(out) :: planklev(0:,:) ! - ! Dimensions: (0:nlayers,nbndlw) - REAL(KIND=r8), intent(out) :: plankbnd(:) ! - ! Dimensions: (nbndlw) - REAL(KIND=r8), intent(out) :: colh2o(:) ! column amount (h2o) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: colco2(:) ! column amount (co2) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: colo3(:) ! column amount (o3) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: coln2o(:) ! column amount (n2o) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: colco(:) ! column amount (co) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: colch4(:) ! column amount (ch4) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: colo2(:) ! column amount (o2) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: colbrd(:) ! column amount (broadening gases) - ! Dimensions: (nlayers) - INTEGER, intent(out) :: indself(:) - ! Dimensions: (nlayers) - INTEGER, intent(out) :: indfor(:) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: selffac(:) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: selffrac(:) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: forfac(:) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: forfrac(:) - ! Dimensions: (nlayers) - INTEGER, intent(out) :: indminor(:) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: minorfrac(:) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: scaleminor(:) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: scaleminorn2(:) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: fac00(:) - REAL(KIND=r8), intent(out) :: fac01(:) - REAL(KIND=r8), intent(out) :: fac10(:) - REAL(KIND=r8), intent(out) :: fac11(:) ! - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: rat_h2och4(:) - REAL(KIND=r8), intent(out) :: rat_h2on2o(:) - REAL(KIND=r8), intent(out) :: rat_h2on2o_1(:) - REAL(KIND=r8), intent(out) :: rat_o3co2_1(:) - REAL(KIND=r8), intent(out) :: rat_h2och4_1(:) - REAL(KIND=r8), intent(out) :: rat_n2oco2_1(:) - REAL(KIND=r8), intent(out) :: rat_h2oo3_1(:) - REAL(KIND=r8), intent(out) :: rat_n2oco2(:) - REAL(KIND=r8), intent(out) :: rat_h2oco2(:) - REAL(KIND=r8), intent(out) :: rat_h2oco2_1(:) - REAL(KIND=r8), intent(out) :: rat_h2oo3(:) - REAL(KIND=r8), intent(out) :: rat_o3co2(:) ! - ! Dimensions: (nlayers) - ! ----- Local ----- - INTEGER :: indbound - INTEGER :: indlev0 - INTEGER :: lay - INTEGER :: indlay - INTEGER :: indlev - INTEGER :: iband - INTEGER :: jp1 - REAL(KIND=r8) :: stpfac - REAL(KIND=r8) :: tbndfrac - REAL(KIND=r8) :: t0frac - REAL(KIND=r8) :: tlayfrac - REAL(KIND=r8) :: tlevfrac - REAL(KIND=r8) :: dbdtlev - REAL(KIND=r8) :: dbdtlay - REAL(KIND=r8) :: plog - REAL(KIND=r8) :: fp - REAL(KIND=r8) :: ft - REAL(KIND=r8) :: ft1 - REAL(KIND=r8) :: water - REAL(KIND=r8) :: scalefac - REAL(KIND=r8) :: factor - REAL(KIND=r8) :: compfp - hvrset = '$Revision: 1.2 $' - stpfac = 296._r8/1013._r8 - indbound = tbound - 159._r8 - if (indbound .lt. 1) then - indbound = 1 - elseif (indbound .gt. 180) then - indbound = 180 - endif - tbndfrac = tbound - 159._r8 - float(indbound) - indlev0 = tz(0) - 159._r8 - if (indlev0 .lt. 1) then - indlev0 = 1 - elseif (indlev0 .gt. 180) then - indlev0 = 180 - endif - t0frac = tz(0) - 159._r8 - float(indlev0) - laytrop = 0 - ! Begin layer loop - ! Calculate the integrated Planck functions for each band at the - ! surface, level, and layer temperatures. - do lay = 1, nlayers - indlay = tavel(lay) - 159._r8 - if (indlay .lt. 1) then - indlay = 1 - elseif (indlay .gt. 180) then - indlay = 180 - endif - tlayfrac = tavel(lay) - 159._r8 - float(indlay) - indlev = tz(lay) - 159._r8 - if (indlev .lt. 1) then - indlev = 1 - elseif (indlev .gt. 180) then - indlev = 180 - endif - tlevfrac = tz(lay) - 159._r8 - float(indlev) - ! Begin spectral band loop - do iband = 1, 15 - if (lay.eq.1) then - dbdtlev = totplnk(indbound+1,iband) - totplnk(indbound,iband) - plankbnd(iband) = semiss(iband) * & - (totplnk(indbound,iband) + tbndfrac * dbdtlev) - dbdtlev = totplnk(indlev0+1,iband)-totplnk(indlev0,iband) - planklev(0,iband) = totplnk(indlev0,iband) + t0frac * dbdtlev - endif - dbdtlev = totplnk(indlev+1,iband) - totplnk(indlev,iband) - dbdtlay = totplnk(indlay+1,iband) - totplnk(indlay,iband) - planklay(lay,iband) = totplnk(indlay,iband) + tlayfrac * dbdtlay - planklev(lay,iband) = totplnk(indlev,iband) + tlevfrac * dbdtlev - enddo - ! For band 16, if radiative transfer will be performed on just - ! this band, use integrated Planck values up to 3250 cm-1. - ! If radiative transfer will be performed across all 16 bands, - ! then include in the integrated Planck values for this band - ! contributions from 2600 cm-1 to infinity. - iband = 16 - if (istart .eq. 16) then - if (lay.eq.1) then - dbdtlev = totplk16(indbound+1) - totplk16(indbound) - plankbnd(iband) = semiss(iband) * & - (totplk16(indbound) + tbndfrac * dbdtlev) - dbdtlev = totplnk(indlev0+1,iband)-totplnk(indlev0,iband) - planklev(0,iband) = totplk16(indlev0) + & - t0frac * dbdtlev - endif - dbdtlev = totplk16(indlev+1) - totplk16(indlev) - dbdtlay = totplk16(indlay+1) - totplk16(indlay) - planklay(lay,iband) = totplk16(indlay) + tlayfrac * dbdtlay - planklev(lay,iband) = totplk16(indlev) + tlevfrac * dbdtlev - else - if (lay.eq.1) then - dbdtlev = totplnk(indbound+1,iband) - totplnk(indbound,iband) - plankbnd(iband) = semiss(iband) * & - (totplnk(indbound,iband) + tbndfrac * dbdtlev) - dbdtlev = totplnk(indlev0+1,iband)-totplnk(indlev0,iband) - planklev(0,iband) = totplnk(indlev0,iband) + t0frac * dbdtlev - endif - dbdtlev = totplnk(indlev+1,iband) - totplnk(indlev,iband) - dbdtlay = totplnk(indlay+1,iband) - totplnk(indlay,iband) - planklay(lay,iband) = totplnk(indlay,iband) + tlayfrac * dbdtlay - planklev(lay,iband) = totplnk(indlev,iband) + tlevfrac * dbdtlev - endif - ! Find the two reference pressures on either side of the - ! layer pressure. Store them in JP and JP1. Store in FP the - ! fraction of the difference (in ln(pressure)) between these - ! two values that the layer pressure lies. - ! plog = alog(pavel(lay)) - plog = dlog(pavel(lay)) - jp(lay) = int(36._r8 - 5*(plog+0.04_r8)) - if (jp(lay) .lt. 1) then - jp(lay) = 1 - elseif (jp(lay) .gt. 58) then - jp(lay) = 58 - endif - jp1 = jp(lay) + 1 - fp = 5._r8 *(preflog(jp(lay)) - plog) - ! Determine, for each reference pressure (JP and JP1), which - ! reference temperature (these are different for each - ! reference pressure) is nearest the layer temperature but does - ! not exceed it. Store these indices in JT and JT1, resp. - ! Store in FT (resp. FT1) the fraction of the way between JT - ! (JT1) and the next highest reference temperature that the - ! layer temperature falls. - jt(lay) = int(3._r8 + (tavel(lay)-tref(jp(lay)))/15._r8) - if (jt(lay) .lt. 1) then - jt(lay) = 1 - elseif (jt(lay) .gt. 4) then - jt(lay) = 4 - endif - ft = ((tavel(lay)-tref(jp(lay)))/15._r8) - float(jt(lay)-3) - jt1(lay) = int(3._r8 + (tavel(lay)-tref(jp1))/15._r8) - if (jt1(lay) .lt. 1) then - jt1(lay) = 1 - elseif (jt1(lay) .gt. 4) then - jt1(lay) = 4 - endif - ft1 = ((tavel(lay)-tref(jp1))/15._r8) - float(jt1(lay)-3) - water = wkl(1,lay)/coldry(lay) - scalefac = pavel(lay) * stpfac / tavel(lay) - ! If the pressure is less than ~100mb, perform a different - ! set of species interpolations. - if (plog .le. 4.56_r8) go to 5300 - laytrop = laytrop + 1 - forfac(lay) = scalefac / (1.+water) - factor = (332.0_r8-tavel(lay))/36.0_r8 - indfor(lay) = min(2, max(1, int(factor))) - forfrac(lay) = factor - float(indfor(lay)) - ! Set up factors needed to separately include the water vapor - ! self-continuum in the calculation of absorption coefficient. - selffac(lay) = water * forfac(lay) - factor = (tavel(lay)-188.0_r8)/7.2_r8 - indself(lay) = min(9, max(1, int(factor)-7)) - selffrac(lay) = factor - float(indself(lay) + 7) - ! Set up factors needed to separately include the minor gases - ! in the calculation of absorption coefficient - scaleminor(lay) = pavel(lay)/tavel(lay) - scaleminorn2(lay) = (pavel(lay)/tavel(lay)) & - *(wbroad(lay)/(coldry(lay)+wkl(1,lay))) - factor = (tavel(lay)-180.8_r8)/7.2_r8 - indminor(lay) = min(18, max(1, int(factor))) - minorfrac(lay) = factor - float(indminor(lay)) - ! Setup reference ratio to be used in calculation of binary - ! species parameter in lower atmosphere. - rat_h2oco2(lay)=chi_mls(1,jp(lay))/chi_mls(2,jp(lay)) - rat_h2oco2_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(2,jp(lay)+1) - rat_h2oo3(lay)=chi_mls(1,jp(lay))/chi_mls(3,jp(lay)) - rat_h2oo3_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(3,jp(lay)+1) - rat_h2on2o(lay)=chi_mls(1,jp(lay))/chi_mls(4,jp(lay)) - rat_h2on2o_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(4,jp(lay)+1) - rat_h2och4(lay)=chi_mls(1,jp(lay))/chi_mls(6,jp(lay)) - rat_h2och4_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(6,jp(lay)+1) - rat_n2oco2(lay)=chi_mls(4,jp(lay))/chi_mls(2,jp(lay)) - rat_n2oco2_1(lay)=chi_mls(4,jp(lay)+1)/chi_mls(2,jp(lay)+1) - ! Calculate needed column amounts. - colh2o(lay) = 1.e-20_r8 * wkl(1,lay) - colco2(lay) = 1.e-20_r8 * wkl(2,lay) - colo3(lay) = 1.e-20_r8 * wkl(3,lay) - coln2o(lay) = 1.e-20_r8 * wkl(4,lay) - colco(lay) = 1.e-20_r8 * wkl(5,lay) - colch4(lay) = 1.e-20_r8 * wkl(6,lay) - colo2(lay) = 1.e-20_r8 * wkl(7,lay) - if (colco2(lay) .eq. 0._r8) colco2(lay) = 1.e-32_r8 * coldry(lay) - if (colo3(lay) .eq. 0._r8) colo3(lay) = 1.e-32_r8 * coldry(lay) - if (coln2o(lay) .eq. 0._r8) coln2o(lay) = 1.e-32_r8 * coldry(lay) - if (colco(lay) .eq. 0._r8) colco(lay) = 1.e-32_r8 * coldry(lay) - if (colch4(lay) .eq. 0._r8) colch4(lay) = 1.e-32_r8 * coldry(lay) - colbrd(lay) = 1.e-20_r8 * wbroad(lay) - go to 5400 - ! Above laytrop. - 5300 continue - forfac(lay) = scalefac / (1.+water) - factor = (tavel(lay)-188.0_r8)/36.0_r8 - indfor(lay) = 3 - forfrac(lay) = factor - 1.0_r8 - ! Set up factors needed to separately include the water vapor - ! self-continuum in the calculation of absorption coefficient. - selffac(lay) = water * forfac(lay) - ! Set up factors needed to separately include the minor gases - ! in the calculation of absorption coefficient - scaleminor(lay) = pavel(lay)/tavel(lay) - scaleminorn2(lay) = (pavel(lay)/tavel(lay)) & - * (wbroad(lay)/(coldry(lay)+wkl(1,lay))) - factor = (tavel(lay)-180.8_r8)/7.2_r8 - indminor(lay) = min(18, max(1, int(factor))) - minorfrac(lay) = factor - float(indminor(lay)) - ! Setup reference ratio to be used in calculation of binary - ! species parameter in upper atmosphere. - rat_h2oco2(lay)=chi_mls(1,jp(lay))/chi_mls(2,jp(lay)) - rat_h2oco2_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(2,jp(lay)+1) - rat_o3co2(lay)=chi_mls(3,jp(lay))/chi_mls(2,jp(lay)) - rat_o3co2_1(lay)=chi_mls(3,jp(lay)+1)/chi_mls(2,jp(lay)+1) - ! Calculate needed column amounts. - colh2o(lay) = 1.e-20_r8 * wkl(1,lay) - colco2(lay) = 1.e-20_r8 * wkl(2,lay) - colo3(lay) = 1.e-20_r8 * wkl(3,lay) - coln2o(lay) = 1.e-20_r8 * wkl(4,lay) - colco(lay) = 1.e-20_r8 * wkl(5,lay) - colch4(lay) = 1.e-20_r8 * wkl(6,lay) - colo2(lay) = 1.e-20_r8 * wkl(7,lay) - if (colco2(lay) .eq. 0._r8) colco2(lay) = 1.e-32_r8 * coldry(lay) - if (colo3(lay) .eq. 0._r8) colo3(lay) = 1.e-32_r8 * coldry(lay) - if (coln2o(lay) .eq. 0._r8) coln2o(lay) = 1.e-32_r8 * coldry(lay) - if (colco(lay) .eq. 0._r8) colco(lay) = 1.e-32_r8 * coldry(lay) - if (colch4(lay) .eq. 0._r8) colch4(lay) = 1.e-32_r8 * coldry(lay) - colbrd(lay) = 1.e-20_r8 * wbroad(lay) - 5400 continue - ! We have now isolated the layer ln pressure and temperature, - ! between two reference pressures and two reference temperatures - ! (for each reference pressure). We multiply the pressure - ! fraction FP with the appropriate temperature fractions to get - ! the factors that will be needed for the interpolation that yields - ! the optical depths (performed in routines TAUGBn for band n).` - compfp = 1. - fp - fac10(lay) = compfp * ft - fac00(lay) = compfp * (1._r8 - ft) - fac11(lay) = fp * ft1 - fac01(lay) = fp * (1._r8 - ft1) - ! Rescale selffac and forfac for use in taumol - selffac(lay) = colh2o(lay)*selffac(lay) - forfac(lay) = colh2o(lay)*forfac(lay) - ! End layer loop - enddo - END SUBROUTINE setcoef_old -#else - SUBROUTINE setcoef(ncol,nlayers, istart, pavel, tavel, tz, tbound, semiss, coldry, wkl, wbroad, laytrop, jp, jt, jt1, planklay,& - planklev, plankbnd, colh2o, colco2, colo3, coln2o, colco, colch4, colo2, colbrd, fac00, fac01, fac10, fac11, rat_h2oco2, & - rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, rat_n2oco2, rat_n2oco2_1, & - rat_o3co2, rat_o3co2_1, selffac, selffrac, indself, forfac, forfrac, indfor, minorfrac, scaleminor, scaleminorn2, & - indminor) - !---------------------------------------------------------------------------- - ! - ! Purpose: For a given atmosphere, calculate the indices and - ! fractions related to the pressure and temperature interpolations. - ! Also calculate the values of the integrated Planck functions - ! for each band at the level and layer temperatures. - ! ------- Declarations ------- - ! ----- Input ----- - INTEGER, intent(in) :: ncol !number of simd columns - INTEGER, intent(in) :: nlayers ! total number of layers - INTEGER, intent(in) :: istart ! beginning band of calculation - REAL(KIND=r8), intent(in) :: pavel(ncol,nlayers) ! layer pressures (mb) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: tavel(ncol,nlayers)! layer temperatures (K) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: tz(ncol,0:nlayers) ! level (interface) temperatures (K) - ! Dimensions: (0:nlayers) - REAL(KIND=r8), intent(in) :: tbound(ncol)! surface temperature (K) - REAL(KIND=r8), intent(in) :: coldry(ncol,nlayers) ! dry air column density (mol/cm2) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: wbroad(ncol,nlayers) ! broadening gas column density (mol/cm2) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: wkl(ncol,mxmol,nlayers) ! molecular amounts (mol/cm-2) - ! Dimensions: (ncol,mxmol,nlayers) - REAL(KIND=r8), intent(in) :: semiss(ncol,nbndlw) ! lw surface emissivity - ! Dimensions: (nbndlw) - ! ----- Output ----- - INTEGER, intent(out),dimension(:) :: laytrop ! tropopause layer index - INTEGER, intent(out) :: jp(ncol,nlayers) ! - ! Dimensions: (nlayers) - INTEGER, intent(out) :: jt(ncol,nlayers) ! - ! Dimensions: (nlayers) - INTEGER, intent(out) :: jt1(ncol,nlayers) ! - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: planklay(ncol,nlayers,nbndlw) ! - ! Dimensions: (ncol,nlayers,nbndlw) - REAL(KIND=r8), intent(out) :: planklev(ncol,0:nlayers,nbndlw) ! - ! Dimensions: (ncol,0:nlayers,nbndlw) - REAL(KIND=r8), intent(out) :: plankbnd(ncol,nbndlw) ! - ! Dimensions: (ncol,nbndlw) - REAL(KIND=r8), intent(out) :: colh2o(ncol,nlayers) ! column amount (h2o) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: colco2(ncol,nlayers) ! column amount (co2) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: colo3(ncol,nlayers) ! column amount (o3) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: coln2o(ncol,nlayers) ! column amount (n2o) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: colco(ncol,nlayers) ! column amount (co) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: colch4(ncol,nlayers) ! column amount (ch4) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: colo2(ncol,nlayers) ! column amount (o2) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: colbrd(ncol,nlayers) ! column amount (broadening gases) - ! Dimensions: (nlayers) - INTEGER, intent(out) :: indself(ncol,nlayers) - ! Dimensions: (nlayers) - INTEGER, intent(out) :: indfor(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: selffac(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: selffrac(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: forfac(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: forfrac(ncol,nlayers) - ! Dimensions: (nlayers) - INTEGER, intent(out) :: indminor(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: minorfrac(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: scaleminor(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: scaleminorn2(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: fac00(ncol,nlayers) - REAL(KIND=r8), intent(out) :: fac01(ncol,nlayers) - REAL(KIND=r8), intent(out) :: fac10(ncol,nlayers) - REAL(KIND=r8), intent(out) :: fac11(ncol,nlayers) ! - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: rat_h2och4(ncol,nlayers) - REAL(KIND=r8), intent(out) :: rat_h2on2o(ncol,nlayers) - REAL(KIND=r8), intent(out) :: rat_h2on2o_1(ncol,nlayers) - REAL(KIND=r8), intent(out) :: rat_o3co2_1(ncol,nlayers) - REAL(KIND=r8), intent(out) :: rat_h2och4_1(ncol,nlayers) - REAL(KIND=r8), intent(out) :: rat_n2oco2_1(ncol,nlayers) - REAL(KIND=r8), intent(out) :: rat_h2oo3_1(ncol,nlayers) - REAL(KIND=r8), intent(out) :: rat_n2oco2(ncol,nlayers) - REAL(KIND=r8), intent(out) :: rat_h2oco2(ncol,nlayers) - REAL(KIND=r8), intent(out) :: rat_h2oco2_1(ncol,nlayers) - REAL(KIND=r8), intent(out) :: rat_h2oo3(ncol,nlayers) - REAL(KIND=r8), intent(out) :: rat_o3co2(ncol,nlayers)! - ! Dimensions: (nlayers) - INTEGER :: indbound(1:ncol) - INTEGER :: indlev0(1:ncol) - INTEGER :: lay - - INTEGER :: icol - - INTEGER :: indlay(1:ncol) - INTEGER :: indlev(1:ncol) - INTEGER :: iband - INTEGER :: jp1(1:ncol,1:nlayers) - REAL(KIND=r8) :: stpfac - REAL(KIND=r8) :: tbndfrac(1:ncol) - REAL(KIND=r8) :: t0frac(1:ncol) - REAL(KIND=r8) :: tlayfrac(1:ncol) - REAL(KIND=r8) :: tlevfrac(1:ncol) - REAL(KIND=r8) :: dbdtlev(1:ncol) - REAL(KIND=r8) :: dbdtlay(1:ncol) - REAL(KIND=r8) :: plog(1:ncol) - REAL(KIND=r8) :: fp(1:ncol) - REAL(KIND=r8) :: ft(1:ncol) - REAL(KIND=r8) :: ft1(1:ncol) - REAL(KIND=r8) :: water(1:ncol) - REAL(KIND=r8) :: scalefac(1:ncol) - REAL(KIND=r8) :: factor(1:ncol) - REAL(KIND=r8) :: compfp(1:ncol) - hvrset = '$Revision: 1.2 $' - - !dir$ assume_aligned tz:64 - !dir$ assume_aligned tavel:64 - !dir$ assume_aligned pavel:64 - !dir$ assume_aligned planklay:64 - !dir$ assume_aligned planklev:64 - !dir$ assume_aligned plankbnd:64 - !dir$ assume_aligned pavel:64 - !dir$ assume_aligned jp:64 - !dir$ assume_aligned jp1:64 - !dir$ assume_aligned jt:64 - !dir$ assume_aligned jt1:64 - !dir$ assume_aligned wkl:64 - !dir$ assume_aligned coldry:64 - stpfac = 296._r8/1013._r8 - !dir$ vector aligned - !dir$ SIMD - do icol=1,ncol - indbound(icol) = tbound(icol) - 159._r8 - if (indbound(icol) .lt. 1) then - indbound(icol) = 1 - elseif (indbound(icol) .gt. 180) then - indbound(icol) = 180 - endif - tbndfrac(icol) = tbound(icol) - 159._r8 - float(indbound(icol)) - indlev0(icol) = tz(icol,0) - 159._r8 - if (indlev0(icol) .lt. 1) then - indlev0(icol) = 1 - elseif (indlev0(icol) .gt. 180) then - indlev0(icol) = 180 - endif - t0frac(icol) = tz(icol,0) - 159._r8 - float(indlev0(icol)) - laytrop(icol) = 0 - - ! Begin layer loop - ! Calculate the integrated Planck functions for each band at the - ! surface, level, and layer temperatures. - end do - - do lay = 1, nlayers - - !dir$ vector aligned - !dir$ SIMD - do icol=1,ncol - indlay(icol) = tavel(icol,lay) - 159._r8 - - if (indlay(icol) .lt. 1) then - indlay(icol) = 1 - elseif (indlay(icol) .gt. 180) then - indlay(icol) = 180 - endif - - tlayfrac(icol) = tavel(icol,lay) - 159._r8 - float(indlay(icol)) ! - - indlev(icol) = tz(icol,lay) - 159._r8 - - if (indlev(icol) .lt. 1) then - indlev(icol) = 1 - elseif (indlev(icol) .gt. 180) then - indlev(icol) = 180 - endif - - tlevfrac(icol) = tz(icol,lay) - 159._r8 - float(indlev(icol)) ! - - ! Begin spectral band loop - end do ! end of icol loop - - do iband = 1, 15 - - !dir$ vector aligned - !dir$ SIMD - do icol=1,ncol - if (lay.eq.1) then - !print*,'inside iband : lay = 1 loop',lay - dbdtlev(icol) = totplnk(indbound(icol)+1,iband) - totplnk(indbound(icol),iband) - plankbnd(icol,iband) = semiss(icol,iband) * & - (totplnk(indbound(icol),iband) + tbndfrac(icol) * dbdtlev(icol)) - dbdtlev(icol) = totplnk(indlev0(icol)+1,iband)-totplnk(indlev0(icol),iband) - planklev(icol,0,iband) = totplnk(indlev0(icol),iband) + t0frac(icol) * dbdtlev(icol) - endif - end do - !dir$ vector aligned - !dir$ SIMD - do icol=1,ncol - dbdtlev(icol) = totplnk(indlev(icol)+1,iband) - totplnk(indlev(icol),iband) - dbdtlay(icol) = totplnk(indlay(icol)+1,iband) - totplnk(indlay(icol),iband) - planklay(icol,lay,iband) = totplnk(indlay(icol),iband) + tlayfrac(icol) * dbdtlay(icol) - planklev(icol,lay,iband) = totplnk(indlev(icol),iband) + tlevfrac(icol) * dbdtlev(icol) - ! print *,'exiting iband loop',iband - end do ! end of icol loop - enddo - - ! For band 16, if radiative transfer will be performed on just - ! this band, use integrated Planck values up to 3250 cm-1. - ! If radiative transfer will be performed across all 16 bands, - ! then include in the integrated Planck values for this band - ! contributions from 2600 cm-1 to infinity. - - iband = 16 - if (istart .eq. 16) then - ! print*,'iband ::::',iband - if (lay.eq.1) then - !dir$ vector aligned - !dir$ SIMD - do icol=1,ncol - dbdtlev(icol) = totplk16(indbound(icol)+1) - totplk16(indbound(icol)) - plankbnd(icol,iband) = semiss(icol,iband) * & - (totplk16(indbound(icol)) + tbndfrac(icol) * dbdtlev(icol)) - dbdtlev(icol) = totplnk(indlev0(icol)+1,iband)-totplnk(indlev0(icol),iband) - planklev(icol,0,iband) = totplk16(indlev0(icol)) + & - t0frac(icol) * dbdtlev(icol) - end do - endif - - !dir$ vector aligned - !dir$ SIMD - do icol=1,ncol - dbdtlev(icol) = totplk16(indlev(icol)+1) - totplk16(indlev(icol)) - dbdtlay(icol) = totplk16(indlay(icol)+1) - totplk16(indlay(icol)) - planklay(icol,lay,iband) = totplk16(indlay(icol)) + tlayfrac(icol) * dbdtlay(icol) - planklev(icol,lay,iband) = totplk16(indlev(icol)) + tlevfrac(icol) * dbdtlev(icol) - end do - else - if (lay.eq.1) then - - !dir$ vector aligned - !dir$ SIMD - do icol=1,ncol - dbdtlev(icol) = totplnk(indbound(icol)+1,iband) - totplnk(indbound(icol),iband) - - plankbnd(icol,iband) = semiss(icol,iband) * & - (totplnk(indbound(icol),iband) + tbndfrac(icol) * dbdtlev(icol)) - dbdtlev(icol) = totplnk(indlev0(icol)+1,iband)-totplnk(indlev0(icol),iband) - planklev(icol,0,iband) = totplnk(indlev0(icol),iband) + t0frac(icol) * dbdtlev(icol) - end do - endif - - !dir$ vector aligned - !dir$ SIMD - do icol=1,ncol - dbdtlev(icol) = totplnk(indlev(icol)+1,iband) - totplnk(indlev(icol),iband) - dbdtlay(icol) = totplnk(indlay(icol)+1,iband) - totplnk(indlay(icol),iband) - planklay(icol,lay,iband) = totplnk(indlay(icol),iband) + tlayfrac(icol) * dbdtlay(icol) - planklev(icol,lay,iband) = totplnk(indlev(icol),iband) + tlevfrac(icol) * dbdtlev(icol) - end do - endif - - ! Find the two reference pressures on either side of the - ! layer pressure. Store them in JP and JP1. Store in FP the - ! fraction of the difference (in ln(pressure)) between these - ! two values that the layer pressure lies. - ! plog = alog(pavel(lay)) - - !dir$ vector aligned - !dir$ SIMD - do icol=1,ncol - plog(icol) = dlog(pavel(icol,lay)) - jp(icol,lay) = int(36._r8 - 5*(plog(icol)+0.04_r8)) - - if (jp(icol,lay) .lt. 1) then - jp(icol,lay) = 1 - elseif (jp(icol,lay) .gt. 58) then - jp(icol,lay) = 58 - endif - jp1(icol,lay) = jp(icol,lay) + 1 - fp(icol) = 5._r8 *(preflog(jp(icol,lay)) - plog(icol)) - - ! Determine, for each reference pressure (JP and JP1), which - ! reference temperature (these are different for each - ! reference pressure) is nearest the layer temperature but does - ! not exceed it. Store these indices in JT and JT1, resp. - ! Store in FT (resp. FT1) the fraction of the way between JT - ! (JT1) and the next highest reference temperature that the - ! layer temperature falls. - ! (JT1) and the next highest reference temperature that the - ! layer temperature falls. - - jt(icol,lay) = int(3._r8 + (tavel(icol,lay)-tref(jp(icol,lay)))/15._r8) - if (jt(icol,lay) .lt. 1) then - jt(icol,lay) = 1 - elseif (jt(icol,lay) .gt. 4) then - jt(icol,lay) = 4 - endif - - ft(icol) = ((tavel(icol,lay)-tref(jp(icol,lay)))/15._r8) - float(jt(icol,lay)-3) - jt1(icol,lay) = int(3._r8 + (tavel(icol,lay)-tref(jp1(icol,lay)))/15._r8) - - if (jt1(icol,lay) .lt. 1) then - jt1(icol,lay) = 1 - elseif (jt1(icol,lay) .gt. 4) then - jt1(icol,lay) = 4 - endif - - ft1(icol) = ((tavel(icol,lay)-tref(jp1(icol,lay)))/15._r8) - float(jt1(icol,lay)-3) - water(icol) = wkl(icol,1,lay)/coldry(icol,lay) - scalefac(icol) = pavel(icol,lay) * stpfac / tavel(icol,lay) - ! If the pressure is less than ~100mb, perform a different - ! set of species interpolations. - - if (plog(icol) .le. 4.56_r8) then - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - forfac(icol,lay) = scalefac(icol) / (1.+water(icol)) - factor(icol) = (tavel(icol,lay)-188.0_r8)/36.0_r8 - indfor(icol,lay) = 3 - forfrac(icol,lay) = factor(icol) - 1.0_r8 - - ! Set up factors needed to separately include the water vapor - ! self-continuum in the calculation of absorption coefficient. - - selffac(icol,lay) = water(icol) * forfac(icol,lay) - - ! Set up factors needed to separately include the minor gases - ! in the calculation of absorption coefficient - - scaleminor(icol,lay) = pavel(icol,lay)/tavel(icol,lay) - scaleminorn2(icol,lay) = (pavel(icol,lay)/tavel(icol,lay)) & - * (wbroad(icol,lay)/(coldry(icol,lay)+wkl(icol,1,lay))) - factor(icol) = (tavel(icol,lay)-180.8_r8)/7.2_r8 - indminor(icol,lay) = min(18, max(1, int(factor(icol)))) - minorfrac(icol,lay) = factor(icol) - float(indminor(icol,lay)) - - ! Setup reference ratio to be used in calculation of binary - ! species parameter in upper atmosphere. - - rat_h2oco2(icol,lay)=chi_mls(1,jp(icol,lay))/chi_mls(2,jp(icol,lay)) - rat_h2oco2_1(icol,lay)=chi_mls(1,jp(icol,lay)+1)/chi_mls(2,jp(icol,lay)+1) - rat_o3co2(icol,lay)=chi_mls(3,jp(icol,lay))/chi_mls(2,jp(icol,lay)) - rat_o3co2_1(icol,lay)=chi_mls(3,jp(icol,lay)+1)/chi_mls(2,jp(icol,lay)+1) - - ! Calculate needed column amounts. - ! Calculate needed column amounts. - - colh2o(icol,lay) = 1.e-20_r8 * wkl(icol,1,lay) - colco2(icol,lay) = 1.e-20_r8 * wkl(icol,2,lay) - colo3(icol,lay) = 1.e-20_r8 * wkl(icol,3,lay) - coln2o(icol,lay) = 1.e-20_r8 * wkl(icol,4,lay) - colco(icol,lay) = 1.e-20_r8 * wkl(icol,5,lay) - colch4(icol,lay) = 1.e-20_r8 * wkl(icol,6,lay) - colo2(icol,lay) = 1.e-20_r8 * wkl(icol,7,lay) - if (colco2(icol,lay) .eq. 0._r8) colco2(icol,lay) = 1.e-32_r8 * coldry(icol,lay) - if (colo3(icol,lay) .eq. 0._r8) colo3(icol,lay) = 1.e-32_r8 * coldry(icol,lay) - if (coln2o(icol,lay) .eq. 0._r8) coln2o(icol,lay) = 1.e-32_r8 * coldry(icol,lay) - if (colco(icol,lay) .eq. 0._r8) colco(icol,lay) = 1.e-32_r8 * coldry(icol,lay) - if (colch4(icol,lay) .eq. 0._r8) colch4(icol,lay) = 1.e-32_r8 * coldry(icol,lay) - colbrd(icol,lay) = 1.e-20_r8 * wbroad(icol,lay) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - else - laytrop(icol) = laytrop(icol) + 1 - forfac(icol,lay) = scalefac(icol) / (1.+water(icol)) - factor(icol) = (332.0_r8-tavel(icol,lay))/36.0_r8 - indfor(icol,lay) = min(2, max(1, int(factor(icol)))) - forfrac(icol,lay) = factor(icol) - float(indfor(icol,lay)) - - ! Set up factors needed to separately include the water vapor - ! self-continuum in the calculation of absorption coefficient. - - selffac(icol,lay) = water(icol) * forfac(icol,lay) - factor(icol) = (tavel(icol,lay)-188.0_r8)/7.2_r8 - indself(icol,lay) = min(9, max(1, int(factor(icol))-7)) - selffrac(icol,lay) = factor(icol) - float(indself(icol,lay) + 7) - indself(icol,lay) = min(9, max(1, int(factor(icol))-7)) - selffrac(icol,lay) = factor(icol) - float(indself(icol,lay) + 7) - - ! Set up factors needed to separately include the minor gases - ! in the calculation of absorption coefficient - - scaleminor(icol,lay) = pavel(icol,lay)/tavel(icol,lay) - scaleminorn2(icol,lay) = (pavel(icol,lay)/tavel(icol,lay)) & - *(wbroad(icol,lay)/(coldry(icol,lay)+wkl(icol,1,lay))) - factor(icol) = (tavel(icol,lay)-180.8_r8)/7.2_r8 - indminor(icol,lay) = min(18, max(1, int(factor(icol)))) - minorfrac(icol,lay) = factor(icol) - float(indminor(icol,lay)) - - ! Setup reference ratio to be used in calculation of binary - ! species parameter in lower atmosphere. - - rat_h2oco2(icol,lay)=chi_mls(1,jp(icol,lay))/chi_mls(2,jp(icol,lay)) - rat_h2oco2_1(icol,lay)=chi_mls(1,jp(icol,lay)+1)/chi_mls(2,jp(icol,lay)+1) - rat_h2oo3(icol,lay)=chi_mls(1,jp(icol,lay))/chi_mls(3,jp(icol,lay)) - rat_h2oo3_1(icol,lay)=chi_mls(1,jp(icol,lay)+1)/chi_mls(3,jp(icol,lay)+1) - rat_h2on2o(icol,lay)=chi_mls(1,jp(icol,lay))/chi_mls(4,jp(icol,lay)) - rat_h2on2o_1(icol,lay)=chi_mls(1,jp(icol,lay)+1)/chi_mls(4,jp(icol,lay)+1) - rat_h2och4(icol,lay)=chi_mls(1,jp(icol,lay))/chi_mls(6,jp(icol,lay)) - rat_h2och4_1(icol,lay)=chi_mls(1,jp(icol,lay)+1)/chi_mls(6,jp(icol,lay)+1) - rat_n2oco2(icol,lay)=chi_mls(4,jp(icol,lay))/chi_mls(2,jp(icol,lay)) - rat_n2oco2_1(icol,lay)=chi_mls(4,jp(icol,lay)+1)/chi_mls(2,jp(icol,lay)+1) - - ! Calculate needed column amounts. - - colh2o(icol,lay) = 1.e-20_r8 * wkl(icol,1,lay) - colco2(icol,lay) = 1.e-20_r8 * wkl(icol,2,lay) - colo3(icol,lay) = 1.e-20_r8 * wkl(icol,3,lay) - coln2o(icol,lay) = 1.e-20_r8 * wkl(icol,4,lay) - colco(icol,lay) = 1.e-20_r8 * wkl(icol,5,lay) - colch4(icol,lay) = 1.e-20_r8 * wkl(icol,6,lay) - colo2(icol,lay) = 1.e-20_r8 * wkl(icol,7,lay) - if (colco2(icol,lay) .eq. 0._r8) colco2(icol,lay) = 1.e-32_r8 * coldry(icol,lay) - if (colo3(icol,lay) .eq. 0._r8) colo3(icol,lay) = 1.e-32_r8 * coldry(icol,lay) - if (coln2o(icol,lay) .eq. 0._r8) coln2o(icol,lay) = 1.e-32_r8 * coldry(icol,lay) - if (colco(icol,lay) .eq. 0._r8) colco(icol,lay) = 1.e-32_r8 * coldry(icol,lay) - if (coln2o(icol,lay) .eq. 0._r8) coln2o(icol,lay) = 1.e-32_r8 * coldry(icol,lay) - if (colco(icol,lay) .eq. 0._r8) colco(icol,lay) = 1.e-32_r8 * coldry(icol,lay) - if (colch4(icol,lay) .eq. 0._r8) colch4(icol,lay) = 1.e-32_r8 * coldry(icol,lay) - colbrd(icol,lay) = 1.e-20_r8 * wbroad(icol,lay) - !go to 5400 - - ! Above laytrop. - endif - !5300 continue - - - - !5400 continue - - ! We have now isolated the layer ln pressure and temperature, - ! between two reference pressures and two reference temperatures - ! (for each reference pressure). We multiply the pressure - ! fraction FP with the appropriate temperature fractions to get - ! the factors that will be needed for the interpolation that yields - ! the optical depths (performed in routines TAUGBn for band n).` - - compfp(icol) = 1. - fp(icol) - fac10(icol,lay) = compfp(icol)* ft(icol) - fac00(icol,lay) = compfp(icol) * (1._r8 - ft(icol)) - fac11(icol,lay) = fp(icol) * ft1(icol) - fac01(icol,lay) = fp(icol) * (1._r8 - ft1(icol)) - - ! Rescale selffac and forfac for use in taumol - - selffac(icol,lay) = colh2o(icol,lay)*selffac(icol,lay) - forfac(icol,lay) = colh2o(icol,lay)*forfac(icol,lay) - - ! End layer loop - !print*,'exiting lay loop',lay - end do - end do - - - - !print*,'exiting icol loop',icol - END SUBROUTINE setcoef -#endif - !*************************************************************************** - - !*************************************************************************** - - END MODULE rrtmg_lw_setcoef diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrtmg_lw_taumol.f90 b/test/ncar_kernels/PORT_lw_rad/src/rrtmg_lw_taumol.f90 deleted file mode 100644 index 883147d62b..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrtmg_lw_taumol.f90 +++ /dev/null @@ -1,3341 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_lw_taumol.f90 -! Generated at: 2015-07-06 23:28:44 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_lw_taumol - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! ------- Modules ------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : im => kind_im, rb => kind_r8 - USE rrlw_con, ONLY: oneminus - USE rrlw_wvn, ONLY: nspa - USE rrlw_wvn, ONLY: nspb - USE rrlw_vsn, ONLY: hvrtau - IMPLICIT NONE - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !---------------------------------------------------------------------------- - - SUBROUTINE taumol(nlayers, pavel, wx, coldry, laytrop, jp, jt, jt1, planklay, planklev, plankbnd, colh2o, colco2, colo3, & - coln2o, colco, colch4, colo2, colbrd, fac00, fac01, fac10, fac11, rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, & - rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, selffac, selffrac, & - indself, forfac, forfrac, indfor, minorfrac, scaleminor, scaleminorn2, indminor, fracs, taug) - !---------------------------------------------------------------------------- - ! ******************************************************************************* - ! * * - ! * Optical depths developed for the * - ! * * - ! * RAPID RADIATIVE TRANSFER MODEL (RRTM) * - ! * * - ! * * - ! * ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC. * - ! * 131 HARTWELL AVENUE * - ! * LEXINGTON, MA 02421 * - ! * * - ! * * - ! * ELI J. MLAWER * - ! * JENNIFER DELAMERE * - ! * STEVEN J. TAUBMAN * - ! * SHEPARD A. CLOUGH * - ! * * - ! * * - ! * * - ! * * - ! * email: mlawer@aer.com * - ! * email: jdelamer@aer.com * - ! * * - ! * The authors wish to acknowledge the contributions of the * - ! * following people: Karen Cady-Pereira, Patrick D. Brown, * - ! * Michael J. Iacono, Ronald E. Farren, Luke Chen, Robert Bergstrom. * - ! * * - ! ******************************************************************************* - ! * * - ! * Revision for g-point reduction: Michael J. Iacono, AER, Inc. * - ! * * - ! ******************************************************************************* - ! * TAUMOL * - ! * * - ! * This file contains the subroutines TAUGBn (where n goes from * - ! * 1 to 16). TAUGBn calculates the optical depths and Planck fractions * - ! * per g-value and layer for band n. * - ! * * - ! * Output: optical depths (unitless) * - ! * fractions needed to compute Planck functions at every layer * - ! * and g-value * - ! * * - ! * COMMON /TAUGCOM/ TAUG(MXLAY,MG) * - ! * COMMON /PLANKG/ FRACS(MXLAY,MG) * - ! * * - ! * Input * - ! * * - ! * COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS) * - ! * COMMON /PRECISE/ ONEMINUS * - ! * COMMON /PROFILE/ NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY), * - ! * & PZ(0:MXLAY),TZ(0:MXLAY) * - ! * COMMON /PROFDATA/ LAYTROP, * - ! * & COLH2O(MXLAY),COLCO2(MXLAY),COLO3(MXLAY), * - ! * & COLN2O(MXLAY),COLCO(MXLAY),COLCH4(MXLAY), * - ! * & COLO2(MXLAY) - ! * COMMON /INTFAC/ FAC00(MXLAY),FAC01(MXLAY), * - ! * & FAC10(MXLAY),FAC11(MXLAY) * - ! * COMMON /INTIND/ JP(MXLAY),JT(MXLAY),JT1(MXLAY) * - ! * COMMON /SELF/ SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(MXLAY) * - ! * * - ! * Description: * - ! * NG(IBAND) - number of g-values in band IBAND * - ! * NSPA(IBAND) - for the lower atmosphere, the number of reference * - ! * atmospheres that are stored for band IBAND per * - ! * pressure level and temperature. Each of these * - ! * atmospheres has different relative amounts of the * - ! * key species for the band (i.e. different binary * - ! * species parameters). * - ! * NSPB(IBAND) - same for upper atmosphere * - ! * ONEMINUS - since problems are caused in some cases by interpolation * - ! * parameters equal to or greater than 1, for these cases * - ! * these parameters are set to this value, slightly < 1. * - ! * PAVEL - layer pressures (mb) * - ! * TAVEL - layer temperatures (degrees K) * - ! * PZ - level pressures (mb) * - ! * TZ - level temperatures (degrees K) * - ! * LAYTROP - layer at which switch is made from one combination of * - ! * key species to another * - ! * COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water * - ! * vapor,carbon dioxide, ozone, nitrous ozide, methane, * - ! * respectively (molecules/cm**2) * - ! * FACij(LAY) - for layer LAY, these are factors that are needed to * - ! * compute the interpolation factors that multiply the * - ! * appropriate reference k-values. A value of 0 (1) for * - ! * i,j indicates that the corresponding factor multiplies * - ! * reference k-value for the lower (higher) of the two * - ! * appropriate temperatures, and altitudes, respectively. * - ! * JP - the index of the lower (in altitude) of the two appropriate * - ! * reference pressure levels needed for interpolation * - ! * JT, JT1 - the indices of the lower of the two appropriate reference * - ! * temperatures needed for interpolation (for pressure * - ! * levels JP and JP+1, respectively) * - ! * SELFFAC - scale factor needed for water vapor self-continuum, equals * - ! * (water vapor density)/(atmospheric density at 296K and * - ! * 1013 mb) * - ! * SELFFRAC - factor needed for temperature interpolation of reference * - ! * water vapor self-continuum data * - ! * INDSELF - index of the lower of the two appropriate reference * - ! * temperatures needed for the self-continuum interpolation * - ! * FORFAC - scale factor needed for water vapor foreign-continuum. * - ! * FORFRAC - factor needed for temperature interpolation of reference * - ! * water vapor foreign-continuum data * - ! * INDFOR - index of the lower of the two appropriate reference * - ! * temperatures needed for the foreign-continuum interpolation * - ! * * - ! * Data input * - ! * COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG),* - ! * FORREF(4,MG), KA_M'MGAS', KB_M'MGAS' * - ! * (note: n is the band number,'MGAS' is the species name of the minor * - ! * gas) * - ! * * - ! * Description: * - ! * KA - k-values for low reference atmospheres (key-species only) * - ! * (units: cm**2/molecule) * - ! * KB - k-values for high reference atmospheres (key-species only) * - ! * (units: cm**2/molecule) * - ! * KA_M'MGAS' - k-values for low reference atmosphere minor species * - ! * (units: cm**2/molecule) * - ! * KB_M'MGAS' - k-values for high reference atmosphere minor species * - ! * (units: cm**2/molecule) * - ! * SELFREF - k-values for water vapor self-continuum for reference * - ! * atmospheres (used below LAYTROP) * - ! * (units: cm**2/molecule) * - ! * FORREF - k-values for water vapor foreign-continuum for reference * - ! * atmospheres (used below/above LAYTROP) * - ! * (units: cm**2/molecule) * - ! * * - ! * DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG) * - ! * EQUIVALENCE (KA,ABSA),(KB,ABSB) * - ! * * - !******************************************************************************* - ! ------- Declarations ------- - ! ----- Input ----- - INTEGER, intent(in) :: nlayers ! total number of layers - REAL(KIND=r8), intent(in) :: pavel(:) ! layer pressures (mb) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: wx(:,:) ! cross-section amounts (mol/cm2) - ! Dimensions: (maxxsec,nlayers) - REAL(KIND=r8), intent(in) :: coldry(:) ! column amount (dry air) - ! Dimensions: (nlayers) - INTEGER, intent(in) :: laytrop ! tropopause layer index - INTEGER, intent(in) :: jp(:) ! - ! Dimensions: (nlayers) - INTEGER, intent(in) :: jt(:) ! - ! Dimensions: (nlayers) - INTEGER, intent(in) :: jt1(:) ! - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: planklay(:,:) ! - ! Dimensions: (nlayers,nbndlw) - REAL(KIND=r8), intent(in) :: planklev(0:,:) ! - ! Dimensions: (nlayers,nbndlw) - REAL(KIND=r8), intent(in) :: plankbnd(:) ! - ! Dimensions: (nbndlw) - REAL(KIND=r8), intent(in) :: colh2o(:) ! column amount (h2o) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: colco2(:) ! column amount (co2) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: colo3(:) ! column amount (o3) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: coln2o(:) ! column amount (n2o) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: colco(:) ! column amount (co) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: colch4(:) ! column amount (ch4) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: colo2(:) ! column amount (o2) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: colbrd(:) ! column amount (broadening gases) - ! Dimensions: (nlayers) - INTEGER, intent(in) :: indself(:) - ! Dimensions: (nlayers) - INTEGER, intent(in) :: indfor(:) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: selffac(:) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: selffrac(:) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: forfac(:) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: forfrac(:) - ! Dimensions: (nlayers) - INTEGER, intent(in) :: indminor(:) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: minorfrac(:) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: scaleminor(:) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: scaleminorn2(:) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: fac11(:) - REAL(KIND=r8), intent(in) :: fac00(:) - REAL(KIND=r8), intent(in) :: fac01(:) - REAL(KIND=r8), intent(in) :: fac10(:) ! - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: rat_h2oco2(:) - REAL(KIND=r8), intent(in) :: rat_h2oco2_1(:) - REAL(KIND=r8), intent(in) :: rat_h2oo3(:) - REAL(KIND=r8), intent(in) :: rat_h2oo3_1(:) - REAL(KIND=r8), intent(in) :: rat_h2on2o(:) - REAL(KIND=r8), intent(in) :: rat_h2och4(:) - REAL(KIND=r8), intent(in) :: rat_h2och4_1(:) - REAL(KIND=r8), intent(in) :: rat_n2oco2(:) - REAL(KIND=r8), intent(in) :: rat_n2oco2_1(:) - REAL(KIND=r8), intent(in) :: rat_o3co2(:) - REAL(KIND=r8), intent(in) :: rat_o3co2_1(:) - REAL(KIND=r8), intent(in) :: rat_h2on2o_1(:) ! - ! Dimensions: (nlayers) - ! ----- Output ----- - REAL(KIND=r8), intent(out) :: fracs(:,:) ! planck fractions - ! Dimensions: (nlayers,ngptlw) - REAL(KIND=r8), intent(out) :: taug(:,:) ! gaseous optical depth - ! Dimensions: (nlayers,ngptlw) - hvrtau = '$Revision: 1.7 $' - ! Calculate gaseous optical depth and planck fractions for each spectral band. - call taugb1 - call taugb2 - call taugb3 - call taugb4 - call taugb5 - call taugb6 - call taugb7 - call taugb8 - call taugb9 - call taugb10 - call taugb11 - call taugb12 - call taugb13 - call taugb14 - call taugb15 - call taugb16 - CONTAINS - !---------------------------------------------------------------------------- - - SUBROUTINE taugb1() - !---------------------------------------------------------------------------- - ! ------- Modifications ------- - ! Written by Eli J. Mlawer, Atmospheric & Environmental Research. - ! Revised by Michael J. Iacono, Atmospheric & Environmental Research. - ! - ! band 1: 10-350 cm-1 (low key - h2o; low minor - n2) - ! (high key - h2o; high minor - n2) - ! - ! note: previous versions of rrtm band 1: - ! 10-250 cm-1 (low - h2o; high - h2o) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrtm, ONLY: ng1 - USE rrlw_kg01, ONLY: selfref - USE rrlw_kg01, ONLY: forref - USE rrlw_kg01, ONLY: ka_mn2 - USE rrlw_kg01, ONLY: absa - USE rrlw_kg01, ONLY: fracrefa - USE rrlw_kg01, ONLY: kb_mn2 - USE rrlw_kg01, ONLY: absb - USE rrlw_kg01, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: ig - REAL(KIND=r8) :: pp - REAL(KIND=r8) :: corradj - REAL(KIND=r8) :: scalen2 - REAL(KIND=r8) :: tauself - REAL(KIND=r8) :: taufor - REAL(KIND=r8) :: taun2 - ! Minor gas mapping levels: - ! lower - n2, p = 142.5490 mbar, t = 215.70 k - ! upper - n2, p = 142.5490 mbar, t = 215.70 k - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature. Below laytrop, the water vapor self-continuum and - ! foreign continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - do lay = 1, laytrop - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(1) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(1) + 1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - pp = pavel(lay) - corradj = 1. - if (pp .lt. 250._r8) then - corradj = 1._r8 - 0.15_r8 * (250._r8-pp) / 154.4_r8 - endif - scalen2 = colbrd(lay) * scaleminorn2(lay) - do ig = 1, ng1 - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & - (forref(indf+1,ig) - forref(indf,ig))) - taun2 = scalen2*(ka_mn2(indm,ig) + & - minorfrac(lay) * (ka_mn2(indm+1,ig) - ka_mn2(indm,ig))) - taug(lay,ig) = corradj * (colh2o(lay) * & - (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + & - fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) & - + tauself + taufor + taun2) - fracs(lay,ig) = fracrefa(ig) - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop+1, nlayers - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(1) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(1) + 1 - indf = indfor(lay) - indm = indminor(lay) - pp = pavel(lay) - corradj = 1._r8 - 0.15_r8 * (pp / 95.6_r8) - scalen2 = colbrd(lay) * scaleminorn2(lay) - do ig = 1, ng1 - taufor = forfac(lay) * (forref(indf,ig) + & - forfrac(lay) * (forref(indf+1,ig) - forref(indf,ig))) - taun2 = scalen2*(kb_mn2(indm,ig) + & - minorfrac(lay) * (kb_mn2(indm+1,ig) - kb_mn2(indm,ig))) - taug(lay,ig) = corradj * (colh2o(lay) * & - (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + & - fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) & - + taufor + taun2) - fracs(lay,ig) = fracrefb(ig) - enddo - enddo - END SUBROUTINE taugb1 - !---------------------------------------------------------------------------- - - SUBROUTINE taugb2() - !---------------------------------------------------------------------------- - ! - ! band 2: 350-500 cm-1 (low key - h2o; high key - h2o) - ! - ! note: previous version of rrtm band 2: - ! 250 - 500 cm-1 (low - h2o; high - h2o) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrtm, ONLY: ng2 - USE parrrtm, ONLY: ngs1 - USE rrlw_kg02, ONLY: selfref - USE rrlw_kg02, ONLY: forref - USE rrlw_kg02, ONLY: absa - USE rrlw_kg02, ONLY: fracrefa - USE rrlw_kg02, ONLY: absb - USE rrlw_kg02, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - REAL(KIND=r8) :: pp - REAL(KIND=r8) :: corradj - REAL(KIND=r8) :: tauself - REAL(KIND=r8) :: taufor - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature. Below laytrop, the water vapor self-continuum and - ! foreign continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - do lay = 1, laytrop - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(2) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(2) + 1 - inds = indself(lay) - indf = indfor(lay) - pp = pavel(lay) - corradj = 1._r8 - .05_r8 * (pp - 100._r8) / 900._r8 - do ig = 1, ng2 - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & - (forref(indf+1,ig) - forref(indf,ig))) - taug(lay,ngs1+ig) = corradj * (colh2o(lay) * & - (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + & - fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) & - + tauself + taufor) - fracs(lay,ngs1+ig) = fracrefa(ig) - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop+1, nlayers - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(2) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(2) + 1 - indf = indfor(lay) - do ig = 1, ng2 - taufor = forfac(lay) * (forref(indf,ig) + & - forfrac(lay) * (forref(indf+1,ig) - forref(indf,ig))) - taug(lay,ngs1+ig) = colh2o(lay) * & - (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + & - fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) & - + taufor - fracs(lay,ngs1+ig) = fracrefb(ig) - enddo - enddo - END SUBROUTINE taugb2 - !---------------------------------------------------------------------------- - - SUBROUTINE taugb3() - !---------------------------------------------------------------------------- - ! - ! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o) - ! (high key - h2o,co2; high minor - n2o) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrtm, ONLY: ng3 - USE parrrtm, ONLY: ngs2 - USE rrlw_ref, ONLY: chi_mls - USE rrlw_kg03, ONLY: selfref - USE rrlw_kg03, ONLY: forref - USE rrlw_kg03, ONLY: ka_mn2o - USE rrlw_kg03, ONLY: absa - USE rrlw_kg03, ONLY: fracrefa - USE rrlw_kg03, ONLY: kb_mn2o - USE rrlw_kg03, ONLY: absb - USE rrlw_kg03, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: ig - INTEGER :: js - INTEGER :: js1 - INTEGER :: jmn2o - INTEGER :: jpl - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: speccomb1 - REAL(KIND=r8) :: specparm1 - REAL(KIND=r8) :: specmult1 - REAL(KIND=r8) :: fs1 - REAL(KIND=r8) :: speccomb_mn2o - REAL(KIND=r8) :: specparm_mn2o - REAL(KIND=r8) :: specmult_mn2o - REAL(KIND=r8) :: fmn2o - REAL(KIND=r8) :: fmn2omf - REAL(KIND=r8) :: chi_n2o - REAL(KIND=r8) :: ratn2o - REAL(KIND=r8) :: adjfac - REAL(KIND=r8) :: adjcoln2o - REAL(KIND=r8) :: speccomb_planck - REAL(KIND=r8) :: specparm_planck - REAL(KIND=r8) :: specmult_planck - REAL(KIND=r8) :: fpl - REAL(KIND=r8) :: p - REAL(KIND=r8) :: p4 - REAL(KIND=r8) :: fk0 - REAL(KIND=r8) :: fk1 - REAL(KIND=r8) :: fk2 - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac200 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac210 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac201 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: fac211 - REAL(KIND=r8) :: tauself - REAL(KIND=r8) :: taufor - REAL(KIND=r8) :: n2om1 - REAL(KIND=r8) :: n2om2 - REAL(KIND=r8) :: absn2o - REAL(KIND=r8) :: refrat_planck_a - REAL(KIND=r8) :: refrat_planck_b - REAL(KIND=r8) :: refrat_m_a - REAL(KIND=r8) :: refrat_m_b - REAL(KIND=r8) :: tau_major - REAL(KIND=r8) :: tau_major1 - ! Minor gas mapping levels: - ! lower - n2o, p = 706.272 mbar, t = 278.94 k - ! upper - n2o, p = 95.58 mbar, t = 215.7 k - ! P = 212.725 mb - refrat_planck_a = chi_mls(1,9)/chi_mls(2,9) - ! P = 95.58 mb - refrat_planck_b = chi_mls(1,13)/chi_mls(2,13) - ! P = 706.270mb - refrat_m_a = chi_mls(1,3)/chi_mls(2,3) - ! P = 95.58 mb - refrat_m_b = chi_mls(1,13)/chi_mls(2,13) - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature, and appropriate species. Below laytrop, the water vapor - ! self-continuum and foreign continuum is interpolated (in temperature) - ! separately. - ! Lower atmosphere loop - do lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) - specparm = colh2o(lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_r8) - speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) - specparm1 = colh2o(lay)/speccomb1 - if (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._r8*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_r8) - speccomb_mn2o = colh2o(lay) + refrat_m_a*colco2(lay) - specparm_mn2o = colh2o(lay)/speccomb_mn2o - if (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus - specmult_mn2o = 8._r8*specparm_mn2o - jmn2o = 1 + int(specmult_mn2o) - fmn2o = mod(specmult_mn2o,1.0_r8) - fmn2omf = minorfrac(lay)*fmn2o - ! In atmospheres where the amount of N2O is too great to be considered - ! a minor species, adjust the column amount of N2O by an empirical factor - ! to obtain the proper contribution. - chi_n2o = coln2o(lay)/coldry(lay) - ratn2o = 1.e20_r8*chi_n2o/chi_mls(4,jp(lay)+1) - if (ratn2o .gt. 1.5_r8) then - adjfac = 0.5_r8+(ratn2o-0.5_r8)**0.65_r8 - adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_r8 - else - adjcoln2o = coln2o(lay) - endif - speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay) - specparm_planck = colh2o(lay)/speccomb_planck - if (specparm_planck .ge. oneminus) specparm_planck=oneminus - specmult_planck = 8._r8*specparm_planck - jpl= 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_r8) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(3) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(3) + js1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - if (specparm .lt. 0.125_r8) then - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - else if (specparm .gt. 0.875_r8) then - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - else - fac000 = (1._r8 - fs) * fac00(lay) - fac010 = (1._r8 - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - endif - if (specparm1 .lt. 0.125_r8) then - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - else if (specparm1 .gt. 0.875_r8) then - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - else - fac001 = (1._r8 - fs1) * fac01(lay) - fac011 = (1._r8 - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - endif - do ig = 1, ng3 - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & - (forref(indf+1,ig) - forref(indf,ig))) - n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o * & - (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,indm,ig)) - n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o * & - (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(jmn2o,indm+1,ig)) - absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1) - if (specparm .lt. 0.125_r8) then - tau_major = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - else if (specparm .gt. 0.875_r8) then - tau_major = speccomb * & - (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + & - fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + & - fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - else - tau_major = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - endif - if (specparm1 .lt. 0.125_r8) then - tau_major1 = speccomb1 * & - (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - else if (specparm1 .gt. 0.875_r8) then - tau_major1 = speccomb1 * & - (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + & - fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + & - fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - else - tau_major1 = speccomb1 * & - (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - endif - taug(lay,ngs2+ig) = tau_major + tau_major1 & - + tauself + taufor & - + adjcoln2o*absn2o - fracs(lay,ngs2+ig) = fracrefa(ig,jpl) + fpl * & - (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop+1, nlayers - speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) - specparm = colh2o(lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 4._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_r8) - speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) - specparm1 = colh2o(lay)/speccomb1 - if (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 4._r8*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_r8) - fac000 = (1._r8 - fs) * fac00(lay) - fac010 = (1._r8 - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - fac001 = (1._r8 - fs1) * fac01(lay) - fac011 = (1._r8 - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - speccomb_mn2o = colh2o(lay) + refrat_m_b*colco2(lay) - specparm_mn2o = colh2o(lay)/speccomb_mn2o - if (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus - specmult_mn2o = 4._r8*specparm_mn2o - jmn2o = 1 + int(specmult_mn2o) - fmn2o = mod(specmult_mn2o,1.0_r8) - fmn2omf = minorfrac(lay)*fmn2o - ! In atmospheres where the amount of N2O is too great to be considered - ! a minor species, adjust the column amount of N2O by an empirical factor - ! to obtain the proper contribution. - chi_n2o = coln2o(lay)/coldry(lay) - ratn2o = 1.e20*chi_n2o/chi_mls(4,jp(lay)+1) - if (ratn2o .gt. 1.5_r8) then - adjfac = 0.5_r8+(ratn2o-0.5_r8)**0.65_r8 - adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_r8 - else - adjcoln2o = coln2o(lay) - endif - speccomb_planck = colh2o(lay)+refrat_planck_b*colco2(lay) - specparm_planck = colh2o(lay)/speccomb_planck - if (specparm_planck .ge. oneminus) specparm_planck=oneminus - specmult_planck = 4._r8*specparm_planck - jpl= 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_r8) - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(3) + js - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(3) + js1 - indf = indfor(lay) - indm = indminor(lay) - do ig = 1, ng3 - taufor = forfac(lay) * (forref(indf,ig) + & - forfrac(lay) * (forref(indf+1,ig) - forref(indf,ig))) - n2om1 = kb_mn2o(jmn2o,indm,ig) + fmn2o * & - (kb_mn2o(jmn2o+1,indm,ig)-kb_mn2o(jmn2o,indm,ig)) - n2om2 = kb_mn2o(jmn2o,indm+1,ig) + fmn2o * & - (kb_mn2o(jmn2o+1,indm+1,ig)-kb_mn2o(jmn2o,indm+1,ig)) - absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1) - taug(lay,ngs2+ig) = speccomb * & - (fac000 * absb(ind0,ig) + & - fac100 * absb(ind0+1,ig) + & - fac010 * absb(ind0+5,ig) + & - fac110 * absb(ind0+6,ig)) & - + speccomb1 * & - (fac001 * absb(ind1,ig) + & - fac101 * absb(ind1+1,ig) + & - fac011 * absb(ind1+5,ig) + & - fac111 * absb(ind1+6,ig)) & - + taufor & - + adjcoln2o*absn2o - fracs(lay,ngs2+ig) = fracrefb(ig,jpl) + fpl * & - (fracrefb(ig,jpl+1)-fracrefb(ig,jpl)) - enddo - enddo - END SUBROUTINE taugb3 - !---------------------------------------------------------------------------- - - SUBROUTINE taugb4() - !---------------------------------------------------------------------------- - ! - ! band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrtm, ONLY: ng4 - USE parrrtm, ONLY: ngs3 - USE rrlw_ref, ONLY: chi_mls - USE rrlw_kg04, ONLY: selfref - USE rrlw_kg04, ONLY: forref - USE rrlw_kg04, ONLY: absa - USE rrlw_kg04, ONLY: fracrefa - USE rrlw_kg04, ONLY: absb - USE rrlw_kg04, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - INTEGER :: js - INTEGER :: js1 - INTEGER :: jpl - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: speccomb1 - REAL(KIND=r8) :: specparm1 - REAL(KIND=r8) :: specmult1 - REAL(KIND=r8) :: fs1 - REAL(KIND=r8) :: speccomb_planck - REAL(KIND=r8) :: specparm_planck - REAL(KIND=r8) :: specmult_planck - REAL(KIND=r8) :: fpl - REAL(KIND=r8) :: p - REAL(KIND=r8) :: p4 - REAL(KIND=r8) :: fk0 - REAL(KIND=r8) :: fk1 - REAL(KIND=r8) :: fk2 - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac200 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac210 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac201 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: fac211 - REAL(KIND=r8) :: tauself - REAL(KIND=r8) :: taufor - REAL(KIND=r8) :: refrat_planck_a - REAL(KIND=r8) :: refrat_planck_b - REAL(KIND=r8) :: tau_major - REAL(KIND=r8) :: tau_major1 - ! P = 142.5940 mb - refrat_planck_a = chi_mls(1,11)/chi_mls(2,11) - ! P = 95.58350 mb - refrat_planck_b = chi_mls(3,13)/chi_mls(2,13) - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature, and appropriate species. Below laytrop, the water - ! vapor self-continuum and foreign continuum is interpolated (in temperature) - ! separately. - ! Lower atmosphere loop - do lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) - specparm = colh2o(lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_r8) - speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) - specparm1 = colh2o(lay)/speccomb1 - if (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._r8*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_r8) - speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay) - specparm_planck = colh2o(lay)/speccomb_planck - if (specparm_planck .ge. oneminus) specparm_planck=oneminus - specmult_planck = 8._r8*specparm_planck - jpl= 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_r8) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(4) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(4) + js1 - inds = indself(lay) - indf = indfor(lay) - if (specparm .lt. 0.125_r8) then - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - else if (specparm .gt. 0.875_r8) then - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - else - fac000 = (1._r8 - fs) * fac00(lay) - fac010 = (1._r8 - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - endif - if (specparm1 .lt. 0.125_r8) then - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - else if (specparm1 .gt. 0.875_r8) then - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - else - fac001 = (1._r8 - fs1) * fac01(lay) - fac011 = (1._r8 - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - endif - do ig = 1, ng4 - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & - (forref(indf+1,ig) - forref(indf,ig))) - if (specparm .lt. 0.125_r8) then - tau_major = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - else if (specparm .gt. 0.875_r8) then - tau_major = speccomb * & - (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + & - fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + & - fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - else - tau_major = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - endif - if (specparm1 .lt. 0.125_r8) then - tau_major1 = speccomb1 * & - (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - else if (specparm1 .gt. 0.875_r8) then - tau_major1 = speccomb1 * & - (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + & - fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + & - fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - else - tau_major1 = speccomb1 * & - (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - endif - taug(lay,ngs3+ig) = tau_major + tau_major1 & - + tauself + taufor - fracs(lay,ngs3+ig) = fracrefa(ig,jpl) + fpl * & - (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop+1, nlayers - speccomb = colo3(lay) + rat_o3co2(lay)*colco2(lay) - specparm = colo3(lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 4._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_r8) - speccomb1 = colo3(lay) + rat_o3co2_1(lay)*colco2(lay) - specparm1 = colo3(lay)/speccomb1 - if (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 4._r8*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_r8) - fac000 = (1._r8 - fs) * fac00(lay) - fac010 = (1._r8 - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - fac001 = (1._r8 - fs1) * fac01(lay) - fac011 = (1._r8 - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - speccomb_planck = colo3(lay)+refrat_planck_b*colco2(lay) - specparm_planck = colo3(lay)/speccomb_planck - if (specparm_planck .ge. oneminus) specparm_planck=oneminus - specmult_planck = 4._r8*specparm_planck - jpl= 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_r8) - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(4) + js - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(4) + js1 - do ig = 1, ng4 - taug(lay,ngs3+ig) = speccomb * & - (fac000 * absb(ind0,ig) + & - fac100 * absb(ind0+1,ig) + & - fac010 * absb(ind0+5,ig) + & - fac110 * absb(ind0+6,ig)) & - + speccomb1 * & - (fac001 * absb(ind1,ig) + & - fac101 * absb(ind1+1,ig) + & - fac011 * absb(ind1+5,ig) + & - fac111 * absb(ind1+6,ig)) - fracs(lay,ngs3+ig) = fracrefb(ig,jpl) + fpl * & - (fracrefb(ig,jpl+1)-fracrefb(ig,jpl)) - enddo - ! Empirical modification to code to improve stratospheric cooling rates - ! for co2. Revised to apply weighting for g-point reduction in this band. - taug(lay,ngs3+8)=taug(lay,ngs3+8)*0.92 - taug(lay,ngs3+9)=taug(lay,ngs3+9)*0.88 - taug(lay,ngs3+10)=taug(lay,ngs3+10)*1.07 - taug(lay,ngs3+11)=taug(lay,ngs3+11)*1.1 - taug(lay,ngs3+12)=taug(lay,ngs3+12)*0.99 - taug(lay,ngs3+13)=taug(lay,ngs3+13)*0.88 - taug(lay,ngs3+14)=taug(lay,ngs3+14)*0.943 - enddo - END SUBROUTINE taugb4 - !---------------------------------------------------------------------------- - - SUBROUTINE taugb5() - !---------------------------------------------------------------------------- - ! - ! band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4) - ! (high key - o3,co2) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrtm, ONLY: ng5 - USE parrrtm, ONLY: ngs4 - USE rrlw_ref, ONLY: chi_mls - USE rrlw_kg05, ONLY: selfref - USE rrlw_kg05, ONLY: forref - USE rrlw_kg05, ONLY: ka_mo3 - USE rrlw_kg05, ONLY: absa - USE rrlw_kg05, ONLY: ccl4 - USE rrlw_kg05, ONLY: fracrefa - USE rrlw_kg05, ONLY: absb - USE rrlw_kg05, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: ig - INTEGER :: js - INTEGER :: js1 - INTEGER :: jmo3 - INTEGER :: jpl - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: speccomb1 - REAL(KIND=r8) :: specparm1 - REAL(KIND=r8) :: specmult1 - REAL(KIND=r8) :: fs1 - REAL(KIND=r8) :: speccomb_mo3 - REAL(KIND=r8) :: specparm_mo3 - REAL(KIND=r8) :: specmult_mo3 - REAL(KIND=r8) :: fmo3 - REAL(KIND=r8) :: speccomb_planck - REAL(KIND=r8) :: specparm_planck - REAL(KIND=r8) :: specmult_planck - REAL(KIND=r8) :: fpl - REAL(KIND=r8) :: p - REAL(KIND=r8) :: p4 - REAL(KIND=r8) :: fk0 - REAL(KIND=r8) :: fk1 - REAL(KIND=r8) :: fk2 - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac200 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac210 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac201 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: fac211 - REAL(KIND=r8) :: tauself - REAL(KIND=r8) :: taufor - REAL(KIND=r8) :: o3m1 - REAL(KIND=r8) :: o3m2 - REAL(KIND=r8) :: abso3 - REAL(KIND=r8) :: refrat_planck_a - REAL(KIND=r8) :: refrat_planck_b - REAL(KIND=r8) :: refrat_m_a - REAL(KIND=r8) :: tau_major - REAL(KIND=r8) :: tau_major1 - ! Minor gas mapping level : - ! lower - o3, p = 317.34 mbar, t = 240.77 k - ! lower - ccl4 - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower/upper atmosphere. - ! P = 473.420 mb - refrat_planck_a = chi_mls(1,5)/chi_mls(2,5) - ! P = 0.2369 mb - refrat_planck_b = chi_mls(3,43)/chi_mls(2,43) - ! P = 317.3480 - refrat_m_a = chi_mls(1,7)/chi_mls(2,7) - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature, and appropriate species. Below laytrop, the - ! water vapor self-continuum and foreign continuum is - ! interpolated (in temperature) separately. - ! Lower atmosphere loop - do lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) - specparm = colh2o(lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_r8) - speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) - specparm1 = colh2o(lay)/speccomb1 - if (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._r8*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_r8) - speccomb_mo3 = colh2o(lay) + refrat_m_a*colco2(lay) - specparm_mo3 = colh2o(lay)/speccomb_mo3 - if (specparm_mo3 .ge. oneminus) specparm_mo3 = oneminus - specmult_mo3 = 8._r8*specparm_mo3 - jmo3 = 1 + int(specmult_mo3) - fmo3 = mod(specmult_mo3,1.0_r8) - speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay) - specparm_planck = colh2o(lay)/speccomb_planck - if (specparm_planck .ge. oneminus) specparm_planck=oneminus - specmult_planck = 8._r8*specparm_planck - jpl= 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_r8) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(5) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(5) + js1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - if (specparm .lt. 0.125_r8) then - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - else if (specparm .gt. 0.875_r8) then - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - else - fac000 = (1._r8 - fs) * fac00(lay) - fac010 = (1._r8 - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - endif - if (specparm1 .lt. 0.125_r8) then - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - else if (specparm1 .gt. 0.875_r8) then - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - else - fac001 = (1._r8 - fs1) * fac01(lay) - fac011 = (1._r8 - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - endif - do ig = 1, ng5 - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & - (forref(indf+1,ig) - forref(indf,ig))) - o3m1 = ka_mo3(jmo3,indm,ig) + fmo3 * & - (ka_mo3(jmo3+1,indm,ig)-ka_mo3(jmo3,indm,ig)) - o3m2 = ka_mo3(jmo3,indm+1,ig) + fmo3 * & - (ka_mo3(jmo3+1,indm+1,ig)-ka_mo3(jmo3,indm+1,ig)) - abso3 = o3m1 + minorfrac(lay)*(o3m2-o3m1) - if (specparm .lt. 0.125_r8) then - tau_major = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - else if (specparm .gt. 0.875_r8) then - tau_major = speccomb * & - (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + & - fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + & - fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - else - tau_major = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - endif - if (specparm1 .lt. 0.125_r8) then - tau_major1 = speccomb1 * & - (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - else if (specparm1 .gt. 0.875_r8) then - tau_major1 = speccomb1 * & - (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + & - fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + & - fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - else - tau_major1 = speccomb1 * & - (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - endif - taug(lay,ngs4+ig) = tau_major + tau_major1 & - + tauself + taufor & - + abso3*colo3(lay) & - + wx(1,lay) * ccl4(ig) - fracs(lay,ngs4+ig) = fracrefa(ig,jpl) + fpl * & - (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop+1, nlayers - speccomb = colo3(lay) + rat_o3co2(lay)*colco2(lay) - specparm = colo3(lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 4._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_r8) - speccomb1 = colo3(lay) + rat_o3co2_1(lay)*colco2(lay) - specparm1 = colo3(lay)/speccomb1 - if (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 4._r8*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_r8) - fac000 = (1._r8 - fs) * fac00(lay) - fac010 = (1._r8 - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - fac001 = (1._r8 - fs1) * fac01(lay) - fac011 = (1._r8 - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - speccomb_planck = colo3(lay)+refrat_planck_b*colco2(lay) - specparm_planck = colo3(lay)/speccomb_planck - if (specparm_planck .ge. oneminus) specparm_planck=oneminus - specmult_planck = 4._r8*specparm_planck - jpl= 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_r8) - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(5) + js - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(5) + js1 - do ig = 1, ng5 - taug(lay,ngs4+ig) = speccomb * & - (fac000 * absb(ind0,ig) + & - fac100 * absb(ind0+1,ig) + & - fac010 * absb(ind0+5,ig) + & - fac110 * absb(ind0+6,ig)) & - + speccomb1 * & - (fac001 * absb(ind1,ig) + & - fac101 * absb(ind1+1,ig) + & - fac011 * absb(ind1+5,ig) + & - fac111 * absb(ind1+6,ig)) & - + wx(1,lay) * ccl4(ig) - fracs(lay,ngs4+ig) = fracrefb(ig,jpl) + fpl * & - (fracrefb(ig,jpl+1)-fracrefb(ig,jpl)) - enddo - enddo - END SUBROUTINE taugb5 - !---------------------------------------------------------------------------- - - SUBROUTINE taugb6() - !---------------------------------------------------------------------------- - ! - ! band 6: 820-980 cm-1 (low key - h2o; low minor - co2) - ! (high key - nothing; high minor - cfc11, cfc12) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrtm, ONLY: ng6 - USE parrrtm, ONLY: ngs5 - USE rrlw_ref, ONLY: chi_mls - USE rrlw_kg06, ONLY: selfref - USE rrlw_kg06, ONLY: forref - USE rrlw_kg06, ONLY: ka_mco2 - USE rrlw_kg06, ONLY: cfc11adj - USE rrlw_kg06, ONLY: absa - USE rrlw_kg06, ONLY: cfc12 - USE rrlw_kg06, ONLY: fracrefa - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: ig - REAL(KIND=r8) :: chi_co2 - REAL(KIND=r8) :: ratco2 - REAL(KIND=r8) :: adjfac - REAL(KIND=r8) :: adjcolco2 - REAL(KIND=r8) :: tauself - REAL(KIND=r8) :: taufor - REAL(KIND=r8) :: absco2 - ! Minor gas mapping level: - ! lower - co2, p = 706.2720 mb, t = 294.2 k - ! upper - cfc11, cfc12 - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature. The water vapor self-continuum and foreign continuum - ! is interpolated (in temperature) separately. - ! Lower atmosphere loop - do lay = 1, laytrop - ! In atmospheres where the amount of CO2 is too great to be considered - ! a minor species, adjust the column amount of CO2 by an empirical factor - ! to obtain the proper contribution. - chi_co2 = colco2(lay)/(coldry(lay)) - ratco2 = 1.e20_r8*chi_co2/chi_mls(2,jp(lay)+1) - if (ratco2 .gt. 3.0_r8) then - adjfac = 2.0_r8+(ratco2-2.0_r8)**0.77_r8 - adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_r8 - else - adjcolco2 = colco2(lay) - endif - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(6) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(6) + 1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - do ig = 1, ng6 - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & - (forref(indf+1,ig) - forref(indf,ig))) - absco2 = (ka_mco2(indm,ig) + minorfrac(lay) * & - (ka_mco2(indm+1,ig) - ka_mco2(indm,ig))) - taug(lay,ngs5+ig) = colh2o(lay) * & - (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + & - fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) & - + tauself + taufor & - + adjcolco2 * absco2 & - + wx(2,lay) * cfc11adj(ig) & - + wx(3,lay) * cfc12(ig) - fracs(lay,ngs5+ig) = fracrefa(ig) - enddo - enddo - ! Upper atmosphere loop - ! Nothing important goes on above laytrop in this band. - do lay = laytrop+1, nlayers - do ig = 1, ng6 - taug(lay,ngs5+ig) = 0.0_r8 & - + wx(2,lay) * cfc11adj(ig) & - + wx(3,lay) * cfc12(ig) - fracs(lay,ngs5+ig) = fracrefa(ig) - enddo - enddo - END SUBROUTINE taugb6 - !---------------------------------------------------------------------------- - - SUBROUTINE taugb7() - !---------------------------------------------------------------------------- - ! - ! band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2) - ! (high key - o3; high minor - co2) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrtm, ONLY: ng7 - USE parrrtm, ONLY: ngs6 - USE rrlw_ref, ONLY: chi_mls - USE rrlw_kg07, ONLY: selfref - USE rrlw_kg07, ONLY: forref - USE rrlw_kg07, ONLY: ka_mco2 - USE rrlw_kg07, ONLY: absa - USE rrlw_kg07, ONLY: fracrefa - USE rrlw_kg07, ONLY: kb_mco2 - USE rrlw_kg07, ONLY: absb - USE rrlw_kg07, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: ig - INTEGER :: js - INTEGER :: js1 - INTEGER :: jmco2 - INTEGER :: jpl - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: speccomb1 - REAL(KIND=r8) :: specparm1 - REAL(KIND=r8) :: specmult1 - REAL(KIND=r8) :: fs1 - REAL(KIND=r8) :: speccomb_mco2 - REAL(KIND=r8) :: specparm_mco2 - REAL(KIND=r8) :: specmult_mco2 - REAL(KIND=r8) :: fmco2 - REAL(KIND=r8) :: speccomb_planck - REAL(KIND=r8) :: specparm_planck - REAL(KIND=r8) :: specmult_planck - REAL(KIND=r8) :: fpl - REAL(KIND=r8) :: p - REAL(KIND=r8) :: p4 - REAL(KIND=r8) :: fk0 - REAL(KIND=r8) :: fk1 - REAL(KIND=r8) :: fk2 - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac200 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac210 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac201 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: fac211 - REAL(KIND=r8) :: tauself - REAL(KIND=r8) :: taufor - REAL(KIND=r8) :: co2m1 - REAL(KIND=r8) :: co2m2 - REAL(KIND=r8) :: absco2 - REAL(KIND=r8) :: chi_co2 - REAL(KIND=r8) :: ratco2 - REAL(KIND=r8) :: adjfac - REAL(KIND=r8) :: adjcolco2 - REAL(KIND=r8) :: refrat_planck_a - REAL(KIND=r8) :: refrat_m_a - REAL(KIND=r8) :: tau_major - REAL(KIND=r8) :: tau_major1 - ! Minor gas mapping level : - ! lower - co2, p = 706.2620 mbar, t= 278.94 k - ! upper - co2, p = 12.9350 mbar, t = 234.01 k - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower atmosphere. - ! P = 706.2620 mb - refrat_planck_a = chi_mls(1,3)/chi_mls(3,3) - ! P = 706.2720 mb - refrat_m_a = chi_mls(1,3)/chi_mls(3,3) - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below laytrop, the water - ! vapor self-continuum and foreign continuum is interpolated - ! (in temperature) separately. - ! Lower atmosphere loop - do lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2oo3(lay)*colo3(lay) - specparm = colh2o(lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_r8) - speccomb1 = colh2o(lay) + rat_h2oo3_1(lay)*colo3(lay) - specparm1 = colh2o(lay)/speccomb1 - if (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._r8*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_r8) - speccomb_mco2 = colh2o(lay) + refrat_m_a*colo3(lay) - specparm_mco2 = colh2o(lay)/speccomb_mco2 - if (specparm_mco2 .ge. oneminus) specparm_mco2 = oneminus - specmult_mco2 = 8._r8*specparm_mco2 - jmco2 = 1 + int(specmult_mco2) - fmco2 = mod(specmult_mco2,1.0_r8) - ! In atmospheres where the amount of CO2 is too great to be considered - ! a minor species, adjust the column amount of CO2 by an empirical factor - ! to obtain the proper contribution. - chi_co2 = colco2(lay)/(coldry(lay)) - ratco2 = 1.e20*chi_co2/chi_mls(2,jp(lay)+1) - if (ratco2 .gt. 3.0_r8) then - adjfac = 3.0_r8+(ratco2-3.0_r8)**0.79_r8 - adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_r8 - else - adjcolco2 = colco2(lay) - endif - speccomb_planck = colh2o(lay)+refrat_planck_a*colo3(lay) - specparm_planck = colh2o(lay)/speccomb_planck - if (specparm_planck .ge. oneminus) specparm_planck=oneminus - specmult_planck = 8._r8*specparm_planck - jpl= 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_r8) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(7) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(7) + js1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - if (specparm .lt. 0.125_r8) then - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - else if (specparm .gt. 0.875_r8) then - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - else - fac000 = (1._r8 - fs) * fac00(lay) - fac010 = (1._r8 - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - endif - if (specparm .lt. 0.125_r8) then - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - else if (specparm1 .gt. 0.875_r8) then - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - else - fac001 = (1._r8 - fs1) * fac01(lay) - fac011 = (1._r8 - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - endif - do ig = 1, ng7 - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & - (forref(indf+1,ig) - forref(indf,ig))) - co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 * & - (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,indm,ig)) - co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 * & - (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(jmco2,indm+1,ig)) - absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1) - if (specparm .lt. 0.125_r8) then - tau_major = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - else if (specparm .gt. 0.875_r8) then - tau_major = speccomb * & - (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + & - fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + & - fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - else - tau_major = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - endif - if (specparm1 .lt. 0.125_r8) then - tau_major1 = speccomb1 * & - (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - else if (specparm1 .gt. 0.875_r8) then - tau_major1 = speccomb1 * & - (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + & - fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + & - fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - else - tau_major1 = speccomb1 * & - (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - endif - taug(lay,ngs6+ig) = tau_major + tau_major1 & - + tauself + taufor & - + adjcolco2*absco2 - fracs(lay,ngs6+ig) = fracrefa(ig,jpl) + fpl * & - (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop+1, nlayers - ! In atmospheres where the amount of CO2 is too great to be considered - ! a minor species, adjust the column amount of CO2 by an empirical factor - ! to obtain the proper contribution. - chi_co2 = colco2(lay)/(coldry(lay)) - ratco2 = 1.e20*chi_co2/chi_mls(2,jp(lay)+1) - if (ratco2 .gt. 3.0_r8) then - adjfac = 2.0_r8+(ratco2-2.0_r8)**0.79_r8 - adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_r8 - else - adjcolco2 = colco2(lay) - endif - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(7) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(7) + 1 - indm = indminor(lay) - do ig = 1, ng7 - absco2 = kb_mco2(indm,ig) + minorfrac(lay) * & - (kb_mco2(indm+1,ig) - kb_mco2(indm,ig)) - taug(lay,ngs6+ig) = colo3(lay) * & - (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + & - fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) & - + adjcolco2 * absco2 - fracs(lay,ngs6+ig) = fracrefb(ig) - enddo - ! Empirical modification to code to improve stratospheric cooling rates - ! for o3. Revised to apply weighting for g-point reduction in this band. - taug(lay,ngs6+6)=taug(lay,ngs6+6)*0.92_r8 - taug(lay,ngs6+7)=taug(lay,ngs6+7)*0.88_r8 - taug(lay,ngs6+8)=taug(lay,ngs6+8)*1.07_r8 - taug(lay,ngs6+9)=taug(lay,ngs6+9)*1.1_r8 - taug(lay,ngs6+10)=taug(lay,ngs6+10)*0.99_r8 - taug(lay,ngs6+11)=taug(lay,ngs6+11)*0.855_r8 - enddo - END SUBROUTINE taugb7 - !---------------------------------------------------------------------------- - - SUBROUTINE taugb8() - !---------------------------------------------------------------------------- - ! - ! band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o) - ! (high key - o3; high minor - co2, n2o) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrtm, ONLY: ng8 - USE parrrtm, ONLY: ngs7 - USE rrlw_ref, ONLY: chi_mls - USE rrlw_kg08, ONLY: selfref - USE rrlw_kg08, ONLY: forref - USE rrlw_kg08, ONLY: ka_mco2 - USE rrlw_kg08, ONLY: ka_mo3 - USE rrlw_kg08, ONLY: ka_mn2o - USE rrlw_kg08, ONLY: cfc12 - USE rrlw_kg08, ONLY: cfc22adj - USE rrlw_kg08, ONLY: absa - USE rrlw_kg08, ONLY: fracrefa - USE rrlw_kg08, ONLY: kb_mco2 - USE rrlw_kg08, ONLY: kb_mn2o - USE rrlw_kg08, ONLY: absb - USE rrlw_kg08, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: ig - REAL(KIND=r8) :: tauself - REAL(KIND=r8) :: taufor - REAL(KIND=r8) :: absco2 - REAL(KIND=r8) :: abso3 - REAL(KIND=r8) :: absn2o - REAL(KIND=r8) :: chi_co2 - REAL(KIND=r8) :: ratco2 - REAL(KIND=r8) :: adjfac - REAL(KIND=r8) :: adjcolco2 - ! Minor gas mapping level: - ! lower - co2, p = 1053.63 mb, t = 294.2 k - ! lower - o3, p = 317.348 mb, t = 240.77 k - ! lower - n2o, p = 706.2720 mb, t= 278.94 k - ! lower - cfc12,cfc11 - ! upper - co2, p = 35.1632 mb, t = 223.28 k - ! upper - n2o, p = 8.716e-2 mb, t = 226.03 k - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature, and appropriate species. Below laytrop, the water vapor - ! self-continuum and foreign continuum is interpolated (in temperature) - ! separately. - ! Lower atmosphere loop - do lay = 1, laytrop - ! In atmospheres where the amount of CO2 is too great to be considered - ! a minor species, adjust the column amount of CO2 by an empirical factor - ! to obtain the proper contribution. - chi_co2 = colco2(lay)/(coldry(lay)) - ratco2 = 1.e20_r8*chi_co2/chi_mls(2,jp(lay)+1) - if (ratco2 .gt. 3.0_r8) then - adjfac = 2.0_r8+(ratco2-2.0_r8)**0.65_r8 - adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_r8 - else - adjcolco2 = colco2(lay) - endif - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(8) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(8) + 1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - do ig = 1, ng8 - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & - (forref(indf+1,ig) - forref(indf,ig))) - absco2 = (ka_mco2(indm,ig) + minorfrac(lay) * & - (ka_mco2(indm+1,ig) - ka_mco2(indm,ig))) - abso3 = (ka_mo3(indm,ig) + minorfrac(lay) * & - (ka_mo3(indm+1,ig) - ka_mo3(indm,ig))) - absn2o = (ka_mn2o(indm,ig) + minorfrac(lay) * & - (ka_mn2o(indm+1,ig) - ka_mn2o(indm,ig))) - taug(lay,ngs7+ig) = colh2o(lay) * & - (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + & - fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) & - + tauself + taufor & - + adjcolco2*absco2 & - + colo3(lay) * abso3 & - + coln2o(lay) * absn2o & - + wx(3,lay) * cfc12(ig) & - + wx(4,lay) * cfc22adj(ig) - fracs(lay,ngs7+ig) = fracrefa(ig) - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop+1, nlayers - ! In atmospheres where the amount of CO2 is too great to be considered - ! a minor species, adjust the column amount of CO2 by an empirical factor - ! to obtain the proper contribution. - chi_co2 = colco2(lay)/coldry(lay) - ratco2 = 1.e20_r8*chi_co2/chi_mls(2,jp(lay)+1) - if (ratco2 .gt. 3.0_r8) then - adjfac = 2.0_r8+(ratco2-2.0_r8)**0.65_r8 - adjcolco2 = adjfac*chi_mls(2,jp(lay)+1) * coldry(lay)*1.e-20_r8 - else - adjcolco2 = colco2(lay) - endif - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(8) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(8) + 1 - indm = indminor(lay) - do ig = 1, ng8 - absco2 = (kb_mco2(indm,ig) + minorfrac(lay) * & - (kb_mco2(indm+1,ig) - kb_mco2(indm,ig))) - absn2o = (kb_mn2o(indm,ig) + minorfrac(lay) * & - (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig))) - taug(lay,ngs7+ig) = colo3(lay) * & - (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + & - fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) & - + adjcolco2*absco2 & - + coln2o(lay)*absn2o & - + wx(3,lay) * cfc12(ig) & - + wx(4,lay) * cfc22adj(ig) - fracs(lay,ngs7+ig) = fracrefb(ig) - enddo - enddo - END SUBROUTINE taugb8 - !---------------------------------------------------------------------------- - - SUBROUTINE taugb9() - !---------------------------------------------------------------------------- - ! - ! band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o) - ! (high key - ch4; high minor - n2o) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrtm, ONLY: ng9 - USE parrrtm, ONLY: ngs8 - USE rrlw_ref, ONLY: chi_mls - USE rrlw_kg09, ONLY: selfref - USE rrlw_kg09, ONLY: forref - USE rrlw_kg09, ONLY: ka_mn2o - USE rrlw_kg09, ONLY: absa - USE rrlw_kg09, ONLY: fracrefa - USE rrlw_kg09, ONLY: kb_mn2o - USE rrlw_kg09, ONLY: absb - USE rrlw_kg09, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: ig - INTEGER :: js - INTEGER :: js1 - INTEGER :: jmn2o - INTEGER :: jpl - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: speccomb1 - REAL(KIND=r8) :: specparm1 - REAL(KIND=r8) :: specmult1 - REAL(KIND=r8) :: fs1 - REAL(KIND=r8) :: speccomb_mn2o - REAL(KIND=r8) :: specparm_mn2o - REAL(KIND=r8) :: specmult_mn2o - REAL(KIND=r8) :: fmn2o - REAL(KIND=r8) :: speccomb_planck - REAL(KIND=r8) :: specparm_planck - REAL(KIND=r8) :: specmult_planck - REAL(KIND=r8) :: fpl - REAL(KIND=r8) :: p - REAL(KIND=r8) :: p4 - REAL(KIND=r8) :: fk0 - REAL(KIND=r8) :: fk1 - REAL(KIND=r8) :: fk2 - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac200 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac210 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac201 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: fac211 - REAL(KIND=r8) :: tauself - REAL(KIND=r8) :: taufor - REAL(KIND=r8) :: n2om1 - REAL(KIND=r8) :: n2om2 - REAL(KIND=r8) :: absn2o - REAL(KIND=r8) :: chi_n2o - REAL(KIND=r8) :: ratn2o - REAL(KIND=r8) :: adjfac - REAL(KIND=r8) :: adjcoln2o - REAL(KIND=r8) :: refrat_planck_a - REAL(KIND=r8) :: refrat_m_a - REAL(KIND=r8) :: tau_major - REAL(KIND=r8) :: tau_major1 - ! Minor gas mapping level : - ! lower - n2o, p = 706.272 mbar, t = 278.94 k - ! upper - n2o, p = 95.58 mbar, t = 215.7 k - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower/upper atmosphere. - ! P = 212 mb - refrat_planck_a = chi_mls(1,9)/chi_mls(6,9) - ! P = 706.272 mb - refrat_m_a = chi_mls(1,3)/chi_mls(6,3) - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below laytrop, the water - ! vapor self-continuum and foreign continuum is interpolated - ! (in temperature) separately. - ! Lower atmosphere loop - do lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2och4(lay)*colch4(lay) - specparm = colh2o(lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_r8) - speccomb1 = colh2o(lay) + rat_h2och4_1(lay)*colch4(lay) - specparm1 = colh2o(lay)/speccomb1 - if (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._r8*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_r8) - speccomb_mn2o = colh2o(lay) + refrat_m_a*colch4(lay) - specparm_mn2o = colh2o(lay)/speccomb_mn2o - if (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus - specmult_mn2o = 8._r8*specparm_mn2o - jmn2o = 1 + int(specmult_mn2o) - fmn2o = mod(specmult_mn2o,1.0_r8) - ! In atmospheres where the amount of N2O is too great to be considered - ! a minor species, adjust the column amount of N2O by an empirical factor - ! to obtain the proper contribution. - chi_n2o = coln2o(lay)/(coldry(lay)) - ratn2o = 1.e20_r8*chi_n2o/chi_mls(4,jp(lay)+1) - if (ratn2o .gt. 1.5_r8) then - adjfac = 0.5_r8+(ratn2o-0.5_r8)**0.65_r8 - adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_r8 - else - adjcoln2o = coln2o(lay) - endif - speccomb_planck = colh2o(lay)+refrat_planck_a*colch4(lay) - specparm_planck = colh2o(lay)/speccomb_planck - if (specparm_planck .ge. oneminus) specparm_planck=oneminus - specmult_planck = 8._r8*specparm_planck - jpl= 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_r8) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(9) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(9) + js1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - if (specparm .lt. 0.125_r8) then - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - else if (specparm .gt. 0.875_r8) then - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - else - fac000 = (1._r8 - fs) * fac00(lay) - fac010 = (1._r8 - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - endif - if (specparm1 .lt. 0.125_r8) then - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - else if (specparm1 .gt. 0.875_r8) then - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - else - fac001 = (1._r8 - fs1) * fac01(lay) - fac011 = (1._r8 - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - endif - do ig = 1, ng9 - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & - (forref(indf+1,ig) - forref(indf,ig))) - n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o * & - (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,indm,ig)) - n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o * & - (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(jmn2o,indm+1,ig)) - absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1) - if (specparm .lt. 0.125_r8) then - tau_major = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - else if (specparm .gt. 0.875_r8) then - tau_major = speccomb * & - (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + & - fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + & - fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - else - tau_major = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - endif - if (specparm1 .lt. 0.125_r8) then - tau_major1 = speccomb1 * & - (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - else if (specparm1 .gt. 0.875_r8) then - tau_major1 = speccomb1 * & - (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + & - fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + & - fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - else - tau_major1 = speccomb1 * & - (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - endif - taug(lay,ngs8+ig) = tau_major + tau_major1 & - + tauself + taufor & - + adjcoln2o*absn2o - fracs(lay,ngs8+ig) = fracrefa(ig,jpl) + fpl * & - (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop+1, nlayers - ! In atmospheres where the amount of N2O is too great to be considered - ! a minor species, adjust the column amount of N2O by an empirical factor - ! to obtain the proper contribution. - chi_n2o = coln2o(lay)/(coldry(lay)) - ratn2o = 1.e20_r8*chi_n2o/chi_mls(4,jp(lay)+1) - if (ratn2o .gt. 1.5_r8) then - adjfac = 0.5_r8+(ratn2o-0.5_r8)**0.65_r8 - adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_r8 - else - adjcoln2o = coln2o(lay) - endif - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(9) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(9) + 1 - indm = indminor(lay) - do ig = 1, ng9 - absn2o = kb_mn2o(indm,ig) + minorfrac(lay) * & - (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig)) - taug(lay,ngs8+ig) = colch4(lay) * & - (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + & - fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) & - + adjcoln2o*absn2o - fracs(lay,ngs8+ig) = fracrefb(ig) - enddo - enddo - END SUBROUTINE taugb9 - !---------------------------------------------------------------------------- - - SUBROUTINE taugb10() - !---------------------------------------------------------------------------- - ! - ! band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrtm, ONLY: ng10 - USE parrrtm, ONLY: ngs9 - USE rrlw_kg10, ONLY: selfref - USE rrlw_kg10, ONLY: forref - USE rrlw_kg10, ONLY: absa - USE rrlw_kg10, ONLY: fracrefa - USE rrlw_kg10, ONLY: absb - USE rrlw_kg10, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - REAL(KIND=r8) :: tauself - REAL(KIND=r8) :: taufor - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature. Below laytrop, the water vapor self-continuum and - ! foreign continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - do lay = 1, laytrop - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(10) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(10) + 1 - inds = indself(lay) - indf = indfor(lay) - do ig = 1, ng10 - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & - (forref(indf+1,ig) - forref(indf,ig))) - taug(lay,ngs9+ig) = colh2o(lay) * & - (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + & - fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) & - + tauself + taufor - fracs(lay,ngs9+ig) = fracrefa(ig) - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop+1, nlayers - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(10) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(10) + 1 - indf = indfor(lay) - do ig = 1, ng10 - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & - (forref(indf+1,ig) - forref(indf,ig))) - taug(lay,ngs9+ig) = colh2o(lay) * & - (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + & - fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) & - + taufor - fracs(lay,ngs9+ig) = fracrefb(ig) - enddo - enddo - END SUBROUTINE taugb10 - !---------------------------------------------------------------------------- - - SUBROUTINE taugb11() - !---------------------------------------------------------------------------- - ! - ! band 11: 1480-1800 cm-1 (low - h2o; low minor - o2) - ! (high key - h2o; high minor - o2) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrtm, ONLY: ng11 - USE parrrtm, ONLY: ngs10 - USE rrlw_kg11, ONLY: selfref - USE rrlw_kg11, ONLY: forref - USE rrlw_kg11, ONLY: ka_mo2 - USE rrlw_kg11, ONLY: absa - USE rrlw_kg11, ONLY: fracrefa - USE rrlw_kg11, ONLY: kb_mo2 - USE rrlw_kg11, ONLY: absb - USE rrlw_kg11, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: ig - REAL(KIND=r8) :: scaleo2 - REAL(KIND=r8) :: tauself - REAL(KIND=r8) :: taufor - REAL(KIND=r8) :: tauo2 - ! Minor gas mapping level : - ! lower - o2, p = 706.2720 mbar, t = 278.94 k - ! upper - o2, p = 4.758820 mbarm t = 250.85 k - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature. Below laytrop, the water vapor self-continuum and - ! foreign continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - do lay = 1, laytrop - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(11) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(11) + 1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - scaleo2 = colo2(lay)*scaleminor(lay) - do ig = 1, ng11 - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & - (forref(indf+1,ig) - forref(indf,ig))) - tauo2 = scaleo2 * (ka_mo2(indm,ig) + minorfrac(lay) * & - (ka_mo2(indm+1,ig) - ka_mo2(indm,ig))) - taug(lay,ngs10+ig) = colh2o(lay) * & - (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + & - fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) & - + tauself + taufor & - + tauo2 - fracs(lay,ngs10+ig) = fracrefa(ig) - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop+1, nlayers - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(11) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(11) + 1 - indf = indfor(lay) - indm = indminor(lay) - scaleo2 = colo2(lay)*scaleminor(lay) - do ig = 1, ng11 - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & - (forref(indf+1,ig) - forref(indf,ig))) - tauo2 = scaleo2 * (kb_mo2(indm,ig) + minorfrac(lay) * & - (kb_mo2(indm+1,ig) - kb_mo2(indm,ig))) - taug(lay,ngs10+ig) = colh2o(lay) * & - (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + & - fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) & - + taufor & - + tauo2 - fracs(lay,ngs10+ig) = fracrefb(ig) - enddo - enddo - END SUBROUTINE taugb11 - !---------------------------------------------------------------------------- - - SUBROUTINE taugb12() - !---------------------------------------------------------------------------- - ! - ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrtm, ONLY: ng12 - USE parrrtm, ONLY: ngs11 - USE rrlw_ref, ONLY: chi_mls - USE rrlw_kg12, ONLY: selfref - USE rrlw_kg12, ONLY: forref - USE rrlw_kg12, ONLY: absa - USE rrlw_kg12, ONLY: fracrefa - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - INTEGER :: js - INTEGER :: js1 - INTEGER :: jpl - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: speccomb1 - REAL(KIND=r8) :: specparm1 - REAL(KIND=r8) :: specmult1 - REAL(KIND=r8) :: fs1 - REAL(KIND=r8) :: speccomb_planck - REAL(KIND=r8) :: specparm_planck - REAL(KIND=r8) :: specmult_planck - REAL(KIND=r8) :: fpl - REAL(KIND=r8) :: p - REAL(KIND=r8) :: p4 - REAL(KIND=r8) :: fk0 - REAL(KIND=r8) :: fk1 - REAL(KIND=r8) :: fk2 - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac200 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac210 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac201 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: fac211 - REAL(KIND=r8) :: tauself - REAL(KIND=r8) :: taufor - REAL(KIND=r8) :: refrat_planck_a - REAL(KIND=r8) :: tau_major - REAL(KIND=r8) :: tau_major1 - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower/upper atmosphere. - ! P = 174.164 mb - refrat_planck_a = chi_mls(1,10)/chi_mls(2,10) - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below laytrop, the water - ! vapor self-continuum adn foreign continuum is interpolated - ! (in temperature) separately. - ! Lower atmosphere loop - do lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) - specparm = colh2o(lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_r8) - speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) - specparm1 = colh2o(lay)/speccomb1 - if (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._r8*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_r8) - speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay) - specparm_planck = colh2o(lay)/speccomb_planck - if (specparm_planck .ge. oneminus) specparm_planck=oneminus - specmult_planck = 8._r8*specparm_planck - jpl= 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_r8) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(12) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(12) + js1 - inds = indself(lay) - indf = indfor(lay) - if (specparm .lt. 0.125_r8) then - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - else if (specparm .gt. 0.875_r8) then - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - else - fac000 = (1._r8 - fs) * fac00(lay) - fac010 = (1._r8 - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - endif - if (specparm1 .lt. 0.125_r8) then - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - else if (specparm1 .gt. 0.875_r8) then - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - else - fac001 = (1._r8 - fs1) * fac01(lay) - fac011 = (1._r8 - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - endif - do ig = 1, ng12 - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & - (forref(indf+1,ig) - forref(indf,ig))) - if (specparm .lt. 0.125_r8) then - tau_major = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - else if (specparm .gt. 0.875_r8) then - tau_major = speccomb * & - (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + & - fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + & - fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - else - tau_major = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - endif - if (specparm1 .lt. 0.125_r8) then - tau_major1 = speccomb1 * & - (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - else if (specparm1 .gt. 0.875_r8) then - tau_major1 = speccomb1 * & - (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + & - fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + & - fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - else - tau_major1 = speccomb1 * & - (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - endif - taug(lay,ngs11+ig) = tau_major + tau_major1 & - + tauself + taufor - fracs(lay,ngs11+ig) = fracrefa(ig,jpl) + fpl * & - (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop+1, nlayers - do ig = 1, ng12 - taug(lay,ngs11+ig) = 0.0_r8 - fracs(lay,ngs11+ig) = 0.0_r8 - enddo - enddo - END SUBROUTINE taugb12 - !---------------------------------------------------------------------------- - - SUBROUTINE taugb13() - !---------------------------------------------------------------------------- - ! - ! band 13: 2080-2250 cm-1 (low key - h2o,n2o; high minor - o3 minor) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrtm, ONLY: ng13 - USE parrrtm, ONLY: ngs12 - USE rrlw_ref, ONLY: chi_mls - USE rrlw_kg13, ONLY: selfref - USE rrlw_kg13, ONLY: forref - USE rrlw_kg13, ONLY: ka_mco2 - USE rrlw_kg13, ONLY: ka_mco - USE rrlw_kg13, ONLY: absa - USE rrlw_kg13, ONLY: fracrefa - USE rrlw_kg13, ONLY: kb_mo3 - USE rrlw_kg13, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: ig - INTEGER :: js - INTEGER :: js1 - INTEGER :: jmco2 - INTEGER :: jmco - INTEGER :: jpl - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: speccomb1 - REAL(KIND=r8) :: specparm1 - REAL(KIND=r8) :: specmult1 - REAL(KIND=r8) :: fs1 - REAL(KIND=r8) :: speccomb_mco2 - REAL(KIND=r8) :: specparm_mco2 - REAL(KIND=r8) :: specmult_mco2 - REAL(KIND=r8) :: fmco2 - REAL(KIND=r8) :: speccomb_mco - REAL(KIND=r8) :: specparm_mco - REAL(KIND=r8) :: specmult_mco - REAL(KIND=r8) :: fmco - REAL(KIND=r8) :: speccomb_planck - REAL(KIND=r8) :: specparm_planck - REAL(KIND=r8) :: specmult_planck - REAL(KIND=r8) :: fpl - REAL(KIND=r8) :: p - REAL(KIND=r8) :: p4 - REAL(KIND=r8) :: fk0 - REAL(KIND=r8) :: fk1 - REAL(KIND=r8) :: fk2 - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac200 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac210 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac201 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: fac211 - REAL(KIND=r8) :: tauself - REAL(KIND=r8) :: taufor - REAL(KIND=r8) :: co2m1 - REAL(KIND=r8) :: co2m2 - REAL(KIND=r8) :: absco2 - REAL(KIND=r8) :: com1 - REAL(KIND=r8) :: com2 - REAL(KIND=r8) :: absco - REAL(KIND=r8) :: abso3 - REAL(KIND=r8) :: chi_co2 - REAL(KIND=r8) :: ratco2 - REAL(KIND=r8) :: adjfac - REAL(KIND=r8) :: adjcolco2 - REAL(KIND=r8) :: refrat_planck_a - REAL(KIND=r8) :: refrat_m_a - REAL(KIND=r8) :: refrat_m_a3 - REAL(KIND=r8) :: tau_major - REAL(KIND=r8) :: tau_major1 - ! Minor gas mapping levels : - ! lower - co2, p = 1053.63 mb, t = 294.2 k - ! lower - co, p = 706 mb, t = 278.94 k - ! upper - o3, p = 95.5835 mb, t = 215.7 k - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower/upper atmosphere. - ! P = 473.420 mb (Level 5) - refrat_planck_a = chi_mls(1,5)/chi_mls(4,5) - ! P = 1053. (Level 1) - refrat_m_a = chi_mls(1,1)/chi_mls(4,1) - ! P = 706. (Level 3) - refrat_m_a3 = chi_mls(1,3)/chi_mls(4,3) - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below laytrop, the water - ! vapor self-continuum and foreign continuum is interpolated - ! (in temperature) separately. - ! Lower atmosphere loop - do lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2on2o(lay)*coln2o(lay) - specparm = colh2o(lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_r8) - speccomb1 = colh2o(lay) + rat_h2on2o_1(lay)*coln2o(lay) - specparm1 = colh2o(lay)/speccomb1 - if (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._r8*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_r8) - speccomb_mco2 = colh2o(lay) + refrat_m_a*coln2o(lay) - specparm_mco2 = colh2o(lay)/speccomb_mco2 - if (specparm_mco2 .ge. oneminus) specparm_mco2 = oneminus - specmult_mco2 = 8._r8*specparm_mco2 - jmco2 = 1 + int(specmult_mco2) - fmco2 = mod(specmult_mco2,1.0_r8) - ! In atmospheres where the amount of CO2 is too great to be considered - ! a minor species, adjust the column amount of CO2 by an empirical factor - ! to obtain the proper contribution. - chi_co2 = colco2(lay)/(coldry(lay)) - ratco2 = 1.e20_r8*chi_co2/3.55e-4_r8 - if (ratco2 .gt. 3.0_r8) then - adjfac = 2.0_r8+(ratco2-2.0_r8)**0.68_r8 - adjcolco2 = adjfac*3.55e-4*coldry(lay)*1.e-20_r8 - else - adjcolco2 = colco2(lay) - endif - speccomb_mco = colh2o(lay) + refrat_m_a3*coln2o(lay) - specparm_mco = colh2o(lay)/speccomb_mco - if (specparm_mco .ge. oneminus) specparm_mco = oneminus - specmult_mco = 8._r8*specparm_mco - jmco = 1 + int(specmult_mco) - fmco = mod(specmult_mco,1.0_r8) - speccomb_planck = colh2o(lay)+refrat_planck_a*coln2o(lay) - specparm_planck = colh2o(lay)/speccomb_planck - if (specparm_planck .ge. oneminus) specparm_planck=oneminus - specmult_planck = 8._r8*specparm_planck - jpl= 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_r8) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(13) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(13) + js1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - if (specparm .lt. 0.125_r8) then - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - else if (specparm .gt. 0.875_r8) then - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - else - fac000 = (1._r8 - fs) * fac00(lay) - fac010 = (1._r8 - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - endif - if (specparm1 .lt. 0.125_r8) then - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - else if (specparm1 .gt. 0.875_r8) then - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - else - fac001 = (1._r8 - fs1) * fac01(lay) - fac011 = (1._r8 - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - endif - do ig = 1, ng13 - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & - (forref(indf+1,ig) - forref(indf,ig))) - co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 * & - (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,indm,ig)) - co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 * & - (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(jmco2,indm+1,ig)) - absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1) - com1 = ka_mco(jmco,indm,ig) + fmco * & - (ka_mco(jmco+1,indm,ig) - ka_mco(jmco,indm,ig)) - com2 = ka_mco(jmco,indm+1,ig) + fmco * & - (ka_mco(jmco+1,indm+1,ig) - ka_mco(jmco,indm+1,ig)) - absco = com1 + minorfrac(lay) * (com2 - com1) - if (specparm .lt. 0.125_r8) then - tau_major = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - else if (specparm .gt. 0.875_r8) then - tau_major = speccomb * & - (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + & - fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + & - fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - else - tau_major = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - endif - if (specparm1 .lt. 0.125_r8) then - tau_major1 = speccomb1 * & - (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - else if (specparm1 .gt. 0.875_r8) then - tau_major1 = speccomb1 * & - (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + & - fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + & - fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - else - tau_major1 = speccomb1 * & - (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - endif - taug(lay,ngs12+ig) = tau_major + tau_major1 & - + tauself + taufor & - + adjcolco2*absco2 & - + colco(lay)*absco - fracs(lay,ngs12+ig) = fracrefa(ig,jpl) + fpl * & - (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop+1, nlayers - indm = indminor(lay) - do ig = 1, ng13 - abso3 = kb_mo3(indm,ig) + minorfrac(lay) * & - (kb_mo3(indm+1,ig) - kb_mo3(indm,ig)) - taug(lay,ngs12+ig) = colo3(lay)*abso3 - fracs(lay,ngs12+ig) = fracrefb(ig) - enddo - enddo - END SUBROUTINE taugb13 - !---------------------------------------------------------------------------- - - SUBROUTINE taugb14() - !---------------------------------------------------------------------------- - ! - ! band 14: 2250-2380 cm-1 (low - co2; high - co2) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrtm, ONLY: ng14 - USE parrrtm, ONLY: ngs13 - USE rrlw_kg14, ONLY: selfref - USE rrlw_kg14, ONLY: forref - USE rrlw_kg14, ONLY: absa - USE rrlw_kg14, ONLY: fracrefa - USE rrlw_kg14, ONLY: absb - USE rrlw_kg14, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - REAL(KIND=r8) :: tauself - REAL(KIND=r8) :: taufor - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature. Below laytrop, the water vapor self-continuum - ! and foreign continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - do lay = 1, laytrop - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(14) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(14) + 1 - inds = indself(lay) - indf = indfor(lay) - do ig = 1, ng14 - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & - (forref(indf+1,ig) - forref(indf,ig))) - taug(lay,ngs13+ig) = colco2(lay) * & - (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + & - fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) & - + tauself + taufor - fracs(lay,ngs13+ig) = fracrefa(ig) - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop+1, nlayers - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(14) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(14) + 1 - do ig = 1, ng14 - taug(lay,ngs13+ig) = colco2(lay) * & - (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + & - fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) - fracs(lay,ngs13+ig) = fracrefb(ig) - enddo - enddo - END SUBROUTINE taugb14 - !---------------------------------------------------------------------------- - - SUBROUTINE taugb15() - !---------------------------------------------------------------------------- - ! - ! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2) - ! (high - nothing) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrtm, ONLY: ng15 - USE parrrtm, ONLY: ngs14 - USE rrlw_ref, ONLY: chi_mls - USE rrlw_kg15, ONLY: selfref - USE rrlw_kg15, ONLY: forref - USE rrlw_kg15, ONLY: ka_mn2 - USE rrlw_kg15, ONLY: absa - USE rrlw_kg15, ONLY: fracrefa - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: ig - INTEGER :: js - INTEGER :: js1 - INTEGER :: jmn2 - INTEGER :: jpl - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: speccomb1 - REAL(KIND=r8) :: specparm1 - REAL(KIND=r8) :: specmult1 - REAL(KIND=r8) :: fs1 - REAL(KIND=r8) :: speccomb_mn2 - REAL(KIND=r8) :: specparm_mn2 - REAL(KIND=r8) :: specmult_mn2 - REAL(KIND=r8) :: fmn2 - REAL(KIND=r8) :: speccomb_planck - REAL(KIND=r8) :: specparm_planck - REAL(KIND=r8) :: specmult_planck - REAL(KIND=r8) :: fpl - REAL(KIND=r8) :: p - REAL(KIND=r8) :: p4 - REAL(KIND=r8) :: fk0 - REAL(KIND=r8) :: fk1 - REAL(KIND=r8) :: fk2 - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac200 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac210 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac201 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: fac211 - REAL(KIND=r8) :: scalen2 - REAL(KIND=r8) :: tauself - REAL(KIND=r8) :: taufor - REAL(KIND=r8) :: n2m1 - REAL(KIND=r8) :: n2m2 - REAL(KIND=r8) :: taun2 - REAL(KIND=r8) :: refrat_planck_a - REAL(KIND=r8) :: refrat_m_a - REAL(KIND=r8) :: tau_major - REAL(KIND=r8) :: tau_major1 - ! Minor gas mapping level : - ! Lower - Nitrogen Continuum, P = 1053., T = 294. - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower atmosphere. - ! P = 1053. mb (Level 1) - refrat_planck_a = chi_mls(4,1)/chi_mls(2,1) - ! P = 1053. - refrat_m_a = chi_mls(4,1)/chi_mls(2,1) - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below laytrop, the water - ! vapor self-continuum and foreign continuum is interpolated - ! (in temperature) separately. - ! Lower atmosphere loop - do lay = 1, laytrop - speccomb = coln2o(lay) + rat_n2oco2(lay)*colco2(lay) - specparm = coln2o(lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_r8) - speccomb1 = coln2o(lay) + rat_n2oco2_1(lay)*colco2(lay) - specparm1 = coln2o(lay)/speccomb1 - if (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._r8*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_r8) - speccomb_mn2 = coln2o(lay) + refrat_m_a*colco2(lay) - specparm_mn2 = coln2o(lay)/speccomb_mn2 - if (specparm_mn2 .ge. oneminus) specparm_mn2 = oneminus - specmult_mn2 = 8._r8*specparm_mn2 - jmn2 = 1 + int(specmult_mn2) - fmn2 = mod(specmult_mn2,1.0_r8) - speccomb_planck = coln2o(lay)+refrat_planck_a*colco2(lay) - specparm_planck = coln2o(lay)/speccomb_planck - if (specparm_planck .ge. oneminus) specparm_planck=oneminus - specmult_planck = 8._r8*specparm_planck - jpl= 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_r8) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(15) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(15) + js1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - scalen2 = colbrd(lay)*scaleminor(lay) - if (specparm .lt. 0.125_r8) then - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - else if (specparm .gt. 0.875_r8) then - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - else - fac000 = (1._r8 - fs) * fac00(lay) - fac010 = (1._r8 - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - endif - if (specparm1 .lt. 0.125_r8) then - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - else if (specparm1 .gt. 0.875_r8) then - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - else - fac001 = (1._r8 - fs1) * fac01(lay) - fac011 = (1._r8 - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - endif - do ig = 1, ng15 - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & - (forref(indf+1,ig) - forref(indf,ig))) - n2m1 = ka_mn2(jmn2,indm,ig) + fmn2 * & - (ka_mn2(jmn2+1,indm,ig) - ka_mn2(jmn2,indm,ig)) - n2m2 = ka_mn2(jmn2,indm+1,ig) + fmn2 * & - (ka_mn2(jmn2+1,indm+1,ig) - ka_mn2(jmn2,indm+1,ig)) - taun2 = scalen2 * (n2m1 + minorfrac(lay) * (n2m2 - n2m1)) - if (specparm .lt. 0.125_r8) then - tau_major = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - else if (specparm .gt. 0.875_r8) then - tau_major = speccomb * & - (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + & - fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + & - fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - else - tau_major = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - endif - if (specparm1 .lt. 0.125_r8) then - tau_major1 = speccomb1 * & - (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - else if (specparm1 .gt. 0.875_r8) then - tau_major1 = speccomb1 * & - (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + & - fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + & - fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - else - tau_major1 = speccomb1 * & - (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - endif - taug(lay,ngs14+ig) = tau_major + tau_major1 & - + tauself + taufor & - + taun2 - fracs(lay,ngs14+ig) = fracrefa(ig,jpl) + fpl * & - (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop+1, nlayers - do ig = 1, ng15 - taug(lay,ngs14+ig) = 0.0_r8 - fracs(lay,ngs14+ig) = 0.0_r8 - enddo - enddo - END SUBROUTINE taugb15 - !---------------------------------------------------------------------------- - - SUBROUTINE taugb16() - !---------------------------------------------------------------------------- - ! - ! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrtm, ONLY: ng16 - USE parrrtm, ONLY: ngs15 - USE rrlw_ref, ONLY: chi_mls - USE rrlw_kg16, ONLY: selfref - USE rrlw_kg16, ONLY: forref - USE rrlw_kg16, ONLY: absa - USE rrlw_kg16, ONLY: fracrefa - USE rrlw_kg16, ONLY: absb - USE rrlw_kg16, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - INTEGER :: js - INTEGER :: js1 - INTEGER :: jpl - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: speccomb1 - REAL(KIND=r8) :: specparm1 - REAL(KIND=r8) :: specmult1 - REAL(KIND=r8) :: fs1 - REAL(KIND=r8) :: speccomb_planck - REAL(KIND=r8) :: specparm_planck - REAL(KIND=r8) :: specmult_planck - REAL(KIND=r8) :: fpl - REAL(KIND=r8) :: p - REAL(KIND=r8) :: p4 - REAL(KIND=r8) :: fk0 - REAL(KIND=r8) :: fk1 - REAL(KIND=r8) :: fk2 - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac200 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac210 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac201 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: fac211 - REAL(KIND=r8) :: tauself - REAL(KIND=r8) :: taufor - REAL(KIND=r8) :: refrat_planck_a - REAL(KIND=r8) :: tau_major - REAL(KIND=r8) :: tau_major1 - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower atmosphere. - ! P = 387. mb (Level 6) - refrat_planck_a = chi_mls(1,6)/chi_mls(6,6) - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature,and appropriate species. Below laytrop, the water - ! vapor self-continuum and foreign continuum is interpolated - ! (in temperature) separately. - ! Lower atmosphere loop - do lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2och4(lay)*colch4(lay) - specparm = colh2o(lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_r8) - speccomb1 = colh2o(lay) + rat_h2och4_1(lay)*colch4(lay) - specparm1 = colh2o(lay)/speccomb1 - if (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._r8*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_r8) - speccomb_planck = colh2o(lay)+refrat_planck_a*colch4(lay) - specparm_planck = colh2o(lay)/speccomb_planck - if (specparm_planck .ge. oneminus) specparm_planck=oneminus - specmult_planck = 8._r8*specparm_planck - jpl= 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_r8) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(16) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(16) + js1 - inds = indself(lay) - indf = indfor(lay) - if (specparm .lt. 0.125_r8) then - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - else if (specparm .gt. 0.875_r8) then - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - else - fac000 = (1._r8 - fs) * fac00(lay) - fac010 = (1._r8 - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - endif - if (specparm1 .lt. 0.125_r8) then - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - else if (specparm1 .gt. 0.875_r8) then - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_r8*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - else - fac001 = (1._r8 - fs1) * fac01(lay) - fac011 = (1._r8 - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - endif - do ig = 1, ng16 - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & - (forref(indf+1,ig) - forref(indf,ig))) - if (specparm .lt. 0.125_r8) then - tau_major = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - else if (specparm .gt. 0.875_r8) then - tau_major = speccomb * & - (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + & - fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + & - fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - else - tau_major = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - endif - if (specparm1 .lt. 0.125_r8) then - tau_major1 = speccomb1 * & - (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - else if (specparm1 .gt. 0.875_r8) then - tau_major1 = speccomb1 * & - (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + & - fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + & - fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - else - tau_major1 = speccomb1 * & - (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - endif - taug(lay,ngs15+ig) = tau_major + tau_major1 & - + tauself + taufor - fracs(lay,ngs15+ig) = fracrefa(ig,jpl) + fpl * & - (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop+1, nlayers - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(16) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(16) + 1 - do ig = 1, ng16 - taug(lay,ngs15+ig) = colch4(lay) * & - (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + & - fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) - fracs(lay,ngs15+ig) = fracrefb(ig) - enddo - enddo - END SUBROUTINE taugb16 - END SUBROUTINE taumol - END MODULE rrtmg_lw_taumol diff --git a/test/ncar_kernels/PORT_lw_rad/src/rrtmg_state.F90 b/test/ncar_kernels/PORT_lw_rad/src/rrtmg_state.F90 deleted file mode 100644 index 269155b43a..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/rrtmg_state.F90 +++ /dev/null @@ -1,262 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_state.F90 -! Generated at: 2015-07-06 23:28:43 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_state - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - PRIVATE - PUBLIC rrtmg_state_t - TYPE rrtmg_state_t - REAL(KIND=r8), allocatable :: h2ovmr(:,:) ! h2o volume mixing ratio - REAL(KIND=r8), allocatable :: o3vmr(:,:) ! o3 volume mixing ratio - REAL(KIND=r8), allocatable :: co2vmr(:,:) ! co2 volume mixing ratio - REAL(KIND=r8), allocatable :: ch4vmr(:,:) ! ch4 volume mixing ratio - REAL(KIND=r8), allocatable :: o2vmr(:,:) ! o2 volume mixing ratio - REAL(KIND=r8), allocatable :: n2ovmr(:,:) ! n2o volume mixing ratio - REAL(KIND=r8), allocatable :: cfc11vmr(:,:) ! cfc11 volume mixing ratio - REAL(KIND=r8), allocatable :: cfc12vmr(:,:) ! cfc12 volume mixing ratio - REAL(KIND=r8), allocatable :: cfc22vmr(:,:) ! cfc22 volume mixing ratio - REAL(KIND=r8), allocatable :: ccl4vmr(:,:) ! ccl4 volume mixing ratio - REAL(KIND=r8), allocatable :: pmidmb(:,:) ! Level pressure (hPa) - REAL(KIND=r8), allocatable :: pintmb(:,:) ! Model interface pressure (hPa) - REAL(KIND=r8), allocatable :: tlay(:,:) ! mid point temperature - REAL(KIND=r8), allocatable :: tlev(:,:) ! interface temperature - END TYPE rrtmg_state_t - ! number of pressure levels greate than 1.e-4_r8 mbar - ! Molecular weight of dry air / water vapor - ! Molecular weight of dry air / carbon dioxide - ! Molecular weight of dry air / ozone - ! Molecular weight of dry air / methane - ! Molecular weight of dry air / nitrous oxide - ! Molecular weight of dry air / oxygen - ! Molecular weight of dry air / CFC11 - ! Molecular weight of dry air / CFC12 - - ! read interface - PUBLIC kgen_read - INTERFACE kgen_read - MODULE PROCEDURE kgen_read_rrtmg_state_t - END INTERFACE kgen_read - - PUBLIC kgen_verify - INTERFACE kgen_verify - MODULE PROCEDURE kgen_verify_rrtmg_state_t - END INTERFACE kgen_verify - - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_r8_dim2_alloc(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim2_alloc - - ! No module extern variables - SUBROUTINE kgen_read_rrtmg_state_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(rrtmg_state_t), INTENT(out) :: var - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%h2ovmr, kgen_unit, printvar=printvar//"%h2ovmr") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%h2ovmr, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%o3vmr, kgen_unit, printvar=printvar//"%o3vmr") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%o3vmr, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%co2vmr, kgen_unit, printvar=printvar//"%co2vmr") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%co2vmr, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%ch4vmr, kgen_unit, printvar=printvar//"%ch4vmr") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%ch4vmr, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%o2vmr, kgen_unit, printvar=printvar//"%o2vmr") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%o2vmr, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%n2ovmr, kgen_unit, printvar=printvar//"%n2ovmr") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%n2ovmr, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%cfc11vmr, kgen_unit, printvar=printvar//"%cfc11vmr") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%cfc11vmr, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%cfc12vmr, kgen_unit, printvar=printvar//"%cfc12vmr") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%cfc12vmr, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%cfc22vmr, kgen_unit, printvar=printvar//"%cfc22vmr") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%cfc22vmr, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%ccl4vmr, kgen_unit, printvar=printvar//"%ccl4vmr") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%ccl4vmr, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%pmidmb, kgen_unit, printvar=printvar//"%pmidmb") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%pmidmb, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%pintmb, kgen_unit, printvar=printvar//"%pintmb") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%pintmb, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%tlay, kgen_unit, printvar=printvar//"%tlay") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%tlay, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%tlev, kgen_unit, printvar=printvar//"%tlev") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%tlev, kgen_unit) - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_rrtmg_state_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(rrtmg_state_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_real_r8_dim2_alloc("h2ovmr", dtype_check_status, var%h2ovmr, ref_var%h2ovmr) - CALL kgen_verify_real_r8_dim2_alloc("o3vmr", dtype_check_status, var%o3vmr, ref_var%o3vmr) - CALL kgen_verify_real_r8_dim2_alloc("co2vmr", dtype_check_status, var%co2vmr, ref_var%co2vmr) - CALL kgen_verify_real_r8_dim2_alloc("ch4vmr", dtype_check_status, var%ch4vmr, ref_var%ch4vmr) - CALL kgen_verify_real_r8_dim2_alloc("o2vmr", dtype_check_status, var%o2vmr, ref_var%o2vmr) - CALL kgen_verify_real_r8_dim2_alloc("n2ovmr", dtype_check_status, var%n2ovmr, ref_var%n2ovmr) - CALL kgen_verify_real_r8_dim2_alloc("cfc11vmr", dtype_check_status, var%cfc11vmr, ref_var%cfc11vmr) - CALL kgen_verify_real_r8_dim2_alloc("cfc12vmr", dtype_check_status, var%cfc12vmr, ref_var%cfc12vmr) - CALL kgen_verify_real_r8_dim2_alloc("cfc22vmr", dtype_check_status, var%cfc22vmr, ref_var%cfc22vmr) - CALL kgen_verify_real_r8_dim2_alloc("ccl4vmr", dtype_check_status, var%ccl4vmr, ref_var%ccl4vmr) - CALL kgen_verify_real_r8_dim2_alloc("pmidmb", dtype_check_status, var%pmidmb, ref_var%pmidmb) - CALL kgen_verify_real_r8_dim2_alloc("pintmb", dtype_check_status, var%pintmb, ref_var%pintmb) - CALL kgen_verify_real_r8_dim2_alloc("tlay", dtype_check_status, var%tlay, ref_var%tlay) - CALL kgen_verify_real_r8_dim2_alloc("tlev", dtype_check_status, var%tlev, ref_var%tlev) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_real_r8_dim2_alloc( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:), ALLOCATABLE :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:) :: temp, temp2 - integer :: n - IF ( ALLOCATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END IF - END SUBROUTINE kgen_verify_real_r8_dim2_alloc - - !-------------------------------------------------------------------------------- - ! sets the number of model levels RRTMG operates - !-------------------------------------------------------------------------------- - - !-------------------------------------------------------------------------------- - ! creates (alloacates) an rrtmg_state object - !-------------------------------------------------------------------------------- - - !-------------------------------------------------------------------------------- - ! updates the concentration fields - !-------------------------------------------------------------------------------- - - !-------------------------------------------------------------------------------- - ! de-allocates an rrtmg_state object - !-------------------------------------------------------------------------------- - - END MODULE rrtmg_state diff --git a/test/ncar_kernels/PORT_lw_rad/src/shr_kind_mod.f90 b/test/ncar_kernels/PORT_lw_rad/src/shr_kind_mod.f90 deleted file mode 100644 index 578541fad3..0000000000 --- a/test/ncar_kernels/PORT_lw_rad/src/shr_kind_mod.f90 +++ /dev/null @@ -1,26 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : shr_kind_mod.f90 -! Generated at: 2015-07-06 23:28:44 -! KGEN version: 0.4.13 - - - - MODULE shr_kind_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - PUBLIC - INTEGER, parameter :: shr_kind_r8 = selected_real_kind(12) ! 8 byte real - ! 4 byte real - ! native real - ! 8 byte integer - ! 4 byte integer - ! native integer - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE shr_kind_mod diff --git a/test/ncar_kernels/PORT_lw_rtrnmc/CESM_license.txt b/test/ncar_kernels/PORT_lw_rtrnmc/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/PORT_lw_rtrnmc/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/PORT_lw_rtrnmc/data/rtrnmc.1.1 b/test/ncar_kernels/PORT_lw_rtrnmc/data/rtrnmc.1.1 deleted file mode 100644 index ff3ed15e80..0000000000 Binary files a/test/ncar_kernels/PORT_lw_rtrnmc/data/rtrnmc.1.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_rtrnmc/data/rtrnmc.1.4 b/test/ncar_kernels/PORT_lw_rtrnmc/data/rtrnmc.1.4 deleted file mode 100644 index 86e744db7b..0000000000 Binary files a/test/ncar_kernels/PORT_lw_rtrnmc/data/rtrnmc.1.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_rtrnmc/data/rtrnmc.1.8 b/test/ncar_kernels/PORT_lw_rtrnmc/data/rtrnmc.1.8 deleted file mode 100644 index 84350a70b2..0000000000 Binary files a/test/ncar_kernels/PORT_lw_rtrnmc/data/rtrnmc.1.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_rtrnmc/data/rtrnmc.5.1 b/test/ncar_kernels/PORT_lw_rtrnmc/data/rtrnmc.5.1 deleted file mode 100644 index ca7ffebcbf..0000000000 Binary files a/test/ncar_kernels/PORT_lw_rtrnmc/data/rtrnmc.5.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_rtrnmc/data/rtrnmc.5.4 b/test/ncar_kernels/PORT_lw_rtrnmc/data/rtrnmc.5.4 deleted file mode 100644 index bb6601fd63..0000000000 Binary files a/test/ncar_kernels/PORT_lw_rtrnmc/data/rtrnmc.5.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_rtrnmc/data/rtrnmc.5.8 b/test/ncar_kernels/PORT_lw_rtrnmc/data/rtrnmc.5.8 deleted file mode 100644 index 5cf222c712..0000000000 Binary files a/test/ncar_kernels/PORT_lw_rtrnmc/data/rtrnmc.5.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_rtrnmc/inc/t1.mk b/test/ncar_kernels/PORT_lw_rtrnmc/inc/t1.mk deleted file mode 100644 index 61d7024dfc..0000000000 --- a/test/ncar_kernels/PORT_lw_rtrnmc/inc/t1.mk +++ /dev/null @@ -1,79 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# Intel default flags -# -# -O2 -fp-model source -convert big_endian -assume byterecl -ftz -# -traceback -assume realloc_lhs -xAVX -# -# -FC_FLAGS := $(OPT) -FC_FLAGS += -Mnofma -Kieee - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - -ALL_OBJS := kernel_driver.o rrtmg_lw_rad.o kgen_utils.o shr_kind_mod.o rrlw_vsn.o rrtmg_lw_rtrnmc.o parrrtm.o rrlw_wvn.o rrlw_tbl.o rrlw_con.o - -verify: - @(grep "verification.FAIL" $(TEST).rslt && echo "FAILED") || (grep "verification.PASS" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 rrtmg_lw_rad.o kgen_utils.o shr_kind_mod.o rrlw_vsn.o rrtmg_lw_rtrnmc.o parrrtm.o rrlw_wvn.o rrlw_tbl.o rrlw_con.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_lw_rad.o: $(SRC_DIR)/rrtmg_lw_rad.f90 kgen_utils.o rrtmg_lw_rtrnmc.o shr_kind_mod.o parrrtm.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_kind_mod.o: $(SRC_DIR)/shr_kind_mod.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_vsn.o: $(SRC_DIR)/rrlw_vsn.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_lw_rtrnmc.o: $(SRC_DIR)/rrtmg_lw_rtrnmc.f90 kgen_utils.o shr_kind_mod.o parrrtm.o rrlw_vsn.o rrlw_wvn.o rrlw_tbl.o rrlw_con.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -parrrtm.o: $(SRC_DIR)/parrrtm.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_wvn.o: $(SRC_DIR)/rrlw_wvn.f90 kgen_utils.o parrrtm.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_tbl.o: $(SRC_DIR)/rrlw_tbl.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_con.o: $(SRC_DIR)/rrlw_con.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -kgen_utils.o: $(SRC_DIR)/kgen_utils.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.rslt diff --git a/test/ncar_kernels/PORT_lw_rtrnmc/lit/runmake b/test/ncar_kernels/PORT_lw_rtrnmc/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/PORT_lw_rtrnmc/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/PORT_lw_rtrnmc/lit/t1.sh b/test/ncar_kernels/PORT_lw_rtrnmc/lit/t1.sh deleted file mode 100644 index 33c953a156..0000000000 --- a/test/ncar_kernels/PORT_lw_rtrnmc/lit/t1.sh +++ /dev/null @@ -1,9 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -# Shared lit script for each tests. Run bash commands that run tests with make. - -# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t -# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/PORT_lw_rtrnmc/makefile b/test/ncar_kernels/PORT_lw_rtrnmc/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/PORT_lw_rtrnmc/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/PORT_lw_rtrnmc/src/kernel_driver.f90 b/test/ncar_kernels/PORT_lw_rtrnmc/src/kernel_driver.f90 deleted file mode 100644 index 9eb3862090..0000000000 --- a/test/ncar_kernels/PORT_lw_rtrnmc/src/kernel_driver.f90 +++ /dev/null @@ -1,87 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-07-26 20:37:04 -! KGEN version: 0.4.13 - - -PROGRAM kernel_driver - USE rrtmg_lw_rad, ONLY : rrtmg_lw - USE rrlw_tbl, ONLY : kgen_read_externs_rrlw_tbl - USE rrlw_wvn, ONLY : kgen_read_externs_rrlw_wvn - USE rrlw_vsn, ONLY : kgen_read_externs_rrlw_vsn - USE rrlw_con, ONLY : kgen_read_externs_rrlw_con - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - - IMPLICIT NONE - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_mpi_rank_at = (/ 1, 4, 8 /) - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(2), PARAMETER :: kgen_counter_at = (/ 1, 5 /) - CHARACTER(LEN=1024) :: kgen_filepath - INTEGER :: ncol - INTEGER :: nlay - - DO kgen_repeat_counter = 0, 5 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 2)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - kgen_filepath = "../data/rtrnmc." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "** Verification against '" // trim(adjustl(kgen_filepath)) // "' **" - - CALL kgen_read_externs_rrlw_tbl(kgen_unit) - CALL kgen_read_externs_rrlw_wvn(kgen_unit) - CALL kgen_read_externs_rrlw_vsn(kgen_unit) - CALL kgen_read_externs_rrlw_con(kgen_unit) - - ! driver variables - READ(UNIT=kgen_unit) ncol - READ(UNIT=kgen_unit) nlay - - call rrtmg_lw(ncol, nlay, kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! write subroutines - ! No subroutines - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/PORT_lw_rtrnmc/src/kgen_utils.f90 b/test/ncar_kernels/PORT_lw_rtrnmc/src/kgen_utils.f90 deleted file mode 100644 index cfa8d114e0..0000000000 --- a/test/ncar_kernels/PORT_lw_rtrnmc/src/kgen_utils.f90 +++ /dev/null @@ -1,61 +0,0 @@ -module kgen_utils_mod - -INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - -type check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - real(kind=kgen_dp) :: minvalue -end type check_t - -public kgen_dp, check_t, kgen_init_check, kgen_print_check - -contains - -subroutine kgen_init_check(check, tolerance, minvalue) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - real(kind=kgen_dp), intent(in), optional :: minvalue - - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.0D-15 - endif - if(present(minvalue)) then - check%minvalue = minvalue - else - check%minvalue = 1.0D-15 - endif -end subroutine kgen_init_check - -subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif -end subroutine kgen_print_check - -end module diff --git a/test/ncar_kernels/PORT_lw_rtrnmc/src/parrrtm.f90 b/test/ncar_kernels/PORT_lw_rtrnmc/src/parrrtm.f90 deleted file mode 100644 index 0d8241572e..0000000000 --- a/test/ncar_kernels/PORT_lw_rtrnmc/src/parrrtm.f90 +++ /dev/null @@ -1,76 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : parrrtm.f90 -! Generated at: 2015-07-26 20:37:04 -! KGEN version: 0.4.13 - - - - MODULE parrrtm - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_lw main parameters - ! - ! Initial version: JJMorcrette, ECMWF, Jul 1998 - ! Revised: MJIacono, AER, Jun 2006 - ! Revised: MJIacono, AER, Aug 2007 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! mxlay : integer: maximum number of layers - ! mg : integer: number of original g-intervals per spectral band - ! nbndlw : integer: number of spectral bands - ! maxxsec: integer: maximum number of cross-section molecules - ! (e.g. cfcs) - ! maxinpx: integer: - ! ngptlw : integer: total number of reduced g-intervals for rrtmg_lw - ! ngNN : integer: number of reduced g-intervals per spectral band - ! ngsNN : integer: cumulative number of g-intervals per band - !------------------------------------------------------------------ - INTEGER, parameter :: nbndlw = 16 - ! Use for 140 g-point model - INTEGER, parameter :: ngptlw = 140 - ! Use for 256 g-point model - ! integer, parameter :: ngptlw = 256 - ! Use for 140 g-point model - ! Use for 256 g-point model - ! integer, parameter :: ng1 = 16 - ! integer, parameter :: ng2 = 16 - ! integer, parameter :: ng3 = 16 - ! integer, parameter :: ng4 = 16 - ! integer, parameter :: ng5 = 16 - ! integer, parameter :: ng6 = 16 - ! integer, parameter :: ng7 = 16 - ! integer, parameter :: ng8 = 16 - ! integer, parameter :: ng9 = 16 - ! integer, parameter :: ng10 = 16 - ! integer, parameter :: ng11 = 16 - ! integer, parameter :: ng12 = 16 - ! integer, parameter :: ng13 = 16 - ! integer, parameter :: ng14 = 16 - ! integer, parameter :: ng15 = 16 - ! integer, parameter :: ng16 = 16 - ! integer, parameter :: ngs1 = 16 - ! integer, parameter :: ngs2 = 32 - ! integer, parameter :: ngs3 = 48 - ! integer, parameter :: ngs4 = 64 - ! integer, parameter :: ngs5 = 80 - ! integer, parameter :: ngs6 = 96 - ! integer, parameter :: ngs7 = 112 - ! integer, parameter :: ngs8 = 128 - ! integer, parameter :: ngs9 = 144 - ! integer, parameter :: ngs10 = 160 - ! integer, parameter :: ngs11 = 176 - ! integer, parameter :: ngs12 = 192 - ! integer, parameter :: ngs13 = 208 - ! integer, parameter :: ngs14 = 224 - ! integer, parameter :: ngs15 = 240 - ! integer, parameter :: ngs16 = 256 - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE parrrtm diff --git a/test/ncar_kernels/PORT_lw_rtrnmc/src/rrlw_con.f90 b/test/ncar_kernels/PORT_lw_rtrnmc/src/rrlw_con.f90 deleted file mode 100644 index 5f5da6bb4d..0000000000 --- a/test/ncar_kernels/PORT_lw_rtrnmc/src/rrlw_con.f90 +++ /dev/null @@ -1,51 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_con.f90 -! Generated at: 2015-07-26 20:37:04 -! KGEN version: 0.4.13 - - - - MODULE rrlw_con - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_lw constants - ! Initial version: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! fluxfac: real : radiance to flux conversion factor - ! heatfac: real : flux to heating rate conversion factor - !oneminus: real : 1.-1.e-6 - ! pi : real : pi - ! grav : real : acceleration of gravity (m/s2) - ! planck : real : planck constant - ! boltz : real : boltzman constant - ! clight : real : speed of light - ! avogad : real : avogadro's constant - ! alosmt : real : - ! gascon : real : gas constant - ! radcn1 : real : - ! radcn2 : real : - !------------------------------------------------------------------ - REAL(KIND=r8) :: fluxfac - REAL(KIND=r8) :: heatfac - PUBLIC kgen_read_externs_rrlw_con - CONTAINS - - ! write subroutines - ! No subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_con(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) fluxfac - READ(UNIT=kgen_unit) heatfac - END SUBROUTINE kgen_read_externs_rrlw_con - - END MODULE rrlw_con diff --git a/test/ncar_kernels/PORT_lw_rtrnmc/src/rrlw_tbl.f90 b/test/ncar_kernels/PORT_lw_rtrnmc/src/rrlw_tbl.f90 deleted file mode 100644 index 348541828d..0000000000 --- a/test/ncar_kernels/PORT_lw_rtrnmc/src/rrlw_tbl.f90 +++ /dev/null @@ -1,58 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_tbl.f90 -! Generated at: 2015-07-26 20:37:04 -! KGEN version: 0.4.13 - - - - MODULE rrlw_tbl - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_lw exponential lookup table arrays - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, Jun 2006 - ! Revised: MJIacono, AER, Aug 2007 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! ntbl : integer: Lookup table dimension - ! tblint : real : Lookup table conversion factor - ! tau_tbl: real : Clear-sky optical depth (used in cloudy radiative - ! transfer) - ! exp_tbl: real : Transmittance lookup table - ! tfn_tbl: real : Tau transition function; i.e. the transition of - ! the Planck function from that for the mean layer - ! temperature to that for the layer boundary - ! temperature as a function of optical depth. - ! The "linear in tau" method is used to make - ! the table. - ! pade : real : Pade constant - ! bpade : real : Inverse of Pade constant - !------------------------------------------------------------------ - INTEGER, parameter :: ntbl = 10000 - REAL(KIND=r8), parameter :: tblint = 10000.0_r8 - REAL(KIND=r8), dimension(0:ntbl) :: tau_tbl - REAL(KIND=r8), dimension(0:ntbl) :: exp_tbl - REAL(KIND=r8), dimension(0:ntbl) :: tfn_tbl - REAL(KIND=r8) :: bpade - PUBLIC kgen_read_externs_rrlw_tbl - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_tbl(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) tau_tbl - READ(UNIT=kgen_unit) exp_tbl - READ(UNIT=kgen_unit) tfn_tbl - READ(UNIT=kgen_unit) bpade - END SUBROUTINE kgen_read_externs_rrlw_tbl - - END MODULE rrlw_tbl diff --git a/test/ncar_kernels/PORT_lw_rtrnmc/src/rrlw_vsn.f90 b/test/ncar_kernels/PORT_lw_rtrnmc/src/rrlw_vsn.f90 deleted file mode 100644 index 9793b35cab..0000000000 --- a/test/ncar_kernels/PORT_lw_rtrnmc/src/rrlw_vsn.f90 +++ /dev/null @@ -1,63 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_vsn.f90 -! Generated at: 2015-07-26 20:37:04 -! KGEN version: 0.4.13 - - - - MODULE rrlw_vsn - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_lw version information - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - !hnamrtm :character: - !hnamini :character: - !hnamcld :character: - !hnamclc :character: - !hnamrtr :character: - !hnamrtx :character: - !hnamrtc :character: - !hnamset :character: - !hnamtau :character: - !hnamatm :character: - !hnamutl :character: - !hnamext :character: - !hnamkg :character: - ! - ! hvrrtm :character: - ! hvrini :character: - ! hvrcld :character: - ! hvrclc :character: - ! hvrrtr :character: - ! hvrrtx :character: - ! hvrrtc :character: - ! hvrset :character: - ! hvrtau :character: - ! hvratm :character: - ! hvrutl :character: - ! hvrext :character: - ! hvrkg :character: - !------------------------------------------------------------------ - CHARACTER(LEN=18) :: hvrrtc - PUBLIC kgen_read_externs_rrlw_vsn - CONTAINS - - ! write subroutines - ! No subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_vsn(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) hvrrtc - END SUBROUTINE kgen_read_externs_rrlw_vsn - - END MODULE rrlw_vsn diff --git a/test/ncar_kernels/PORT_lw_rtrnmc/src/rrlw_wvn.f90 b/test/ncar_kernels/PORT_lw_rtrnmc/src/rrlw_wvn.f90 deleted file mode 100644 index 68ec46ed92..0000000000 --- a/test/ncar_kernels/PORT_lw_rtrnmc/src/rrlw_wvn.f90 +++ /dev/null @@ -1,73 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_wvn.f90 -! Generated at: 2015-07-26 20:37:04 -! KGEN version: 0.4.13 - - - - MODULE rrlw_wvn - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE parrrtm, ONLY: ngptlw - USE parrrtm, ONLY: nbndlw - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_lw spectral information - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! ng : integer: Number of original g-intervals in each spectral band - ! nspa : integer: For the lower atmosphere, the number of reference - ! atmospheres that are stored for each spectral band - ! per pressure level and temperature. Each of these - ! atmospheres has different relative amounts of the - ! key species for the band (i.e. different binary - ! species parameters). - ! nspb : integer: Same as nspa for the upper atmosphere - !wavenum1: real : Spectral band lower boundary in wavenumbers - !wavenum2: real : Spectral band upper boundary in wavenumbers - ! delwave: real : Spectral band width in wavenumbers - ! totplnk: real : Integrated Planck value for each band; (band 16 - ! includes total from 2600 cm-1 to infinity) - ! Used for calculation across total spectrum - !totplk16: real : Integrated Planck value for band 16 (2600-3250 cm-1) - ! Used for calculation in band 16 only if - ! individual band output requested - ! - ! ngc : integer: The number of new g-intervals in each band - ! ngs : integer: The cumulative sum of new g-intervals for each band - ! ngm : integer: The index of each new g-interval relative to the - ! original 16 g-intervals in each band - ! ngn : integer: The number of original g-intervals that are - ! combined to make each new g-intervals in each band - ! ngb : integer: The band index for each new g-interval - ! wt : real : RRTM weights for the original 16 g-intervals - ! rwgt : real : Weights for combining original 16 g-intervals - ! (256 total) into reduced set of g-intervals - ! (140 total) - ! nxmol : integer: Number of cross-section molecules - ! ixindx : integer: Flag for active cross-sections in calculation - !------------------------------------------------------------------ - REAL(KIND=r8) :: delwave(nbndlw) - INTEGER :: ngs(nbndlw) - INTEGER :: ngb(ngptlw) - PUBLIC kgen_read_externs_rrlw_wvn - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_wvn(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) delwave - READ(UNIT=kgen_unit) ngs - READ(UNIT=kgen_unit) ngb - END SUBROUTINE kgen_read_externs_rrlw_wvn - - END MODULE rrlw_wvn diff --git a/test/ncar_kernels/PORT_lw_rtrnmc/src/rrtmg_lw_rad.f90 b/test/ncar_kernels/PORT_lw_rtrnmc/src/rrtmg_lw_rad.f90 deleted file mode 100644 index f7dc6073dc..0000000000 --- a/test/ncar_kernels/PORT_lw_rtrnmc/src/rrtmg_lw_rad.f90 +++ /dev/null @@ -1,625 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_lw_rad.f90 -! Generated at: 2015-07-26 20:37:03 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_lw_rad - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! - ! **************************************************************************** - ! * * - ! * RRTMG_LW * - ! * * - ! * * - ! * * - ! * a rapid radiative transfer model * - ! * for the longwave region * - ! * for application to general circulation models * - ! * * - ! * * - ! * Atmospheric and Environmental Research, Inc. * - ! * 131 Hartwell Avenue * - ! * Lexington, MA 02421 * - ! * * - ! * * - ! * Eli J. Mlawer * - ! * Jennifer S. Delamere * - ! * Michael J. Iacono * - ! * Shepard A. Clough * - ! * * - ! * * - ! * * - ! * * - ! * * - ! * * - ! * email: miacono@aer.com * - ! * email: emlawer@aer.com * - ! * email: jdelamer@aer.com * - ! * * - ! * The authors wish to acknowledge the contributions of the * - ! * following people: Steven J. Taubman, Karen Cady-Pereira, * - ! * Patrick D. Brown, Ronald E. Farren, Luke Chen, Robert Bergstrom. * - ! * * - ! **************************************************************************** - ! -------- Modules -------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - ! Move call to rrtmg_lw_ini and following use association to - ! GCM initialization area - ! use rrtmg_lw_init, only: rrtmg_lw_ini - USE rrtmg_lw_rtrnmc, ONLY: rtrnmc - IMPLICIT NONE - ! public interfaces/functions/subroutines - PUBLIC rrtmg_lw - !------------------------------------------------------------------ - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !------------------------------------------------------------------ - !------------------------------------------------------------------ - ! Public subroutines - !------------------------------------------------------------------ - - SUBROUTINE rrtmg_lw(ncol, nlay, kgen_unit) - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------- Description -------- - ! This program is the driver subroutine for RRTMG_LW, the AER LW radiation - ! model for application to GCMs, that has been adapted from RRTM_LW for - ! improved efficiency. - ! - ! NOTE: The call to RRTMG_LW_INI should be moved to the GCM initialization - ! area, since this has to be called only once. - ! - ! This routine: - ! a) calls INATM to read in the atmospheric profile from GCM; - ! all layering in RRTMG is ordered from surface to toa. - ! b) calls CLDPRMC to set cloud optical depth for McICA based - ! on input cloud properties - ! c) calls SETCOEF to calculate various quantities needed for - ! the radiative transfer algorithm - ! d) calls TAUMOL to calculate gaseous optical depths for each - ! of the 16 spectral bands - ! e) calls RTRNMC (for both clear and cloudy profiles) to perform the - ! radiative transfer calculation using McICA, the Monte-Carlo - ! Independent Column Approximation, to represent sub-grid scale - ! cloud variability - ! f) passes the necessary fluxes and cooling rates back to GCM - ! - ! Two modes of operation are possible: - ! The mode is chosen by using either rrtmg_lw.nomcica.f90 (to not use - ! McICA) or rrtmg_lw.f90 (to use McICA) to interface with a GCM. - ! - ! 1) Standard, single forward model calculation (imca = 0) - ! 2) Monte Carlo Independent Column Approximation (McICA, Pincus et al., - ! JC, 2003) method is applied to the forward model calculation (imca = 1) - ! - ! This call to RRTMG_LW must be preceeded by a call to the module - ! mcica_subcol_gen_lw.f90 to run the McICA sub-column cloud generator, - ! which will provide the cloud physical or cloud optical properties - ! on the RRTMG quadrature point (ngpt) dimension. - ! - ! Two methods of cloud property input are possible: - ! Cloud properties can be input in one of two ways (controlled by input - ! flags inflglw, iceflglw, and liqflglw; see text file rrtmg_lw_instructions - ! and subroutine rrtmg_lw_cldprop.f90 for further details): - ! - ! 1) Input cloud fraction and cloud optical depth directly (inflglw = 0) - ! 2) Input cloud fraction and cloud physical properties (inflglw = 1 or 2); - ! cloud optical properties are calculated by cldprop or cldprmc based - ! on input settings of iceflglw and liqflglw - ! - ! One method of aerosol property input is possible: - ! Aerosol properties can be input in only one way (controlled by input - ! flag iaer, see text file rrtmg_lw_instructions for further details): - ! - ! 1) Input aerosol optical depth directly by layer and spectral band (iaer=10); - ! band average optical depth at the mid-point of each spectral band. - ! RRTMG_LW currently treats only aerosol absorption; - ! scattering capability is not presently available. - ! - ! - ! ------- Modifications ------- - ! - ! This version of RRTMG_LW has been modified from RRTM_LW to use a reduced - ! set of g-points for application to GCMs. - ! - !-- Original version (derived from RRTM_LW), reduction of g-points, other - ! revisions for use with GCMs. - ! 1999: M. J. Iacono, AER, Inc. - !-- Adapted for use with NCAR/CAM. - ! May 2004: M. J. Iacono, AER, Inc. - !-- Revised to add McICA capability. - ! Nov 2005: M. J. Iacono, AER, Inc. - !-- Conversion to F90 formatting for consistency with rrtmg_sw. - ! Feb 2007: M. J. Iacono, AER, Inc. - !-- Modifications to formatting to use assumed-shape arrays. - ! Aug 2007: M. J. Iacono, AER, Inc. - !-- Modified to add longwave aerosol absorption. - ! Apr 2008: M. J. Iacono, AER, Inc. - ! --------- Modules ---------- - USE parrrtm, ONLY: nbndlw - USE parrrtm, ONLY: ngptlw - ! ------- Declarations ------- - ! ----- Input ----- - integer, intent(in) :: kgen_unit - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - ! chunk identifier - INTEGER, intent(in) :: ncol ! Number of horizontal columns - INTEGER, intent(in) :: nlay ! Number of model layers - ! Cloud overlap method - ! 0: Clear only - ! 1: Random - ! 2: Maximum/random - ! 3: Maximum - ! Layer pressures (hPa, mb) - ! Dimensions: (ncol,nlay) - ! Interface pressures (hPa, mb) - ! Dimensions: (ncol,nlay+1) - ! Layer temperatures (K) - ! Dimensions: (ncol,nlay) - ! Interface temperatures (K) - ! Dimensions: (ncol,nlay+1) - ! Surface temperature (K) - ! Dimensions: (ncol) - ! H2O volume mixing ratio - ! Dimensions: (ncol,nlay) - ! O3 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! CO2 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! Methane volume mixing ratio - ! Dimensions: (ncol,nlay) - ! O2 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! Nitrous oxide volume mixing ratio - ! Dimensions: (ncol,nlay) - ! CFC11 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! CFC12 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! CFC22 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! CCL4 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! Surface emissivity - ! Dimensions: (ncol,nbndlw) - ! Flag for cloud optical properties - ! Flag for ice particle specification - ! Flag for liquid droplet specification - ! Cloud fraction - ! Dimensions: (ngptlw,ncol,nlay) - ! Cloud ice water path (g/m2) - ! Dimensions: (ngptlw,ncol,nlay) - ! Cloud liquid water path (g/m2) - ! Dimensions: (ngptlw,ncol,nlay) - ! Cloud ice effective radius (microns) - ! Dimensions: (ncol,nlay) - ! Cloud water drop effective radius (microns) - ! Dimensions: (ncol,nlay) - ! Cloud optical depth - ! Dimensions: (ngptlw,ncol,nlay) - ! real(kind=r8), intent(in) :: ssacmcl(:,:,:) ! Cloud single scattering albedo - ! Dimensions: (ngptlw,ncol,nlay) - ! for future expansion - ! lw scattering not yet available - ! real(kind=r8), intent(in) :: asmcmcl(:,:,:) ! Cloud asymmetry parameter - ! Dimensions: (ngptlw,ncol,nlay) - ! for future expansion - ! lw scattering not yet available - ! aerosol optical depth - ! at mid-point of LW spectral bands - ! Dimensions: (ncol,nlay,nbndlw) - ! real(kind=r8), intent(in) :: ssaaer(:,:,:) ! aerosol single scattering albedo - ! Dimensions: (ncol,nlay,nbndlw) - ! for future expansion - ! (lw aerosols/scattering not yet available) - ! real(kind=r8), intent(in) :: asmaer(:,:,:) ! aerosol asymmetry parameter - ! Dimensions: (ncol,nlay,nbndlw) - ! for future expansion - ! (lw aerosols/scattering not yet available) - ! ----- Output ----- - ! Total sky longwave upward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Total sky longwave downward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Total sky longwave radiative heating rate (K/d) - ! Dimensions: (ncol,nlay) - ! Clear sky longwave upward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Clear sky longwave downward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Clear sky longwave radiative heating rate (K/d) - ! Dimensions: (ncol,nlay) - ! Total sky longwave upward flux spectral (W/m2) - ! Dimensions: (nbndlw,ncol,nlay+1) - ! Total sky longwave downward flux spectral (W/m2) - ! Dimensions: (nbndlw,ncol,nlay+1) - ! ----- Local ----- - ! Control - INTEGER :: istart ! beginning band of calculation - INTEGER :: iend ! ending band of calculation - INTEGER :: iout ! output option flag (inactive) - ! aerosol option flag - ! column loop index - ! flag for mcica [0=off, 1=on] - ! value for changing mcica permute seed - ! layer loop index - ! g-point loop index - ! Atmosphere - ! layer pressures (mb) - ! layer temperatures (K) - REAL(KIND=r8) :: pz(ncol,0:nlay) ! level (interface) pressures (hPa, mb) - ! level (interface) temperatures (K) - ! surface temperature (K) - ! dry air column density (mol/cm2) - ! broadening gas column density (mol/cm2) - ! molecular amounts (mol/cm-2) - ! cross-section amounts (mol/cm-2) - REAL(KIND=r8) :: pwvcm(ncol) ! precipitable water vapor (cm) - REAL(KIND=r8) :: semiss(ncol,nbndlw) ! lw surface emissivity - REAL(KIND=r8) :: fracs(ncol,nlay,ngptlw) ! - ! gaseous optical depths - REAL(KIND=r8) :: taut(ncol,nlay,ngptlw) ! gaseous + aerosol optical depths - ! aerosol optical depth - ! real(kind=r8) :: ssaa(nlay,nbndlw) ! aerosol single scattering albedo - ! for future expansion - ! (lw aerosols/scattering not yet available) - ! real(kind=r8) :: asma(nlay+1,nbndlw) ! aerosol asymmetry parameter - ! for future expansion - ! (lw aerosols/scattering not yet available) - ! Atmosphere - setcoef - ! tropopause layer index - ! lookup table index - ! lookup table index - ! lookup table index - REAL(KIND=r8) :: planklay(ncol,nlay,nbndlw) ! - REAL(KIND=r8) :: planklev(ncol,0:nlay,nbndlw) ! - REAL(KIND=r8) :: plankbnd(ncol,nbndlw) ! - ! column amount (h2o) - ! column amount (co2) - ! column amount (o3) - ! column amount (n2o) - ! column amount (co) - ! column amount (ch4) - ! column amount (o2) - ! column amount (broadening gases) - ! - ! - ! Atmosphere/clouds - cldprop - INTEGER :: ncbands(ncol) ! number of cloud spectral bands - ! flag for cloud property method - ! flag for ice cloud properties - ! flag for liquid cloud properties - ! Atmosphere/clouds - cldprmc [mcica] - REAL(KIND=r8) :: cldfmc(ncol,ngptlw,nlay) ! cloud fraction [mcica] - ! cloud ice water path [mcica] - ! cloud liquid water path [mcica] - ! liquid particle size (microns) - ! ice particle effective radius (microns) - ! ice particle generalized effective size (microns) - REAL(KIND=r8) :: taucmc(ncol,ngptlw,nlay) ! cloud optical depth [mcica] - ! real(kind=r8) :: ssacmc(ngptlw,nlay) ! cloud single scattering albedo [mcica] - ! for future expansion - ! (lw scattering not yet available) - ! real(kind=r8) :: asmcmc(ngptlw,nlay) ! cloud asymmetry parameter [mcica] - ! for future expansion - ! (lw scattering not yet available) - ! Output - REAL(KIND=r8) :: totuflux(ncol,0:nlay) - REAL(KIND=r8) :: ref_totuflux(ncol,0:nlay) ! upward longwave flux (w/m2) - REAL(KIND=r8) :: totdflux(ncol,0:nlay) - REAL(KIND=r8) :: ref_totdflux(ncol,0:nlay) ! downward longwave flux (w/m2) - REAL(KIND=r8) :: totufluxs(ncol,nbndlw,0:nlay) - REAL(KIND=r8) :: ref_totufluxs(ncol,nbndlw,0:nlay) ! upward longwave flux spectral (w/m2) - REAL(KIND=r8) :: totdfluxs(ncol,nbndlw,0:nlay) - REAL(KIND=r8) :: ref_totdfluxs(ncol,nbndlw,0:nlay) ! downward longwave flux spectral (w/m2) - REAL(KIND=r8) :: fnet(ncol,0:nlay) - REAL(KIND=r8) :: ref_fnet(ncol,0:nlay) ! net longwave flux (w/m2) - REAL(KIND=r8) :: htr(ncol,0:nlay) - REAL(KIND=r8) :: ref_htr(ncol,0:nlay) ! longwave heating rate (k/day) - REAL(KIND=r8) :: totuclfl(ncol,0:nlay) - REAL(KIND=r8) :: ref_totuclfl(ncol,0:nlay) ! clear sky upward longwave flux (w/m2) - REAL(KIND=r8) :: totdclfl(ncol,0:nlay) - REAL(KIND=r8) :: ref_totdclfl(ncol,0:nlay) ! clear sky downward longwave flux (w/m2) - REAL(KIND=r8) :: fnetc(ncol,0:nlay) - REAL(KIND=r8) :: ref_fnetc(ncol,0:nlay) ! clear sky net longwave flux (w/m2) - REAL(KIND=r8) :: htrc(ncol,0:nlay) - REAL(KIND=r8) :: ref_htrc(ncol,0:nlay) ! clear sky longwave heating rate (k/day) - !DIR$ ATTRIBUTES ALIGN : 64 :: pz - ! Initializations - ! orig: fluxfac = pi * 2.d4 ! orig: fluxfac = pi * 2.d4 - ! Set imca to select calculation type: - ! imca = 0, use standard forward model calculation - ! imca = 1, use McICA for Monte Carlo treatment of sub-grid cloud variability - ! *** This version uses McICA (imca = 1) *** - ! Set icld to select of clear or cloud calculation and cloud overlap method - ! icld = 0, clear only - ! icld = 1, with clouds using random cloud overlap - ! icld = 2, with clouds using maximum/random cloud overlap - ! icld = 3, with clouds using maximum cloud overlap (McICA only) - ! Set iaer to select aerosol option - ! iaer = 0, no aerosols - ! iaer = 10, input total aerosol optical depth (tauaer) directly - !Call model and data initialization, compute lookup tables, perform - ! reduction of g-points from 256 to 140 for input absorption coefficient - ! data and other arrays. - ! - ! In a GCM this call should be placed in the model initialization - ! area, since this has to be called only once. - ! call rrtmg_lw_ini - ! This is the main longitude/column loop within RRTMG. - ! Prepare atmospheric profile from GCM for use in RRTMG, and define - ! other input parameters. - ! For cloudy atmosphere, use cldprop to set cloud optical properties based on - ! input cloud physical properties. Select method based on choices described - ! in cldprop. Cloud fraction, water path, liquid droplet and ice particle - ! effective radius must be passed into cldprop. Cloud fraction and cloud - ! optical depth are transferred to rrtmg_lw arrays in cldprop. - ! Calculate information needed by the radiative transfer routine - ! that is specific to this atmosphere, especially some of the - ! coefficients and indices needed to compute the optical depths - ! by interpolating data from stored reference atmospheres. - ! Call the radiative transfer routine. - ! Either routine can be called to do clear sky calculation. If clouds - ! are present, then select routine based on cloud overlap assumption - ! to be used. Clear sky calculation is done simultaneously. - ! For McICA, RTRNMC is called for clear and cloudy calculations. - !orig tolerance = 1.E-14 - tolerance = 7.E-14 ! PGI/NVIDIA - CALL kgen_init_check(check_status, tolerance) - READ(UNIT=kgen_unit) istart - READ(UNIT=kgen_unit) iend - READ(UNIT=kgen_unit) iout - READ(UNIT=kgen_unit) pz - READ(UNIT=kgen_unit) pwvcm - READ(UNIT=kgen_unit) semiss - READ(UNIT=kgen_unit) fracs - READ(UNIT=kgen_unit) taut - READ(UNIT=kgen_unit) planklay - READ(UNIT=kgen_unit) planklev - READ(UNIT=kgen_unit) plankbnd - READ(UNIT=kgen_unit) ncbands - READ(UNIT=kgen_unit) cldfmc - READ(UNIT=kgen_unit) taucmc - READ(UNIT=kgen_unit) totuflux - READ(UNIT=kgen_unit) totdflux - READ(UNIT=kgen_unit) totufluxs - READ(UNIT=kgen_unit) totdfluxs - READ(UNIT=kgen_unit) fnet - READ(UNIT=kgen_unit) htr - READ(UNIT=kgen_unit) totuclfl - READ(UNIT=kgen_unit) totdclfl - READ(UNIT=kgen_unit) fnetc - READ(UNIT=kgen_unit) htrc - - READ(UNIT=kgen_unit) ref_totuflux - READ(UNIT=kgen_unit) ref_totdflux - READ(UNIT=kgen_unit) ref_totufluxs - READ(UNIT=kgen_unit) ref_totdfluxs - READ(UNIT=kgen_unit) ref_fnet - READ(UNIT=kgen_unit) ref_htr - READ(UNIT=kgen_unit) ref_totuclfl - READ(UNIT=kgen_unit) ref_totdclfl - READ(UNIT=kgen_unit) ref_fnetc - READ(UNIT=kgen_unit) ref_htrc - - - ! call to kernel - call rtrnmc(ncol, nlay, istart, iend, iout, pz, semiss, ncbands, & - cldfmc, taucmc, planklay, planklev, plankbnd, & - pwvcm, fracs, taut, & - totuflux, totdflux, fnet, htr, & - totuclfl, totdclfl, fnetc, htrc, totufluxs, totdfluxs ) - ! kernel verification for output variables - CALL kgen_verify_real_r8_dim2( "totuflux", check_status, totuflux, ref_totuflux) - CALL kgen_verify_real_r8_dim2( "totdflux", check_status, totdflux, ref_totdflux) - CALL kgen_verify_real_r8_dim3( "totufluxs", check_status, totufluxs, ref_totufluxs) - CALL kgen_verify_real_r8_dim3( "totdfluxs", check_status, totdfluxs, ref_totdfluxs) - CALL kgen_verify_real_r8_dim2( "fnet", check_status, fnet, ref_fnet) - CALL kgen_verify_real_r8_dim2( "htr", check_status, htr, ref_htr) - CALL kgen_verify_real_r8_dim2( "totuclfl", check_status, totuclfl, ref_totuclfl) - CALL kgen_verify_real_r8_dim2( "totdclfl", check_status, totdclfl, ref_totdclfl) - CALL kgen_verify_real_r8_dim2( "fnetc", check_status, fnetc, ref_fnetc) - CALL kgen_verify_real_r8_dim2( "htrc", check_status, htrc, ref_htrc) - CALL kgen_print_check("rtrnmc", check_status) - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,10 - CALL rtrnmc(ncol, nlay, istart, iend, iout, pz, semiss, ncbands, cldfmc, taucmc, planklay, planklev, plankbnd, pwvcm, fracs, taut, totuflux, totdflux, fnet, htr, totuclfl, totdclfl, fnetc, htrc, totufluxs, totdfluxs) - END DO - CALL system_clock(stop_clock, rate_clock) - WRITE(*,*) - PRINT *, "Elapsed time (sec): ", (stop_clock - start_clock)/REAL(rate_clock*10) - ! Transfer up and down fluxes and heating rate to output arrays. - ! Vertical indexing goes from bottom to top - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_r8_dim2(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim2 - - SUBROUTINE kgen_read_real_r8_dim3(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2,idx3 - INTEGER, DIMENSION(2,3) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim3 - - - ! verify subroutines - SUBROUTINE kgen_verify_real_r8_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim2 - - SUBROUTINE kgen_verify_real_r8_dim3( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim3 - - END SUBROUTINE rrtmg_lw - !*************************************************************************** - - END MODULE rrtmg_lw_rad diff --git a/test/ncar_kernels/PORT_lw_rtrnmc/src/rrtmg_lw_rtrnmc.f90 b/test/ncar_kernels/PORT_lw_rtrnmc/src/rrtmg_lw_rtrnmc.f90 deleted file mode 100644 index 0925abc62e..0000000000 --- a/test/ncar_kernels/PORT_lw_rtrnmc/src/rrtmg_lw_rtrnmc.f90 +++ /dev/null @@ -1,506 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_lw_rtrnmc.f90 -! Generated at: 2015-07-26 20:37:04 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_lw_rtrnmc - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! --------- Modules ---------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE parrrtm, ONLY: ngptlw - USE parrrtm, ONLY: nbndlw - USE rrlw_con, ONLY: fluxfac - USE rrlw_con, ONLY: heatfac - USE rrlw_wvn, ONLY: ngb - USE rrlw_wvn, ONLY: ngs - USE rrlw_wvn, ONLY: delwave - USE rrlw_tbl, ONLY: bpade - USE rrlw_tbl, ONLY: tblint - USE rrlw_tbl, ONLY: tfn_tbl - USE rrlw_tbl, ONLY: exp_tbl - USE rrlw_tbl, ONLY: tau_tbl - USE rrlw_vsn, ONLY: hvrrtc - IMPLICIT NONE - PUBLIC rtrnmc - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !----------------------------------------------------------------------------- - - SUBROUTINE rtrnmc(ncol, nlayers, istart, iend, iout, pz, semiss, ncbands, cldfmc, taucmc, planklay, planklev, plankbnd, & - pwvcm, fracs, taut, totuflux, totdflux, fnet, htr, totuclfl, totdclfl, fnetc, htrc, totufluxs, totdfluxs) - !----------------------------------------------------------------------------- - ! - ! Original version: E. J. Mlawer, et al. RRTM_V3.0 - ! Revision for GCMs: Michael J. Iacono; October, 2002 - ! Revision for F90: Michael J. Iacono; June, 2006 - ! - ! This program calculates the upward fluxes, downward fluxes, and - ! heating rates for an arbitrary clear or cloudy atmosphere. The input - ! to this program is the atmospheric profile, all Planck function - ! information, and the cloud fraction by layer. A variable diffusivity - ! angle (SECDIFF) is used for the angle integration. Bands 2-3 and 5-9 - ! use a value for SECDIFF that varies from 1.50 to 1.80 as a function of - ! the column water vapor, and other bands use a value of 1.66. The Gaussian - ! weight appropriate to this angle (WTDIFF=0.5) is applied here. Note that - ! use of the emissivity angle for the flux integration can cause errors of - ! 1 to 4 W/m2 within cloudy layers. - ! Clouds are treated with the McICA stochastic approach and maximum-random - ! cloud overlap. - !*************************************************************************** - ! ------- Declarations ------- - ! ----- Input ----- - INTEGER, intent(in) :: ncol ! total number of columns - INTEGER, intent(in) :: nlayers ! total number of layers - INTEGER, intent(in) :: istart ! beginning band of calculation - INTEGER, intent(in) :: iend ! ending band of calculation - INTEGER, intent(in) :: iout ! output option flag - ! Atmosphere - REAL(KIND=r8), intent(in) :: pz(:,0:) ! level (interface) pressures (hPa, mb) - ! Dimensions: (ncol,0:nlayers) - REAL(KIND=r8), intent(in) :: pwvcm(:) ! precipitable water vapor (cm) - ! Dimensions: (ncol) - REAL(KIND=r8), intent(in) :: semiss(:,:) ! lw surface emissivity - ! Dimensions: (ncol,nbndlw) - REAL(KIND=r8), intent(in) :: planklay(:,:,:) ! - ! Dimensions: (ncol,nlayers,nbndlw) - REAL(KIND=r8), intent(in) :: planklev(:,0:,:) ! - ! Dimensions: (ncol,0:nlayers,nbndlw) - REAL(KIND=r8), intent(in) :: plankbnd(:,:) ! - ! Dimensions: (ncol,nbndlw) - REAL(KIND=r8), intent(in) :: fracs(:,:,:) ! - ! Dimensions: (ncol,nlayers,ngptw) - REAL(KIND=r8), intent(in) :: taut(:,:,:) ! gaseous + aerosol optical depths - ! Dimensions: (ncol,nlayers,ngptlw) - ! Clouds - INTEGER, intent(in) :: ncbands(:) ! number of cloud spectral bands - ! Dimensions: (ncol) - REAL(KIND=r8), intent(in) :: cldfmc(:,:,:) ! layer cloud fraction [mcica] - ! Dimensions: (ncol,ngptlw,nlayers) - REAL(KIND=r8), intent(in) :: taucmc(:,:,:) ! layer cloud optical depth [mcica] - ! Dimensions: (ncol,ngptlw,nlayers) - ! ----- Output ----- - REAL(KIND=r8), intent(out) :: totuflux(:,0:) ! upward longwave flux (w/m2) - ! Dimensions: (ncol,0:nlayers) - REAL(KIND=r8), intent(out) :: totdflux(:,0:) ! downward longwave flux (w/m2) - ! Dimensions: (ncol,0:nlayers) - REAL(KIND=r8), intent(out) :: fnet(:,0:) ! net longwave flux (w/m2) - ! Dimensions: (ncol,0:nlayers) - REAL(KIND=r8), intent(out) :: htr(:,0:) ! longwave heating rate (k/day) - ! Dimensions: (ncol,0:nlayers) - REAL(KIND=r8), intent(out) :: totuclfl(:,0:) ! clear sky upward longwave flux (w/m2) - ! Dimensions: (ncol,0:nlayers) - REAL(KIND=r8), intent(out) :: totdclfl(:,0:) ! clear sky downward longwave flux (w/m2) - ! Dimensions: (ncol,0:nlayers) - REAL(KIND=r8), intent(out) :: fnetc(:,0:) ! clear sky net longwave flux (w/m2) - ! Dimensions: (ncol,0:nlayers) - REAL(KIND=r8), intent(out) :: htrc(:,0:) ! clear sky longwave heating rate (k/day) - ! Dimensions: (ncol,0:nlayers) - REAL(KIND=r8), intent(out) :: totufluxs(:,:,0:) ! upward longwave flux spectral (w/m2) - ! Dimensions: (ncol,nbndlw, 0:nlayers) - REAL(KIND=r8), intent(out) :: totdfluxs(:,:,0:) ! downward longwave flux spectral (w/m2) - ! Dimensions: (ncol,nbndlw, 0:nlayers) - ! ----- Local ----- - ! Declarations for radiative transfer - REAL(KIND=r8) :: abscld(nlayers,ngptlw) - REAL(KIND=r8) :: atot(nlayers) - REAL(KIND=r8) :: atrans(nlayers) - REAL(KIND=r8) :: bbugas(nlayers) - REAL(KIND=r8) :: bbutot(nlayers) - REAL(KIND=r8) :: clrurad(0:nlayers) - REAL(KIND=r8) :: clrdrad(0:nlayers) - REAL(KIND=r8) :: efclfrac(nlayers,ngptlw) - REAL(KIND=r8) :: uflux(0:nlayers) - REAL(KIND=r8) :: dflux(0:nlayers) - REAL(KIND=r8) :: urad(0:nlayers) - REAL(KIND=r8) :: drad(0:nlayers) - REAL(KIND=r8) :: uclfl(0:nlayers) - REAL(KIND=r8) :: dclfl(0:nlayers) - REAL(KIND=r8) :: odcld(nlayers,ngptlw) - REAL(KIND=r8) :: secdiff(nbndlw) ! secant of diffusivity angle - REAL(KIND=r8) :: a0(nbndlw) - REAL(KIND=r8) :: a1(nbndlw) - REAL(KIND=r8) :: a2(nbndlw) ! diffusivity angle adjustment coefficients - REAL(KIND=r8) :: wtdiff - REAL(KIND=r8) :: rec_6 - REAL(KIND=r8) :: transcld - REAL(KIND=r8) :: radld - REAL(KIND=r8) :: radclrd - REAL(KIND=r8) :: plfrac - REAL(KIND=r8) :: blay - REAL(KIND=r8) :: dplankup - REAL(KIND=r8) :: dplankdn - REAL(KIND=r8) :: odepth - REAL(KIND=r8) :: odtot - REAL(KIND=r8) :: odepth_rec - REAL(KIND=r8) :: gassrc - REAL(KIND=r8) :: odtot_rec - REAL(KIND=r8) :: bbdtot - REAL(KIND=r8) :: bbd - REAL(KIND=r8) :: tblind - REAL(KIND=r8) :: tfactot - REAL(KIND=r8) :: tfacgas - REAL(KIND=r8) :: transc - REAL(KIND=r8) :: tausfac - REAL(KIND=r8) :: rad0 - REAL(KIND=r8) :: reflect - REAL(KIND=r8) :: radlu - REAL(KIND=r8) :: radclru - INTEGER :: icldlyr(nlayers) ! flag for cloud in layer - INTEGER :: ibnd - INTEGER :: lay - INTEGER :: ig - INTEGER :: ib - INTEGER :: iband - INTEGER :: lev - INTEGER :: l ! loop indices - INTEGER :: igc ! g-point interval counter - INTEGER :: iclddn ! flag for cloud in down path - INTEGER :: ittot - INTEGER :: itgas - INTEGER :: itr ! lookup table indices - ! ------- Definitions ------- - ! input - ! nlayers ! number of model layers - ! ngptlw ! total number of g-point subintervals - ! nbndlw ! number of longwave spectral bands - ! ncbands ! number of spectral bands for clouds - ! secdiff ! diffusivity angle - ! wtdiff ! weight for radiance to flux conversion - ! pavel ! layer pressures (mb) - ! pz ! level (interface) pressures (mb) - ! tavel ! layer temperatures (k) - ! tz ! level (interface) temperatures(mb) - ! tbound ! surface temperature (k) - ! cldfrac ! layer cloud fraction - ! taucloud ! layer cloud optical depth - ! itr ! integer look-up table index - ! icldlyr ! flag for cloudy layers - ! iclddn ! flag for cloud in column at any layer - ! semiss ! surface emissivities for each band - ! reflect ! surface reflectance - ! bpade ! 1/(pade constant) - ! tau_tbl ! clear sky optical depth look-up table - ! exp_tbl ! exponential look-up table for transmittance - ! tfn_tbl ! tau transition function look-up table - ! local - ! atrans ! gaseous absorptivity - ! abscld ! cloud absorptivity - ! atot ! combined gaseous and cloud absorptivity - ! odclr ! clear sky (gaseous) optical depth - ! odcld ! cloud optical depth - ! odtot ! optical depth of gas and cloud - ! tfacgas ! gas-only pade factor, used for planck fn - ! tfactot ! gas and cloud pade factor, used for planck fn - ! bbdgas ! gas-only planck function for downward rt - ! bbugas ! gas-only planck function for upward rt - ! bbdtot ! gas and cloud planck function for downward rt - ! bbutot ! gas and cloud planck function for upward calc. - ! gassrc ! source radiance due to gas only - ! efclfrac ! effective cloud fraction - ! radlu ! spectrally summed upward radiance - ! radclru ! spectrally summed clear sky upward radiance - ! urad ! upward radiance by layer - ! clrurad ! clear sky upward radiance by layer - ! radld ! spectrally summed downward radiance - ! radclrd ! spectrally summed clear sky downward radiance - ! drad ! downward radiance by layer - ! clrdrad ! clear sky downward radiance by layer - ! output - ! totuflux ! upward longwave flux (w/m2) - ! totdflux ! downward longwave flux (w/m2) - ! fnet ! net longwave flux (w/m2) - ! htr ! longwave heating rate (k/day) - ! totuclfl ! clear sky upward longwave flux (w/m2) - ! totdclfl ! clear sky downward longwave flux (w/m2) - ! fnetc ! clear sky net longwave flux (w/m2) - ! htrc ! clear sky longwave heating rate (k/day) - ! This secant and weight corresponds to the standard diffusivity - ! angle. This initial value is redefined below for some bands. - data wtdiff /0.5_r8/ - data rec_6 /0.166667_r8/ - ! Reset diffusivity angle for Bands 2-3 and 5-9 to vary (between 1.50 - ! and 1.80) as a function of total column water vapor. The function - ! has been defined to minimize flux and cooling rate errors in these bands - ! over a wide range of precipitable water values. - data a0 / 1.66_r8, 1.55_r8, 1.58_r8, 1.66_r8, & - 1.54_r8, 1.454_r8, 1.89_r8, 1.33_r8, & - 1.668_r8, 1.66_r8, 1.66_r8, 1.66_r8, & - 1.66_r8, 1.66_r8, 1.66_r8, 1.66_r8 / - data a1 / 0.00_r8, 0.25_r8, 0.22_r8, 0.00_r8, & - 0.13_r8, 0.446_r8, -0.10_r8, 0.40_r8, & - -0.006_r8, 0.00_r8, 0.00_r8, 0.00_r8, & - 0.00_r8, 0.00_r8, 0.00_r8, 0.00_r8 / - data a2 / 0.00_r8, -12.0_r8, -11.7_r8, 0.00_r8, & - -0.72_r8,-0.243_r8, 0.19_r8,-0.062_r8, & - 0.414_r8, 0.00_r8, 0.00_r8, 0.00_r8, & - 0.00_r8, 0.00_r8, 0.00_r8, 0.00_r8 / - INTEGER :: iplon - hvrrtc = '$Revision: 1.3 $' - do iplon=1,ncol - do ibnd = 1,nbndlw - if (ibnd.eq.1 .or. ibnd.eq.4 .or. ibnd.ge.10) then - secdiff(ibnd) = 1.66_r8 - else - secdiff(ibnd) = a0(ibnd) + a1(ibnd)*exp(a2(ibnd)*pwvcm(iplon)) - endif - enddo - if (pwvcm(iplon).lt.1.0) secdiff(6) = 1.80_r8 - if (pwvcm(iplon).gt.7.1) secdiff(7) = 1.50_r8 - urad(0) = 0.0_r8 - drad(0) = 0.0_r8 - totuflux(iplon,0) = 0.0_r8 - totdflux(iplon,0) = 0.0_r8 - clrurad(0) = 0.0_r8 - clrdrad(0) = 0.0_r8 - totuclfl(iplon,0) = 0.0_r8 - totdclfl(iplon,0) = 0.0_r8 - do lay = 1, nlayers - urad(lay) = 0.0_r8 - drad(lay) = 0.0_r8 - totuflux(iplon,lay) = 0.0_r8 - totdflux(iplon,lay) = 0.0_r8 - clrurad(lay) = 0.0_r8 - clrdrad(lay) = 0.0_r8 - totuclfl(iplon,lay) = 0.0_r8 - totdclfl(iplon,lay) = 0.0_r8 - icldlyr(lay) = 0 - ! Change to band loop? - do ig = 1, ngptlw - if (cldfmc(iplon,ig,lay) .eq. 1._r8) then - ib = ngb(ig) - odcld(lay,ig) = secdiff(ib) * taucmc(iplon,ig,lay) - transcld = exp(-odcld(lay,ig)) - abscld(lay,ig) = 1._r8 - transcld - efclfrac(lay,ig) = abscld(lay,ig) * cldfmc(iplon,ig,lay) - icldlyr(lay) = 1 - else - odcld(lay,ig) = 0.0_r8 - abscld(lay,ig) = 0.0_r8 - efclfrac(lay,ig) = 0.0_r8 - endif - enddo - enddo - igc = 1 - ! Loop over frequency bands. - do iband = istart, iend - ! Reinitialize g-point counter for each band if output for each band is requested. - if (iout.gt.0.and.iband.ge.2) igc = ngs(iband-1)+1 - ! Loop over g-channels. - 1000 continue - ! Radiative transfer starts here. - radld = 0._r8 - radclrd = 0._r8 - iclddn = 0 - ! Downward radiative transfer loop. - do lev = nlayers, 1, -1 - plfrac = fracs(iplon,lev,igc) - blay = planklay(iplon,lev,iband) - dplankup = planklev(iplon,lev,iband) - blay - dplankdn = planklev(iplon,lev-1,iband) - blay - odepth = secdiff(iband) * taut(iplon,lev,igc) - if (odepth .lt. 0.0_r8) odepth = 0.0_r8 - ! Cloudy layer - if (icldlyr(lev).eq.1) then - iclddn = 1 - odtot = odepth + odcld(lev,igc) - if (odtot .lt. 0.06_r8) then - atrans(lev) = odepth - 0.5_r8*odepth*odepth - odepth_rec = rec_6*odepth - gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev) - atot(lev) = odtot - 0.5_r8*odtot*odtot - odtot_rec = rec_6*odtot - bbdtot = plfrac * (blay+dplankdn*odtot_rec) - bbd = plfrac*(blay+dplankdn*odepth_rec) - radld = radld - radld * (atrans(lev) + & - efclfrac(lev,igc) * (1. - atrans(lev))) + & - gassrc + cldfmc(iplon,igc,lev) * & - (bbdtot * atot(lev) - gassrc) - drad( lev-1) = drad(lev-1) + radld - bbugas(lev) = plfrac * (blay+dplankup*odepth_rec) - bbutot(lev) = plfrac * (blay+dplankup*odtot_rec) - elseif (odepth .le. 0.06_r8) then - atrans(lev) = odepth - 0.5_r8*odepth*odepth - odepth_rec = rec_6*odepth - gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev) - odtot = odepth + odcld(lev,igc) - tblind = odtot/(bpade+odtot) - ittot = tblint*tblind + 0.5_r8 - tfactot = tfn_tbl(ittot) - bbdtot = plfrac * (blay + tfactot*dplankdn) - bbd = plfrac*(blay+dplankdn*odepth_rec) - atot(lev) = 1. - exp_tbl(ittot) - radld = radld - radld * (atrans(lev) + & - efclfrac(lev,igc) * (1._r8 - atrans(lev))) + & - gassrc + cldfmc(iplon,igc,lev) * & - (bbdtot * atot(lev) - gassrc) - drad(lev-1) = drad(lev-1) + radld - bbugas(lev) = plfrac * (blay + dplankup*odepth_rec) - bbutot(lev) = plfrac * (blay + tfactot * dplankup) - else - tblind = odepth/(bpade+odepth) - itgas = tblint*tblind+0.5_r8 - odepth = tau_tbl(itgas) - atrans(lev) = 1._r8 - exp_tbl(itgas) - tfacgas = tfn_tbl(itgas) - gassrc = atrans(lev) * plfrac * (blay + tfacgas*dplankdn) - odtot = odepth + odcld(lev,igc) - tblind = odtot/(bpade+odtot) - ittot = tblint*tblind + 0.5_r8 - tfactot = tfn_tbl(ittot) - bbdtot = plfrac * (blay + tfactot*dplankdn) - bbd = plfrac*(blay+tfacgas*dplankdn) - atot(lev) = 1._r8 - exp_tbl(ittot) - radld = radld - radld * (atrans(lev) + & - efclfrac(lev,igc) * (1._r8 - atrans(lev))) + & - gassrc + cldfmc(iplon,igc,lev) * & - (bbdtot * atot(lev) - gassrc) - drad(lev-1) = drad(lev-1) + radld - bbugas(lev) = plfrac * (blay + tfacgas * dplankup) - bbutot(lev) = plfrac * (blay + tfactot * dplankup) - endif - ! Clear layer - else - if (odepth .le. 0.06_r8) then - atrans(lev) = odepth-0.5_r8*odepth*odepth - odepth = rec_6*odepth - bbd = plfrac*(blay+dplankdn*odepth) - bbugas(lev) = plfrac*(blay+dplankup*odepth) - else - tblind = odepth/(bpade+odepth) - itr = tblint*tblind+0.5_r8 - transc = exp_tbl(itr) - atrans(lev) = 1._r8-transc - tausfac = tfn_tbl(itr) - bbd = plfrac*(blay+tausfac*dplankdn) - bbugas(lev) = plfrac * (blay + tausfac * dplankup) - endif - radld = radld + (bbd-radld)*atrans(lev) - drad(lev-1) = drad(lev-1) + radld - endif - ! Set clear sky stream to total sky stream as long as layers - ! remain clear. Streams diverge when a cloud is reached (iclddn=1), - ! and clear sky stream must be computed separately from that point. - if (iclddn.eq.1) then - radclrd = radclrd + (bbd-radclrd) * atrans(lev) - clrdrad(lev-1) = clrdrad(lev-1) + radclrd - else - radclrd = radld - clrdrad(lev-1) = drad(lev-1) - endif - enddo - ! Spectral emissivity & reflectance - ! Include the contribution of spectrally varying longwave emissivity - ! and reflection from the surface to the upward radiative transfer. - ! Note: Spectral and Lambertian reflection are identical for the - ! diffusivity angle flux integration used here. - rad0 = fracs(iplon,1,igc) * plankbnd(iplon,iband) - ! Add in specular reflection of surface downward radiance. - reflect = 1._r8 - semiss(iplon,iband) - radlu = rad0 + reflect * radld - radclru = rad0 + reflect * radclrd - ! Upward radiative transfer loop. - urad(0) = urad(0) + radlu - clrurad(0) = clrurad(0) + radclru - do lev = 1, nlayers - ! Cloudy layer - if (icldlyr(lev) .eq. 1) then - gassrc = bbugas(lev) * atrans(lev) - radlu = radlu - radlu * (atrans(lev) + & - efclfrac(lev,igc) * (1._r8 - atrans(lev))) + & - gassrc + cldfmc(iplon,igc,lev) * & - (bbutot(lev) * atot(lev) - gassrc) - urad(lev) = urad(lev) + radlu - ! Clear layer - else - radlu = radlu + (bbugas(lev)-radlu)*atrans(lev) - urad(lev) = urad(lev) + radlu - endif - ! Set clear sky stream to total sky stream as long as all layers - ! are clear (iclddn=0). Streams must be calculated separately at - ! all layers when a cloud is present (ICLDDN=1), because surface - ! reflectance is different for each stream. - if (iclddn.eq.1) then - radclru = radclru + (bbugas(lev)-radclru)*atrans(lev) - clrurad(lev) = clrurad(lev) + radclru - else - radclru = radlu - clrurad(lev) = urad(lev) - endif - enddo - ! Increment g-point counter - igc = igc + 1 - ! Return to continue radiative transfer for all g-channels in present band - if (igc .le. ngs(iband)) go to 1000 - ! Process longwave output from band for total and clear streams. - ! Calculate upward, downward, and net flux. - do lev = nlayers, 0, -1 - uflux(lev) = urad(lev)*wtdiff - dflux(lev) = drad(lev)*wtdiff - urad(lev) = 0.0_r8 - drad(lev) = 0.0_r8 - totuflux(iplon,lev) = totuflux(iplon,lev) + uflux(lev) * delwave(iband) - totdflux(iplon,lev) = totdflux(iplon,lev) + dflux(lev) * delwave(iband) - uclfl(lev) = clrurad(lev)*wtdiff - dclfl(lev) = clrdrad(lev)*wtdiff - clrurad(lev) = 0.0_r8 - clrdrad(lev) = 0.0_r8 - totuclfl(iplon,lev) = totuclfl(iplon,lev) + uclfl(lev) * delwave(iband) - totdclfl(iplon,lev) = totdclfl(iplon,lev) + dclfl(lev) * delwave(iband) - totufluxs(iplon,iband,lev) = uflux(lev) * delwave(iband) - totdfluxs(iplon,iband,lev) = dflux(lev) * delwave(iband) - enddo - ! End spectral band loop - enddo - enddo - do iplon=1,ncol - ! Calculate fluxes at surface - totuflux(iplon,0) = totuflux(iplon,0) * fluxfac - totdflux(iplon,0) = totdflux(iplon,0) * fluxfac - totufluxs(iplon,:,0) = totufluxs(iplon,:,0) * fluxfac - totdfluxs(iplon,:,0) = totdfluxs(iplon,:,0) * fluxfac - fnet(iplon,0) = totuflux(iplon,0) - totdflux(iplon,0) - totuclfl(iplon,0) = totuclfl(iplon,0) * fluxfac - totdclfl(iplon,0) = totdclfl(iplon,0) * fluxfac - fnetc(iplon,0) = totuclfl(iplon,0) - totdclfl(iplon,0) - enddo - ! Calculate fluxes at model levels - do lev = 1, nlayers - do iplon=1,ncol - totuflux(iplon,lev) = totuflux(iplon,lev) * fluxfac - totdflux(iplon,lev) = totdflux(iplon,lev) * fluxfac - totufluxs(iplon,:,lev) = totufluxs(iplon,:,lev) * fluxfac - totdfluxs(iplon,:,lev) = totdfluxs(iplon,:,lev) * fluxfac - fnet(iplon,lev) = totuflux(iplon,lev) - totdflux(iplon,lev) - totuclfl(iplon,lev) = totuclfl(iplon,lev) * fluxfac - totdclfl(iplon,lev) = totdclfl(iplon,lev) * fluxfac - fnetc(iplon,lev) = totuclfl(iplon,lev) - totdclfl(iplon,lev) - l = lev - 1 - ! Calculate heating rates at model layers - htr(iplon,l)=heatfac*(fnet(iplon,l)-fnet(iplon,lev))/(pz(iplon,l)-pz(iplon,lev)) - htrc(iplon,l)=heatfac*(fnetc(iplon,l)-fnetc(iplon,lev))/(pz(iplon,l)-pz(iplon,lev)) - enddo - enddo - ! Set heating rate to zero in top layer - do iplon=1,ncol - htr(iplon,nlayers) = 0.0_r8 - htrc(iplon,nlayers) = 0.0_r8 - enddo - END SUBROUTINE rtrnmc - END MODULE rrtmg_lw_rtrnmc diff --git a/test/ncar_kernels/PORT_lw_rtrnmc/src/shr_kind_mod.f90 b/test/ncar_kernels/PORT_lw_rtrnmc/src/shr_kind_mod.f90 deleted file mode 100644 index 3907b1b1f0..0000000000 --- a/test/ncar_kernels/PORT_lw_rtrnmc/src/shr_kind_mod.f90 +++ /dev/null @@ -1,26 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : shr_kind_mod.f90 -! Generated at: 2015-07-26 20:37:04 -! KGEN version: 0.4.13 - - - - MODULE shr_kind_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - PUBLIC - INTEGER, parameter :: shr_kind_r8 = selected_real_kind(12) ! 8 byte real - ! 4 byte real - ! native real - ! 8 byte integer - ! 4 byte integer - ! native integer - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE shr_kind_mod diff --git a/test/ncar_kernels/PORT_lw_setcoef/CESM_license.txt b/test/ncar_kernels/PORT_lw_setcoef/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/PORT_lw_setcoef/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.1.1 b/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.1.1 deleted file mode 100644 index c8076d90ef..0000000000 Binary files a/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.1.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.1.4 b/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.1.4 deleted file mode 100644 index e802dc91d6..0000000000 Binary files a/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.1.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.1.8 b/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.1.8 deleted file mode 100644 index 06c96e38aa..0000000000 Binary files a/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.1.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.10.1 b/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.10.1 deleted file mode 100644 index 727afb40d8..0000000000 Binary files a/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.10.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.10.4 b/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.10.4 deleted file mode 100644 index 4f2adf175c..0000000000 Binary files a/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.10.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.10.8 b/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.10.8 deleted file mode 100644 index 6f643fa2c1..0000000000 Binary files a/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.10.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.5.1 b/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.5.1 deleted file mode 100644 index 1417e450b9..0000000000 Binary files a/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.5.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.5.4 b/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.5.4 deleted file mode 100644 index 12fb2cb0c4..0000000000 Binary files a/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.5.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.5.8 b/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.5.8 deleted file mode 100644 index 7a7d124452..0000000000 Binary files a/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.5.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_lw_setcoef/inc/t1.mk b/test/ncar_kernels/PORT_lw_setcoef/inc/t1.mk deleted file mode 100644 index 2887d2c57a..0000000000 --- a/test/ncar_kernels/PORT_lw_setcoef/inc/t1.mk +++ /dev/null @@ -1,76 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# Intel default flags -# -# -O2 -fp-model source -convert big_endian -assume byterecl -ftz -# -traceback -assume realloc_lhs -xAVX -# -# -FC_FLAGS := $(OPT) -FC_FLAGS += -Mnofma -Kieee - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - -ALL_OBJS := kernel_driver.o rrtmg_lw_rad.o kgen_utils.o shr_kind_mod.o rrlw_ref.o rrlw_vsn.o parrrtm.o rrlw_wvn.o rrtmg_lw_setcoef.o - -verify: - @(grep "verification.FAIL" $(TEST).rslt && echo "FAILED") || (grep "verification.PASS" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 rrtmg_lw_rad.o kgen_utils.o shr_kind_mod.o rrlw_ref.o rrlw_vsn.o parrrtm.o rrlw_wvn.o rrtmg_lw_setcoef.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_lw_rad.o: $(SRC_DIR)/rrtmg_lw_rad.f90 kgen_utils.o rrtmg_lw_setcoef.o shr_kind_mod.o parrrtm.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_kind_mod.o: $(SRC_DIR)/shr_kind_mod.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_ref.o: $(SRC_DIR)/rrlw_ref.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_vsn.o: $(SRC_DIR)/rrlw_vsn.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -parrrtm.o: $(SRC_DIR)/parrrtm.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrlw_wvn.o: $(SRC_DIR)/rrlw_wvn.f90 kgen_utils.o shr_kind_mod.o parrrtm.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_lw_setcoef.o: $(SRC_DIR)/rrtmg_lw_setcoef.f90 kgen_utils.o shr_kind_mod.o parrrtm.o rrlw_vsn.o rrlw_wvn.o rrlw_ref.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -kgen_utils.o: $(SRC_DIR)/kgen_utils.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.oo *.rslt diff --git a/test/ncar_kernels/PORT_lw_setcoef/lit/runmake b/test/ncar_kernels/PORT_lw_setcoef/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/PORT_lw_setcoef/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/PORT_lw_setcoef/lit/t1.sh b/test/ncar_kernels/PORT_lw_setcoef/lit/t1.sh deleted file mode 100644 index 33c953a156..0000000000 --- a/test/ncar_kernels/PORT_lw_setcoef/lit/t1.sh +++ /dev/null @@ -1,9 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -# Shared lit script for each tests. Run bash commands that run tests with make. - -# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t -# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/PORT_lw_setcoef/makefile b/test/ncar_kernels/PORT_lw_setcoef/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/PORT_lw_setcoef/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/PORT_lw_setcoef/src/kernel_driver.f90 b/test/ncar_kernels/PORT_lw_setcoef/src/kernel_driver.f90 deleted file mode 100644 index 546a51095d..0000000000 --- a/test/ncar_kernels/PORT_lw_setcoef/src/kernel_driver.f90 +++ /dev/null @@ -1,85 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-07-26 18:24:46 -! KGEN version: 0.4.13 - - -PROGRAM kernel_driver - USE rrtmg_lw_rad, ONLY : rrtmg_lw - USE rrlw_wvn, ONLY : kgen_read_externs_rrlw_wvn - USE rrlw_vsn, ONLY : kgen_read_externs_rrlw_vsn - USE rrlw_ref, ONLY : kgen_read_externs_rrlw_ref - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - - IMPLICIT NONE - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_mpi_rank_at = (/ 1, 4, 8 /) - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_counter_at = (/ 1, 10, 5 /) - CHARACTER(LEN=1024) :: kgen_filepath - INTEGER :: ncol - INTEGER :: nlay - - DO kgen_repeat_counter = 0, 8 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - kgen_filepath = "../data/setcoef." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "** Verification against '" // trim(adjustl(kgen_filepath)) // "' **" - - CALL kgen_read_externs_rrlw_wvn(kgen_unit) - CALL kgen_read_externs_rrlw_vsn(kgen_unit) - CALL kgen_read_externs_rrlw_ref(kgen_unit) - - ! driver variables - READ(UNIT=kgen_unit) ncol - READ(UNIT=kgen_unit) nlay - - call rrtmg_lw(ncol, nlay, kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! write subroutines - ! No subroutines - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/PORT_lw_setcoef/src/kgen_utils.f90 b/test/ncar_kernels/PORT_lw_setcoef/src/kgen_utils.f90 deleted file mode 100644 index cfa8d114e0..0000000000 --- a/test/ncar_kernels/PORT_lw_setcoef/src/kgen_utils.f90 +++ /dev/null @@ -1,61 +0,0 @@ -module kgen_utils_mod - -INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - -type check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - real(kind=kgen_dp) :: minvalue -end type check_t - -public kgen_dp, check_t, kgen_init_check, kgen_print_check - -contains - -subroutine kgen_init_check(check, tolerance, minvalue) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - real(kind=kgen_dp), intent(in), optional :: minvalue - - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.0D-15 - endif - if(present(minvalue)) then - check%minvalue = minvalue - else - check%minvalue = 1.0D-15 - endif -end subroutine kgen_init_check - -subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif -end subroutine kgen_print_check - -end module diff --git a/test/ncar_kernels/PORT_lw_setcoef/src/parrrtm.f90 b/test/ncar_kernels/PORT_lw_setcoef/src/parrrtm.f90 deleted file mode 100644 index 0b8ed93a02..0000000000 --- a/test/ncar_kernels/PORT_lw_setcoef/src/parrrtm.f90 +++ /dev/null @@ -1,76 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : parrrtm.f90 -! Generated at: 2015-07-26 18:24:46 -! KGEN version: 0.4.13 - - - - MODULE parrrtm - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_lw main parameters - ! - ! Initial version: JJMorcrette, ECMWF, Jul 1998 - ! Revised: MJIacono, AER, Jun 2006 - ! Revised: MJIacono, AER, Aug 2007 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! mxlay : integer: maximum number of layers - ! mg : integer: number of original g-intervals per spectral band - ! nbndlw : integer: number of spectral bands - ! maxxsec: integer: maximum number of cross-section molecules - ! (e.g. cfcs) - ! maxinpx: integer: - ! ngptlw : integer: total number of reduced g-intervals for rrtmg_lw - ! ngNN : integer: number of reduced g-intervals per spectral band - ! ngsNN : integer: cumulative number of g-intervals per band - !------------------------------------------------------------------ - INTEGER, parameter :: nbndlw = 16 - INTEGER, parameter :: mxmol = 38 - ! Use for 140 g-point model - ! Use for 256 g-point model - ! integer, parameter :: ngptlw = 256 - ! Use for 140 g-point model - ! Use for 256 g-point model - ! integer, parameter :: ng1 = 16 - ! integer, parameter :: ng2 = 16 - ! integer, parameter :: ng3 = 16 - ! integer, parameter :: ng4 = 16 - ! integer, parameter :: ng5 = 16 - ! integer, parameter :: ng6 = 16 - ! integer, parameter :: ng7 = 16 - ! integer, parameter :: ng8 = 16 - ! integer, parameter :: ng9 = 16 - ! integer, parameter :: ng10 = 16 - ! integer, parameter :: ng11 = 16 - ! integer, parameter :: ng12 = 16 - ! integer, parameter :: ng13 = 16 - ! integer, parameter :: ng14 = 16 - ! integer, parameter :: ng15 = 16 - ! integer, parameter :: ng16 = 16 - ! integer, parameter :: ngs1 = 16 - ! integer, parameter :: ngs2 = 32 - ! integer, parameter :: ngs3 = 48 - ! integer, parameter :: ngs4 = 64 - ! integer, parameter :: ngs5 = 80 - ! integer, parameter :: ngs6 = 96 - ! integer, parameter :: ngs7 = 112 - ! integer, parameter :: ngs8 = 128 - ! integer, parameter :: ngs9 = 144 - ! integer, parameter :: ngs10 = 160 - ! integer, parameter :: ngs11 = 176 - ! integer, parameter :: ngs12 = 192 - ! integer, parameter :: ngs13 = 208 - ! integer, parameter :: ngs14 = 224 - ! integer, parameter :: ngs15 = 240 - ! integer, parameter :: ngs16 = 256 - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE parrrtm diff --git a/test/ncar_kernels/PORT_lw_setcoef/src/rrlw_ref.f90 b/test/ncar_kernels/PORT_lw_setcoef/src/rrlw_ref.f90 deleted file mode 100644 index 1f1024ec5a..0000000000 --- a/test/ncar_kernels/PORT_lw_setcoef/src/rrlw_ref.f90 +++ /dev/null @@ -1,46 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_ref.f90 -! Generated at: 2015-07-26 18:24:46 -! KGEN version: 0.4.13 - - - - MODULE rrlw_ref - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_lw reference atmosphere - ! Based on standard mid-latitude summer profile - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! pref : real : Reference pressure levels - ! preflog: real : Reference pressure levels, ln(pref) - ! tref : real : Reference temperature levels for MLS profile - ! chi_mls: real : - !------------------------------------------------------------------ - REAL(KIND=r8), dimension(59) :: preflog - REAL(KIND=r8), dimension(59) :: tref - REAL(KIND=r8) :: chi_mls(7,59) - PUBLIC kgen_read_externs_rrlw_ref - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_ref(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) preflog - READ(UNIT=kgen_unit) tref - READ(UNIT=kgen_unit) chi_mls - END SUBROUTINE kgen_read_externs_rrlw_ref - - END MODULE rrlw_ref diff --git a/test/ncar_kernels/PORT_lw_setcoef/src/rrlw_vsn.f90 b/test/ncar_kernels/PORT_lw_setcoef/src/rrlw_vsn.f90 deleted file mode 100644 index 08cbde6d85..0000000000 --- a/test/ncar_kernels/PORT_lw_setcoef/src/rrlw_vsn.f90 +++ /dev/null @@ -1,63 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_vsn.f90 -! Generated at: 2015-07-26 18:24:46 -! KGEN version: 0.4.13 - - - - MODULE rrlw_vsn - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_lw version information - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - !hnamrtm :character: - !hnamini :character: - !hnamcld :character: - !hnamclc :character: - !hnamrtr :character: - !hnamrtx :character: - !hnamrtc :character: - !hnamset :character: - !hnamtau :character: - !hnamatm :character: - !hnamutl :character: - !hnamext :character: - !hnamkg :character: - ! - ! hvrrtm :character: - ! hvrini :character: - ! hvrcld :character: - ! hvrclc :character: - ! hvrrtr :character: - ! hvrrtx :character: - ! hvrrtc :character: - ! hvrset :character: - ! hvrtau :character: - ! hvratm :character: - ! hvrutl :character: - ! hvrext :character: - ! hvrkg :character: - !------------------------------------------------------------------ - CHARACTER(LEN=18) :: hvrset - PUBLIC kgen_read_externs_rrlw_vsn - CONTAINS - - ! write subroutines - ! No subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_vsn(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) hvrset - END SUBROUTINE kgen_read_externs_rrlw_vsn - - END MODULE rrlw_vsn diff --git a/test/ncar_kernels/PORT_lw_setcoef/src/rrlw_wvn.f90 b/test/ncar_kernels/PORT_lw_setcoef/src/rrlw_wvn.f90 deleted file mode 100644 index 01f2c0b246..0000000000 --- a/test/ncar_kernels/PORT_lw_setcoef/src/rrlw_wvn.f90 +++ /dev/null @@ -1,70 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrlw_wvn.f90 -! Generated at: 2015-07-26 18:24:46 -! KGEN version: 0.4.13 - - - - MODULE rrlw_wvn - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE parrrtm, ONLY: nbndlw - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_lw spectral information - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! ng : integer: Number of original g-intervals in each spectral band - ! nspa : integer: For the lower atmosphere, the number of reference - ! atmospheres that are stored for each spectral band - ! per pressure level and temperature. Each of these - ! atmospheres has different relative amounts of the - ! key species for the band (i.e. different binary - ! species parameters). - ! nspb : integer: Same as nspa for the upper atmosphere - !wavenum1: real : Spectral band lower boundary in wavenumbers - !wavenum2: real : Spectral band upper boundary in wavenumbers - ! delwave: real : Spectral band width in wavenumbers - ! totplnk: real : Integrated Planck value for each band; (band 16 - ! includes total from 2600 cm-1 to infinity) - ! Used for calculation across total spectrum - !totplk16: real : Integrated Planck value for band 16 (2600-3250 cm-1) - ! Used for calculation in band 16 only if - ! individual band output requested - ! - ! ngc : integer: The number of new g-intervals in each band - ! ngs : integer: The cumulative sum of new g-intervals for each band - ! ngm : integer: The index of each new g-interval relative to the - ! original 16 g-intervals in each band - ! ngn : integer: The number of original g-intervals that are - ! combined to make each new g-intervals in each band - ! ngb : integer: The band index for each new g-interval - ! wt : real : RRTM weights for the original 16 g-intervals - ! rwgt : real : Weights for combining original 16 g-intervals - ! (256 total) into reduced set of g-intervals - ! (140 total) - ! nxmol : integer: Number of cross-section molecules - ! ixindx : integer: Flag for active cross-sections in calculation - !------------------------------------------------------------------ - REAL(KIND=r8) :: totplnk(181,nbndlw) - REAL(KIND=r8) :: totplk16(181) - PUBLIC kgen_read_externs_rrlw_wvn - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrlw_wvn(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) totplnk - READ(UNIT=kgen_unit) totplk16 - END SUBROUTINE kgen_read_externs_rrlw_wvn - - END MODULE rrlw_wvn diff --git a/test/ncar_kernels/PORT_lw_setcoef/src/rrtmg_lw_rad.f90 b/test/ncar_kernels/PORT_lw_setcoef/src/rrtmg_lw_rad.f90 deleted file mode 100644 index c4d7e4231f..0000000000 --- a/test/ncar_kernels/PORT_lw_setcoef/src/rrtmg_lw_rad.f90 +++ /dev/null @@ -1,879 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_lw_rad.f90 -! Generated at: 2015-07-26 18:24:46 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_lw_rad - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! - ! **************************************************************************** - ! * * - ! * RRTMG_LW * - ! * * - ! * * - ! * * - ! * a rapid radiative transfer model * - ! * for the longwave region * - ! * for application to general circulation models * - ! * * - ! * * - ! * Atmospheric and Environmental Research, Inc. * - ! * 131 Hartwell Avenue * - ! * Lexington, MA 02421 * - ! * * - ! * * - ! * Eli J. Mlawer * - ! * Jennifer S. Delamere * - ! * Michael J. Iacono * - ! * Shepard A. Clough * - ! * * - ! * * - ! * * - ! * * - ! * * - ! * * - ! * email: miacono@aer.com * - ! * email: emlawer@aer.com * - ! * email: jdelamer@aer.com * - ! * * - ! * The authors wish to acknowledge the contributions of the * - ! * following people: Steven J. Taubman, Karen Cady-Pereira, * - ! * Patrick D. Brown, Ronald E. Farren, Luke Chen, Robert Bergstrom. * - ! * * - ! **************************************************************************** - ! -------- Modules -------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - ! Move call to rrtmg_lw_ini and following use association to - ! GCM initialization area - ! use rrtmg_lw_init, only: rrtmg_lw_ini - USE rrtmg_lw_setcoef, ONLY: setcoef - IMPLICIT NONE - ! public interfaces/functions/subroutines - PUBLIC rrtmg_lw - !------------------------------------------------------------------ - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !------------------------------------------------------------------ - !------------------------------------------------------------------ - ! Public subroutines - !------------------------------------------------------------------ - - SUBROUTINE rrtmg_lw(ncol, nlay, kgen_unit) - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------- Description -------- - ! This program is the driver subroutine for RRTMG_LW, the AER LW radiation - ! model for application to GCMs, that has been adapted from RRTM_LW for - ! improved efficiency. - ! - ! NOTE: The call to RRTMG_LW_INI should be moved to the GCM initialization - ! area, since this has to be called only once. - ! - ! This routine: - ! a) calls INATM to read in the atmospheric profile from GCM; - ! all layering in RRTMG is ordered from surface to toa. - ! b) calls CLDPRMC to set cloud optical depth for McICA based - ! on input cloud properties - ! c) calls SETCOEF to calculate various quantities needed for - ! the radiative transfer algorithm - ! d) calls TAUMOL to calculate gaseous optical depths for each - ! of the 16 spectral bands - ! e) calls RTRNMC (for both clear and cloudy profiles) to perform the - ! radiative transfer calculation using McICA, the Monte-Carlo - ! Independent Column Approximation, to represent sub-grid scale - ! cloud variability - ! f) passes the necessary fluxes and cooling rates back to GCM - ! - ! Two modes of operation are possible: - ! The mode is chosen by using either rrtmg_lw.nomcica.f90 (to not use - ! McICA) or rrtmg_lw.f90 (to use McICA) to interface with a GCM. - ! - ! 1) Standard, single forward model calculation (imca = 0) - ! 2) Monte Carlo Independent Column Approximation (McICA, Pincus et al., - ! JC, 2003) method is applied to the forward model calculation (imca = 1) - ! - ! This call to RRTMG_LW must be preceeded by a call to the module - ! mcica_subcol_gen_lw.f90 to run the McICA sub-column cloud generator, - ! which will provide the cloud physical or cloud optical properties - ! on the RRTMG quadrature point (ngpt) dimension. - ! - ! Two methods of cloud property input are possible: - ! Cloud properties can be input in one of two ways (controlled by input - ! flags inflglw, iceflglw, and liqflglw; see text file rrtmg_lw_instructions - ! and subroutine rrtmg_lw_cldprop.f90 for further details): - ! - ! 1) Input cloud fraction and cloud optical depth directly (inflglw = 0) - ! 2) Input cloud fraction and cloud physical properties (inflglw = 1 or 2); - ! cloud optical properties are calculated by cldprop or cldprmc based - ! on input settings of iceflglw and liqflglw - ! - ! One method of aerosol property input is possible: - ! Aerosol properties can be input in only one way (controlled by input - ! flag iaer, see text file rrtmg_lw_instructions for further details): - ! - ! 1) Input aerosol optical depth directly by layer and spectral band (iaer=10); - ! band average optical depth at the mid-point of each spectral band. - ! RRTMG_LW currently treats only aerosol absorption; - ! scattering capability is not presently available. - ! - ! - ! ------- Modifications ------- - ! - ! This version of RRTMG_LW has been modified from RRTM_LW to use a reduced - ! set of g-points for application to GCMs. - ! - !-- Original version (derived from RRTM_LW), reduction of g-points, other - ! revisions for use with GCMs. - ! 1999: M. J. Iacono, AER, Inc. - !-- Adapted for use with NCAR/CAM. - ! May 2004: M. J. Iacono, AER, Inc. - !-- Revised to add McICA capability. - ! Nov 2005: M. J. Iacono, AER, Inc. - !-- Conversion to F90 formatting for consistency with rrtmg_sw. - ! Feb 2007: M. J. Iacono, AER, Inc. - !-- Modifications to formatting to use assumed-shape arrays. - ! Aug 2007: M. J. Iacono, AER, Inc. - !-- Modified to add longwave aerosol absorption. - ! Apr 2008: M. J. Iacono, AER, Inc. - ! --------- Modules ---------- - USE parrrtm, ONLY: nbndlw - USE parrrtm, ONLY: mxmol - ! ------- Declarations ------- - ! ----- Input ----- - integer, intent(in) :: kgen_unit - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - ! chunk identifier - INTEGER, intent(in) :: ncol ! Number of horizontal columns - INTEGER, intent(in) :: nlay ! Number of model layers - ! Cloud overlap method - ! 0: Clear only - ! 1: Random - ! 2: Maximum/random - ! 3: Maximum - ! Layer pressures (hPa, mb) - ! Dimensions: (ncol,nlay) - ! Interface pressures (hPa, mb) - ! Dimensions: (ncol,nlay+1) - ! Layer temperatures (K) - ! Dimensions: (ncol,nlay) - ! Interface temperatures (K) - ! Dimensions: (ncol,nlay+1) - ! Surface temperature (K) - ! Dimensions: (ncol) - ! H2O volume mixing ratio - ! Dimensions: (ncol,nlay) - ! O3 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! CO2 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! Methane volume mixing ratio - ! Dimensions: (ncol,nlay) - ! O2 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! Nitrous oxide volume mixing ratio - ! Dimensions: (ncol,nlay) - ! CFC11 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! CFC12 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! CFC22 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! CCL4 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! Surface emissivity - ! Dimensions: (ncol,nbndlw) - ! Flag for cloud optical properties - ! Flag for ice particle specification - ! Flag for liquid droplet specification - ! Cloud fraction - ! Dimensions: (ngptlw,ncol,nlay) - ! Cloud ice water path (g/m2) - ! Dimensions: (ngptlw,ncol,nlay) - ! Cloud liquid water path (g/m2) - ! Dimensions: (ngptlw,ncol,nlay) - ! Cloud ice effective radius (microns) - ! Dimensions: (ncol,nlay) - ! Cloud water drop effective radius (microns) - ! Dimensions: (ncol,nlay) - ! Cloud optical depth - ! Dimensions: (ngptlw,ncol,nlay) - ! real(kind=r8), intent(in) :: ssacmcl(:,:,:) ! Cloud single scattering albedo - ! Dimensions: (ngptlw,ncol,nlay) - ! for future expansion - ! lw scattering not yet available - ! real(kind=r8), intent(in) :: asmcmcl(:,:,:) ! Cloud asymmetry parameter - ! Dimensions: (ngptlw,ncol,nlay) - ! for future expansion - ! lw scattering not yet available - ! aerosol optical depth - ! at mid-point of LW spectral bands - ! Dimensions: (ncol,nlay,nbndlw) - ! real(kind=r8), intent(in) :: ssaaer(:,:,:) ! aerosol single scattering albedo - ! Dimensions: (ncol,nlay,nbndlw) - ! for future expansion - ! (lw aerosols/scattering not yet available) - ! real(kind=r8), intent(in) :: asmaer(:,:,:) ! aerosol asymmetry parameter - ! Dimensions: (ncol,nlay,nbndlw) - ! for future expansion - ! (lw aerosols/scattering not yet available) - ! ----- Output ----- - ! Total sky longwave upward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Total sky longwave downward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Total sky longwave radiative heating rate (K/d) - ! Dimensions: (ncol,nlay) - ! Clear sky longwave upward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Clear sky longwave downward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Clear sky longwave radiative heating rate (K/d) - ! Dimensions: (ncol,nlay) - ! Total sky longwave upward flux spectral (W/m2) - ! Dimensions: (nbndlw,ncol,nlay+1) - ! Total sky longwave downward flux spectral (W/m2) - ! Dimensions: (nbndlw,ncol,nlay+1) - ! ----- Local ----- - ! Control - INTEGER :: istart ! beginning band of calculation - ! ending band of calculation - ! output option flag (inactive) - ! aerosol option flag - ! column loop index - ! flag for mcica [0=off, 1=on] - ! value for changing mcica permute seed - ! layer loop index - ! g-point loop index - ! Atmosphere - REAL(KIND=r8) :: pavel(ncol,nlay) ! layer pressures (mb) - REAL(KIND=r8) :: tavel(ncol,nlay) ! layer temperatures (K) - ! level (interface) pressures (hPa, mb) - REAL(KIND=r8) :: tz(ncol,0:nlay) ! level (interface) temperatures (K) - REAL(KIND=r8) :: tbound(ncol) ! surface temperature (K) - REAL(KIND=r8) :: coldry(ncol,nlay) ! dry air column density (mol/cm2) - REAL(KIND=r8) :: wbrodl(ncol,nlay) ! broadening gas column density (mol/cm2) - REAL(KIND=r8) :: wkl(ncol,mxmol,nlay) ! molecular amounts (mol/cm-2) - ! cross-section amounts (mol/cm-2) - ! precipitable water vapor (cm) - REAL(KIND=r8) :: semiss(ncol,nbndlw) ! lw surface emissivity - ! - ! gaseous optical depths - ! gaseous + aerosol optical depths - ! aerosol optical depth - ! real(kind=r8) :: ssaa(nlay,nbndlw) ! aerosol single scattering albedo - ! for future expansion - ! (lw aerosols/scattering not yet available) - ! real(kind=r8) :: asma(nlay+1,nbndlw) ! aerosol asymmetry parameter - ! for future expansion - ! (lw aerosols/scattering not yet available) - ! Atmosphere - setcoef - INTEGER :: laytrop(ncol) - INTEGER :: ref_laytrop(ncol) ! tropopause layer index - INTEGER :: jp(ncol,nlay) - INTEGER :: ref_jp(ncol,nlay) ! lookup table index - INTEGER :: jt(ncol,nlay) - INTEGER :: ref_jt(ncol,nlay) ! lookup table index - INTEGER :: jt1(ncol,nlay) - INTEGER :: ref_jt1(ncol,nlay) ! lookup table index - REAL(KIND=r8) :: planklay(ncol,nlay,nbndlw) - REAL(KIND=r8) :: ref_planklay(ncol,nlay,nbndlw) ! - REAL(KIND=r8) :: planklev(ncol,0:nlay,nbndlw) - REAL(KIND=r8) :: ref_planklev(ncol,0:nlay,nbndlw) ! - REAL(KIND=r8) :: plankbnd(ncol,nbndlw) - REAL(KIND=r8) :: ref_plankbnd(ncol,nbndlw) ! - REAL(KIND=r8) :: colh2o(ncol,nlay) - REAL(KIND=r8) :: ref_colh2o(ncol,nlay) ! column amount (h2o) - REAL(KIND=r8) :: colco2(ncol,nlay) - REAL(KIND=r8) :: ref_colco2(ncol,nlay) ! column amount (co2) - REAL(KIND=r8) :: colo3(ncol,nlay) - REAL(KIND=r8) :: ref_colo3(ncol,nlay) ! column amount (o3) - REAL(KIND=r8) :: coln2o(ncol,nlay) - REAL(KIND=r8) :: ref_coln2o(ncol,nlay) ! column amount (n2o) - REAL(KIND=r8) :: colco(ncol,nlay) - REAL(KIND=r8) :: ref_colco(ncol,nlay) ! column amount (co) - REAL(KIND=r8) :: colch4(ncol,nlay) - REAL(KIND=r8) :: ref_colch4(ncol,nlay) ! column amount (ch4) - REAL(KIND=r8) :: colo2(ncol,nlay) - REAL(KIND=r8) :: ref_colo2(ncol,nlay) ! column amount (o2) - REAL(KIND=r8) :: colbrd(ncol,nlay) - REAL(KIND=r8) :: ref_colbrd(ncol,nlay) ! column amount (broadening gases) - INTEGER :: indself(ncol,nlay) - INTEGER :: ref_indself(ncol,nlay) - INTEGER :: indfor(ncol,nlay) - INTEGER :: ref_indfor(ncol,nlay) - REAL(KIND=r8) :: selffac(ncol,nlay) - REAL(KIND=r8) :: ref_selffac(ncol,nlay) - REAL(KIND=r8) :: selffrac(ncol,nlay) - REAL(KIND=r8) :: ref_selffrac(ncol,nlay) - REAL(KIND=r8) :: forfac(ncol,nlay) - REAL(KIND=r8) :: ref_forfac(ncol,nlay) - REAL(KIND=r8) :: forfrac(ncol,nlay) - REAL(KIND=r8) :: ref_forfrac(ncol,nlay) - INTEGER :: indminor(ncol,nlay) - INTEGER :: ref_indminor(ncol,nlay) - REAL(KIND=r8) :: minorfrac(ncol,nlay) - REAL(KIND=r8) :: ref_minorfrac(ncol,nlay) - REAL(KIND=r8) :: scaleminor(ncol,nlay) - REAL(KIND=r8) :: ref_scaleminor(ncol,nlay) - REAL(KIND=r8) :: scaleminorn2(ncol,nlay) - REAL(KIND=r8) :: ref_scaleminorn2(ncol,nlay) - REAL(KIND=r8) :: fac01(ncol,nlay) - REAL(KIND=r8) :: ref_fac01(ncol,nlay) - REAL(KIND=r8) :: fac10(ncol,nlay) - REAL(KIND=r8) :: ref_fac10(ncol,nlay) - REAL(KIND=r8) :: fac11(ncol,nlay) - REAL(KIND=r8) :: ref_fac11(ncol,nlay) - REAL(KIND=r8) :: fac00(ncol,nlay) - REAL(KIND=r8) :: ref_fac00(ncol,nlay) ! - REAL(KIND=r8) :: rat_o3co2_1(ncol,nlay) - REAL(KIND=r8) :: ref_rat_o3co2_1(ncol,nlay) - REAL(KIND=r8) :: rat_o3co2(ncol,nlay) - REAL(KIND=r8) :: ref_rat_o3co2(ncol,nlay) - REAL(KIND=r8) :: rat_h2och4(ncol,nlay) - REAL(KIND=r8) :: ref_rat_h2och4(ncol,nlay) - REAL(KIND=r8) :: rat_h2oo3(ncol,nlay) - REAL(KIND=r8) :: ref_rat_h2oo3(ncol,nlay) - REAL(KIND=r8) :: rat_h2och4_1(ncol,nlay) - REAL(KIND=r8) :: ref_rat_h2och4_1(ncol,nlay) - REAL(KIND=r8) :: rat_h2oo3_1(ncol,nlay) - REAL(KIND=r8) :: ref_rat_h2oo3_1(ncol,nlay) - REAL(KIND=r8) :: rat_h2oco2(ncol,nlay) - REAL(KIND=r8) :: ref_rat_h2oco2(ncol,nlay) - REAL(KIND=r8) :: rat_n2oco2(ncol,nlay) - REAL(KIND=r8) :: ref_rat_n2oco2(ncol,nlay) - REAL(KIND=r8) :: rat_h2on2o(ncol,nlay) - REAL(KIND=r8) :: ref_rat_h2on2o(ncol,nlay) - REAL(KIND=r8) :: rat_n2oco2_1(ncol,nlay) - REAL(KIND=r8) :: ref_rat_n2oco2_1(ncol,nlay) - REAL(KIND=r8) :: rat_h2oco2_1(ncol,nlay) - REAL(KIND=r8) :: ref_rat_h2oco2_1(ncol,nlay) - REAL(KIND=r8) :: rat_h2on2o_1(ncol,nlay) - REAL(KIND=r8) :: ref_rat_h2on2o_1(ncol,nlay) ! - ! Atmosphere/clouds - cldprop - ! number of cloud spectral bands - ! flag for cloud property method - ! flag for ice cloud properties - ! flag for liquid cloud properties - ! Atmosphere/clouds - cldprmc [mcica] - ! cloud fraction [mcica] - ! cloud ice water path [mcica] - ! cloud liquid water path [mcica] - ! liquid particle size (microns) - ! ice particle effective radius (microns) - ! ice particle generalized effective size (microns) - ! cloud optical depth [mcica] - ! real(kind=r8) :: ssacmc(ngptlw,nlay) ! cloud single scattering albedo [mcica] - ! for future expansion - ! (lw scattering not yet available) - ! real(kind=r8) :: asmcmc(ngptlw,nlay) ! cloud asymmetry parameter [mcica] - ! for future expansion - ! (lw scattering not yet available) - ! Output - ! upward longwave flux (w/m2) - ! downward longwave flux (w/m2) - ! upward longwave flux spectral (w/m2) - ! downward longwave flux spectral (w/m2) - ! net longwave flux (w/m2) - ! longwave heating rate (k/day) - ! clear sky upward longwave flux (w/m2) - ! clear sky downward longwave flux (w/m2) - ! clear sky net longwave flux (w/m2) - ! clear sky longwave heating rate (k/day) - ! Initializations - ! orig: fluxfac = pi * 2.d4 ! orig: fluxfac = pi * 2.d4 - ! Set imca to select calculation type: - ! imca = 0, use standard forward model calculation - ! imca = 1, use McICA for Monte Carlo treatment of sub-grid cloud variability - ! *** This version uses McICA (imca = 1) *** - ! Set icld to select of clear or cloud calculation and cloud overlap method - ! icld = 0, clear only - ! icld = 1, with clouds using random cloud overlap - ! icld = 2, with clouds using maximum/random cloud overlap - ! icld = 3, with clouds using maximum cloud overlap (McICA only) - ! Set iaer to select aerosol option - ! iaer = 0, no aerosols - ! iaer = 10, input total aerosol optical depth (tauaer) directly - !Call model and data initialization, compute lookup tables, perform - ! reduction of g-points from 256 to 140 for input absorption coefficient - ! data and other arrays. - ! - ! In a GCM this call should be placed in the model initialization - ! area, since this has to be called only once. - ! call rrtmg_lw_ini - ! This is the main longitude/column loop within RRTMG. - ! Prepare atmospheric profile from GCM for use in RRTMG, and define - ! other input parameters. - ! For cloudy atmosphere, use cldprop to set cloud optical properties based on - ! input cloud physical properties. Select method based on choices described - ! in cldprop. Cloud fraction, water path, liquid droplet and ice particle - ! effective radius must be passed into cldprop. Cloud fraction and cloud - ! optical depth are transferred to rrtmg_lw arrays in cldprop. - ! Calculate information needed by the radiative transfer routine - ! that is specific to this atmosphere, especially some of the - ! coefficients and indices needed to compute the optical depths - ! by interpolating data from stored reference atmospheres. - tolerance = 1.E-14 - CALL kgen_init_check(check_status, tolerance) - READ(UNIT=kgen_unit) istart - READ(UNIT=kgen_unit) pavel - READ(UNIT=kgen_unit) tavel - READ(UNIT=kgen_unit) tz - READ(UNIT=kgen_unit) tbound - READ(UNIT=kgen_unit) coldry - READ(UNIT=kgen_unit) wbrodl - READ(UNIT=kgen_unit) wkl - READ(UNIT=kgen_unit) semiss - READ(UNIT=kgen_unit) laytrop - READ(UNIT=kgen_unit) jp - READ(UNIT=kgen_unit) jt - READ(UNIT=kgen_unit) jt1 - READ(UNIT=kgen_unit) planklay - READ(UNIT=kgen_unit) planklev - READ(UNIT=kgen_unit) plankbnd - READ(UNIT=kgen_unit) colh2o - READ(UNIT=kgen_unit) colco2 - READ(UNIT=kgen_unit) colo3 - READ(UNIT=kgen_unit) coln2o - READ(UNIT=kgen_unit) colco - READ(UNIT=kgen_unit) colch4 - READ(UNIT=kgen_unit) colo2 - READ(UNIT=kgen_unit) colbrd - READ(UNIT=kgen_unit) indself - READ(UNIT=kgen_unit) indfor - READ(UNIT=kgen_unit) selffac - READ(UNIT=kgen_unit) selffrac - READ(UNIT=kgen_unit) forfac - READ(UNIT=kgen_unit) forfrac - READ(UNIT=kgen_unit) indminor - READ(UNIT=kgen_unit) minorfrac - READ(UNIT=kgen_unit) scaleminor - READ(UNIT=kgen_unit) scaleminorn2 - READ(UNIT=kgen_unit) fac01 - READ(UNIT=kgen_unit) fac10 - READ(UNIT=kgen_unit) fac11 - READ(UNIT=kgen_unit) fac00 - READ(UNIT=kgen_unit) rat_o3co2_1 - READ(UNIT=kgen_unit) rat_o3co2 - READ(UNIT=kgen_unit) rat_h2och4 - READ(UNIT=kgen_unit) rat_h2oo3 - READ(UNIT=kgen_unit) rat_h2och4_1 - READ(UNIT=kgen_unit) rat_h2oo3_1 - READ(UNIT=kgen_unit) rat_h2oco2 - READ(UNIT=kgen_unit) rat_n2oco2 - READ(UNIT=kgen_unit) rat_h2on2o - READ(UNIT=kgen_unit) rat_n2oco2_1 - READ(UNIT=kgen_unit) rat_h2oco2_1 - READ(UNIT=kgen_unit) rat_h2on2o_1 - - READ(UNIT=kgen_unit) ref_laytrop - READ(UNIT=kgen_unit) ref_jp - READ(UNIT=kgen_unit) ref_jt - READ(UNIT=kgen_unit) ref_jt1 - READ(UNIT=kgen_unit) ref_planklay - READ(UNIT=kgen_unit) ref_planklev - READ(UNIT=kgen_unit) ref_plankbnd - READ(UNIT=kgen_unit) ref_colh2o - READ(UNIT=kgen_unit) ref_colco2 - READ(UNIT=kgen_unit) ref_colo3 - READ(UNIT=kgen_unit) ref_coln2o - READ(UNIT=kgen_unit) ref_colco - READ(UNIT=kgen_unit) ref_colch4 - READ(UNIT=kgen_unit) ref_colo2 - READ(UNIT=kgen_unit) ref_colbrd - READ(UNIT=kgen_unit) ref_indself - READ(UNIT=kgen_unit) ref_indfor - READ(UNIT=kgen_unit) ref_selffac - READ(UNIT=kgen_unit) ref_selffrac - READ(UNIT=kgen_unit) ref_forfac - READ(UNIT=kgen_unit) ref_forfrac - READ(UNIT=kgen_unit) ref_indminor - READ(UNIT=kgen_unit) ref_minorfrac - READ(UNIT=kgen_unit) ref_scaleminor - READ(UNIT=kgen_unit) ref_scaleminorn2 - READ(UNIT=kgen_unit) ref_fac01 - READ(UNIT=kgen_unit) ref_fac10 - READ(UNIT=kgen_unit) ref_fac11 - READ(UNIT=kgen_unit) ref_fac00 - READ(UNIT=kgen_unit) ref_rat_o3co2_1 - READ(UNIT=kgen_unit) ref_rat_o3co2 - READ(UNIT=kgen_unit) ref_rat_h2och4 - READ(UNIT=kgen_unit) ref_rat_h2oo3 - READ(UNIT=kgen_unit) ref_rat_h2och4_1 - READ(UNIT=kgen_unit) ref_rat_h2oo3_1 - READ(UNIT=kgen_unit) ref_rat_h2oco2 - READ(UNIT=kgen_unit) ref_rat_n2oco2 - READ(UNIT=kgen_unit) ref_rat_h2on2o - READ(UNIT=kgen_unit) ref_rat_n2oco2_1 - READ(UNIT=kgen_unit) ref_rat_h2oco2_1 - READ(UNIT=kgen_unit) ref_rat_h2on2o_1 - - - ! call to kernel - call setcoef(ncol,nlay, istart, pavel, tavel, tz, tbound, semiss, & - coldry, wkl, wbrodl, & - laytrop, jp, jt, jt1, planklay, planklev, plankbnd, & - colh2o, colco2, colo3, coln2o, colco, colch4, colo2, & - colbrd, fac00, fac01, fac10, fac11, & - rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, & - rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, & - rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, & - selffac, selffrac, indself, forfac, forfrac, indfor, & - minorfrac, scaleminor, scaleminorn2, indminor) - ! kernel verification for output variables - CALL kgen_verify_integer_4_dim1( "laytrop", check_status, laytrop, ref_laytrop) - CALL kgen_verify_integer_4_dim2( "jp", check_status, jp, ref_jp) - CALL kgen_verify_integer_4_dim2( "jt", check_status, jt, ref_jt) - CALL kgen_verify_integer_4_dim2( "jt1", check_status, jt1, ref_jt1) - CALL kgen_verify_real_r8_dim3( "planklay", check_status, planklay, ref_planklay) - CALL kgen_verify_real_r8_dim3( "planklev", check_status, planklev, ref_planklev) - CALL kgen_verify_real_r8_dim2( "plankbnd", check_status, plankbnd, ref_plankbnd) - CALL kgen_verify_real_r8_dim2( "colh2o", check_status, colh2o, ref_colh2o) - CALL kgen_verify_real_r8_dim2( "colco2", check_status, colco2, ref_colco2) - CALL kgen_verify_real_r8_dim2( "colo3", check_status, colo3, ref_colo3) - CALL kgen_verify_real_r8_dim2( "coln2o", check_status, coln2o, ref_coln2o) - CALL kgen_verify_real_r8_dim2( "colco", check_status, colco, ref_colco) - CALL kgen_verify_real_r8_dim2( "colch4", check_status, colch4, ref_colch4) - CALL kgen_verify_real_r8_dim2( "colo2", check_status, colo2, ref_colo2) - CALL kgen_verify_real_r8_dim2( "colbrd", check_status, colbrd, ref_colbrd) - CALL kgen_verify_integer_4_dim2( "indself", check_status, indself, ref_indself) - CALL kgen_verify_integer_4_dim2( "indfor", check_status, indfor, ref_indfor) - CALL kgen_verify_real_r8_dim2( "selffac", check_status, selffac, ref_selffac) - CALL kgen_verify_real_r8_dim2( "selffrac", check_status, selffrac, ref_selffrac) - CALL kgen_verify_real_r8_dim2( "forfac", check_status, forfac, ref_forfac) - CALL kgen_verify_real_r8_dim2( "forfrac", check_status, forfrac, ref_forfrac) - CALL kgen_verify_integer_4_dim2( "indminor", check_status, indminor, ref_indminor) - CALL kgen_verify_real_r8_dim2( "minorfrac", check_status, minorfrac, ref_minorfrac) - CALL kgen_verify_real_r8_dim2( "scaleminor", check_status, scaleminor, ref_scaleminor) - CALL kgen_verify_real_r8_dim2( "scaleminorn2", check_status, scaleminorn2, ref_scaleminorn2) - CALL kgen_verify_real_r8_dim2( "fac01", check_status, fac01, ref_fac01) - CALL kgen_verify_real_r8_dim2( "fac10", check_status, fac10, ref_fac10) - CALL kgen_verify_real_r8_dim2( "fac11", check_status, fac11, ref_fac11) - CALL kgen_verify_real_r8_dim2( "fac00", check_status, fac00, ref_fac00) - CALL kgen_verify_real_r8_dim2( "rat_o3co2_1", check_status, rat_o3co2_1, ref_rat_o3co2_1) - CALL kgen_verify_real_r8_dim2( "rat_o3co2", check_status, rat_o3co2, ref_rat_o3co2) - CALL kgen_verify_real_r8_dim2( "rat_h2och4", check_status, rat_h2och4, ref_rat_h2och4) - CALL kgen_verify_real_r8_dim2( "rat_h2oo3", check_status, rat_h2oo3, ref_rat_h2oo3) - CALL kgen_verify_real_r8_dim2( "rat_h2och4_1", check_status, rat_h2och4_1, ref_rat_h2och4_1) - CALL kgen_verify_real_r8_dim2( "rat_h2oo3_1", check_status, rat_h2oo3_1, ref_rat_h2oo3_1) - CALL kgen_verify_real_r8_dim2( "rat_h2oco2", check_status, rat_h2oco2, ref_rat_h2oco2) - CALL kgen_verify_real_r8_dim2( "rat_n2oco2", check_status, rat_n2oco2, ref_rat_n2oco2) - CALL kgen_verify_real_r8_dim2( "rat_h2on2o", check_status, rat_h2on2o, ref_rat_h2on2o) - CALL kgen_verify_real_r8_dim2( "rat_n2oco2_1", check_status, rat_n2oco2_1, ref_rat_n2oco2_1) - CALL kgen_verify_real_r8_dim2( "rat_h2oco2_1", check_status, rat_h2oco2_1, ref_rat_h2oco2_1) - CALL kgen_verify_real_r8_dim2( "rat_h2on2o_1", check_status, rat_h2on2o_1, ref_rat_h2on2o_1) - CALL kgen_print_check("setcoef", check_status) - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,10 - CALL setcoef(ncol, nlay, istart, pavel, tavel, tz, tbound, semiss, coldry, wkl, wbrodl, laytrop, & -jp, jt, jt1, planklay, planklev, plankbnd, colh2o, colco2, colo3, coln2o, colco, colch4, colo2, colbrd, fac00, & -fac01, fac10, fac11, rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, rat_h2on2o, rat_h2on2o_1, rat_h2och4, & -rat_h2och4_1, rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, selffac, selffrac, indself, forfac, forfrac, & -indfor, minorfrac, scaleminor, scaleminorn2, indminor) - END DO - CALL system_clock(stop_clock, rate_clock) - WRITE(*,*) - PRINT *, "Elapsed time (sec): ", (stop_clock - start_clock)/REAL(rate_clock*10) - ! Call the radiative transfer routine. - ! Either routine can be called to do clear sky calculation. If clouds - ! are present, then select routine based on cloud overlap assumption - ! to be used. Clear sky calculation is done simultaneously. - ! For McICA, RTRNMC is called for clear and cloudy calculations. - ! Transfer up and down fluxes and heating rate to output arrays. - ! Vertical indexing goes from bottom to top - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_integer_4_dim1(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - integer(KIND=4), INTENT(OUT), ALLOCATABLE, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_integer_4_dim1 - - SUBROUTINE kgen_read_integer_4_dim2(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - integer(KIND=4), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_integer_4_dim2 - - SUBROUTINE kgen_read_real_r8_dim3(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2,idx3 - INTEGER, DIMENSION(2,3) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim3 - - SUBROUTINE kgen_read_real_r8_dim2(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim2 - - - ! verify subroutines - SUBROUTINE kgen_verify_integer_4_dim1( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in), DIMENSION(:) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - end if - - check_status%numFatal = check_status%numFatal+1 - END IF - END SUBROUTINE kgen_verify_integer_4_dim1 - - SUBROUTINE kgen_verify_integer_4_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in), DIMENSION(:,:) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - end if - - check_status%numFatal = check_status%numFatal+1 - END IF - END SUBROUTINE kgen_verify_integer_4_dim2 - - SUBROUTINE kgen_verify_real_r8_dim3( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim3 - - SUBROUTINE kgen_verify_real_r8_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim2 - - END SUBROUTINE rrtmg_lw - !*************************************************************************** - - END MODULE rrtmg_lw_rad diff --git a/test/ncar_kernels/PORT_lw_setcoef/src/rrtmg_lw_setcoef.f90 b/test/ncar_kernels/PORT_lw_setcoef/src/rrtmg_lw_setcoef.f90 deleted file mode 100644 index bbb065b8ce..0000000000 --- a/test/ncar_kernels/PORT_lw_setcoef/src/rrtmg_lw_setcoef.f90 +++ /dev/null @@ -1,454 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_lw_setcoef.f90 -! Generated at: 2015-07-26 18:24:46 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_lw_setcoef - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! ------- Modules ------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE parrrtm, ONLY: nbndlw - USE parrrtm, ONLY: mxmol - USE rrlw_wvn, ONLY: totplnk - USE rrlw_wvn, ONLY: totplk16 - USE rrlw_ref, only : preflog - USE rrlw_ref, only : tref - USE rrlw_ref, only : chi_mls - USE rrlw_vsn, ONLY: hvrset - IMPLICIT NONE - PUBLIC setcoef - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !---------------------------------------------------------------------------- - - SUBROUTINE setcoef(ncol, nlayers, istart, pavel, tavel, tz, tbound, semiss, coldry, wkl, wbroad, laytrop, jp, jt, jt1, & - planklay, planklev, plankbnd, colh2o, colco2, colo3, coln2o, colco, colch4, colo2, colbrd, fac00, fac01, fac10, fac11, & - rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, rat_n2oco2, & - rat_n2oco2_1, rat_o3co2, rat_o3co2_1, selffac, selffrac, indself, forfac, forfrac, indfor, minorfrac, scaleminor, & - scaleminorn2, indminor) - !---------------------------------------------------------------------------- - ! - ! Purpose: For a given atmosphere, calculate the indices and - ! fractions related to the pressure and temperature interpolations. - ! Also calculate the values of the integrated Planck functions - ! for each band at the level and layer temperatures. - ! ------- Declarations ------- - ! ----- Input ----- - INTEGER, intent(in) :: ncol !number of simd columns - INTEGER, intent(in) :: nlayers ! total number of layers - INTEGER, intent(in) :: istart ! beginning band of calculation - REAL(KIND=r8), intent(in) :: pavel(ncol,nlayers) ! layer pressures (mb) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: tavel(ncol,nlayers) ! layer temperatures (K) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: tz(ncol,0:nlayers) ! level (interface) temperatures (K) - ! Dimensions: (0:nlayers) - REAL(KIND=r8), intent(in) :: tbound(ncol) ! surface temperature (K) - REAL(KIND=r8), intent(in) :: coldry(ncol,nlayers) ! dry air column density (mol/cm2) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: wbroad(ncol,nlayers) ! broadening gas column density (mol/cm2) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: wkl(ncol,mxmol,nlayers) ! molecular amounts (mol/cm-2) - ! Dimensions: (ncol,mxmol,nlayers) - REAL(KIND=r8), intent(in) :: semiss(ncol,nbndlw) ! lw surface emissivity - ! Dimensions: (nbndlw) - ! ----- Output ----- - INTEGER, intent(out), dimension(:) :: laytrop ! tropopause layer index - INTEGER, intent(out) :: jp(ncol,nlayers) ! - ! Dimensions: (nlayers) - INTEGER, intent(out) :: jt(ncol,nlayers) ! - ! Dimensions: (nlayers) - INTEGER, intent(out) :: jt1(ncol,nlayers) ! - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: planklay(ncol,nlayers,nbndlw) ! - ! Dimensions: (ncol,nlayers,nbndlw) - REAL(KIND=r8), intent(out) :: planklev(ncol,0:nlayers,nbndlw) ! - ! Dimensions: (ncol,0:nlayers,nbndlw) - REAL(KIND=r8), intent(out) :: plankbnd(ncol,nbndlw) ! - ! Dimensions: (ncol,nbndlw) - REAL(KIND=r8), intent(out) :: colh2o(ncol,nlayers) ! column amount (h2o) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: colco2(ncol,nlayers) ! column amount (co2) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: colo3(ncol,nlayers) ! column amount (o3) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: coln2o(ncol,nlayers) ! column amount (n2o) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: colco(ncol,nlayers) ! column amount (co) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: colch4(ncol,nlayers) ! column amount (ch4) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: colo2(ncol,nlayers) ! column amount (o2) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: colbrd(ncol,nlayers) ! column amount (broadening gases) - ! Dimensions: (nlayers) - INTEGER, intent(out) :: indself(ncol,nlayers) - ! Dimensions: (nlayers) - INTEGER, intent(out) :: indfor(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: selffac(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: selffrac(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: forfac(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: forfrac(ncol,nlayers) - ! Dimensions: (nlayers) - INTEGER, intent(out) :: indminor(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: minorfrac(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: scaleminor(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: scaleminorn2(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: fac00(ncol,nlayers) - REAL(KIND=r8), intent(out) :: fac01(ncol,nlayers) - REAL(KIND=r8), intent(out) :: fac10(ncol,nlayers) - REAL(KIND=r8), intent(out) :: fac11(ncol,nlayers) ! - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(out) :: rat_h2och4(ncol,nlayers) - REAL(KIND=r8), intent(out) :: rat_h2on2o(ncol,nlayers) - REAL(KIND=r8), intent(out) :: rat_h2on2o_1(ncol,nlayers) - REAL(KIND=r8), intent(out) :: rat_o3co2_1(ncol,nlayers) - REAL(KIND=r8), intent(out) :: rat_h2och4_1(ncol,nlayers) - REAL(KIND=r8), intent(out) :: rat_n2oco2_1(ncol,nlayers) - REAL(KIND=r8), intent(out) :: rat_h2oo3_1(ncol,nlayers) - REAL(KIND=r8), intent(out) :: rat_n2oco2(ncol,nlayers) - REAL(KIND=r8), intent(out) :: rat_h2oco2(ncol,nlayers) - REAL(KIND=r8), intent(out) :: rat_h2oco2_1(ncol,nlayers) - REAL(KIND=r8), intent(out) :: rat_h2oo3(ncol,nlayers) - REAL(KIND=r8), intent(out) :: rat_o3co2(ncol,nlayers) ! - ! Dimensions: (nlayers) - INTEGER :: indbound(1:ncol) - INTEGER :: indlev0(1:ncol) - INTEGER :: lay - INTEGER :: icol - INTEGER :: indlay(1:ncol) - INTEGER :: indlev(1:ncol) - INTEGER :: iband - INTEGER :: jp1(1:ncol,1:nlayers) - REAL(KIND=r8) :: stpfac - REAL(KIND=r8) :: tbndfrac(1:ncol) - REAL(KIND=r8) :: t0frac(1:ncol) - REAL(KIND=r8) :: tlayfrac(1:ncol) - REAL(KIND=r8) :: tlevfrac(1:ncol) - REAL(KIND=r8) :: dbdtlev(1:ncol) - REAL(KIND=r8) :: dbdtlay(1:ncol) - REAL(KIND=r8) :: plog(1:ncol) - REAL(KIND=r8) :: fp(1:ncol) - REAL(KIND=r8) :: ft(1:ncol) - REAL(KIND=r8) :: ft1(1:ncol) - REAL(KIND=r8) :: water(1:ncol) - REAL(KIND=r8) :: scalefac(1:ncol) - REAL(KIND=r8) :: factor(1:ncol) - REAL(KIND=r8) :: compfp(1:ncol) - hvrset = '$Revision: 1.2 $' - !dir$ assume_aligned tz:64 - !dir$ assume_aligned tavel:64 - !dir$ assume_aligned pavel:64 - !dir$ assume_aligned planklay:64 - !dir$ assume_aligned planklev:64 - !dir$ assume_aligned plankbnd:64 - !dir$ assume_aligned pavel:64 - !dir$ assume_aligned jp:64 - !dir$ assume_aligned jp1:64 - !dir$ assume_aligned jt:64 - !dir$ assume_aligned jt1:64 - !dir$ assume_aligned wkl:64 - !dir$ assume_aligned coldry:64 - stpfac = 296._r8/1013._r8 - !dir$ vector aligned - !dir$ SIMD - do icol=1,ncol - indbound(icol) = tbound(icol) - 159._r8 - if (indbound(icol) .lt. 1) then - indbound(icol) = 1 - elseif (indbound(icol) .gt. 180) then - indbound(icol) = 180 - endif - tbndfrac(icol) = tbound(icol) - 159._r8 - float(indbound(icol)) - indlev0(icol) = tz(icol,0) - 159._r8 - if (indlev0(icol) .lt. 1) then - indlev0(icol) = 1 - elseif (indlev0(icol) .gt. 180) then - indlev0(icol) = 180 - endif - t0frac(icol) = tz(icol,0) - 159._r8 - float(indlev0(icol)) - laytrop(icol) = 0 - ! Begin layer loop - ! Calculate the integrated Planck functions for each band at the - ! surface, level, and layer temperatures. - end do - do lay = 1, nlayers - !dir$ vector aligned - !dir$ SIMD - do icol=1,ncol - indlay(icol) = tavel(icol,lay) - 159._r8 - if (indlay(icol) .lt. 1) then - indlay(icol) = 1 - elseif (indlay(icol) .gt. 180) then - indlay(icol) = 180 - endif - tlayfrac(icol) = tavel(icol,lay) - 159._r8 - float(indlay(icol)) ! ! - indlev(icol) = tz(icol,lay) - 159._r8 - if (indlev(icol) .lt. 1) then - indlev(icol) = 1 - elseif (indlev(icol) .gt. 180) then - indlev(icol) = 180 - endif - tlevfrac(icol) = tz(icol,lay) - 159._r8 - float(indlev(icol)) ! ! - ! Begin spectral band loop - end do ! end of icol loop ! end of icol loop - do iband = 1, 15 - !dir$ vector aligned - !dir$ SIMD - do icol=1,ncol - if (lay.eq.1) then - !print*,'inside iband : lay = 1 loop',lay - dbdtlev(icol) = totplnk(indbound(icol)+1,iband) - totplnk(indbound(icol),iband) - plankbnd(icol,iband) = semiss(icol,iband) * & - (totplnk(indbound(icol),iband) + tbndfrac(icol) * dbdtlev(icol)) - dbdtlev(icol) = totplnk(indlev0(icol)+1,iband)-totplnk(indlev0(icol),iband) - planklev(icol,0,iband) = totplnk(indlev0(icol),iband) + t0frac(icol) * dbdtlev(icol) - endif - end do - !dir$ vector aligned - !dir$ SIMD - do icol=1,ncol - dbdtlev(icol) = totplnk(indlev(icol)+1,iband) - totplnk(indlev(icol),iband) - dbdtlay(icol) = totplnk(indlay(icol)+1,iband) - totplnk(indlay(icol),iband) - planklay(icol,lay,iband) = totplnk(indlay(icol),iband) + tlayfrac(icol) * dbdtlay(icol) - planklev(icol,lay,iband) = totplnk(indlev(icol),iband) + tlevfrac(icol) * dbdtlev(icol) - ! print *,'exiting iband loop',iband - end do ! end of icol loop ! end of icol loop - enddo - ! For band 16, if radiative transfer will be performed on just - ! this band, use integrated Planck values up to 3250 cm-1. - ! If radiative transfer will be performed across all 16 bands, - ! then include in the integrated Planck values for this band - ! contributions from 2600 cm-1 to infinity. - iband = 16 - if (istart .eq. 16) then - ! print*,'iband ::::',iband - if (lay.eq.1) then - !dir$ vector aligned - !dir$ SIMD - do icol=1,ncol - dbdtlev(icol) = totplk16(indbound(icol)+1) - totplk16(indbound(icol)) - plankbnd(icol,iband) = semiss(icol,iband) * & - (totplk16(indbound(icol)) + tbndfrac(icol) * dbdtlev(icol)) - dbdtlev(icol) = totplnk(indlev0(icol)+1,iband)-totplnk(indlev0(icol),iband) - planklev(icol,0,iband) = totplk16(indlev0(icol)) + & - t0frac(icol) * dbdtlev(icol) - end do - endif - !dir$ vector aligned - !dir$ SIMD - do icol=1,ncol - dbdtlev(icol) = totplk16(indlev(icol)+1) - totplk16(indlev(icol)) - dbdtlay(icol) = totplk16(indlay(icol)+1) - totplk16(indlay(icol)) - planklay(icol,lay,iband) = totplk16(indlay(icol)) + tlayfrac(icol) * dbdtlay(icol) - planklev(icol,lay,iband) = totplk16(indlev(icol)) + tlevfrac(icol) * dbdtlev(icol) - end do - else - if (lay.eq.1) then - !dir$ vector aligned - !dir$ SIMD - do icol=1,ncol - dbdtlev(icol) = totplnk(indbound(icol)+1,iband) - totplnk(indbound(icol),iband) - plankbnd(icol,iband) = semiss(icol,iband) * & - (totplnk(indbound(icol),iband) + tbndfrac(icol) * dbdtlev(icol)) - dbdtlev(icol) = totplnk(indlev0(icol)+1,iband)-totplnk(indlev0(icol),iband) - planklev(icol,0,iband) = totplnk(indlev0(icol),iband) + t0frac(icol) * dbdtlev(icol) - end do - endif - !dir$ vector aligned - !dir$ SIMD - do icol=1,ncol - dbdtlev(icol) = totplnk(indlev(icol)+1,iband) - totplnk(indlev(icol),iband) - dbdtlay(icol) = totplnk(indlay(icol)+1,iband) - totplnk(indlay(icol),iband) - planklay(icol,lay,iband) = totplnk(indlay(icol),iband) + tlayfrac(icol) * dbdtlay(icol) - planklev(icol,lay,iband) = totplnk(indlev(icol),iband) + tlevfrac(icol) * dbdtlev(icol) - end do - endif - ! Find the two reference pressures on either side of the - ! layer pressure. Store them in JP and JP1. Store in FP the - ! fraction of the difference (in ln(pressure)) between these - ! two values that the layer pressure lies. - ! plog = alog(pavel(lay)) - !dir$ vector aligned - !dir$ SIMD - do icol=1,ncol - plog(icol) = dlog(pavel(icol,lay)) - jp(icol,lay) = int(36._r8 - 5*(plog(icol)+0.04_r8)) - if (jp(icol,lay) .lt. 1) then - jp(icol,lay) = 1 - elseif (jp(icol,lay) .gt. 58) then - jp(icol,lay) = 58 - endif - jp1(icol,lay) = jp(icol,lay) + 1 - fp(icol) = 5._r8 *(preflog(jp(icol,lay)) - plog(icol)) - ! Determine, for each reference pressure (JP and JP1), which - ! reference temperature (these are different for each - ! reference pressure) is nearest the layer temperature but does - ! not exceed it. Store these indices in JT and JT1, resp. - ! Store in FT (resp. FT1) the fraction of the way between JT - ! (JT1) and the next highest reference temperature that the - ! layer temperature falls. - ! (JT1) and the next highest reference temperature that the - ! layer temperature falls. - jt(icol,lay) = int(3._r8 + (tavel(icol,lay)-tref(jp(icol,lay)))/15._r8) - if (jt(icol,lay) .lt. 1) then - jt(icol,lay) = 1 - elseif (jt(icol,lay) .gt. 4) then - jt(icol,lay) = 4 - endif - ft(icol) = ((tavel(icol,lay)-tref(jp(icol,lay)))/15._r8) - float(jt(icol,lay)-3) - jt1(icol,lay) = int(3._r8 + (tavel(icol,lay)-tref(jp1(icol,lay)))/15._r8) - if (jt1(icol,lay) .lt. 1) then - jt1(icol,lay) = 1 - elseif (jt1(icol,lay) .gt. 4) then - jt1(icol,lay) = 4 - endif - ft1(icol) = ((tavel(icol,lay)-tref(jp1(icol,lay)))/15._r8) - float(jt1(icol,lay)-3) - water(icol) = wkl(icol,1,lay)/coldry(icol,lay) - scalefac(icol) = pavel(icol,lay) * stpfac / tavel(icol,lay) - ! If the pressure is less than ~100mb, perform a different - ! set of species interpolations. - if (plog(icol) .le. 4.56_r8) then - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - forfac(icol,lay) = scalefac(icol) / (1.+water(icol)) - factor(icol) = (tavel(icol,lay)-188.0_r8)/36.0_r8 - indfor(icol,lay) = 3 - forfrac(icol,lay) = factor(icol) - 1.0_r8 - ! Set up factors needed to separately include the water vapor - ! self-continuum in the calculation of absorption coefficient. - selffac(icol,lay) = water(icol) * forfac(icol,lay) - ! Set up factors needed to separately include the minor gases - ! in the calculation of absorption coefficient - scaleminor(icol,lay) = pavel(icol,lay)/tavel(icol,lay) - scaleminorn2(icol,lay) = (pavel(icol,lay)/tavel(icol,lay)) & - * (wbroad(icol,lay)/(coldry(icol,lay)+wkl(icol,1,lay))) - factor(icol) = (tavel(icol,lay)-180.8_r8)/7.2_r8 - indminor(icol,lay) = min(18, max(1, int(factor(icol)))) - minorfrac(icol,lay) = factor(icol) - float(indminor(icol,lay)) - ! Setup reference ratio to be used in calculation of binary - ! species parameter in upper atmosphere. - rat_h2oco2(icol,lay)=chi_mls(1,jp(icol,lay))/chi_mls(2,jp(icol,lay)) - rat_h2oco2_1(icol,lay)=chi_mls(1,jp(icol,lay)+1)/chi_mls(2,jp(icol,lay)+1) - rat_o3co2(icol,lay)=chi_mls(3,jp(icol,lay))/chi_mls(2,jp(icol,lay)) - rat_o3co2_1(icol,lay)=chi_mls(3,jp(icol,lay)+1)/chi_mls(2,jp(icol,lay)+1) - ! Calculate needed column amounts. - ! Calculate needed column amounts. - colh2o(icol,lay) = 1.e-20_r8 * wkl(icol,1,lay) - colco2(icol,lay) = 1.e-20_r8 * wkl(icol,2,lay) - colo3(icol,lay) = 1.e-20_r8 * wkl(icol,3,lay) - coln2o(icol,lay) = 1.e-20_r8 * wkl(icol,4,lay) - colco(icol,lay) = 1.e-20_r8 * wkl(icol,5,lay) - colch4(icol,lay) = 1.e-20_r8 * wkl(icol,6,lay) - colo2(icol,lay) = 1.e-20_r8 * wkl(icol,7,lay) - if (colco2(icol,lay) .eq. 0._r8) colco2(icol,lay) = 1.e-32_r8 * coldry(icol,lay) - if (colo3(icol,lay) .eq. 0._r8) colo3(icol,lay) = 1.e-32_r8 * coldry(icol,lay) - if (coln2o(icol,lay) .eq. 0._r8) coln2o(icol,lay) = 1.e-32_r8 * coldry(icol,lay) - if (colco(icol,lay) .eq. 0._r8) colco(icol,lay) = 1.e-32_r8 * coldry(icol,lay) - if (colch4(icol,lay) .eq. 0._r8) colch4(icol,lay) = 1.e-32_r8 * coldry(icol,lay) - colbrd(icol,lay) = 1.e-20_r8 * wbroad(icol,lay) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - else - laytrop(icol) = laytrop(icol) + 1 - forfac(icol,lay) = scalefac(icol) / (1.+water(icol)) - factor(icol) = (332.0_r8-tavel(icol,lay))/36.0_r8 - indfor(icol,lay) = min(2, max(1, int(factor(icol)))) - forfrac(icol,lay) = factor(icol) - float(indfor(icol,lay)) - ! Set up factors needed to separately include the water vapor - ! self-continuum in the calculation of absorption coefficient. - selffac(icol,lay) = water(icol) * forfac(icol,lay) - factor(icol) = (tavel(icol,lay)-188.0_r8)/7.2_r8 - indself(icol,lay) = min(9, max(1, int(factor(icol))-7)) - selffrac(icol,lay) = factor(icol) - float(indself(icol,lay) + 7) - indself(icol,lay) = min(9, max(1, int(factor(icol))-7)) - selffrac(icol,lay) = factor(icol) - float(indself(icol,lay) + 7) - ! Set up factors needed to separately include the minor gases - ! in the calculation of absorption coefficient - scaleminor(icol,lay) = pavel(icol,lay)/tavel(icol,lay) - scaleminorn2(icol,lay) = (pavel(icol,lay)/tavel(icol,lay)) & - *(wbroad(icol,lay)/(coldry(icol,lay)+wkl(icol,1,lay))) - factor(icol) = (tavel(icol,lay)-180.8_r8)/7.2_r8 - indminor(icol,lay) = min(18, max(1, int(factor(icol)))) - minorfrac(icol,lay) = factor(icol) - float(indminor(icol,lay)) - ! Setup reference ratio to be used in calculation of binary - ! species parameter in lower atmosphere. - rat_h2oco2(icol,lay)=chi_mls(1,jp(icol,lay))/chi_mls(2,jp(icol,lay)) - rat_h2oco2_1(icol,lay)=chi_mls(1,jp(icol,lay)+1)/chi_mls(2,jp(icol,lay)+1) - rat_h2oo3(icol,lay)=chi_mls(1,jp(icol,lay))/chi_mls(3,jp(icol,lay)) - rat_h2oo3_1(icol,lay)=chi_mls(1,jp(icol,lay)+1)/chi_mls(3,jp(icol,lay)+1) - rat_h2on2o(icol,lay)=chi_mls(1,jp(icol,lay))/chi_mls(4,jp(icol,lay)) - rat_h2on2o_1(icol,lay)=chi_mls(1,jp(icol,lay)+1)/chi_mls(4,jp(icol,lay)+1) - rat_h2och4(icol,lay)=chi_mls(1,jp(icol,lay))/chi_mls(6,jp(icol,lay)) - rat_h2och4_1(icol,lay)=chi_mls(1,jp(icol,lay)+1)/chi_mls(6,jp(icol,lay)+1) - rat_n2oco2(icol,lay)=chi_mls(4,jp(icol,lay))/chi_mls(2,jp(icol,lay)) - rat_n2oco2_1(icol,lay)=chi_mls(4,jp(icol,lay)+1)/chi_mls(2,jp(icol,lay)+1) - ! Calculate needed column amounts. - colh2o(icol,lay) = 1.e-20_r8 * wkl(icol,1,lay) - colco2(icol,lay) = 1.e-20_r8 * wkl(icol,2,lay) - colo3(icol,lay) = 1.e-20_r8 * wkl(icol,3,lay) - coln2o(icol,lay) = 1.e-20_r8 * wkl(icol,4,lay) - colco(icol,lay) = 1.e-20_r8 * wkl(icol,5,lay) - colch4(icol,lay) = 1.e-20_r8 * wkl(icol,6,lay) - colo2(icol,lay) = 1.e-20_r8 * wkl(icol,7,lay) - if (colco2(icol,lay) .eq. 0._r8) colco2(icol,lay) = 1.e-32_r8 * coldry(icol,lay) - if (colo3(icol,lay) .eq. 0._r8) colo3(icol,lay) = 1.e-32_r8 * coldry(icol,lay) - if (coln2o(icol,lay) .eq. 0._r8) coln2o(icol,lay) = 1.e-32_r8 * coldry(icol,lay) - if (colco(icol,lay) .eq. 0._r8) colco(icol,lay) = 1.e-32_r8 * coldry(icol,lay) - if (coln2o(icol,lay) .eq. 0._r8) coln2o(icol,lay) = 1.e-32_r8 * coldry(icol,lay) - if (colco(icol,lay) .eq. 0._r8) colco(icol,lay) = 1.e-32_r8 * coldry(icol,lay) - if (colch4(icol,lay) .eq. 0._r8) colch4(icol,lay) = 1.e-32_r8 * coldry(icol,lay) - colbrd(icol,lay) = 1.e-20_r8 * wbroad(icol,lay) - !go to 5400 - ! Above laytrop. - endif - !5300 continue - !5400 continue - ! We have now isolated the layer ln pressure and temperature, - ! between two reference pressures and two reference temperatures - ! (for each reference pressure). We multiply the pressure - ! fraction FP with the appropriate temperature fractions to get - ! the factors that will be needed for the interpolation that yields - ! the optical depths (performed in routines TAUGBn for band n).` - compfp(icol) = 1. - fp(icol) - fac10(icol,lay) = compfp(icol)* ft(icol) - fac00(icol,lay) = compfp(icol) * (1._r8 - ft(icol)) - fac11(icol,lay) = fp(icol) * ft1(icol) - fac01(icol,lay) = fp(icol) * (1._r8 - ft1(icol)) - ! Rescale selffac and forfac for use in taumol - selffac(icol,lay) = colh2o(icol,lay)*selffac(icol,lay) - forfac(icol,lay) = colh2o(icol,lay)*forfac(icol,lay) - ! End layer loop - !print*,'exiting lay loop',lay - end do - end do - !print*,'exiting icol loop',icol - END SUBROUTINE setcoef - !*************************************************************************** - - !*************************************************************************** - - END MODULE rrtmg_lw_setcoef diff --git a/test/ncar_kernels/PORT_lw_setcoef/src/shr_kind_mod.f90 b/test/ncar_kernels/PORT_lw_setcoef/src/shr_kind_mod.f90 deleted file mode 100644 index bca182767e..0000000000 --- a/test/ncar_kernels/PORT_lw_setcoef/src/shr_kind_mod.f90 +++ /dev/null @@ -1,26 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : shr_kind_mod.f90 -! Generated at: 2015-07-26 18:24:46 -! KGEN version: 0.4.13 - - - - MODULE shr_kind_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - PUBLIC - INTEGER, parameter :: shr_kind_r8 = selected_real_kind(12) ! 8 byte real - ! 4 byte real - ! native real - ! 8 byte integer - ! 4 byte integer - ! native integer - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE shr_kind_mod diff --git a/test/ncar_kernels/PORT_reftra_sw/CESM_license.txt b/test/ncar_kernels/PORT_reftra_sw/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/PORT_reftra_sw/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/PORT_reftra_sw/data/reftra_sw.1.0 b/test/ncar_kernels/PORT_reftra_sw/data/reftra_sw.1.0 deleted file mode 100644 index d63a7e6b61..0000000000 Binary files a/test/ncar_kernels/PORT_reftra_sw/data/reftra_sw.1.0 and /dev/null differ diff --git a/test/ncar_kernels/PORT_reftra_sw/inc/t1.mk b/test/ncar_kernels/PORT_reftra_sw/inc/t1.mk deleted file mode 100644 index eb3a2104ec..0000000000 --- a/test/ncar_kernels/PORT_reftra_sw/inc/t1.mk +++ /dev/null @@ -1,51 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# -# PGI default flags -# -# FC_FLAGS := -# -# Intel default flags -# -# FC_FLAGS := -# -FC_FLAGS := $(OPT) -FC_FLAGS += -Mnofma - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - -ALL_OBJS := kernel_reftra_sw.o - -verify: - @(grep "FAIL" $(TEST).rslt && echo "FAILED") || (grep "PASSED" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt | grep -v "PASS" - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_reftra_sw.o: $(SRC_DIR)/kernel_reftra_sw.F90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.oo *.rslt - diff --git a/test/ncar_kernels/PORT_reftra_sw/lit/runmake b/test/ncar_kernels/PORT_reftra_sw/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/PORT_reftra_sw/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/PORT_reftra_sw/lit/t1.sh b/test/ncar_kernels/PORT_reftra_sw/lit/t1.sh deleted file mode 100644 index 33c953a156..0000000000 --- a/test/ncar_kernels/PORT_reftra_sw/lit/t1.sh +++ /dev/null @@ -1,9 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -# Shared lit script for each tests. Run bash commands that run tests with make. - -# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t -# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/PORT_reftra_sw/makefile b/test/ncar_kernels/PORT_reftra_sw/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/PORT_reftra_sw/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/PORT_reftra_sw/src/kernel_reftra_sw.F90 b/test/ncar_kernels/PORT_reftra_sw/src/kernel_reftra_sw.F90 deleted file mode 100644 index a56477b674..0000000000 --- a/test/ncar_kernels/PORT_reftra_sw/src/kernel_reftra_sw.F90 +++ /dev/null @@ -1,526 +0,0 @@ - MODULE resolvers - - ! RESOLVER SPECS - INTEGER, PARAMETER :: r8 = selected_real_kind(12) - REAL(KIND = r8), PARAMETER :: tblint = 10000.0 - REAL(KIND = r8), PARAMETER :: od_lo = 0.06 - INTEGER, PARAMETER :: ntbl = 10000 - - END MODULE - - PROGRAM kernel_reftra_sw - USE resolvers - - IMPLICIT NONE - - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(1), PARAMETER :: kgen_mpi_rank_at = (/ 0 /) - INTEGER :: kgen_ierr, kgen_unit, kgen_get_newunit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(1), PARAMETER :: kgen_counter_at = (/ 1 /) - CHARACTER(LEN=1024) :: kgen_filepath - INTEGER, DIMENSION(2,10) :: kgen_bound - - ! DRIVER SPECS - REAL(KIND = r8) :: prmu0 - INTEGER :: nlayers - - DO kgen_repeat_counter = 1, 1 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 1)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 1)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - - kgen_filepath = "../data/reftra_sw." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit(kgen_mpi_rank+kgen_counter) - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - ! READ DRIVER INSTATE - - READ(UNIT = kgen_unit) prmu0 - READ(UNIT = kgen_unit) nlayers - - ! KERNEL DRIVER RUN - CALL kernel_driver(prmu0, nlayers, kgen_unit) - CLOSE (UNIT=kgen_unit) - - END DO - END PROGRAM kernel_reftra_sw - - ! KERNEL DRIVER SUBROUTINE - SUBROUTINE kernel_driver(prmu0, nlayers, kgen_unit) - USE resolvers - - IMPLICIT NONE - INTEGER, INTENT(IN) :: kgen_unit - INTEGER, DIMENSION(2,10) :: kgen_bound - - ! STATE SPECS - REAL(KIND = r8) :: ztradc(nlayers + 1) - INTEGER :: klev - REAL(KIND = r8) :: bpade - REAL(KIND = r8), INTENT(IN) :: prmu0 - CHARACTER*18 :: hvrrft - REAL(KIND = r8) :: ztauc(nlayers) - REAL(KIND = r8) :: zomcc(nlayers) - REAL(KIND = r8), DIMENSION(0 : ntbl) :: exp_tbl - INTEGER, INTENT(IN) :: nlayers - REAL(KIND = r8) :: zrefdc(nlayers + 1) - REAL(KIND = r8) :: ztrac(nlayers + 1) - REAL(KIND = r8) :: zrefc(nlayers + 1) - REAL(KIND = r8) :: zgcc(nlayers) - LOGICAL :: lrtchkclr(nlayers) - REAL(KIND = r8) :: outstate_ztradc(nlayers + 1) - REAL(KIND = r8) :: outstate_zrefdc(nlayers + 1) - REAL(KIND = r8) :: outstate_ztrac(nlayers + 1) - REAL(KIND = r8) :: outstate_zrefc(nlayers + 1) - - !JMD manual timer additions - integer*8 c1,c2,cr,cm - real*8 dt - integer :: itmax=100000 - character(len=80), parameter :: kname='[kernel_reftra_sw]' - integer :: it - !JMD - LOGICAL :: lstatus = .TRUE. - - ! READ CALLER INSTATE - - READ(UNIT = kgen_unit) ztradc - READ(UNIT = kgen_unit) klev - READ(UNIT = kgen_unit) ztauc - READ(UNIT = kgen_unit) zomcc - READ(UNIT = kgen_unit) zrefdc - READ(UNIT = kgen_unit) ztrac - READ(UNIT = kgen_unit) zrefc - READ(UNIT = kgen_unit) zgcc - READ(UNIT = kgen_unit) lrtchkclr - ! READ CALLEE INSTATE - - READ(UNIT = kgen_unit) bpade - READ(UNIT = kgen_unit) hvrrft - READ(UNIT = kgen_unit) exp_tbl - ! READ CALLEE OUTSTATE - - ! READ CALLER OUTSTATE - - READ(UNIT = kgen_unit) outstate_ztradc - READ(UNIT = kgen_unit) outstate_zrefdc - READ(UNIT = kgen_unit) outstate_ztrac - READ(UNIT = kgen_unit) outstate_zrefc - - call system_clock(c1,cr,cm) - ! KERNEL RUN - do it=1,itmax - CALL reftra_sw(klev, lrtchkclr, zgcc, prmu0, ztauc, zomcc, zrefc, zrefdc, ztrac, ztradc) - enddo - call system_clock(c2,cr,cm) - dt = dble(c2-c1)/dble(cr) - print *, TRIM(kname), ' total time (sec): ',dt - print *, TRIM(kname), ' time per call (usec): ',1.e6*dt/dble(itmax) - - - ! STATE VERIFICATION - IF ( ALL( outstate_ztradc == ztradc ) ) THEN - WRITE(*,*) "ztradc is IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_ztradc - !WRITE(*,*) "KERNEL: ", ztradc - IF ( ALL( outstate_ztradc == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - lstatus = .FALSE. - WRITE(*,*) "ztradc is NOT IDENTICAL." - WRITE(*,*) count( outstate_ztradc /= ztradc), " of ", size( ztradc ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_ztradc - ztradc)**2)/real(size(outstate_ztradc))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_ztradc - ztradc)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_ztradc - ztradc)) - WRITE(*,*) "Mean value of kernel-generated outstate_ztradc is ", sum(ztradc)/real(size(ztradc)) - WRITE(*,*) "Mean value of original outstate_ztradc is ", sum(outstate_ztradc)/real(size(outstate_ztradc)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_zrefdc == zrefdc ) ) THEN - WRITE(*,*) "zrefdc is IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_zrefdc - !WRITE(*,*) "KERNEL: ", zrefdc - IF ( ALL( outstate_zrefdc == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - lstatus = .FALSE. - WRITE(*,*) "zrefdc is NOT IDENTICAL." - WRITE(*,*) count( outstate_zrefdc /= zrefdc), " of ", size( zrefdc ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_zrefdc - zrefdc)**2)/real(size(outstate_zrefdc))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_zrefdc - zrefdc)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_zrefdc - zrefdc)) - WRITE(*,*) "Mean value of kernel-generated outstate_zrefdc is ", sum(zrefdc)/real(size(zrefdc)) - WRITE(*,*) "Mean value of original outstate_zrefdc is ", sum(outstate_zrefdc)/real(size(outstate_zrefdc)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_ztrac == ztrac ) ) THEN - WRITE(*,*) "ztrac is IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_ztrac - !WRITE(*,*) "KERNEL: ", ztrac - IF ( ALL( outstate_ztrac == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - lstatus = .FALSE. - WRITE(*,*) "ztrac is NOT IDENTICAL." - WRITE(*,*) count( outstate_ztrac /= ztrac), " of ", size( ztrac ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_ztrac - ztrac)**2)/real(size(outstate_ztrac))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_ztrac - ztrac)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_ztrac - ztrac)) - WRITE(*,*) "Mean value of kernel-generated outstate_ztrac is ", sum(ztrac)/real(size(ztrac)) - WRITE(*,*) "Mean value of original outstate_ztrac is ", sum(outstate_ztrac)/real(size(outstate_ztrac)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_zrefc == zrefc ) ) THEN - WRITE(*,*) "zrefc is IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_zrefc - !WRITE(*,*) "KERNEL: ", zrefc - IF ( ALL( outstate_zrefc == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - lstatus = .FALSE. - WRITE(*,*) "zrefc is NOT IDENTICAL." - WRITE(*,*) count( outstate_zrefc /= zrefc), " of ", size( zrefc ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_zrefc - zrefc)**2)/real(size(outstate_zrefc))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_zrefc - zrefc)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_zrefc - zrefc)) - WRITE(*,*) "Mean value of kernel-generated outstate_zrefc is ", sum(zrefc)/real(size(zrefc)) - WRITE(*,*) "Mean value of original outstate_zrefc is ", sum(outstate_zrefc)/real(size(outstate_zrefc)) - WRITE(*,*) "" - END IF - - IF ( lstatus ) THEN - WRITE(*,*) "PASSED" - ELSE - WRITE(*,*) "FAILED" - END IF - - ! DEALLOCATE INSTATE - - ! DEALLOCATE OUTSTATE - ! DEALLOCATE CALLEE INSTATE - - ! DEALLOCATE INSTATE - ! DEALLOCATE CALEE OUTSTATE - - ! DEALLOCATE OUTSTATE - - CONTAINS - - - ! KERNEL SUBPROGRAM - subroutine reftra_sw(nlayers, lrtchk, pgg, prmuz, ptau, pw, pref, prefd, ptra, ptrad) - ! -------------------------------------------------------------------- - - ! Purpose: computes the reflectivity and transmissivity of a clear or - ! cloudy layer using a choice of various approximations. - ! - ! Interface: *rrtmg_sw_reftra* is called by *rrtmg_sw_spcvrt* - ! - ! Description: - ! explicit arguments : - ! -------------------- - ! inputs - ! ------ - ! lrtchk = .t. for all layers in clear profile - ! lrtchk = .t. for cloudy layers in cloud profile - ! = .f. for clear layers in cloud profile - ! pgg = assymetry factor - ! prmuz = cosine solar zenith angle - ! ptau = optical thickness - ! pw = single scattering albedo - ! - ! outputs - ! ------- - ! pref : collimated beam reflectivity - ! prefd : diffuse beam reflectivity - ! ptra : collimated beam transmissivity - ! ptrad : diffuse beam transmissivity - ! - ! - ! Method: - ! ------- - ! standard delta-eddington, p.i.f.m., or d.o.m. layer calculations. - ! kmodts = 1 eddington (joseph et al., 1976) - ! = 2 pifm (zdunkowski et al., 1980) - ! = 3 discrete ordinates (liou, 1973) - ! - ! - ! Modifications: - ! -------------- - ! Original: J-JMorcrette, ECMWF, Feb 2003 - ! Revised for F90 reformatting: MJIacono, AER, Jul 2006 - ! Revised to add exponential lookup table: MJIacono, AER, Aug 2007 - ! - ! ------------------------------------------------------------------ - - ! ------- Declarations ------ - - ! ------- Input ------- - - integer, intent(in) :: nlayers - - logical, intent(in) :: lrtchk(:) - ! Logical flag for reflectivity and - ! and transmissivity calculation; - ! Dimensions: (nlayers) - - real(kind=r8), intent(in) :: pgg(:) - ! asymmetry parameter - ! Dimensions: (nlayers) - real(kind=r8), intent(in) :: ptau(:) - ! optical depth - ! Dimensions: (nlayers) - real(kind=r8), intent(in) :: pw(:) - ! single scattering albedo - ! Dimensions: (nlayers) - real(kind=r8), intent(in) :: prmuz - ! cosine of solar zenith angle - - ! ------- Output ------- - - real(kind=r8), intent(inout) :: pref(:) - ! direct beam reflectivity - ! Dimensions: (nlayers+1) - real(kind=r8), intent(inout) :: prefd(:) - ! diffuse beam reflectivity - ! Dimensions: (nlayers+1) - real(kind=r8), intent(inout) :: ptra(:) - ! direct beam transmissivity - ! Dimensions: (nlayers+1) - real(kind=r8), intent(inout) :: ptrad(:) - ! diffuse beam transmissivity - ! Dimensions: (nlayers+1) - - ! ------- Local ------- - - integer :: jk, jl, kmodts - integer :: itind - - real(kind=r8) :: tblind - real(kind=r8) :: za, za1, za2 - real(kind=r8) :: zbeta, zdend, zdenr, zdent - real(kind=r8) :: ze1, ze2, zem1, zem2, zemm, zep1, zep2 - real(kind=r8) :: zg, zg3, zgamma1, zgamma2, zgamma3, zgamma4, zgt - real(kind=r8) :: zr1, zr2, zr3, zr4, zr5 - real(kind=r8) :: zrk, zrk2, zrkg, zrm1, zrp, zrp1, zrpp - real(kind=r8) :: zsr3, zt1, zt2, zt3, zt4, zt5, zto1 - real(kind=r8) :: zw, zwcrit, zwo - - real(kind=r8), parameter :: eps = 1.e-08_r8 - - ! ------------------------------------------------------------------ - - ! Initialize - - hvrrft = '$Revision$' - - zsr3=sqrt(3._r8) - zwcrit=0.9999995_r8 - kmodts=2 - - do jk=1, nlayers - if (.not.lrtchk(jk)) then - pref(jk) =0._r8 - ptra(jk) =1._r8 - prefd(jk)=0._r8 - ptrad(jk)=1._r8 - else - zto1=ptau(jk) - zw =pw(jk) - zg =pgg(jk) - - ! General two-stream expressions - - zg3= 3._r8 * zg - if (kmodts == 1) then - zgamma1= (7._r8 - zw * (4._r8 + zg3)) * 0.25_r8 - zgamma2=-(1._r8 - zw * (4._r8 - zg3)) * 0.25_r8 - zgamma3= (2._r8 - zg3 * prmuz ) * 0.25_r8 - else if (kmodts == 2) then - zgamma1= (8._r8 - zw * (5._r8 + zg3)) * 0.25_r8 - zgamma2= 3._r8 *(zw * (1._r8 - zg )) * 0.25_r8 - zgamma3= (2._r8 - zg3 * prmuz ) * 0.25_r8 - else if (kmodts == 3) then - zgamma1= zsr3 * (2._r8 - zw * (1._r8 + zg)) * 0.5_r8 - zgamma2= zsr3 * zw * (1._r8 - zg ) * 0.5_r8 - zgamma3= (1._r8 - zsr3 * zg * prmuz ) * 0.5_r8 - end if - zgamma4= 1._r8 - zgamma3 - - ! Recompute original s.s.a. to test for conservative solution - - zwo= zw / (1._r8 - (1._r8 - zw) * (zg / (1._r8 - zg))**2) - - if (zwo >= zwcrit) then - ! Conservative scattering - - za = zgamma1 * prmuz - za1 = za - zgamma3 - zgt = zgamma1 * zto1 - - ! Homogeneous reflectance and transmittance, - ! collimated beam - - ze1 = min ( zto1 / prmuz , 500._r8) - ! ze2 = exp( -ze1 ) - - ! Use exponential lookup table for transmittance, or expansion of - ! exponential for low tau - if (ze1 .le. od_lo) then - ze2 = 1._r8 - ze1 + 0.5_r8 * ze1 * ze1 - else - tblind = ze1 / (bpade + ze1) - itind = tblint * tblind + 0.5_r8 - ze2 = exp_tbl(itind) - endif - ! - - pref(jk) = (zgt - za1 * (1._r8 - ze2)) / (1._r8 + zgt) - ptra(jk) = 1._r8 - pref(jk) - - ! isotropic incidence - - prefd(jk) = zgt / (1._r8 + zgt) - ptrad(jk) = 1._r8 - prefd(jk) - - ! This is applied for consistency between total (delta-scaled) and direct (unscaled) - ! calculations at very low optical depths (tau < 1.e-4) when the exponential lookup - ! table returns a transmittance of 1.0. - if (ze2 .eq. 1.0_r8) then - pref(jk) = 0.0_r8 - ptra(jk) = 1.0_r8 - prefd(jk) = 0.0_r8 - ptrad(jk) = 1.0_r8 - endif - - else - ! Non-conservative scattering - - za1 = zgamma1 * zgamma4 + zgamma2 * zgamma3 - za2 = zgamma1 * zgamma3 + zgamma2 * zgamma4 - zrk = sqrt ( zgamma1**2 - zgamma2**2) - zrp = zrk * prmuz - zrp1 = 1._r8 + zrp - zrm1 = 1._r8 - zrp - zrk2 = 2._r8 * zrk - zrpp = 1._r8 - zrp*zrp - zrkg = zrk + zgamma1 - zr1 = zrm1 * (za2 + zrk * zgamma3) - zr2 = zrp1 * (za2 - zrk * zgamma3) - zr3 = zrk2 * (zgamma3 - za2 * prmuz ) - zr4 = zrpp * zrkg - zr5 = zrpp * (zrk - zgamma1) - zt1 = zrp1 * (za1 + zrk * zgamma4) - zt2 = zrm1 * (za1 - zrk * zgamma4) - zt3 = zrk2 * (zgamma4 + za1 * prmuz ) - zt4 = zr4 - zt5 = zr5 - zbeta = (zgamma1 - zrk) / zrkg - !- zr5 / zr4 - - ! Homogeneous reflectance and transmittance - - ze1 = min ( zrk * zto1, 500._r8) - ze2 = min ( zto1 / prmuz , 500._r8) - ! - ! Original - ! zep1 = exp( ze1 ) - ! zem1 = exp(-ze1 ) - ! zep2 = exp( ze2 ) - ! zem2 = exp(-ze2 ) - ! - ! Revised original, to reduce exponentials - ! zep1 = exp( ze1 ) - ! zem1 = 1._r8 / zep1 - ! zep2 = exp( ze2 ) - ! zem2 = 1._r8 / zep2 - ! - ! Use exponential lookup table for transmittance, or expansion of - ! exponential for low tau - if (ze1 .le. od_lo) then - zem1 = 1._r8 - ze1 + 0.5_r8 * ze1 * ze1 - zep1 = 1._r8 / zem1 - else - tblind = ze1 / (bpade + ze1) - itind = tblint * tblind + 0.5_r8 - zem1 = exp_tbl(itind) - zep1 = 1._r8 / zem1 - endif - - if (ze2 .le. od_lo) then - zem2 = 1._r8 - ze2 + 0.5_r8 * ze2 * ze2 - zep2 = 1._r8 / zem2 - else - tblind = ze2 / (bpade + ze2) - itind = tblint * tblind + 0.5_r8 - zem2 = exp_tbl(itind) - zep2 = 1._r8 / zem2 - endif - - ! collimated beam - - zdenr = zr4*zep1 + zr5*zem1 - zdent = zt4*zep1 + zt5*zem1 - if (zdenr .ge. -eps .and. zdenr .le. eps) then - pref(jk) = eps - ptra(jk) = zem2 - else - pref(jk) = zw * (zr1*zep1 - zr2*zem1 - zr3*zem2) / zdenr - ptra(jk) = zem2 - zem2 * zw * (zt1*zep1 - zt2*zem1 - zt3*zep2) / zdent - endif - - ! diffuse beam - - zemm = zem1*zem1 - zdend = 1._r8 / ( (1._r8 - zbeta*zemm ) * zrkg) - prefd(jk) = zgamma2 * (1._r8 - zemm) * zdend - ptrad(jk) = zrk2*zem1*zdend - - endif - - endif - - enddo - - end subroutine reftra_sw - - END SUBROUTINE kernel_driver - - - FUNCTION kgen_get_newunit(seed) RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - INTEGER, INTENT(IN) :: seed - - new_unit = -1 - - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE diff --git a/test/ncar_kernels/PORT_rtrnmc/CESM_license.txt b/test/ncar_kernels/PORT_rtrnmc/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/PORT_rtrnmc/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/PORT_rtrnmc/data/rtrnmc.1.0 b/test/ncar_kernels/PORT_rtrnmc/data/rtrnmc.1.0 deleted file mode 100644 index 062e277415..0000000000 Binary files a/test/ncar_kernels/PORT_rtrnmc/data/rtrnmc.1.0 and /dev/null differ diff --git a/test/ncar_kernels/PORT_rtrnmc/data/rtrnmc.10.0 b/test/ncar_kernels/PORT_rtrnmc/data/rtrnmc.10.0 deleted file mode 100644 index f1ea94649f..0000000000 Binary files a/test/ncar_kernels/PORT_rtrnmc/data/rtrnmc.10.0 and /dev/null differ diff --git a/test/ncar_kernels/PORT_rtrnmc/data/rtrnmc.10.1 b/test/ncar_kernels/PORT_rtrnmc/data/rtrnmc.10.1 deleted file mode 100644 index c3d6aede17..0000000000 Binary files a/test/ncar_kernels/PORT_rtrnmc/data/rtrnmc.10.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_rtrnmc/inc/t1.mk b/test/ncar_kernels/PORT_rtrnmc/inc/t1.mk deleted file mode 100644 index 94205639fb..0000000000 --- a/test/ncar_kernels/PORT_rtrnmc/inc/t1.mk +++ /dev/null @@ -1,52 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# -# PGI default flags -# -# FC_FLAGS := -# -# Intel default flags -# -# FC_FLAGS := -# -FC_FLAGS := $(OPT) -FC_FLAGS += -Mnofma - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - -ALL_OBJS := kernel_rtrnmc.o - -verify: - @(grep "FAIL" $(TEST).rslt && echo "FAILED") || (grep "PASSED" $(TEST).rslt -q && echo PASSED) -# the test prints multiple "PASS" and "FAIL" messages. Only want "PASS" to be visible to lit if there are no failures - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt | grep -v "PASS" - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_rtrnmc.o: $(SRC_DIR)/kernel_rtrnmc.F90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.oo *.rslt - diff --git a/test/ncar_kernels/PORT_rtrnmc/lit/runmake b/test/ncar_kernels/PORT_rtrnmc/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/PORT_rtrnmc/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/PORT_rtrnmc/lit/t1.sh b/test/ncar_kernels/PORT_rtrnmc/lit/t1.sh deleted file mode 100644 index 33c953a156..0000000000 --- a/test/ncar_kernels/PORT_rtrnmc/lit/t1.sh +++ /dev/null @@ -1,9 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -# Shared lit script for each tests. Run bash commands that run tests with make. - -# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t -# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/PORT_rtrnmc/makefile b/test/ncar_kernels/PORT_rtrnmc/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/PORT_rtrnmc/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/PORT_rtrnmc/src/kernel_rtrnmc.F90 b/test/ncar_kernels/PORT_rtrnmc/src/kernel_rtrnmc.F90 deleted file mode 100644 index dfc046991f..0000000000 --- a/test/ncar_kernels/PORT_rtrnmc/src/kernel_rtrnmc.F90 +++ /dev/null @@ -1,664 +0,0 @@ - MODULE resolvers - - ! RESOLVER SPECS - INTEGER, PARAMETER :: r8 = selected_real_kind(12) - INTEGER, PARAMETER :: ngptlw = 140 - INTEGER, PARAMETER :: nbndlw = 16 - REAL(KIND = r8), PARAMETER :: tblint = 10000.0_r8 - INTEGER, PARAMETER :: ntbl = 10000 - - END MODULE - - PROGRAM kernel_rtrnmc - USE resolvers - - IMPLICIT NONE - - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(2), PARAMETER :: kgen_mpi_rank_at = (/ 0,1 /) - INTEGER :: kgen_ierr, kgen_unit, kgen_get_newunit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(1), PARAMETER :: kgen_counter_at = (/ 10 /) - CHARACTER(LEN=1024) :: kgen_filepath - INTEGER, DIMENSION(2,10) :: kgen_bound - - ! DRIVER SPECS - INTEGER :: nlay - - DO kgen_repeat_counter = 1, 2 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 1)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 2)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - - kgen_filepath = "../data/rtrnmc." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit(kgen_mpi_rank+kgen_counter) - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) "Kernel output is being verified against " // trim(adjustl(kgen_filepath)) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - ! READ DRIVER INSTATE - - READ(UNIT = kgen_unit) nlay - - ! KERNEL DRIVER RUN - CALL kernel_driver(nlay, kgen_unit) - CLOSE (UNIT=kgen_unit) - - WRITE (*,*) - END DO - END PROGRAM kernel_rtrnmc - - ! KERNEL DRIVER SUBROUTINE - SUBROUTINE kernel_driver(nlay, kgen_unit) - USE resolvers - - IMPLICIT NONE - INTEGER, INTENT(IN) :: kgen_unit - INTEGER, DIMENSION(2,10) :: kgen_bound - - ! STATE SPECS - CHARACTER*18 :: hvrrtc - INTEGER, INTENT(IN) :: nlay - REAL(KIND = r8) :: pwvcm - REAL(KIND = r8) :: bpade - INTEGER :: ncbands - REAL(KIND = r8), DIMENSION(0 : ntbl) :: exp_tbl - REAL(KIND = r8) :: totdflux(0 : nlay) - REAL(KIND = r8) :: fnetc(0 : nlay) - REAL(KIND = r8) :: htr(0 : nlay) - REAL(KIND = r8) :: plankbnd(nbndlw) - INTEGER :: istart - INTEGER :: ngb(ngptlw) - REAL(KIND = r8) :: pz(0 : nlay) - REAL(KIND = r8) :: totdclfl(0 : nlay) - REAL(KIND = r8) :: fracs(nlay, ngptlw) - INTEGER :: ngs(nbndlw) - REAL(KIND = r8) :: totdfluxs(nbndlw, 0 : nlay) - REAL(KIND = r8) :: fluxfac - REAL(KIND = r8) :: heatfac - REAL(KIND = r8) :: taut(nlay, ngptlw) - REAL(KIND = r8) :: semiss(nbndlw) - REAL(KIND = r8) :: totufluxs(nbndlw, 0 : nlay) - REAL(KIND = r8) :: taucmc(ngptlw, nlay) - REAL(KIND = r8) :: planklay(nlay, nbndlw) - REAL(KIND = r8) :: totuclfl(0 : nlay) - REAL(KIND = r8) :: htrc(0 : nlay) - REAL(KIND = r8), DIMENSION(0 : ntbl) :: tfn_tbl - REAL(KIND = r8) :: fnet(0 : nlay) - REAL(KIND = r8) :: planklev(0 : nlay, nbndlw) - INTEGER :: iout - REAL(KIND = r8) :: cldfmc(ngptlw, nlay) - REAL(KIND = r8) :: totuflux(0 : nlay) - REAL(KIND = r8), DIMENSION(0 : ntbl) :: tau_tbl - REAL(KIND = r8) :: delwave(nbndlw) - INTEGER :: iend - INTEGER :: outstate_ncbands - REAL(KIND = r8) :: outstate_totdflux(0 : nlay) - REAL(KIND = r8) :: outstate_fnetc(0 : nlay) - REAL(KIND = r8) :: outstate_htr(0 : nlay) - REAL(KIND = r8) :: outstate_totdclfl(0 : nlay) - REAL(KIND = r8) :: outstate_totdfluxs(nbndlw, 0 : nlay) - REAL(KIND = r8) :: outstate_totufluxs(nbndlw, 0 : nlay) - REAL(KIND = r8) :: outstate_totuclfl(0 : nlay) - REAL(KIND = r8) :: outstate_htrc(0 : nlay) - REAL(KIND = r8) :: outstate_fnet(0 : nlay) - REAL(KIND = r8) :: outstate_totuflux(0 : nlay) - - LOGICAL :: lstatus = .TRUE. - ! READ CALLER INSTATE - - READ(UNIT = kgen_unit) pwvcm - READ(UNIT = kgen_unit) ncbands - READ(UNIT = kgen_unit) plankbnd - READ(UNIT = kgen_unit) istart - READ(UNIT = kgen_unit) pz - READ(UNIT = kgen_unit) fracs - READ(UNIT = kgen_unit) taut - READ(UNIT = kgen_unit) semiss - READ(UNIT = kgen_unit) taucmc - READ(UNIT = kgen_unit) planklay - READ(UNIT = kgen_unit) planklev - READ(UNIT = kgen_unit) iout - READ(UNIT = kgen_unit) cldfmc - READ(UNIT = kgen_unit) iend - ! READ CALLEE INSTATE - - READ(UNIT = kgen_unit) hvrrtc - READ(UNIT = kgen_unit) bpade - READ(UNIT = kgen_unit) exp_tbl - READ(UNIT = kgen_unit) ngb - READ(UNIT = kgen_unit) ngs - READ(UNIT = kgen_unit) fluxfac - READ(UNIT = kgen_unit) heatfac - READ(UNIT = kgen_unit) tfn_tbl - READ(UNIT = kgen_unit) tau_tbl - READ(UNIT = kgen_unit) delwave - ! READ CALLEE OUTSTATE - - ! READ CALLER OUTSTATE - - READ(UNIT = kgen_unit) outstate_ncbands - READ(UNIT = kgen_unit) outstate_totdflux - READ(UNIT = kgen_unit) outstate_fnetc - READ(UNIT = kgen_unit) outstate_htr - READ(UNIT = kgen_unit) outstate_totdclfl - READ(UNIT = kgen_unit) outstate_totdfluxs - READ(UNIT = kgen_unit) outstate_totufluxs - READ(UNIT = kgen_unit) outstate_totuclfl - READ(UNIT = kgen_unit) outstate_htrc - READ(UNIT = kgen_unit) outstate_fnet - READ(UNIT = kgen_unit) outstate_totuflux - - ! KERNEL RUN - CALL rtrnmc(nlay, istart, iend, iout, pz, semiss, ncbands, cldfmc, & - taucmc, planklay, planklev, plankbnd, pwvcm, fracs, taut, & - totuflux, totdflux, fnet, htr, totuclfl, totdclfl, fnetc, & - htrc, totufluxs, totdfluxs) - - ! STATE VERIFICATION - IF ( outstate_ncbands == ncbands ) THEN - WRITE(*,*) "ncbands is IDENTICAL( ", outstate_ncbands, " )." - ELSE - lstatus = .FALSE. - WRITE(*,*) "ncbands is NOT IDENTICAL." - WRITE(*,*) "STATE : ", outstate_ncbands - WRITE(*,*) "KERNEL: ", ncbands - END IF - IF ( ALL( outstate_totdflux == totdflux ) ) THEN - WRITE(*,*) "All elements of totdflux are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_totdflux - !WRITE(*,*) "KERNEL: ", totdflux - IF ( ALL( outstate_totdflux == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - lstatus = .FALSE. - WRITE(*,*) "totdflux is NOT IDENTICAL." - WRITE(*,*) count( outstate_totdflux /= totdflux), " of ", size( totdflux ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_totdflux - totdflux)**2)/real(size(outstate_totdflux))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_totdflux - totdflux)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_totdflux - totdflux)) - WRITE(*,*) "Mean value of kernel-generated outstate_totdflux is ", sum(totdflux)/real(size(totdflux)) - WRITE(*,*) "Mean value of original outstate_totdflux is ", sum(outstate_totdflux)/real(size(outstate_totdflux)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_fnetc == fnetc ) ) THEN - WRITE(*,*) "All elements of fnetc are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_fnetc - !WRITE(*,*) "KERNEL: ", fnetc - IF ( ALL( outstate_fnetc == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - lstatus = .FALSE. - WRITE(*,*) "fnetc is NOT IDENTICAL." - WRITE(*,*) count( outstate_fnetc /= fnetc), " of ", size( fnetc ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_fnetc - fnetc)**2)/real(size(outstate_fnetc))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_fnetc - fnetc)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_fnetc - fnetc)) - WRITE(*,*) "Mean value of kernel-generated outstate_fnetc is ", sum(fnetc)/real(size(fnetc)) - WRITE(*,*) "Mean value of original outstate_fnetc is ", sum(outstate_fnetc)/real(size(outstate_fnetc)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_htr == htr ) ) THEN - WRITE(*,*) "All elements of htr are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_htr - !WRITE(*,*) "KERNEL: ", htr - IF ( ALL( outstate_htr == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - lstatus = .FALSE. - WRITE(*,*) "htr is NOT IDENTICAL." - WRITE(*,*) count( outstate_htr /= htr), " of ", size( htr ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_htr - htr)**2)/real(size(outstate_htr))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_htr - htr)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_htr - htr)) - WRITE(*,*) "Mean value of kernel-generated outstate_htr is ", sum(htr)/real(size(htr)) - WRITE(*,*) "Mean value of original outstate_htr is ", sum(outstate_htr)/real(size(outstate_htr)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_totdclfl == totdclfl ) ) THEN - WRITE(*,*) "All elements of totdclfl are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_totdclfl - !WRITE(*,*) "KERNEL: ", totdclfl - IF ( ALL( outstate_totdclfl == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - lstatus = .FALSE. - WRITE(*,*) "totdclfl is NOT IDENTICAL." - WRITE(*,*) count( outstate_totdclfl /= totdclfl), " of ", size( totdclfl ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_totdclfl - totdclfl)**2)/real(size(outstate_totdclfl))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_totdclfl - totdclfl)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_totdclfl - totdclfl)) - WRITE(*,*) "Mean value of kernel-generated outstate_totdclfl is ", sum(totdclfl)/real(size(totdclfl)) - WRITE(*,*) "Mean value of original outstate_totdclfl is ", sum(outstate_totdclfl)/real(size(outstate_totdclfl)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_totdfluxs == totdfluxs ) ) THEN - WRITE(*,*) "All elements of totdfluxs are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_totdfluxs - !WRITE(*,*) "KERNEL: ", totdfluxs - IF ( ALL( outstate_totdfluxs == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - lstatus = .FALSE. - WRITE(*,*) "totdfluxs is NOT IDENTICAL." - WRITE(*,*) count( outstate_totdfluxs /= totdfluxs), " of ", size( totdfluxs ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_totdfluxs - totdfluxs)**2)/real(size(outstate_totdfluxs))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_totdfluxs - totdfluxs)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_totdfluxs - totdfluxs)) - WRITE(*,*) "Mean value of kernel-generated outstate_totdfluxs is ", sum(totdfluxs)/real(size(totdfluxs)) - WRITE(*,*) "Mean value of original outstate_totdfluxs is ", sum(outstate_totdfluxs)/real(size(outstate_totdfluxs)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_totufluxs == totufluxs ) ) THEN - WRITE(*,*) "All elements of totufluxs are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_totufluxs - !WRITE(*,*) "KERNEL: ", totufluxs - IF ( ALL( outstate_totufluxs == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - lstatus = .FALSE. - WRITE(*,*) "totufluxs is NOT IDENTICAL." - WRITE(*,*) count( outstate_totufluxs /= totufluxs), " of ", size( totufluxs ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_totufluxs - totufluxs)**2)/real(size(outstate_totufluxs))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_totufluxs - totufluxs)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_totufluxs - totufluxs)) - WRITE(*,*) "Mean value of kernel-generated outstate_totufluxs is ", sum(totufluxs)/real(size(totufluxs)) - WRITE(*,*) "Mean value of original outstate_totufluxs is ", sum(outstate_totufluxs)/real(size(outstate_totufluxs)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_totuclfl == totuclfl ) ) THEN - WRITE(*,*) "All elements of totuclfl are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_totuclfl - !WRITE(*,*) "KERNEL: ", totuclfl - IF ( ALL( outstate_totuclfl == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - lstatus = .FALSE. - WRITE(*,*) "totuclfl is NOT IDENTICAL." - WRITE(*,*) count( outstate_totuclfl /= totuclfl), " of ", size( totuclfl ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_totuclfl - totuclfl)**2)/real(size(outstate_totuclfl))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_totuclfl - totuclfl)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_totuclfl - totuclfl)) - WRITE(*,*) "Mean value of kernel-generated outstate_totuclfl is ", sum(totuclfl)/real(size(totuclfl)) - WRITE(*,*) "Mean value of original outstate_totuclfl is ", sum(outstate_totuclfl)/real(size(outstate_totuclfl)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_htrc == htrc ) ) THEN - WRITE(*,*) "All elements of htrc are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_htrc - !WRITE(*,*) "KERNEL: ", htrc - IF ( ALL( outstate_htrc == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - lstatus = .FALSE. - WRITE(*,*) "htrc is NOT IDENTICAL." - WRITE(*,*) count( outstate_htrc /= htrc), " of ", size( htrc ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_htrc - htrc)**2)/real(size(outstate_htrc))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_htrc - htrc)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_htrc - htrc)) - WRITE(*,*) "Mean value of kernel-generated outstate_htrc is ", sum(htrc)/real(size(htrc)) - WRITE(*,*) "Mean value of original outstate_htrc is ", sum(outstate_htrc)/real(size(outstate_htrc)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_fnet == fnet ) ) THEN - WRITE(*,*) "All elements of fnet are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_fnet - !WRITE(*,*) "KERNEL: ", fnet - IF ( ALL( outstate_fnet == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - lstatus = .FALSE. - WRITE(*,*) "fnet is NOT IDENTICAL." - WRITE(*,*) count( outstate_fnet /= fnet), " of ", size( fnet ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_fnet - fnet)**2)/real(size(outstate_fnet))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_fnet - fnet)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_fnet - fnet)) - WRITE(*,*) "Mean value of kernel-generated outstate_fnet is ", sum(fnet)/real(size(fnet)) - WRITE(*,*) "Mean value of original outstate_fnet is ", sum(outstate_fnet)/real(size(outstate_fnet)) - WRITE(*,*) "" - END IF - IF ( ALL( outstate_totuflux == totuflux ) ) THEN - WRITE(*,*) "All elements of totuflux are IDENTICAL." - !WRITE(*,*) "STATE : ", outstate_totuflux - !WRITE(*,*) "KERNEL: ", totuflux - IF ( ALL( outstate_totuflux == 0 ) ) THEN - WRITE(*,*) "All values are zero." - END IF - ELSE - lstatus = .FALSE. - WRITE(*,*) "totuflux is NOT IDENTICAL." - WRITE(*,*) count( outstate_totuflux /= totuflux), " of ", size( totuflux ), " elements are different." - WRITE(*,*) "RMS of difference is ", sqrt(sum((outstate_totuflux - totuflux)**2)/real(size(outstate_totuflux))) - WRITE(*,*) "Minimum difference is ", minval(abs(outstate_totuflux - totuflux)) - WRITE(*,*) "Maximum difference is ", maxval(abs(outstate_totuflux - totuflux)) - WRITE(*,*) "Mean value of kernel-generated outstate_totuflux is ", sum(totuflux)/real(size(totuflux)) - WRITE(*,*) "Mean value of original outstate_totuflux is ", sum(outstate_totuflux)/real(size(outstate_totuflux)) - WRITE(*,*) "" - END IF - - IF ( lstatus ) THEN - WRITE(*,*) "PASSED" - ELSE - WRITE(*,*) "FAILED" - END IF - - ! DEALLOCATE INSTATE - - ! DEALLOCATE OUTSTATE - ! DEALLOCATE CALLEE INSTATE - - ! DEALLOCATE INSTATE - ! DEALLOCATE CALEE OUTSTATE - - ! DEALLOCATE OUTSTATE - - CONTAINS - - - ! KERNEL SUBPROGRAM - subroutine rtrnmc(nlayers, istart, iend, iout, pz, semiss, ncbands,& - cldfmc, taucmc, planklay, planklev, plankbnd,& - pwvcm, fracs, taut,& - totuflux, totdflux, fnet, htr,& - totuclfl, totdclfl, fnetc, htrc, totufluxs, totdfluxs ) - integer, intent(in) :: nlayers - integer, intent(in) :: istart - integer, intent(in) :: iend - integer, intent(in) :: iout - real(kind=r8), intent(in) :: pz(0:) - real(kind=r8), intent(in) :: pwvcm - real(kind=r8), intent(in) :: semiss(:) - real(kind=r8), intent(in) :: planklay(:,:) - real(kind=r8), intent(in) :: planklev(0:,:) - real(kind=r8), intent(in) :: plankbnd(:) - real(kind=r8), intent(in) :: fracs(:,:) - real(kind=r8), intent(in) :: taut(:,:) - integer, intent(in) :: ncbands - real(kind=r8), intent(in) :: cldfmc(:,:) - real(kind=r8), intent(in) :: taucmc(:,:) - real(kind=r8), intent(out) :: totuflux(0:) - real(kind=r8), intent(out) :: totdflux(0:) - real(kind=r8), intent(out) :: fnet(0:) - real(kind=r8), intent(out) :: htr(0:) - real(kind=r8), intent(out) :: totuclfl(0:) - real(kind=r8), intent(out) :: totdclfl(0:) - real(kind=r8), intent(out) :: fnetc(0:) - real(kind=r8), intent(out) :: htrc(0:) - real(kind=r8), intent(out) :: totufluxs(:,0:) - real(kind=r8), intent(out) :: totdfluxs(:,0:) - real(kind=r8) :: abscld(nlayers,ngptlw) - real(kind=r8) :: atot(nlayers) - real(kind=r8) :: atrans(nlayers) - real(kind=r8) :: bbugas(nlayers) - real(kind=r8) :: bbutot(nlayers) - real(kind=r8) :: clrurad(0:nlayers) - real(kind=r8) :: clrdrad(0:nlayers) - real(kind=r8) :: efclfrac(nlayers,ngptlw) - real(kind=r8) :: uflux(0:nlayers) - real(kind=r8) :: dflux(0:nlayers) - real(kind=r8) :: urad(0:nlayers) - real(kind=r8) :: drad(0:nlayers) - real(kind=r8) :: uclfl(0:nlayers) - real(kind=r8) :: dclfl(0:nlayers) - real(kind=r8) :: odcld(nlayers,ngptlw) - real(kind=r8) :: secdiff(nbndlw) - real(kind=r8) :: a0(nbndlw),a1(nbndlw),a2(nbndlw) - real(kind=r8) :: wtdiff, rec_6 - real(kind=r8) :: transcld, radld, radclrd, plfrac, blay, dplankup, dplankdn - real(kind=r8) :: odepth, odtot, odepth_rec, odtot_rec, gassrc - real(kind=r8) :: tblind, tfactot, bbd, bbdtot, tfacgas, transc, tausfac - real(kind=r8) :: rad0, reflect, radlu, radclru - integer :: icldlyr(nlayers) - integer :: ibnd, ib, iband, lay, lev, l, ig - integer :: igc - integer :: iclddn - integer :: ittot, itgas, itr - data wtdiff /0.5_r8/ - data rec_6 /0.166667_r8/ - data a0 / 1.66_r8, 1.55_r8, 1.58_r8, 1.66_r8, 1.54_r8, 1.454_r8, 1.89_r8, 1.33_r8, 1.668_r8, 1.66_r8, 1.66_r8, 1.66_r8, 1.66_r8, 1.66_r8, 1.66_r8, 1.66_r8 / - data a1 / 0.00_r8, 0.25_r8, 0.22_r8, 0.00_r8, 0.13_r8, 0.446_r8, -0.10_r8, 0.40_r8, -0.006_r8, 0.00_r8, 0.00_r8, 0.00_r8, 0.00_r8, 0.00_r8, 0.00_r8, 0.00_r8 / - data a2 / 0.00_r8, -12.0_r8, -11.7_r8, 0.00_r8, -0.72_r8,-0.243_r8, 0.19_r8,-0.062_r8, 0.414_r8, 0.00_r8, 0.00_r8, 0.00_r8, 0.00_r8, 0.00_r8, 0.00_r8, 0.00_r8 / - hvrrtc = '$Revision$' - do ibnd = 1,nbndlw - if (ibnd.eq.1 .or. ibnd.eq.4 .or. ibnd.ge.10) then - secdiff(ibnd) = 1.66_r8 - else - secdiff(ibnd) = a0(ibnd) + a1(ibnd)*exp(a2(ibnd)*pwvcm) - endif - enddo - if (pwvcm.lt.1.0) secdiff(6) = 1.80_r8 - if (pwvcm.gt.7.1) secdiff(7) = 1.50_r8 - urad(0) = 0.0_r8 - drad(0) = 0.0_r8 - totuflux(0) = 0.0_r8 - totdflux(0) = 0.0_r8 - clrurad(0) = 0.0_r8 - clrdrad(0) = 0.0_r8 - totuclfl(0) = 0.0_r8 - totdclfl(0) = 0.0_r8 - do lay = 1, nlayers - urad(lay) = 0.0_r8 - drad(lay) = 0.0_r8 - totuflux(lay) = 0.0_r8 - totdflux(lay) = 0.0_r8 - clrurad(lay) = 0.0_r8 - clrdrad(lay) = 0.0_r8 - totuclfl(lay) = 0.0_r8 - totdclfl(lay) = 0.0_r8 - icldlyr(lay) = 0 - do ig = 1, ngptlw - if (cldfmc(ig,lay) .eq. 1._r8) then - ib = ngb(ig) - odcld(lay,ig) = secdiff(ib) * taucmc(ig,lay) - transcld = exp(-odcld(lay,ig)) - abscld(lay,ig) = 1._r8 - transcld - efclfrac(lay,ig) = abscld(lay,ig) * cldfmc(ig,lay) - icldlyr(lay) = 1 - else - odcld(lay,ig) = 0.0_r8 - abscld(lay,ig) = 0.0_r8 - efclfrac(lay,ig) = 0.0_r8 - endif - enddo - enddo - igc = 1 - do iband = istart, iend - if (iout.gt.0.and.iband.ge.2) igc = ngs(iband-1)+1 - 1000 continue - radld = 0._r8 - radclrd = 0._r8 - iclddn = 0 - do lev = nlayers, 1, -1 - plfrac = fracs(lev,igc) - blay = planklay(lev,iband) - dplankup = planklev(lev,iband) - blay - dplankdn = planklev(lev-1,iband) - blay - odepth = secdiff(iband) * taut(lev,igc) - if (odepth .lt. 0.0_r8) odepth = 0.0_r8 - if (icldlyr(lev).eq.1) then - iclddn = 1 - odtot = odepth + odcld(lev,igc) - if (odtot .lt. 0.06_r8) then - atrans(lev) = odepth - 0.5_r8*odepth*odepth - odepth_rec = rec_6*odepth - gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev) - atot(lev) = odtot - 0.5_r8*odtot*odtot - odtot_rec = rec_6*odtot - bbdtot = plfrac * (blay+dplankdn*odtot_rec) - bbd = plfrac*(blay+dplankdn*odepth_rec) - radld = radld - radld * (atrans(lev) + efclfrac(lev,igc) * (1. - atrans(lev))) + gassrc + cldfmc(igc,lev) * (bbdtot * atot(lev) - gassrc) - drad(lev-1) = drad(lev-1) + radld - bbugas(lev) = plfrac * (blay+dplankup*odepth_rec) - bbutot(lev) = plfrac * (blay+dplankup*odtot_rec) - elseif (odepth .le. 0.06_r8) then - atrans(lev) = odepth - 0.5_r8*odepth*odepth - odepth_rec = rec_6*odepth - gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev) - odtot = odepth + odcld(lev,igc) - tblind = odtot/(bpade+odtot) - ittot = tblint*tblind + 0.5_r8 - tfactot = tfn_tbl(ittot) - bbdtot = plfrac * (blay + tfactot*dplankdn) - bbd = plfrac*(blay+dplankdn*odepth_rec) - atot(lev) = 1. - exp_tbl(ittot) - radld = radld - radld * (atrans(lev) + efclfrac(lev,igc) * (1._r8 - atrans(lev))) + gassrc + cldfmc(igc,lev) * (bbdtot * atot(lev) - gassrc) - drad(lev-1) = drad(lev-1) + radld - bbugas(lev) = plfrac * (blay + dplankup*odepth_rec) - bbutot(lev) = plfrac * (blay + tfactot * dplankup) - else - tblind = odepth/(bpade+odepth) - itgas = tblint*tblind+0.5_r8 - odepth = tau_tbl(itgas) - atrans(lev) = 1._r8 - exp_tbl(itgas) - tfacgas = tfn_tbl(itgas) - gassrc = atrans(lev) * plfrac * (blay + tfacgas*dplankdn) - odtot = odepth + odcld(lev,igc) - tblind = odtot/(bpade+odtot) - ittot = tblint*tblind + 0.5_r8 - tfactot = tfn_tbl(ittot) - bbdtot = plfrac * (blay + tfactot*dplankdn) - bbd = plfrac*(blay+tfacgas*dplankdn) - atot(lev) = 1._r8 - exp_tbl(ittot) - radld = radld - radld * (atrans(lev) + efclfrac(lev,igc) * (1._r8 - atrans(lev))) + gassrc + cldfmc(igc,lev) * (bbdtot * atot(lev) - gassrc) - drad(lev-1) = drad(lev-1) + radld - bbugas(lev) = plfrac * (blay + tfacgas * dplankup) - bbutot(lev) = plfrac * (blay + tfactot * dplankup) - endif - else - if (odepth .le. 0.06_r8) then - atrans(lev) = odepth-0.5_r8*odepth*odepth - odepth = rec_6*odepth - bbd = plfrac*(blay+dplankdn*odepth) - bbugas(lev) = plfrac*(blay+dplankup*odepth) - else - tblind = odepth/(bpade+odepth) - itr = tblint*tblind+0.5_r8 - transc = exp_tbl(itr) - atrans(lev) = 1._r8-transc - tausfac = tfn_tbl(itr) - bbd = plfrac*(blay+tausfac*dplankdn) - bbugas(lev) = plfrac * (blay + tausfac * dplankup) - endif - radld = radld + (bbd-radld)*atrans(lev) - drad(lev-1) = drad(lev-1) + radld - endif - if (iclddn.eq.1) then - radclrd = radclrd + (bbd-radclrd) * atrans(lev) - clrdrad(lev-1) = clrdrad(lev-1) + radclrd - else - radclrd = radld - clrdrad(lev-1) = drad(lev-1) - endif - enddo - rad0 = fracs(1,igc) * plankbnd(iband) - reflect = 1._r8 - semiss(iband) - radlu = rad0 + reflect * radld - radclru = rad0 + reflect * radclrd - urad(0) = urad(0) + radlu - clrurad(0) = clrurad(0) + radclru - do lev = 1, nlayers - if (icldlyr(lev) .eq. 1) then - gassrc = bbugas(lev) * atrans(lev) - radlu = radlu - radlu * (atrans(lev) + efclfrac(lev,igc) * (1._r8 - atrans(lev))) + gassrc + cldfmc(igc,lev) * (bbutot(lev) * atot(lev) - gassrc) - urad(lev) = urad(lev) + radlu - else - radlu = radlu + (bbugas(lev)-radlu)*atrans(lev) - urad(lev) = urad(lev) + radlu - endif - if (iclddn.eq.1) then - radclru = radclru + (bbugas(lev)-radclru)*atrans(lev) - clrurad(lev) = clrurad(lev) + radclru - else - radclru = radlu - clrurad(lev) = urad(lev) - endif - enddo - igc = igc + 1 - if (igc .le. ngs(iband)) go to 1000 - do lev = nlayers, 0, -1 - uflux(lev) = urad(lev)*wtdiff - dflux(lev) = drad(lev)*wtdiff - urad(lev) = 0.0_r8 - drad(lev) = 0.0_r8 - totuflux(lev) = totuflux(lev) + uflux(lev) * delwave(iband) - totdflux(lev) = totdflux(lev) + dflux(lev) * delwave(iband) - uclfl(lev) = clrurad(lev)*wtdiff - dclfl(lev) = clrdrad(lev)*wtdiff - clrurad(lev) = 0.0_r8 - clrdrad(lev) = 0.0_r8 - totuclfl(lev) = totuclfl(lev) + uclfl(lev) * delwave(iband) - totdclfl(lev) = totdclfl(lev) + dclfl(lev) * delwave(iband) - totufluxs(iband,lev) = uflux(lev) * delwave(iband) - totdfluxs(iband,lev) = dflux(lev) * delwave(iband) - enddo - enddo - totuflux(0) = totuflux(0) * fluxfac - totdflux(0) = totdflux(0) * fluxfac - totufluxs(:,0) = totufluxs(:,0) * fluxfac - totdfluxs(:,0) = totdfluxs(:,0) * fluxfac - fnet(0) = totuflux(0) - totdflux(0) - totuclfl(0) = totuclfl(0) * fluxfac - totdclfl(0) = totdclfl(0) * fluxfac - fnetc(0) = totuclfl(0) - totdclfl(0) - do lev = 1, nlayers - totuflux(lev) = totuflux(lev) * fluxfac - totdflux(lev) = totdflux(lev) * fluxfac - totufluxs(:,lev) = totufluxs(:,lev) * fluxfac - totdfluxs(:,lev) = totdfluxs(:,lev) * fluxfac - fnet(lev) = totuflux(lev) - totdflux(lev) - totuclfl(lev) = totuclfl(lev) * fluxfac - totdclfl(lev) = totdclfl(lev) * fluxfac - fnetc(lev) = totuclfl(lev) - totdclfl(lev) - l = lev - 1 - htr(l)=heatfac*(fnet(l)-fnet(lev))/(pz(l)-pz(lev)) - htrc(l)=heatfac*(fnetc(l)-fnetc(lev))/(pz(l)-pz(lev)) - enddo - htr(nlayers) = 0.0_r8 - htrc(nlayers) = 0.0_r8 - end subroutine rtrnmc - - END SUBROUTINE kernel_driver - - - ! RESOLVER SUBPROGRAMS - - FUNCTION kgen_get_newunit(seed) RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - INTEGER, INTENT(IN) :: seed - - new_unit = -1 - - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE diff --git a/test/ncar_kernels/PORT_sw_cldprmc/CESM_license.txt b/test/ncar_kernels/PORT_sw_cldprmc/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/PORT_sw_cldprmc/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.1.1 b/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.1.1 deleted file mode 100644 index afb2dad6ab..0000000000 Binary files a/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.1.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.1.4 b/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.1.4 deleted file mode 100644 index 0887be4617..0000000000 Binary files a/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.1.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.1.8 b/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.1.8 deleted file mode 100644 index 98941121e7..0000000000 Binary files a/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.1.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.10.1 b/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.10.1 deleted file mode 100644 index 5666c07437..0000000000 Binary files a/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.10.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.10.4 b/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.10.4 deleted file mode 100644 index 4b4db2a612..0000000000 Binary files a/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.10.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.10.8 b/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.10.8 deleted file mode 100644 index 90e2c525fd..0000000000 Binary files a/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.10.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.5.1 b/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.5.1 deleted file mode 100644 index 6060e8add6..0000000000 Binary files a/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.5.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.5.4 b/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.5.4 deleted file mode 100644 index ada9221d86..0000000000 Binary files a/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.5.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.5.8 b/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.5.8 deleted file mode 100644 index 56dc6d81ae..0000000000 Binary files a/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.5.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_cldprmc/inc/t1.mk b/test/ncar_kernels/PORT_sw_cldprmc/inc/t1.mk deleted file mode 100644 index b5f4db1c1a..0000000000 --- a/test/ncar_kernels/PORT_sw_cldprmc/inc/t1.mk +++ /dev/null @@ -1,76 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# Intel default flags -# -# FC_FLAGS := -# -O2 -fp-model source -convert big_endian -assume byterecl -ftz -# -traceback -assume realloc_lhs -xAVX -# -FC_FLAGS := $(OPT) -FC_FLAGS += -Mnofma - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - -ALL_OBJS := kernel_driver.o rrtmg_sw_rad.o kgen_utils.o shr_kind_mod.o rrtmg_sw_cldprmc.o rrsw_wvn.o rrsw_cld.o parrrsw.o rrsw_vsn.o - -verify: - @(grep "verification.FAIL" $(TEST).rslt && echo "FAILED") || (grep "verification.PASS" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 rrtmg_sw_rad.o kgen_utils.o shr_kind_mod.o rrtmg_sw_cldprmc.o rrsw_wvn.o rrsw_cld.o parrrsw.o rrsw_vsn.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_sw_rad.o: $(SRC_DIR)/rrtmg_sw_rad.f90 kgen_utils.o rrtmg_sw_cldprmc.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_kind_mod.o: $(SRC_DIR)/shr_kind_mod.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_sw_cldprmc.o: $(SRC_DIR)/rrtmg_sw_cldprmc.f90 kgen_utils.o shr_kind_mod.o parrrsw.o rrsw_vsn.o rrsw_wvn.o rrsw_cld.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_wvn.o: $(SRC_DIR)/rrsw_wvn.f90 kgen_utils.o parrrsw.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_cld.o: $(SRC_DIR)/rrsw_cld.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -parrrsw.o: $(SRC_DIR)/parrrsw.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_vsn.o: $(SRC_DIR)/rrsw_vsn.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -kgen_utils.o: $(SRC_DIR)/kgen_utils.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.rslt diff --git a/test/ncar_kernels/PORT_sw_cldprmc/lit/runmake b/test/ncar_kernels/PORT_sw_cldprmc/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/PORT_sw_cldprmc/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/PORT_sw_cldprmc/lit/t1.sh b/test/ncar_kernels/PORT_sw_cldprmc/lit/t1.sh deleted file mode 100644 index 33c953a156..0000000000 --- a/test/ncar_kernels/PORT_sw_cldprmc/lit/t1.sh +++ /dev/null @@ -1,9 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -# Shared lit script for each tests. Run bash commands that run tests with make. - -# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t -# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/PORT_sw_cldprmc/makefile b/test/ncar_kernels/PORT_sw_cldprmc/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/PORT_sw_cldprmc/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/PORT_sw_cldprmc/src/kernel_driver.f90 b/test/ncar_kernels/PORT_sw_cldprmc/src/kernel_driver.f90 deleted file mode 100644 index 121a94ff4e..0000000000 --- a/test/ncar_kernels/PORT_sw_cldprmc/src/kernel_driver.f90 +++ /dev/null @@ -1,85 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-07-27 00:38:35 -! KGEN version: 0.4.13 - - -PROGRAM kernel_driver - USE rrtmg_sw_rad, ONLY : rrtmg_sw - USE rrsw_vsn, ONLY : kgen_read_externs_rrsw_vsn - USE rrsw_cld, ONLY : kgen_read_externs_rrsw_cld - USE rrsw_wvn, ONLY : kgen_read_externs_rrsw_wvn - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - - IMPLICIT NONE - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_mpi_rank_at = (/ 1, 4, 8 /) - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_counter_at = (/ 1, 10, 5 /) - CHARACTER(LEN=1024) :: kgen_filepath - INTEGER :: ncol - INTEGER :: nlay - - DO kgen_repeat_counter = 0, 8 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - kgen_filepath = "../data/cldprmc_sw." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "** Verification against '" // trim(adjustl(kgen_filepath)) // "' **" - - CALL kgen_read_externs_rrsw_vsn(kgen_unit) - CALL kgen_read_externs_rrsw_cld(kgen_unit) - CALL kgen_read_externs_rrsw_wvn(kgen_unit) - - ! driver variables - READ(UNIT=kgen_unit) ncol - READ(UNIT=kgen_unit) nlay - - call rrtmg_sw(ncol, nlay, kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! write subroutines - ! No subroutines - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/PORT_sw_cldprmc/src/kgen_utils.f90 b/test/ncar_kernels/PORT_sw_cldprmc/src/kgen_utils.f90 deleted file mode 100644 index cfa8d114e0..0000000000 --- a/test/ncar_kernels/PORT_sw_cldprmc/src/kgen_utils.f90 +++ /dev/null @@ -1,61 +0,0 @@ -module kgen_utils_mod - -INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - -type check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - real(kind=kgen_dp) :: minvalue -end type check_t - -public kgen_dp, check_t, kgen_init_check, kgen_print_check - -contains - -subroutine kgen_init_check(check, tolerance, minvalue) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - real(kind=kgen_dp), intent(in), optional :: minvalue - - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.0D-15 - endif - if(present(minvalue)) then - check%minvalue = minvalue - else - check%minvalue = 1.0D-15 - endif -end subroutine kgen_init_check - -subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif -end subroutine kgen_print_check - -end module diff --git a/test/ncar_kernels/PORT_sw_cldprmc/src/parrrsw.f90 b/test/ncar_kernels/PORT_sw_cldprmc/src/parrrsw.f90 deleted file mode 100644 index d5692fcd8b..0000000000 --- a/test/ncar_kernels/PORT_sw_cldprmc/src/parrrsw.f90 +++ /dev/null @@ -1,81 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : parrrsw.f90 -! Generated at: 2015-07-27 00:38:36 -! KGEN version: 0.4.13 - - - - MODULE parrrsw - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw main parameters - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! mxlay : integer: maximum number of layers - ! mg : integer: number of original g-intervals per spectral band - ! nbndsw : integer: number of spectral bands - ! naerec : integer: number of aerosols (iaer=6, ecmwf aerosol option) - ! ngptsw : integer: total number of reduced g-intervals for rrtmg_lw - ! ngNN : integer: number of reduced g-intervals per spectral band - ! ngsNN : integer: cumulative number of g-intervals per band - !------------------------------------------------------------------ - ! Settings for single column mode. - ! For GCM use, set nlon to number of longitudes, and - ! mxlay to number of model layers - !jplay, klev - !jpg - !jpsw, ksw - !jpaer - ! Use for 112 g-point model - INTEGER, parameter :: ngptsw = 112 !jpgpt - ! Use for 224 g-point model - ! integer, parameter :: ngptsw = 224 !jpgpt - ! may need to rename these - from v2.6 - INTEGER, parameter :: jpb1 = 16 !istart - INTEGER, parameter :: jpb2 = 29 !iend - ! ^ - ! Use for 112 g-point model - ! Use for 224 g-point model - ! integer, parameter :: ng16 = 16 - ! integer, parameter :: ng17 = 16 - ! integer, parameter :: ng18 = 16 - ! integer, parameter :: ng19 = 16 - ! integer, parameter :: ng20 = 16 - ! integer, parameter :: ng21 = 16 - ! integer, parameter :: ng22 = 16 - ! integer, parameter :: ng23 = 16 - ! integer, parameter :: ng24 = 16 - ! integer, parameter :: ng25 = 16 - ! integer, parameter :: ng26 = 16 - ! integer, parameter :: ng27 = 16 - ! integer, parameter :: ng28 = 16 - ! integer, parameter :: ng29 = 16 - ! integer, parameter :: ngs16 = 16 - ! integer, parameter :: ngs17 = 32 - ! integer, parameter :: ngs18 = 48 - ! integer, parameter :: ngs19 = 64 - ! integer, parameter :: ngs20 = 80 - ! integer, parameter :: ngs21 = 96 - ! integer, parameter :: ngs22 = 112 - ! integer, parameter :: ngs23 = 128 - ! integer, parameter :: ngs24 = 144 - ! integer, parameter :: ngs25 = 160 - ! integer, parameter :: ngs26 = 176 - ! integer, parameter :: ngs27 = 192 - ! integer, parameter :: ngs28 = 208 - ! integer, parameter :: ngs29 = 224 - ! Source function solar constant - ! W/m2 - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE parrrsw diff --git a/test/ncar_kernels/PORT_sw_cldprmc/src/rrsw_cld.f90 b/test/ncar_kernels/PORT_sw_cldprmc/src/rrsw_cld.f90 deleted file mode 100644 index c221624687..0000000000 --- a/test/ncar_kernels/PORT_sw_cldprmc/src/rrsw_cld.f90 +++ /dev/null @@ -1,84 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_cld.f90 -! Generated at: 2015-07-27 00:38:36 -! KGEN version: 0.4.13 - - - - MODULE rrsw_cld - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw cloud property coefficients - ! - ! Initial: J.-J. Morcrette, ECMWF, oct1999 - ! Revised: J. Delamere/MJIacono, AER, aug2005 - ! Revised: MJIacono, AER, nov2005 - ! Revised: MJIacono, AER, jul2006 - !------------------------------------------------------------------ - ! - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! xxxliq1 : real : optical properties (extinction coefficient, single - ! scattering albedo, assymetry factor) from - ! Hu & Stamnes, j. clim., 6, 728-742, 1993. - ! xxxice2 : real : optical properties (extinction coefficient, single - ! scattering albedo, assymetry factor) from streamer v3.0, - ! Key, streamer user's guide, cooperative institude - ! for meteorological studies, 95 pp., 2001. - ! xxxice3 : real : optical properties (extinction coefficient, single - ! scattering albedo, assymetry factor) from - ! Fu, j. clim., 9, 1996. - ! xbari : real : optical property coefficients for five spectral - ! intervals (2857-4000, 4000-5263, 5263-7692, 7692-14285, - ! and 14285-40000 wavenumbers) following - ! Ebert and Curry, jgr, 97, 3831-3836, 1992. - !------------------------------------------------------------------ - REAL(KIND=r8) :: extliq1(58,16:29) - REAL(KIND=r8) :: ssaliq1(58,16:29) - REAL(KIND=r8) :: asyliq1(58,16:29) - REAL(KIND=r8) :: extice2(43,16:29) - REAL(KIND=r8) :: ssaice2(43,16:29) - REAL(KIND=r8) :: asyice2(43,16:29) - REAL(KIND=r8) :: extice3(46,16:29) - REAL(KIND=r8) :: ssaice3(46,16:29) - REAL(KIND=r8) :: asyice3(46,16:29) - REAL(KIND=r8) :: fdlice3(46,16:29) - REAL(KIND=r8) :: abari(5) - REAL(KIND=r8) :: bbari(5) - REAL(KIND=r8) :: cbari(5) - REAL(KIND=r8) :: dbari(5) - REAL(KIND=r8) :: ebari(5) - REAL(KIND=r8) :: fbari(5) - PUBLIC kgen_read_externs_rrsw_cld - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_cld(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) extliq1 - READ(UNIT=kgen_unit) ssaliq1 - READ(UNIT=kgen_unit) asyliq1 - READ(UNIT=kgen_unit) extice2 - READ(UNIT=kgen_unit) ssaice2 - READ(UNIT=kgen_unit) asyice2 - READ(UNIT=kgen_unit) extice3 - READ(UNIT=kgen_unit) ssaice3 - READ(UNIT=kgen_unit) asyice3 - READ(UNIT=kgen_unit) fdlice3 - READ(UNIT=kgen_unit) abari - READ(UNIT=kgen_unit) bbari - READ(UNIT=kgen_unit) cbari - READ(UNIT=kgen_unit) dbari - READ(UNIT=kgen_unit) ebari - READ(UNIT=kgen_unit) fbari - END SUBROUTINE kgen_read_externs_rrsw_cld - - END MODULE rrsw_cld diff --git a/test/ncar_kernels/PORT_sw_cldprmc/src/rrsw_vsn.f90 b/test/ncar_kernels/PORT_sw_cldprmc/src/rrsw_vsn.f90 deleted file mode 100644 index 5a2185fc62..0000000000 --- a/test/ncar_kernels/PORT_sw_cldprmc/src/rrsw_vsn.f90 +++ /dev/null @@ -1,65 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_vsn.f90 -! Generated at: 2015-07-27 00:38:36 -! KGEN version: 0.4.13 - - - - MODULE rrsw_vsn - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw version information - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jul2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - !hnamrtm :character: - !hnamini :character: - !hnamcld :character: - !hnamclc :character: - !hnamrft :character: - !hnamspv :character: - !hnamspc :character: - !hnamset :character: - !hnamtau :character: - !hnamvqd :character: - !hnamatm :character: - !hnamutl :character: - !hnamext :character: - !hnamkg :character: - ! - ! hvrrtm :character: - ! hvrini :character: - ! hvrcld :character: - ! hvrclc :character: - ! hvrrft :character: - ! hvrspv :character: - ! hvrspc :character: - ! hvrset :character: - ! hvrtau :character: - ! hvrvqd :character: - ! hvratm :character: - ! hvrutl :character: - ! hvrext :character: - ! hvrkg :character: - !------------------------------------------------------------------ - CHARACTER(LEN=18) :: hvrclc - PUBLIC kgen_read_externs_rrsw_vsn - CONTAINS - - ! write subroutines - ! No subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_vsn(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) hvrclc - END SUBROUTINE kgen_read_externs_rrsw_vsn - - END MODULE rrsw_vsn diff --git a/test/ncar_kernels/PORT_sw_cldprmc/src/rrsw_wvn.f90 b/test/ncar_kernels/PORT_sw_cldprmc/src/rrsw_wvn.f90 deleted file mode 100644 index bbe6607d25..0000000000 --- a/test/ncar_kernels/PORT_sw_cldprmc/src/rrsw_wvn.f90 +++ /dev/null @@ -1,59 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_wvn.f90 -! Generated at: 2015-07-27 00:38:36 -! KGEN version: 0.4.13 - - - - MODULE rrsw_wvn - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE parrrsw, ONLY: ngptsw - USE parrrsw, ONLY: jpb1 - USE parrrsw, ONLY: jpb2 - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw spectral information - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jul2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! ng : integer: Number of original g-intervals in each spectral band - ! nspa : integer: - ! nspb : integer: - !wavenum1: real : Spectral band lower boundary in wavenumbers - !wavenum2: real : Spectral band upper boundary in wavenumbers - ! delwave: real : Spectral band width in wavenumbers - ! - ! ngc : integer: The number of new g-intervals in each band - ! ngs : integer: The cumulative sum of new g-intervals for each band - ! ngm : integer: The index of each new g-interval relative to the - ! original 16 g-intervals in each band - ! ngn : integer: The number of original g-intervals that are - ! combined to make each new g-intervals in each band - ! ngb : integer: The band index for each new g-interval - ! wt : real : RRTM weights for the original 16 g-intervals - ! rwgt : real : Weights for combining original 16 g-intervals - ! (224 total) into reduced set of g-intervals - ! (112 total) - !------------------------------------------------------------------ - REAL(KIND=r8) :: wavenum2(jpb1:jpb2) - INTEGER :: ngb(ngptsw) - PUBLIC kgen_read_externs_rrsw_wvn - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_wvn(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) wavenum2 - READ(UNIT=kgen_unit) ngb - END SUBROUTINE kgen_read_externs_rrsw_wvn - - END MODULE rrsw_wvn diff --git a/test/ncar_kernels/PORT_sw_cldprmc/src/rrtmg_sw_cldprmc.f90 b/test/ncar_kernels/PORT_sw_cldprmc/src/rrtmg_sw_cldprmc.f90 deleted file mode 100644 index 0bdebcbb22..0000000000 --- a/test/ncar_kernels/PORT_sw_cldprmc/src/rrtmg_sw_cldprmc.f90 +++ /dev/null @@ -1,386 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_sw_cldprmc.f90 -! Generated at: 2015-07-27 00:38:36 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_sw_cldprmc - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! ------- Modules ------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE parrrsw, ONLY: ngptsw - USE rrsw_cld, ONLY: abari - USE rrsw_cld, ONLY: bbari - USE rrsw_cld, ONLY: cbari - USE rrsw_cld, ONLY: dbari - USE rrsw_cld, ONLY: ebari - USE rrsw_cld, ONLY: fbari - USE rrsw_cld, ONLY: extice2 - USE rrsw_cld, ONLY: ssaice2 - USE rrsw_cld, ONLY: asyice2 - USE rrsw_cld, ONLY: extice3 - USE rrsw_cld, ONLY: ssaice3 - USE rrsw_cld, ONLY: asyice3 - USE rrsw_cld, ONLY: fdlice3 - USE rrsw_cld, ONLY: extliq1 - USE rrsw_cld, ONLY: ssaliq1 - USE rrsw_cld, ONLY: asyliq1 - USE rrsw_wvn, ONLY: ngb - USE rrsw_wvn, ONLY: wavenum2 - USE rrsw_vsn, ONLY: hvrclc - IMPLICIT NONE - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - ! ---------------------------------------------------------------------------- - - SUBROUTINE cldprmc_sw(ncol, nlayers, inflag, iceflag, liqflag, cldfmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, taormc, & - taucmc, ssacmc, asmcmc, fsfcmc) - ! ---------------------------------------------------------------------------- - ! Purpose: Compute the cloud optical properties for each cloudy layer - ! and g-point interval for use by the McICA method. - ! Note: Only inflag = 0 and inflag=2/liqflag=1/iceflag=2,3 are available; - ! (Hu & Stamnes, Key, and Fu) are implemented. - ! ------- Input ------- - INTEGER, intent(in) :: nlayers ! total number of layers - INTEGER, intent(in) :: ncol ! total number of layers - INTEGER, intent(in) :: inflag(:) ! see definitions - INTEGER, intent(in) :: iceflag(:) ! see definitions - INTEGER, intent(in) :: liqflag(:) ! see definitions - REAL(KIND=r8), intent(in) :: cldfmc(:,:,:) ! cloud fraction [mcica] - ! Dimensions: (ngptsw,nlayers) - REAL(KIND=r8), intent(in) :: ciwpmc(:,:,:) ! cloud ice water path [mcica] - ! Dimensions: (ngptsw,nlayers) - REAL(KIND=r8), intent(in) :: clwpmc(:,:,:) ! cloud liquid water path [mcica] - ! Dimensions: (ngptsw,nlayers) - REAL(KIND=r8), intent(in) :: relqmc(:,:) ! cloud liquid particle effective radius (microns) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: reicmc(:,:) ! cloud ice particle effective radius (microns) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: dgesmc(:,:) ! cloud ice particle generalized effective size (microns) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: fsfcmc(:,:,:) ! cloud forward scattering fraction - ! Dimensions: (ngptsw,nlayers) - ! ------- Output ------- - REAL(KIND=r8), intent(inout) :: taucmc(:,:,:) ! cloud optical depth (delta scaled) - ! Dimensions: (ngptsw,nlayers) - REAL(KIND=r8), intent(inout) :: ssacmc(:,:,:) ! single scattering albedo (delta scaled) - ! Dimensions: (ngptsw,nlayers) - REAL(KIND=r8), intent(inout) :: asmcmc(:,:,:) ! asymmetry parameter (delta scaled) - ! Dimensions: (ngptsw,nlayers) - REAL(KIND=r8), intent(out) :: taormc(:,:) ! cloud optical depth (non-delta scaled) - ! Dimensions: (ngptsw,nlayers) - ! ------- Local ------- - ! integer :: ncbands - INTEGER :: lay - INTEGER :: ig - INTEGER :: ib - INTEGER :: icx - INTEGER :: iplon - INTEGER :: istr,index - REAL(KIND=r8), parameter :: eps = 1.e-06_r8 ! epsilon - REAL(KIND=r8), parameter :: cldmin = 1.e-80_r8 ! minimum value for cloud quantities - REAL(KIND=r8) :: cwp ! total cloud water path - REAL(KIND=r8) :: radliq ! cloud liquid droplet radius (microns) - REAL(KIND=r8) :: radice ! cloud ice effective radius (microns) - REAL(KIND=r8) :: dgeice ! cloud ice generalized effective size (microns) - REAL(KIND=r8) :: factor - REAL(KIND=r8) :: fint - REAL(KIND=r8) :: taucldorig_a - REAL(KIND=r8) :: ffp - REAL(KIND=r8) :: ffp1 - REAL(KIND=r8) :: ffpssa - REAL(KIND=r8) :: ssacloud_a - REAL(KIND=r8) :: taucloud_a - REAL(KIND=r8) :: tauliqorig - REAL(KIND=r8) :: tauiceorig - REAL(KIND=r8) :: ssaliq - REAL(KIND=r8) :: tauliq - REAL(KIND=r8) :: ssaice - REAL(KIND=r8) :: tauice - REAL(KIND=r8) :: scatliq - REAL(KIND=r8) :: scatice - REAL(KIND=r8) :: fdelta(ngptsw) - REAL(KIND=r8) :: extcoice(ngptsw) - REAL(KIND=r8) :: gice(ngptsw) - REAL(KIND=r8) :: ssacoice(ngptsw) - REAL(KIND=r8) :: forwice(ngptsw) - REAL(KIND=r8) :: extcoliq(ngptsw) - REAL(KIND=r8) :: gliq(ngptsw) - REAL(KIND=r8) :: ssacoliq(ngptsw) - REAL(KIND=r8) :: forwliq(ngptsw) - ! Initialize - hvrclc = '$Revision: 1.4 $' - ! Initialize - ! Some of these initializations are done in rrtmg_sw.f90. - do iplon =1,ncol - do lay = 1, nlayers - do ig = 1, ngptsw - taormc(ig,lay) = taucmc(iplon,ig,lay) - ! taucmc(ig,lay) = 0.0_r8 - ! ssacmc(ig,lay) = 1.0_r8 - ! asmcmc(ig,lay) = 0.0_r8 - enddo - enddo - ! Main layer loop - do lay = 1, nlayers - ! Main g-point interval loop - do ig = 1, ngptsw - cwp = ciwpmc(iplon,ig,lay) + clwpmc(iplon,ig,lay) - if (cldfmc(iplon,ig,lay) .ge. cldmin .and. & - (cwp .ge. cldmin .or. taucmc(iplon,ig,lay) .ge. cldmin)) then - ! (inflag=0): Cloud optical properties input directly - if (inflag(iplon) .eq. 0) then - ! Cloud optical properties already defined in taucmc, ssacmc, asmcmc are unscaled; - ! Apply delta-M scaling here (using Henyey-Greenstein approximation) - taucldorig_a = taucmc(iplon,ig,lay) - ffp = fsfcmc(iplon,ig,lay) - ffp1 = 1.0_r8 - ffp - ffpssa = 1.0_r8 - ffp * ssacmc(iplon,ig,lay) - ssacloud_a = ffp1 * ssacmc(iplon,ig,lay) / ffpssa - taucloud_a = ffpssa * taucldorig_a - taormc(ig,lay) = taucldorig_a - ssacmc(iplon,ig,lay) = ssacloud_a - taucmc(iplon,ig,lay) = taucloud_a - asmcmc(iplon,ig,lay) = (asmcmc(iplon,ig,lay) - ffp) / (ffp1) - elseif (inflag(iplon) .eq. 1) then - stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA' - ! (inflag=2): Separate treatement of ice clouds and water clouds. - elseif (inflag(iplon) .eq. 2) then - radice = reicmc(iplon,lay) - ! Calculation of absorption coefficients due to ice clouds. - if (ciwpmc(iplon,ig,lay) .eq. 0.0) then - extcoice(ig) = 0.0_r8 - ssacoice(ig) = 0.0_r8 - gice(ig) = 0.0_r8 - forwice(ig) = 0.0_r8 - ! (iceflag = 1): - ! Note: This option uses Ebert and Curry approach for all particle sizes similar to - ! CAM3 implementation, though this is somewhat unjustified for large ice particles - elseif (iceflag(iplon) .eq. 1) then - ib = ngb(ig) - if (wavenum2(ib) .gt. 1.43e04_r8) then - icx = 1 - elseif (wavenum2(ib) .gt. 7.7e03_r8) then - icx = 2 - elseif (wavenum2(ib) .gt. 5.3e03_r8) then - icx = 3 - elseif (wavenum2(ib) .gt. 4.0e03_r8) then - icx = 4 - elseif (wavenum2(ib) .ge. 2.5e03_r8) then - icx = 5 - endif - extcoice(ig) = (abari(icx) + bbari(icx)/radice) - ssacoice(ig) = 1._r8 - cbari(icx) - dbari(icx) * radice - gice(ig) = ebari(icx) + fbari(icx) * radice - ! Check to ensure upper limit of gice is within physical limits for large particles - if (gice(ig).ge.1._r8) gice(ig) = 1._r8 - eps - forwice(ig) = gice(ig)*gice(ig) - ! Check to ensure all calculated quantities are within physical limits. - if (extcoice(ig) .lt. 0.0_r8) stop 'ICE EXTINCTION LESS THAN 0.0' - if (ssacoice(ig) .gt. 1.0_r8) stop 'ICE SSA GRTR THAN 1.0' - if (ssacoice(ig) .lt. 0.0_r8) stop 'ICE SSA LESS THAN 0.0' - if (gice(ig) .gt. 1.0_r8) stop 'ICE ASYM GRTR THAN 1.0' - if (gice(ig) .lt. 0.0_r8) stop 'ICE ASYM LESS THAN 0.0' - ! For iceflag=2 option, combine with iceflag=0 option to handle large particle sizes. - ! Use iceflag=2 option for ice particle effective radii from 5.0 to 131.0 microns - ! and use iceflag=0 option for ice particles greater than 131.0 microns. - ! *** NOTE: Transition between two methods has not been smoothed. - elseif (iceflag(iplon) .eq. 2) then - if (radice .lt. 5.0_r8) stop 'ICE RADIUS OUT OF BOUNDS' - if (radice .ge. 5.0_r8 .and. radice .le. 131._r8) then - factor = (radice - 2._r8)/3._r8 - index = int(factor) - if (index .eq. 43) index = 42 - fint = factor - float(index) - ib = ngb(ig) - extcoice(ig) = extice2(index,ib) + fint * & - (extice2(index+1,ib) - extice2(index,ib)) - ssacoice(ig) = ssaice2(index,ib) + fint * & - (ssaice2(index+1,ib) - ssaice2(index,ib)) - gice(ig) = asyice2(index,ib) + fint * & - (asyice2(index+1,ib) - asyice2(index,ib)) - forwice(ig) = gice(ig)*gice(ig) - ! Check to ensure all calculated quantities are within physical limits. - if (extcoice(ig) .lt. 0.0_r8) stop 'ICE EXTINCTION LESS THAN 0.0' - if (ssacoice(ig) .gt. 1.0_r8) stop 'ICE SSA GRTR THAN 1.0' - if (ssacoice(ig) .lt. 0.0_r8) stop 'ICE SSA LESS THAN 0.0' - if (gice(ig) .gt. 1.0_r8) stop 'ICE ASYM GRTR THAN 1.0' - if (gice(ig) .lt. 0.0_r8) stop 'ICE ASYM LESS THAN 0.0' - elseif (radice .gt. 131._r8) then - ib = ngb(ig) - if (wavenum2(ib) .gt. 1.43e04_r8) then - icx = 1 - elseif (wavenum2(ib) .gt. 7.7e03_r8) then - icx = 2 - elseif (wavenum2(ib) .gt. 5.3e03_r8) then - icx = 3 - elseif (wavenum2(ib) .gt. 4.0e03_r8) then - icx = 4 - elseif (wavenum2(ib) .ge. 2.5e03_r8) then - icx = 5 - endif - extcoice(ig) = (abari(icx) + bbari(icx)/radice) - ssacoice(ig) = 1._r8 - cbari(icx) - dbari(icx) * radice - gice(ig) = ebari(icx) + fbari(icx) * radice - ! Check to ensure upper limit of gice is within physical limits for large particles - if (gice(ig).ge.1.0_r8) gice(ig) = 1.0_r8-eps - forwice(ig) = gice(ig)*gice(ig) - ! Check to ensure all calculated quantities are within physical limits. - if (extcoice(ig) .lt. 0.0_r8) stop 'ICE EXTINCTION LESS THAN 0.0' - if (ssacoice(ig) .gt. 1.0_r8) stop 'ICE SSA GRTR THAN 1.0' - if (ssacoice(ig) .lt. 0.0_r8) stop 'ICE SSA LESS THAN 0.0' - if (gice(ig) .gt. 1.0_r8) stop 'ICE ASYM GRTR THAN 1.0' - if (gice(ig) .lt. 0.0_r8) stop 'ICE ASYM LESS THAN 0.0' - endif - ! For iceflag=3 option, combine with iceflag=0 option to handle large particle sizes - ! Use iceflag=3 option for ice particle effective radii from 3.2 to 91.0 microns - ! (generalized effective size, dge, from 5 to 140 microns), and use iceflag=0 option - ! for ice particle effective radii greater than 91.0 microns (dge = 140 microns). - ! *** NOTE: Fu parameterization requires particle size in generalized effective size. - ! *** NOTE: Transition between two methods has not been smoothed. - elseif (iceflag(iplon) .eq. 3) then - dgeice = dgesmc(iplon,lay) - if (dgeice .lt. 5.0_r8) stop 'ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' - if (dgeice .ge. 5.0_r8 .and. dgeice .le. 140._r8) then - factor = (dgeice - 2._r8)/3._r8 - index = int(factor) - if (index .eq. 46) index = 45 - fint = factor - float(index) - ib = ngb(ig) - extcoice(ig) = extice3(index,ib) + fint * & - (extice3(index+1,ib) - extice3(index,ib)) - ssacoice(ig) = ssaice3(index,ib) + fint * & - (ssaice3(index+1,ib) - ssaice3(index,ib)) - gice(ig) = asyice3(index,ib) + fint * & - (asyice3(index+1,ib) - asyice3(index,ib)) - fdelta(ig) = fdlice3(index,ib) + fint * & - (fdlice3(index+1,ib) - fdlice3(index,ib)) - if (fdelta(ig) .lt. 0.0_r8) stop 'FDELTA LESS THAN 0.0' - if (fdelta(ig) .gt. 1.0_r8) stop 'FDELTA GT THAN 1.0' - forwice(ig) = fdelta(ig) + 0.5_r8 / ssacoice(ig) - ! See Fu 1996 p. 2067 - if (forwice(ig) .gt. gice(ig)) forwice(ig) = gice(ig) - ! Check to ensure all calculated quantities are within physical limits. - if (extcoice(ig) .lt. 0.0_r8) stop 'ICE EXTINCTION LESS THAN 0.0' - if (ssacoice(ig) .gt. 1.0_r8) stop 'ICE SSA GRTR THAN 1.0' - if (ssacoice(ig) .lt. 0.0_r8) stop 'ICE SSA LESS THAN 0.0' - if (gice(ig) .gt. 1.0_r8) stop 'ICE ASYM GRTR THAN 1.0' - if (gice(ig) .lt. 0.0_r8) stop 'ICE ASYM LESS THAN 0.0' - elseif (dgeice .gt. 140._r8) then - ib = ngb(ig) - if (wavenum2(ib) .gt. 1.43e04_r8) then - icx = 1 - elseif (wavenum2(ib) .gt. 7.7e03_r8) then - icx = 2 - elseif (wavenum2(ib) .gt. 5.3e03_r8) then - icx = 3 - elseif (wavenum2(ib) .gt. 4.0e03_r8) then - icx = 4 - elseif (wavenum2(ib) .ge. 2.5e03_r8) then - icx = 5 - endif - extcoice(ig) = (abari(icx) + bbari(icx)/radice) - ssacoice(ig) = 1._r8 - cbari(icx) - dbari(icx) * radice - gice(ig) = ebari(icx) + fbari(icx) * radice - ! Check to ensure upper limit of gice is within physical limits for large particles - if (gice(ig).ge.1._r8) gice(ig) = 1._r8 - eps - forwice(ig) = gice(ig)*gice(ig) - ! Check to ensure all calculated quantities are within physical limits. - if (extcoice(ig) .lt. 0.0_r8) stop 'ICE EXTINCTION LESS THAN 0.0' - if (ssacoice(ig) .gt. 1.0_r8) stop 'ICE SSA GRTR THAN 1.0' - if (ssacoice(ig) .lt. 0.0_r8) stop 'ICE SSA LESS THAN 0.0' - if (gice(ig) .gt. 1.0_r8) stop 'ICE ASYM GRTR THAN 1.0' - if (gice(ig) .lt. 0.0_r8) stop 'ICE ASYM LESS THAN 0.0' - endif - endif - ! Calculation of absorption coefficients due to water clouds. - if (clwpmc(iplon,ig,lay) .eq. 0.0_r8) then - extcoliq(ig) = 0.0_r8 - ssacoliq(ig) = 0.0_r8 - gliq(ig) = 0.0_r8 - forwliq(ig) = 0.0_r8 - elseif (liqflag(iplon) .eq. 1) then - radliq = relqmc(iplon,lay) - if (radliq .lt. 1.5_r8 .or. radliq .gt. 60._r8) stop & - 'liquid effective radius out of bounds' - index = int(radliq - 1.5_r8) - if (index .eq. 0) index = 1 - if (index .eq. 58) index = 57 - fint = radliq - 1.5_r8 - float(index) - ib = ngb(ig) - extcoliq(ig) = extliq1(index,ib) + fint * & - (extliq1(index+1,ib) - extliq1(index,ib)) - ssacoliq(ig) = ssaliq1(index,ib) + fint * & - (ssaliq1(index+1,ib) - ssaliq1(index,ib)) - if (fint .lt. 0._r8 .and. ssacoliq(ig) .gt. 1._r8) & - ssacoliq(ig) = ssaliq1(index,ib) - gliq(ig) = asyliq1(index,ib) + fint * & - (asyliq1(index+1,ib) - asyliq1(index,ib)) - forwliq(ig) = gliq(ig)*gliq(ig) - ! Check to ensure all calculated quantities are within physical limits. - if (extcoliq(ig) .lt. 0.0_r8) stop 'LIQUID EXTINCTION LESS THAN 0.0' - if (ssacoliq(ig) .gt. 1.0_r8) stop 'LIQUID SSA GRTR THAN 1.0' - if (ssacoliq(ig) .lt. 0.0_r8) stop 'LIQUID SSA LESS THAN 0.0' - if (gliq(ig) .gt. 1.0_r8) stop 'LIQUID ASYM GRTR THAN 1.0' - if (gliq(ig) .lt. 0.0_r8) stop 'LIQUID ASYM LESS THAN 0.0' - endif - tauliqorig = clwpmc(iplon,ig,lay) * extcoliq(ig) - tauiceorig = ciwpmc(iplon,ig,lay) * extcoice(ig) - taormc(ig,lay) = tauliqorig + tauiceorig - ssaliq = ssacoliq(ig) * (1._r8 - forwliq(ig)) / & - (1._r8 - forwliq(ig) * ssacoliq(ig)) - tauliq = (1._r8 - forwliq(ig) * ssacoliq(ig)) * tauliqorig - ssaice = ssacoice(ig) * (1._r8 - forwice(ig)) / & - (1._r8 - forwice(ig) * ssacoice(ig)) - tauice = (1._r8 - forwice(ig) * ssacoice(ig)) * tauiceorig - scatliq = ssaliq * tauliq - scatice = ssaice * tauice - taucmc(iplon,ig,lay) = tauliq + tauice - ! Ensure non-zero taucmc and scatice - if(taucmc(iplon,ig,lay).eq.0.) taucmc(iplon,ig,lay) = cldmin - if(scatice.eq.0.) scatice = cldmin - ssacmc(iplon,ig,lay) = (scatliq + scatice) / taucmc(iplon,ig,lay) - if (iceflag(iplon) .eq. 3) then - ! In accordance with the 1996 Fu paper, equation A.3, - ! the moments for ice were calculated depending on whether using spheres - ! or hexagonal ice crystals. - ! Set asymetry parameter to first moment (istr=1) - istr = 1 - asmcmc(iplon,ig,lay) = (1.0_r8/(scatliq+scatice))* & - (scatliq*(gliq(ig)**istr - forwliq(ig)) / & - (1.0_r8 - forwliq(ig)) + scatice * ((gice(ig)-forwice(ig))/ & - (1.0_r8 - forwice(ig)))**istr) - else - ! This code is the standard method for delta-m scaling. - ! Set asymetry parameter to first moment (istr=1) - istr = 1 - asmcmc(iplon,ig,lay) = (scatliq * & - (gliq(ig)**istr - forwliq(ig)) / & - (1.0_r8 - forwliq(ig)) + scatice * (gice(ig)**istr - forwice(ig)) / & - (1.0_r8 - forwice(ig)))/(scatliq + scatice) - endif - endif - endif - ! End g-point interval loop - enddo - ! End layer loop - enddo - end do - END SUBROUTINE cldprmc_sw - END MODULE rrtmg_sw_cldprmc diff --git a/test/ncar_kernels/PORT_sw_cldprmc/src/rrtmg_sw_rad.f90 b/test/ncar_kernels/PORT_sw_cldprmc/src/rrtmg_sw_rad.f90 deleted file mode 100644 index 59152b0201..0000000000 --- a/test/ncar_kernels/PORT_sw_cldprmc/src/rrtmg_sw_rad.f90 +++ /dev/null @@ -1,690 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_sw_rad.f90 -! Generated at: 2015-07-27 00:38:35 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_sw_rad - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! - ! **************************************************************************** - ! * * - ! * RRTMG_SW * - ! * * - ! * * - ! * * - ! * a rapid radiative transfer model * - ! * for the solar spectral region * - ! * for application to general circulation models * - ! * * - ! * * - ! * Atmospheric and Environmental Research, Inc. * - ! * 131 Hartwell Avenue * - ! * Lexington, MA 02421 * - ! * * - ! * * - ! * Eli J. Mlawer * - ! * Jennifer S. Delamere * - ! * Michael J. Iacono * - ! * Shepard A. Clough * - ! * * - ! * * - ! * * - ! * * - ! * * - ! * * - ! * email: miacono@aer.com * - ! * email: emlawer@aer.com * - ! * email: jdelamer@aer.com * - ! * * - ! * The authors wish to acknowledge the contributions of the * - ! * following people: Steven J. Taubman, Patrick D. Brown, * - ! * Ronald E. Farren, Luke Chen, Robert Bergstrom. * - ! * * - ! **************************************************************************** - ! --------- Modules --------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE rrtmg_sw_cldprmc, ONLY: cldprmc_sw - ! Move call to rrtmg_sw_ini and following use association to - ! GCM initialization area - ! use rrtmg_sw_init, only: rrtmg_sw_ini - IMPLICIT NONE - ! public interfaces/functions/subroutines - ! public :: rrtmg_sw, inatm_sw, earth_sun - PUBLIC rrtmg_sw - !------------------------------------------------------------------ - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !------------------------------------------------------------------ - !------------------------------------------------------------------ - ! Public subroutines - !------------------------------------------------------------------ - - SUBROUTINE rrtmg_sw(ncol, nlay, kgen_unit) - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! ------- Description ------- - ! This program is the driver for RRTMG_SW, the AER SW radiation model for - ! application to GCMs, that has been adapted from RRTM_SW for improved - ! efficiency and to provide fractional cloudiness and cloud overlap - ! capability using McICA. - ! - ! Note: The call to RRTMG_SW_INI should be moved to the GCM initialization - ! area, since this has to be called only once. - ! - ! This routine - ! b) calls INATM_SW to read in the atmospheric profile; - ! all layering in RRTMG is ordered from surface to toa. - ! c) calls CLDPRMC_SW to set cloud optical depth for McICA based - ! on input cloud properties - ! d) calls SETCOEF_SW to calculate various quantities needed for - ! the radiative transfer algorithm - ! e) calls SPCVMC to call the two-stream model that in turn - ! calls TAUMOL to calculate gaseous optical depths for each - ! of the 16 spectral bands and to perform the radiative transfer - ! using McICA, the Monte-Carlo Independent Column Approximation, - ! to represent sub-grid scale cloud variability - ! f) passes the calculated fluxes and cooling rates back to GCM - ! - ! Two modes of operation are possible: - ! The mode is chosen by using either rrtmg_sw.nomcica.f90 (to not use - ! McICA) or rrtmg_sw.f90 (to use McICA) to interface with a GCM. - ! - ! 1) Standard, single forward model calculation (imca = 0); this is - ! valid only for clear sky or fully overcast clouds - ! 2) Monte Carlo Independent Column Approximation (McICA, Pincus et al., - ! JC, 2003) method is applied to the forward model calculation (imca = 1) - ! This method is valid for clear sky or partial cloud conditions. - ! - ! This call to RRTMG_SW must be preceeded by a call to the module - ! mcica_subcol_gen_sw.f90 to run the McICA sub-column cloud generator, - ! which will provide the cloud physical or cloud optical properties - ! on the RRTMG quadrature point (ngptsw) dimension. - ! - ! Two methods of cloud property input are possible: - ! Cloud properties can be input in one of two ways (controlled by input - ! flags inflag, iceflag and liqflag; see text file rrtmg_sw_instructions - ! and subroutine rrtmg_sw_cldprop.f90 for further details): - ! - ! 1) Input cloud fraction, cloud optical depth, single scattering albedo - ! and asymmetry parameter directly (inflgsw = 0) - ! 2) Input cloud fraction and cloud physical properties: ice fracion, - ! ice and liquid particle sizes (inflgsw = 1 or 2); - ! cloud optical properties are calculated by cldprop or cldprmc based - ! on input settings of iceflgsw and liqflgsw - ! - ! Two methods of aerosol property input are possible: - ! Aerosol properties can be input in one of two ways (controlled by input - ! flag iaer, see text file rrtmg_sw_instructions for further details): - ! - ! 1) Input aerosol optical depth, single scattering albedo and asymmetry - ! parameter directly by layer and spectral band (iaer=10) - ! 2) Input aerosol optical depth and 0.55 micron directly by layer and use - ! one or more of six ECMWF aerosol types (iaer=6) - ! - ! - ! ------- Modifications ------- - ! - ! This version of RRTMG_SW has been modified from RRTM_SW to use a reduced - ! set of g-point intervals and a two-stream model for application to GCMs. - ! - !-- Original version (derived from RRTM_SW) - ! 2002: AER. Inc. - !-- Conversion to F90 formatting; addition of 2-stream radiative transfer - ! Feb 2003: J.-J. Morcrette, ECMWF - !-- Additional modifications for GCM application - ! Aug 2003: M. J. Iacono, AER Inc. - !-- Total number of g-points reduced from 224 to 112. Original - ! set of 224 can be restored by exchanging code in module parrrsw.f90 - ! and in file rrtmg_sw_init.f90. - ! Apr 2004: M. J. Iacono, AER, Inc. - !-- Modifications to include output for direct and diffuse - ! downward fluxes. There are output as "true" fluxes without - ! any delta scaling applied. Code can be commented to exclude - ! this calculation in source file rrtmg_sw_spcvrt.f90. - ! Jan 2005: E. J. Mlawer, M. J. Iacono, AER, Inc. - !-- Revised to add McICA capability. - ! Nov 2005: M. J. Iacono, AER, Inc. - !-- Reformatted for consistency with rrtmg_lw. - ! Feb 2007: M. J. Iacono, AER, Inc. - !-- Modifications to formatting to use assumed-shape arrays. - ! Aug 2007: M. J. Iacono, AER, Inc. - !-- Modified to output direct and diffuse fluxes either with or without - ! delta scaling based on setting of idelm flag - ! Dec 2008: M. J. Iacono, AER, Inc. - ! --------- Modules --------- - USE parrrsw, ONLY: ngptsw - ! ------- Declarations - ! ----- Input ----- - integer, intent(in) :: kgen_unit - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - ! chunk identifier - INTEGER, intent(in) :: ncol ! Number of horizontal columns - INTEGER, intent(in) :: nlay ! Number of model layers - ! Cloud overlap method - ! 0: Clear only - ! 1: Random - ! 2: Maximum/random - ! 3: Maximum - ! Layer pressures (hPa, mb) - ! Dimensions: (ncol,nlay) - ! Interface pressures (hPa, mb) - ! Dimensions: (ncol,nlay+1) - ! Layer temperatures (K) - ! Dimensions: (ncol,nlay) - ! Interface temperatures (K) - ! Dimensions: (ncol,nlay+1) - ! Surface temperature (K) - ! Dimensions: (ncol) - ! H2O volume mixing ratio - ! Dimensions: (ncol,nlay) - ! O3 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! CO2 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! Methane volume mixing ratio - ! Dimensions: (ncol,nlay) - ! O2 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! Nitrous oxide volume mixing ratio - ! Dimensions: (ncol,nlay) - ! UV/vis surface albedo direct rad - ! Dimensions: (ncol) - ! Near-IR surface albedo direct rad - ! Dimensions: (ncol) - ! UV/vis surface albedo: diffuse rad - ! Dimensions: (ncol) - ! Near-IR surface albedo: diffuse rad - ! Dimensions: (ncol) - ! Day of the year (used to get Earth/Sun - ! distance if adjflx not provided) - ! Flux adjustment for Earth/Sun distance - ! Cosine of solar zenith angle - ! Dimensions: (ncol) - ! Solar constant (Wm-2) scaling per band - ! Flag for cloud optical properties - ! Flag for ice particle specification - ! Flag for liquid droplet specification - ! Cloud fraction - ! Dimensions: (ngptsw,ncol,nlay) - ! Cloud optical depth - ! Dimensions: (ngptsw,ncol,nlay) - ! Cloud single scattering albedo - ! Dimensions: (ngptsw,ncol,nlay) - ! Cloud asymmetry parameter - ! Dimensions: (ngptsw,ncol,nlay) - ! Cloud forward scattering parameter - ! Dimensions: (ngptsw,ncol,nlay) - ! Cloud ice water path (g/m2) - ! Dimensions: (ngptsw,ncol,nlay) - ! Cloud liquid water path (g/m2) - ! Dimensions: (ngptsw,ncol,nlay) - ! Cloud ice effective radius (microns) - ! Dimensions: (ncol,nlay) - ! Cloud water drop effective radius (microns) - ! Dimensions: (ncol,nlay) - ! Aerosol optical depth (iaer=10 only) - ! Dimensions: (ncol,nlay,nbndsw) - ! (non-delta scaled) - ! Aerosol single scattering albedo (iaer=10 only) - ! Dimensions: (ncol,nlay,nbndsw) - ! (non-delta scaled) - ! Aerosol asymmetry parameter (iaer=10 only) - ! Dimensions: (ncol,nlay,nbndsw) - ! (non-delta scaled) - ! real(kind=r8), intent(in) :: ecaer(:,:,:) ! Aerosol optical depth at 0.55 micron (iaer=6 only) - ! Dimensions: (ncol,nlay,naerec) - ! (non-delta scaled) - ! ----- Output ----- - ! Total sky shortwave upward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Total sky shortwave downward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Total sky shortwave radiative heating rate (K/d) - ! Dimensions: (ncol,nlay) - ! Clear sky shortwave upward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Clear sky shortwave downward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Clear sky shortwave radiative heating rate (K/d) - ! Dimensions: (ncol,nlay) - ! Direct downward shortwave flux, UV/vis - ! Diffuse downward shortwave flux, UV/vis - ! Direct downward shortwave flux, near-IR - ! Diffuse downward shortwave flux, near-IR - ! Net shortwave flux, near-IR - ! Net clear sky shortwave flux, near-IR - ! shortwave spectral flux up - ! shortwave spectral flux down - ! ----- Local ----- - ! Control - ! beginning band of calculation - ! ending band of calculation - ! cldprop/cldprmc use flag - ! output option flag (inactive) - ! aerosol option flag - ! delta-m scaling flag - ! [0 = direct and diffuse fluxes are unscaled] - ! [1 = direct and diffuse fluxes are scaled] - ! (total downward fluxes are always delta scaled) - ! instrumental cosine response flag (inactive) - ! column loop index - ! layer loop index ! jk - ! band loop index ! jsw - ! indices - ! layer loop index - ! value for changing mcica permute seed - ! flag for mcica [0=off, 1=on] - ! epsilon - ! flux to heating conversion ratio - ! Atmosphere - ! layer pressures (mb) - ! layer temperatures (K) - ! level (interface) pressures (hPa, mb) - ! level (interface) temperatures (K) - ! surface temperature (K) - ! layer pressure thickness (hPa, mb) - ! dry air column amount - ! molecular amounts (mol/cm-2) - ! real(kind=r8) :: earth_sun ! function for Earth/Sun distance factor - ! Cosine of solar zenith angle - ! adjustment for current Earth/Sun distance - ! real(kind=r8) :: solvar(jpband) ! solar constant scaling factor from rrtmg_sw - ! default value of 1368.22 Wm-2 at 1 AU - ! surface albedo, direct ! zalbp - ! surface albedo, diffuse ! zalbd - ! Aerosol optical depth - ! Aerosol single scattering albedo - ! Aerosol asymmetry parameter - ! Atmosphere - setcoef - ! tropopause layer index - ! - ! - ! - ! - ! - ! column amount (h2o) - ! column amount (co2) - ! column amount (o3) - ! column amount (n2o) - ! column amount (ch4) - ! column amount (o2) - ! column amount - ! column amount - ! - ! Atmosphere/clouds - cldprop - ! number of cloud spectral bands - INTEGER :: inflag(ncol) ! flag for cloud property method - INTEGER :: iceflag(ncol) ! flag for ice cloud properties - INTEGER :: liqflag(ncol) ! flag for liquid cloud properties - ! real(kind=r8) :: cldfrac(nlay) ! layer cloud fraction - ! real(kind=r8) :: tauc(nlay) ! cloud optical depth (non-delta scaled) - ! real(kind=r8) :: ssac(nlay) ! cloud single scattering albedo (non-delta scaled) - ! real(kind=r8) :: asmc(nlay) ! cloud asymmetry parameter (non-delta scaled) - ! real(kind=r8) :: ciwp(nlay) ! cloud ice water path - ! real(kind=r8) :: clwp(nlay) ! cloud liquid water path - ! real(kind=r8) :: rei(nlay) ! cloud ice particle size - ! real(kind=r8) :: rel(nlay) ! cloud liquid particle size - ! real(kind=r8) :: taucloud(nlay,jpband) ! cloud optical depth - ! real(kind=r8) :: taucldorig(nlay,jpband) ! cloud optical depth (non-delta scaled) - ! real(kind=r8) :: ssacloud(nlay,jpband) ! cloud single scattering albedo - ! real(kind=r8) :: asmcloud(nlay,jpband) ! cloud asymmetry parameter - ! Atmosphere/clouds - cldprmc [mcica] - REAL(KIND=r8) :: cldfmc(ncol,ngptsw,nlay) ! cloud fraction [mcica] - REAL(KIND=r8) :: ciwpmc(ncol,ngptsw,nlay) ! cloud ice water path [mcica] - REAL(KIND=r8) :: clwpmc(ncol,ngptsw,nlay) ! cloud liquid water path [mcica] - REAL(KIND=r8) :: relqmc(ncol,nlay) ! liquid particle size (microns) - REAL(KIND=r8) :: reicmc(ncol,nlay) ! ice particle effective radius (microns) - REAL(KIND=r8) :: dgesmc(ncol,nlay) ! ice particle generalized effective size (microns) - REAL(KIND=r8) :: taucmc(ncol,ngptsw,nlay) - REAL(KIND=r8) :: ref_taucmc(ncol,ngptsw,nlay) ! cloud optical depth [mcica] - REAL(KIND=r8) :: taormc(ngptsw,nlay) - REAL(KIND=r8) :: ref_taormc(ngptsw,nlay) ! unscaled cloud optical depth [mcica] - REAL(KIND=r8) :: ssacmc(ncol,ngptsw,nlay) - REAL(KIND=r8) :: ref_ssacmc(ncol,ngptsw,nlay) ! cloud single scattering albedo [mcica] - REAL(KIND=r8) :: asmcmc(ncol,ngptsw,nlay) - REAL(KIND=r8) :: ref_asmcmc(ncol,ngptsw,nlay) ! cloud asymmetry parameter [mcica] - REAL(KIND=r8) :: fsfcmc(ncol,ngptsw,nlay) ! cloud forward scattering fraction [mcica] - ! Atmosphere/clouds/aerosol - spcvrt,spcvmc - ! cloud optical depth - ! unscaled cloud optical depth - ! cloud asymmetry parameter - ! (first moment of phase function) - ! cloud single scattering albedo - ! total aerosol optical depth - ! total aerosol asymmetry parameter - ! total aerosol single scattering albedo - ! cloud fraction [mcica] - ! cloud optical depth [mcica] - ! unscaled cloud optical depth [mcica] - ! cloud asymmetry parameter [mcica] - ! cloud single scattering albedo [mcica] - ! temporary upward shortwave flux (w/m2) - ! temporary downward shortwave flux (w/m2) - ! temporary clear sky upward shortwave flux (w/m2) - ! temporary clear sky downward shortwave flux (w/m2) - ! temporary downward direct shortwave flux (w/m2) - ! temporary clear sky downward direct shortwave flux (w/m2) - ! temporary UV downward shortwave flux (w/m2) - ! temporary clear sky UV downward shortwave flux (w/m2) - ! temporary UV downward direct shortwave flux (w/m2) - ! temporary clear sky UV downward direct shortwave flux (w/m2) - ! temporary near-IR downward shortwave flux (w/m2) - ! temporary clear sky near-IR downward shortwave flux (w/m2) - ! temporary near-IR downward direct shortwave flux (w/m2) - ! temporary clear sky near-IR downward direct shortwave flux (w/m2) - ! Added for near-IR flux diagnostic - ! temporary near-IR downward shortwave flux (w/m2) - ! temporary clear sky near-IR downward shortwave flux (w/m2) - ! Optional output fields - ! Total sky shortwave net flux (W/m2) - ! Clear sky shortwave net flux (W/m2) - ! Direct downward shortwave surface flux - ! Diffuse downward shortwave surface flux - ! Total sky downward shortwave flux, UV/vis - ! Total sky downward shortwave flux, near-IR - ! temporary upward shortwave flux spectral (w/m2) - ! temporary downward shortwave flux spectral (w/m2) - ! Output - inactive - ! real(kind=r8) :: zuvfu(nlay+2) ! temporary upward UV shortwave flux (w/m2) - ! real(kind=r8) :: zuvfd(nlay+2) ! temporary downward UV shortwave flux (w/m2) - ! real(kind=r8) :: zuvcu(nlay+2) ! temporary clear sky upward UV shortwave flux (w/m2) - ! real(kind=r8) :: zuvcd(nlay+2) ! temporary clear sky downward UV shortwave flux (w/m2) - ! real(kind=r8) :: zvsfu(nlay+2) ! temporary upward visible shortwave flux (w/m2) - ! real(kind=r8) :: zvsfd(nlay+2) ! temporary downward visible shortwave flux (w/m2) - ! real(kind=r8) :: zvscu(nlay+2) ! temporary clear sky upward visible shortwave flux (w/m2) - ! real(kind=r8) :: zvscd(nlay+2) ! temporary clear sky downward visible shortwave flux (w/m2) - ! real(kind=r8) :: znifu(nlay+2) ! temporary upward near-IR shortwave flux (w/m2) - ! real(kind=r8) :: znifd(nlay+2) ! temporary downward near-IR shortwave flux (w/m2) - ! real(kind=r8) :: znicu(nlay+2) ! temporary clear sky upward near-IR shortwave flux (w/m2) - ! real(kind=r8) :: znicd(nlay+2) ! temporary clear sky downward near-IR shortwave flux (w/m2) - ! Initializations - ! In a GCM with or without McICA, set nlon to the longitude dimension - ! - ! Set imca to select calculation type: - ! imca = 0, use standard forward model calculation (clear and overcast only) - ! imca = 1, use McICA for Monte Carlo treatment of sub-grid cloud variability - ! (clear, overcast or partial cloud conditions) - ! *** This version uses McICA (imca = 1) *** - ! Set icld to select of clear or cloud calculation and cloud - ! overlap method (read by subroutine readprof from input file INPUT_RRTM): - ! icld = 0, clear only - ! icld = 1, with clouds using random cloud overlap (McICA only) - ! icld = 2, with clouds using maximum/random cloud overlap (McICA only) - ! icld = 3, with clouds using maximum cloud overlap (McICA only) - ! Set iaer to select aerosol option - ! iaer = 0, no aerosols - ! iaer = 6, use six ECMWF aerosol types - ! input aerosol optical depth at 0.55 microns for each aerosol type (ecaer) - ! iaer = 10, input total aerosol optical depth, single scattering albedo - ! and asymmetry parameter (tauaer, ssaaer, asmaer) directly - ! Set idelm to select between delta-M scaled or unscaled output direct and diffuse fluxes - ! NOTE: total downward fluxes are always delta scaled - ! idelm = 0, output direct and diffuse flux components are not delta scaled - ! (direct flux does not include forward scattering peak) - ! idelm = 1, output direct and diffuse flux components are delta scaled (default) - ! (direct flux includes part or most of forward scattering peak) - ! Call model and data initialization, compute lookup tables, perform - ! reduction of g-points from 224 to 112 for input absorption - ! coefficient data and other arrays. - ! - ! In a GCM this call should be placed in the model initialization - ! area, since this has to be called only once. - ! call rrtmg_sw_ini - ! This is the main longitude/column loop in RRTMG. - ! Modify to loop over all columns (nlon) or over daylight columns - !JMD #define OLD_INATM_SW 1 - ! For cloudy atmosphere, use cldprop to set cloud optical properties based on - ! input cloud physical properties. Select method based on choices described - ! in cldprop. Cloud fraction, water path, liquid droplet and ice particle - ! effective radius must be passed in cldprop. Cloud fraction and cloud - ! optical properties are transferred to rrtmg_sw arrays in cldprop. - tolerance = 1.E-14 - CALL kgen_init_check(check_status, tolerance) - READ(UNIT=kgen_unit) inflag - READ(UNIT=kgen_unit) iceflag - READ(UNIT=kgen_unit) liqflag - READ(UNIT=kgen_unit) cldfmc - READ(UNIT=kgen_unit) ciwpmc - READ(UNIT=kgen_unit) clwpmc - READ(UNIT=kgen_unit) relqmc - READ(UNIT=kgen_unit) reicmc - READ(UNIT=kgen_unit) dgesmc - READ(UNIT=kgen_unit) taucmc - READ(UNIT=kgen_unit) taormc - READ(UNIT=kgen_unit) ssacmc - READ(UNIT=kgen_unit) asmcmc - READ(UNIT=kgen_unit) fsfcmc - - READ(UNIT=kgen_unit) ref_taucmc - READ(UNIT=kgen_unit) ref_taormc - READ(UNIT=kgen_unit) ref_ssacmc - READ(UNIT=kgen_unit) ref_asmcmc - - - ! call to kernel - call cldprmc_sw(ncol,nlay, inflag, iceflag, liqflag, cldfmc, & - ciwpmc, clwpmc, reicmc, dgesmc, relqmc, & - taormc, taucmc, ssacmc, asmcmc, fsfcmc) - ! kernel verification for output variables - CALL kgen_verify_real_r8_dim3( "taucmc", check_status, taucmc, ref_taucmc) - CALL kgen_verify_real_r8_dim2( "taormc", check_status, taormc, ref_taormc) - CALL kgen_verify_real_r8_dim3( "ssacmc", check_status, ssacmc, ref_ssacmc) - CALL kgen_verify_real_r8_dim3( "asmcmc", check_status, asmcmc, ref_asmcmc) - CALL kgen_print_check("cldprmc_sw", check_status) - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,10 - CALL cldprmc_sw(ncol, nlay, inflag, iceflag, liqflag, cldfmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, taormc, taucmc, ssacmc, asmcmc, fsfcmc) - END DO - CALL system_clock(stop_clock, rate_clock) - WRITE(*,*) - PRINT *, "Elapsed time (sec): ", (stop_clock - start_clock)/REAL(rate_clock*10) - ! Calculate coefficients for the temperature and pressure dependence of the - ! molecular absorption coefficients by interpolating data from stored - !do iplon = 1, ncol ! reference atmospheres. - ! call setcoef_sw(nlay, pavel(iplon,:), tavel(iplon,:), pz(iplon,:), tz(iplon,:), tbound(iplon), coldry(iplon,:), wkl( - ! iplon,:,:), & - ! laytrop(iplon), layswtch(iplon), laylow(iplon), jp(iplon,:), jt(iplon,:), jt1(iplon,:), & - ! co2mult(iplon,:), colch4(iplon,:), colco2(iplon,:), colh2o(iplon,:), colmol(iplon,:), coln2o(iplon,:) - ! , & - ! colo2(iplon,:), colo3(iplon,:), fac00(iplon,:), fac01(iplon,:), fac10(iplon,:), fac11(iplon,:), & - ! selffac(iplon,:), selffrac(iplon,:), indself(iplon,:), forfac(iplon,:), forfrac(iplon,:), indfor( - ! iplon,:)) - !end do - ! Cosine of the solar zenith angle - ! Prevent using value of zero; ideally, SW model is not called from host model when sun - ! is below horizon - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_r8_dim3(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2,idx3 - INTEGER, DIMENSION(2,3) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim3 - - SUBROUTINE kgen_read_real_r8_dim2(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim2 - - - ! verify subroutines - SUBROUTINE kgen_verify_real_r8_dim3( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim3 - - SUBROUTINE kgen_verify_real_r8_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim2 - - END SUBROUTINE rrtmg_sw - !************************************************************************* - - !*************************************************************************** - - END MODULE rrtmg_sw_rad diff --git a/test/ncar_kernels/PORT_sw_cldprmc/src/shr_kind_mod.f90 b/test/ncar_kernels/PORT_sw_cldprmc/src/shr_kind_mod.f90 deleted file mode 100644 index 938d8aeec9..0000000000 --- a/test/ncar_kernels/PORT_sw_cldprmc/src/shr_kind_mod.f90 +++ /dev/null @@ -1,26 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : shr_kind_mod.f90 -! Generated at: 2015-07-27 00:38:35 -! KGEN version: 0.4.13 - - - - MODULE shr_kind_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - PUBLIC - INTEGER, parameter :: shr_kind_r8 = selected_real_kind(12) ! 8 byte real - ! 4 byte real - ! native real - ! 8 byte integer - ! 4 byte integer - ! native integer - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE shr_kind_mod diff --git a/test/ncar_kernels/PORT_sw_inatm/CESM_license.txt b/test/ncar_kernels/PORT_sw_inatm/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/PORT_sw_inatm/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.1.1 b/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.1.1 deleted file mode 100644 index 0d34ff30dc..0000000000 Binary files a/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.1.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.1.4 b/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.1.4 deleted file mode 100644 index 0817ea3c24..0000000000 Binary files a/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.1.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.1.8 b/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.1.8 deleted file mode 100644 index 1b1eff5be4..0000000000 Binary files a/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.1.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.10.1 b/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.10.1 deleted file mode 100644 index 5b61513ab8..0000000000 Binary files a/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.10.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.10.4 b/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.10.4 deleted file mode 100644 index 69c0f14e40..0000000000 Binary files a/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.10.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.10.8 b/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.10.8 deleted file mode 100644 index 9d48d5bc81..0000000000 Binary files a/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.10.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.5.1 b/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.5.1 deleted file mode 100644 index 4e8e8f56ab..0000000000 Binary files a/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.5.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.5.4 b/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.5.4 deleted file mode 100644 index f28fcfa5d3..0000000000 Binary files a/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.5.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.5.8 b/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.5.8 deleted file mode 100644 index 55434d77d1..0000000000 Binary files a/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.5.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_inatm/inc/t1.mk b/test/ncar_kernels/PORT_sw_inatm/inc/t1.mk deleted file mode 100644 index bc00893f94..0000000000 --- a/test/ncar_kernels/PORT_sw_inatm/inc/t1.mk +++ /dev/null @@ -1,66 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# Intel default flags -# -# FC_FLAGS := -# -O2 -fp-model source -convert big_endian -assume byterecl -ftz -# -traceback -assume realloc_lhs -xAVX -# -FC_FLAGS := $(OPT) - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - -ALL_OBJS := kernel_driver.o rrtmg_sw_rad.o kgen_utils.o rrsw_con.o shr_kind_mod.o parrrsw.o - -verify: - @(grep "FAIL" $(TEST).rslt && echo "FAILED") || (grep "PASSED" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt | grep -v "PASSED" - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 rrtmg_sw_rad.o kgen_utils.o rrsw_con.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_sw_rad.o: $(SRC_DIR)/rrtmg_sw_rad.f90 kgen_utils.o shr_kind_mod.o parrrsw.o rrsw_con.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_con.o: $(SRC_DIR)/rrsw_con.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_kind_mod.o: $(SRC_DIR)/shr_kind_mod.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -parrrsw.o: $(SRC_DIR)/parrrsw.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -kgen_utils.o: $(SRC_DIR)/kgen_utils.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.oo *.rslt diff --git a/test/ncar_kernels/PORT_sw_inatm/lit/runmake b/test/ncar_kernels/PORT_sw_inatm/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/PORT_sw_inatm/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/PORT_sw_inatm/lit/t1.sh b/test/ncar_kernels/PORT_sw_inatm/lit/t1.sh deleted file mode 100644 index 33c953a156..0000000000 --- a/test/ncar_kernels/PORT_sw_inatm/lit/t1.sh +++ /dev/null @@ -1,9 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -# Shared lit script for each tests. Run bash commands that run tests with make. - -# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t -# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/PORT_sw_inatm/makefile b/test/ncar_kernels/PORT_sw_inatm/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/PORT_sw_inatm/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/PORT_sw_inatm/src/kernel_driver.f90 b/test/ncar_kernels/PORT_sw_inatm/src/kernel_driver.f90 deleted file mode 100644 index a7e6564e3b..0000000000 --- a/test/ncar_kernels/PORT_sw_inatm/src/kernel_driver.f90 +++ /dev/null @@ -1,213 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-07-27 00:31:37 -! KGEN version: 0.4.13 - - -PROGRAM kernel_driver - USE rrtmg_sw_rad, ONLY : rrtmg_sw - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - USE parrrsw, ONLY: nbndsw - USE rrsw_con, ONLY : kgen_read_externs_rrsw_con - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - - IMPLICIT NONE - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_mpi_rank_at = (/ 1, 4, 8 /) - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_counter_at = (/ 1, 10, 5 /) - CHARACTER(LEN=1024) :: kgen_filepath - REAL(KIND=r8), allocatable :: ciwpmcl(:,:,:) - REAL(KIND=r8), allocatable :: tauaer(:,:,:) - REAL(KIND=r8), allocatable :: tlay(:,:) - REAL(KIND=r8), allocatable :: tlev(:,:) - REAL(KIND=r8), allocatable :: plev(:,:) - REAL(KIND=r8), allocatable :: tsfc(:) - REAL(KIND=r8), allocatable :: h2ovmr(:,:) - INTEGER :: inflgsw - REAL(KIND=r8), allocatable :: ssaaer(:,:,:) - REAL(KIND=r8), allocatable :: co2vmr(:,:) - REAL(KIND=r8), allocatable :: clwpmcl(:,:,:) - REAL(KIND=r8), allocatable :: ch4vmr(:,:) - REAL(KIND=r8), allocatable :: ssacmcl(:,:,:) - REAL(KIND=r8), allocatable :: o2vmr(:,:) - REAL(KIND=r8), allocatable :: n2ovmr(:,:) - REAL(KIND=r8) :: adjes - REAL(KIND=r8), allocatable :: asmaer(:,:,:) - INTEGER :: dyofyr - REAL(KIND=r8), allocatable :: reicmcl(:,:) - REAL(KIND=r8), allocatable :: solvar(:) - REAL(KIND=r8), allocatable :: o3vmr(:,:) - INTEGER :: iceflgsw - INTEGER :: liqflgsw - INTEGER :: ncol - INTEGER :: nlay - REAL(KIND=r8), allocatable :: cldfmcl(:,:,:) - REAL(KIND=r8), allocatable :: relqmcl(:,:) - REAL(KIND=r8), allocatable :: taucmcl(:,:,:) - REAL(KIND=r8), allocatable :: fsfcmcl(:,:,:) - INTEGER :: icld - REAL(KIND=r8), allocatable :: asmcmcl(:,:,:) - REAL(KIND=r8), allocatable :: play(:,:) - - DO kgen_repeat_counter = 0, 8 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - kgen_filepath = "../data/inatm_sw." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "** Verification against '" // trim(adjustl(kgen_filepath)) // "' **" - - CALL kgen_read_externs_rrsw_con(kgen_unit) - - ! driver variables - READ(UNIT=kgen_unit) ncol - READ(UNIT=kgen_unit) nlay - READ(UNIT=kgen_unit) icld - CALL kgen_read_real_r8_dim2(play, kgen_unit) - CALL kgen_read_real_r8_dim2(plev, kgen_unit) - CALL kgen_read_real_r8_dim2(tlay, kgen_unit) - CALL kgen_read_real_r8_dim2(tlev, kgen_unit) - CALL kgen_read_real_r8_dim1(tsfc, kgen_unit) - CALL kgen_read_real_r8_dim2(h2ovmr, kgen_unit) - CALL kgen_read_real_r8_dim2(o3vmr, kgen_unit) - CALL kgen_read_real_r8_dim2(co2vmr, kgen_unit) - CALL kgen_read_real_r8_dim2(ch4vmr, kgen_unit) - CALL kgen_read_real_r8_dim2(o2vmr, kgen_unit) - CALL kgen_read_real_r8_dim2(n2ovmr, kgen_unit) - READ(UNIT=kgen_unit) dyofyr - READ(UNIT=kgen_unit) adjes - CALL kgen_read_real_r8_dim1(solvar, kgen_unit) - READ(UNIT=kgen_unit) inflgsw - READ(UNIT=kgen_unit) iceflgsw - READ(UNIT=kgen_unit) liqflgsw - CALL kgen_read_real_r8_dim3(cldfmcl, kgen_unit) - CALL kgen_read_real_r8_dim3(taucmcl, kgen_unit) - CALL kgen_read_real_r8_dim3(ssacmcl, kgen_unit) - CALL kgen_read_real_r8_dim3(asmcmcl, kgen_unit) - CALL kgen_read_real_r8_dim3(fsfcmcl, kgen_unit) - CALL kgen_read_real_r8_dim3(ciwpmcl, kgen_unit) - CALL kgen_read_real_r8_dim3(clwpmcl, kgen_unit) - CALL kgen_read_real_r8_dim2(reicmcl, kgen_unit) - CALL kgen_read_real_r8_dim2(relqmcl, kgen_unit) - CALL kgen_read_real_r8_dim3(tauaer, kgen_unit) - CALL kgen_read_real_r8_dim3(ssaaer, kgen_unit) - CALL kgen_read_real_r8_dim3(asmaer, kgen_unit) - - call rrtmg_sw(ncol, nlay, icld, play, plev, tlay, tlev, tsfc, h2ovmr, o3vmr, co2vmr, ch4vmr, o2vmr, & -n2ovmr, dyofyr, adjes, solvar, inflgsw, iceflgsw, liqflgsw, cldfmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl, & -ciwpmcl, clwpmcl, reicmcl, relqmcl, tauaer, ssaaer, asmaer, kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_r8_dim2(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim2 - - SUBROUTINE kgen_read_real_r8_dim1(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim1 - - SUBROUTINE kgen_read_real_r8_dim3(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2,idx3 - INTEGER, DIMENSION(2,3) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim3 - - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/PORT_sw_inatm/src/kgen_utils.f90 b/test/ncar_kernels/PORT_sw_inatm/src/kgen_utils.f90 deleted file mode 100644 index cfa8d114e0..0000000000 --- a/test/ncar_kernels/PORT_sw_inatm/src/kgen_utils.f90 +++ /dev/null @@ -1,61 +0,0 @@ -module kgen_utils_mod - -INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - -type check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - real(kind=kgen_dp) :: minvalue -end type check_t - -public kgen_dp, check_t, kgen_init_check, kgen_print_check - -contains - -subroutine kgen_init_check(check, tolerance, minvalue) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - real(kind=kgen_dp), intent(in), optional :: minvalue - - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.0D-15 - endif - if(present(minvalue)) then - check%minvalue = minvalue - else - check%minvalue = 1.0D-15 - endif -end subroutine kgen_init_check - -subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif -end subroutine kgen_print_check - -end module diff --git a/test/ncar_kernels/PORT_sw_inatm/src/parrrsw.f90 b/test/ncar_kernels/PORT_sw_inatm/src/parrrsw.f90 deleted file mode 100644 index 538469b14f..0000000000 --- a/test/ncar_kernels/PORT_sw_inatm/src/parrrsw.f90 +++ /dev/null @@ -1,84 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : parrrsw.f90 -! Generated at: 2015-07-27 00:31:37 -! KGEN version: 0.4.13 - - - - MODULE parrrsw - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw main parameters - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! mxlay : integer: maximum number of layers - ! mg : integer: number of original g-intervals per spectral band - ! nbndsw : integer: number of spectral bands - ! naerec : integer: number of aerosols (iaer=6, ecmwf aerosol option) - ! ngptsw : integer: total number of reduced g-intervals for rrtmg_lw - ! ngNN : integer: number of reduced g-intervals per spectral band - ! ngsNN : integer: cumulative number of g-intervals per band - !------------------------------------------------------------------ - ! Settings for single column mode. - ! For GCM use, set nlon to number of longitudes, and - ! mxlay to number of model layers - !jplay, klev - !jpg - INTEGER, parameter :: nbndsw = 14 !jpsw, ksw - !jpaer - INTEGER, parameter :: mxmol = 38 - INTEGER, parameter :: nmol = 7 - ! Use for 112 g-point model - INTEGER, parameter :: ngptsw = 112 !jpgpt - ! Use for 224 g-point model - ! integer, parameter :: ngptsw = 224 !jpgpt - ! may need to rename these - from v2.6 - INTEGER, parameter :: jpband = 29 - INTEGER, parameter :: jpb1 = 16 !istart - INTEGER, parameter :: jpb2 = 29 !iend - ! ^ - ! Use for 112 g-point model - ! Use for 224 g-point model - ! integer, parameter :: ng16 = 16 - ! integer, parameter :: ng17 = 16 - ! integer, parameter :: ng18 = 16 - ! integer, parameter :: ng19 = 16 - ! integer, parameter :: ng20 = 16 - ! integer, parameter :: ng21 = 16 - ! integer, parameter :: ng22 = 16 - ! integer, parameter :: ng23 = 16 - ! integer, parameter :: ng24 = 16 - ! integer, parameter :: ng25 = 16 - ! integer, parameter :: ng26 = 16 - ! integer, parameter :: ng27 = 16 - ! integer, parameter :: ng28 = 16 - ! integer, parameter :: ng29 = 16 - ! integer, parameter :: ngs16 = 16 - ! integer, parameter :: ngs17 = 32 - ! integer, parameter :: ngs18 = 48 - ! integer, parameter :: ngs19 = 64 - ! integer, parameter :: ngs20 = 80 - ! integer, parameter :: ngs21 = 96 - ! integer, parameter :: ngs22 = 112 - ! integer, parameter :: ngs23 = 128 - ! integer, parameter :: ngs24 = 144 - ! integer, parameter :: ngs25 = 160 - ! integer, parameter :: ngs26 = 176 - ! integer, parameter :: ngs27 = 192 - ! integer, parameter :: ngs28 = 208 - ! integer, parameter :: ngs29 = 224 - ! Source function solar constant - ! W/m2 - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE parrrsw diff --git a/test/ncar_kernels/PORT_sw_inatm/src/rrsw_con.f90 b/test/ncar_kernels/PORT_sw_inatm/src/rrsw_con.f90 deleted file mode 100644 index 5b063103c5..0000000000 --- a/test/ncar_kernels/PORT_sw_inatm/src/rrsw_con.f90 +++ /dev/null @@ -1,53 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_con.f90 -! Generated at: 2015-07-27 00:31:37 -! KGEN version: 0.4.13 - - - - MODULE rrsw_con - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw constants - ! Initial version: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! fluxfac: real : radiance to flux conversion factor - ! heatfac: real : flux to heating rate conversion factor - !oneminus: real : 1.-1.e-6 - ! pi : real : pi - ! grav : real : acceleration of gravity (m/s2) - ! planck : real : planck constant - ! boltz : real : boltzman constant - ! clight : real : speed of light - ! avogad : real : avogadro's constant - ! alosmt : real : - ! gascon : real : gas constant - ! radcn1 : real : - ! radcn2 : real : - !------------------------------------------------------------------ - REAL(KIND=r8) :: pi - REAL(KIND=r8) :: grav - REAL(KIND=r8) :: avogad - PUBLIC kgen_read_externs_rrsw_con - CONTAINS - - ! write subroutines - ! No subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_con(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) pi - READ(UNIT=kgen_unit) grav - READ(UNIT=kgen_unit) avogad - END SUBROUTINE kgen_read_externs_rrsw_con - - END MODULE rrsw_con diff --git a/test/ncar_kernels/PORT_sw_inatm/src/rrtmg_sw_rad.f90 b/test/ncar_kernels/PORT_sw_inatm/src/rrtmg_sw_rad.f90 deleted file mode 100644 index e30cc04fb5..0000000000 --- a/test/ncar_kernels/PORT_sw_inatm/src/rrtmg_sw_rad.f90 +++ /dev/null @@ -1,1211 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_sw_rad.f90 -! Generated at: 2015-07-27 00:31:37 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_sw_rad - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! - ! **************************************************************************** - ! * * - ! * RRTMG_SW * - ! * * - ! * * - ! * * - ! * a rapid radiative transfer model * - ! * for the solar spectral region * - ! * for application to general circulation models * - ! * * - ! * * - ! * Atmospheric and Environmental Research, Inc. * - ! * 131 Hartwell Avenue * - ! * Lexington, MA 02421 * - ! * * - ! * * - ! * Eli J. Mlawer * - ! * Jennifer S. Delamere * - ! * Michael J. Iacono * - ! * Shepard A. Clough * - ! * * - ! * * - ! * * - ! * * - ! * * - ! * * - ! * email: miacono@aer.com * - ! * email: emlawer@aer.com * - ! * email: jdelamer@aer.com * - ! * * - ! * The authors wish to acknowledge the contributions of the * - ! * following people: Steven J. Taubman, Patrick D. Brown, * - ! * Ronald E. Farren, Luke Chen, Robert Bergstrom. * - ! * * - ! **************************************************************************** - ! --------- Modules --------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - ! Move call to rrtmg_sw_ini and following use association to - ! GCM initialization area - ! use rrtmg_sw_init, only: rrtmg_sw_ini - IMPLICIT NONE - ! public interfaces/functions/subroutines - ! public :: rrtmg_sw, inatm_sw, earth_sun - - PUBLIC rrtmg_sw - !------------------------------------------------------------------ - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !------------------------------------------------------------------ - !------------------------------------------------------------------ - ! Public subroutines - !------------------------------------------------------------------ - - SUBROUTINE rrtmg_sw(ncol, nlay, icld, play, plev, tlay, tlev, tsfc, h2ovmr, o3vmr, co2vmr, ch4vmr, o2vmr, n2ovmr, dyofyr, & - adjes, solvar, inflgsw, iceflgsw, liqflgsw, cldfmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl, ciwpmcl, clwpmcl, reicmcl, & - relqmcl, tauaer, ssaaer, asmaer, kgen_unit) - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! ------- Description ------- - ! This program is the driver for RRTMG_SW, the AER SW radiation model for - ! application to GCMs, that has been adapted from RRTM_SW for improved - ! efficiency and to provide fractional cloudiness and cloud overlap - ! capability using McICA. - ! - ! Note: The call to RRTMG_SW_INI should be moved to the GCM initialization - ! area, since this has to be called only once. - ! - ! This routine - ! b) calls INATM_SW to read in the atmospheric profile; - ! all layering in RRTMG is ordered from surface to toa. - ! c) calls CLDPRMC_SW to set cloud optical depth for McICA based - ! on input cloud properties - ! d) calls SETCOEF_SW to calculate various quantities needed for - ! the radiative transfer algorithm - ! e) calls SPCVMC to call the two-stream model that in turn - ! calls TAUMOL to calculate gaseous optical depths for each - ! of the 16 spectral bands and to perform the radiative transfer - ! using McICA, the Monte-Carlo Independent Column Approximation, - ! to represent sub-grid scale cloud variability - ! f) passes the calculated fluxes and cooling rates back to GCM - ! - ! Two modes of operation are possible: - ! The mode is chosen by using either rrtmg_sw.nomcica.f90 (to not use - ! McICA) or rrtmg_sw.f90 (to use McICA) to interface with a GCM. - ! - ! 1) Standard, single forward model calculation (imca = 0); this is - ! valid only for clear sky or fully overcast clouds - ! 2) Monte Carlo Independent Column Approximation (McICA, Pincus et al., - ! JC, 2003) method is applied to the forward model calculation (imca = 1) - ! This method is valid for clear sky or partial cloud conditions. - ! - ! This call to RRTMG_SW must be preceeded by a call to the module - ! mcica_subcol_gen_sw.f90 to run the McICA sub-column cloud generator, - ! which will provide the cloud physical or cloud optical properties - ! on the RRTMG quadrature point (ngptsw) dimension. - ! - ! Two methods of cloud property input are possible: - ! Cloud properties can be input in one of two ways (controlled by input - ! flags inflag, iceflag and liqflag; see text file rrtmg_sw_instructions - ! and subroutine rrtmg_sw_cldprop.f90 for further details): - ! - ! 1) Input cloud fraction, cloud optical depth, single scattering albedo - ! and asymmetry parameter directly (inflgsw = 0) - ! 2) Input cloud fraction and cloud physical properties: ice fracion, - ! ice and liquid particle sizes (inflgsw = 1 or 2); - ! cloud optical properties are calculated by cldprop or cldprmc based - ! on input settings of iceflgsw and liqflgsw - ! - ! Two methods of aerosol property input are possible: - ! Aerosol properties can be input in one of two ways (controlled by input - ! flag iaer, see text file rrtmg_sw_instructions for further details): - ! - ! 1) Input aerosol optical depth, single scattering albedo and asymmetry - ! parameter directly by layer and spectral band (iaer=10) - ! 2) Input aerosol optical depth and 0.55 micron directly by layer and use - ! one or more of six ECMWF aerosol types (iaer=6) - ! - ! - ! ------- Modifications ------- - ! - ! This version of RRTMG_SW has been modified from RRTM_SW to use a reduced - ! set of g-point intervals and a two-stream model for application to GCMs. - ! - !-- Original version (derived from RRTM_SW) - ! 2002: AER. Inc. - !-- Conversion to F90 formatting; addition of 2-stream radiative transfer - ! Feb 2003: J.-J. Morcrette, ECMWF - !-- Additional modifications for GCM application - ! Aug 2003: M. J. Iacono, AER Inc. - !-- Total number of g-points reduced from 224 to 112. Original - ! set of 224 can be restored by exchanging code in module parrrsw.f90 - ! and in file rrtmg_sw_init.f90. - ! Apr 2004: M. J. Iacono, AER, Inc. - !-- Modifications to include output for direct and diffuse - ! downward fluxes. There are output as "true" fluxes without - ! any delta scaling applied. Code can be commented to exclude - ! this calculation in source file rrtmg_sw_spcvrt.f90. - ! Jan 2005: E. J. Mlawer, M. J. Iacono, AER, Inc. - !-- Revised to add McICA capability. - ! Nov 2005: M. J. Iacono, AER, Inc. - !-- Reformatted for consistency with rrtmg_lw. - ! Feb 2007: M. J. Iacono, AER, Inc. - !-- Modifications to formatting to use assumed-shape arrays. - ! Aug 2007: M. J. Iacono, AER, Inc. - !-- Modified to output direct and diffuse fluxes either with or without - ! delta scaling based on setting of idelm flag - ! Dec 2008: M. J. Iacono, AER, Inc. - ! --------- Modules --------- - USE parrrsw, ONLY: jpband - USE parrrsw, ONLY: ngptsw - USE parrrsw, ONLY: nbndsw - USE parrrsw, ONLY: mxmol - ! ------- Declarations - ! ----- Input ----- - integer, intent(in) :: kgen_unit - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - character(len=1024), parameter :: kname ='rrtmg_sw_inatm' - integer, parameter :: maxiter = 100 - - ! chunk identifier - INTEGER, intent(in) :: ncol ! Number of horizontal columns - INTEGER, intent(in) :: nlay ! Number of model layers - INTEGER, intent(inout) :: icld ! Cloud overlap method - ! 0: Clear only - ! 1: Random - ! 2: Maximum/random - ! 3: Maximum - REAL(KIND=r8), intent(in) :: play(:,:) ! Layer pressures (hPa, mb) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: plev(:,:) ! Interface pressures (hPa, mb) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(in) :: tlay(:,:) ! Layer temperatures (K) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: tlev(:,:) ! Interface temperatures (K) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(in) :: tsfc(:) ! Surface temperature (K) - ! Dimensions: (ncol) - REAL(KIND=r8), intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: o2vmr(:,:) ! O2 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio - ! Dimensions: (ncol,nlay) - ! UV/vis surface albedo direct rad - ! Dimensions: (ncol) - ! Near-IR surface albedo direct rad - ! Dimensions: (ncol) - ! UV/vis surface albedo: diffuse rad - ! Dimensions: (ncol) - ! Near-IR surface albedo: diffuse rad - ! Dimensions: (ncol) - INTEGER, intent(in) :: dyofyr ! Day of the year (used to get Earth/Sun - ! distance if adjflx not provided) - REAL(KIND=r8), intent(in) :: adjes ! Flux adjustment for Earth/Sun distance - ! Cosine of solar zenith angle - ! Dimensions: (ncol) - REAL(KIND=r8), intent(in) :: solvar(1:nbndsw) ! Solar constant (Wm-2) scaling per band - INTEGER, intent(in) :: inflgsw ! Flag for cloud optical properties - INTEGER, intent(in) :: iceflgsw ! Flag for ice particle specification - INTEGER, intent(in) :: liqflgsw ! Flag for liquid droplet specification - REAL(KIND=r8), intent(in) :: cldfmcl(:,:,:) ! Cloud fraction - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: taucmcl(:,:,:) ! Cloud optical depth - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: ssacmcl(:,:,:) ! Cloud single scattering albedo - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: asmcmcl(:,:,:) ! Cloud asymmetry parameter - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: fsfcmcl(:,:,:) ! Cloud forward scattering parameter - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: ciwpmcl(:,:,:) ! Cloud ice water path (g/m2) - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: clwpmcl(:,:,:) ! Cloud liquid water path (g/m2) - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: reicmcl(:,:) ! Cloud ice effective radius (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: tauaer(:,:,:) ! Aerosol optical depth (iaer=10 only) - ! Dimensions: (ncol,nlay,nbndsw) - ! (non-delta scaled) - REAL(KIND=r8), intent(in) :: ssaaer(:,:,:) ! Aerosol single scattering albedo (iaer=10 only) - ! Dimensions: (ncol,nlay,nbndsw) - ! (non-delta scaled) - REAL(KIND=r8), intent(in) :: asmaer(:,:,:) ! Aerosol asymmetry parameter (iaer=10 only) - ! Dimensions: (ncol,nlay,nbndsw) - ! (non-delta scaled) - ! real(kind=r8), intent(in) :: ecaer(:,:,:) ! Aerosol optical depth at 0.55 micron (iaer=6 only) - ! Dimensions: (ncol,nlay,naerec) - ! (non-delta scaled) - ! ----- Output ----- - ! Total sky shortwave upward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Total sky shortwave downward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Total sky shortwave radiative heating rate (K/d) - ! Dimensions: (ncol,nlay) - ! Clear sky shortwave upward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Clear sky shortwave downward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Clear sky shortwave radiative heating rate (K/d) - ! Dimensions: (ncol,nlay) - ! Direct downward shortwave flux, UV/vis - ! Diffuse downward shortwave flux, UV/vis - ! Direct downward shortwave flux, near-IR - ! Diffuse downward shortwave flux, near-IR - ! Net shortwave flux, near-IR - ! Net clear sky shortwave flux, near-IR - ! shortwave spectral flux up - ! shortwave spectral flux down - ! ----- Local ----- - ! Control - ! beginning band of calculation - ! ending band of calculation - ! cldprop/cldprmc use flag - ! output option flag (inactive) - INTEGER :: iaer ! aerosol option flag - ! delta-m scaling flag - ! [0 = direct and diffuse fluxes are unscaled] - ! [1 = direct and diffuse fluxes are scaled] - ! (total downward fluxes are always delta scaled) - ! instrumental cosine response flag (inactive) - ! column loop index - ! layer loop index ! jk - ! band loop index ! jsw - ! indices - ! layer loop index - ! value for changing mcica permute seed - ! flag for mcica [0=off, 1=on] - ! epsilon - ! flux to heating conversion ratio - ! Atmosphere - REAL(KIND=r8) :: pavel(ncol,nlay) - REAL(KIND=r8) :: ref_pavel(ncol,nlay) ! layer pressures (mb) - REAL(KIND=r8) :: tavel(ncol,nlay) - REAL(KIND=r8) :: ref_tavel(ncol,nlay) ! layer temperatures (K) - REAL(KIND=r8) :: pz(ncol,0:nlay) - REAL(KIND=r8) :: ref_pz(ncol,0:nlay) ! level (interface) pressures (hPa, mb) - REAL(KIND=r8) :: tz(ncol,0:nlay) - REAL(KIND=r8) :: ref_tz(ncol,0:nlay) ! level (interface) temperatures (K) - REAL(KIND=r8) :: tbound(ncol) - REAL(KIND=r8) :: ref_tbound(ncol) ! surface temperature (K) - REAL(KIND=r8) :: pdp(ncol,nlay) - REAL(KIND=r8) :: ref_pdp(ncol,nlay) ! layer pressure thickness (hPa, mb) - REAL(KIND=r8) :: coldry(ncol,nlay) - REAL(KIND=r8) :: ref_coldry(ncol,nlay) ! dry air column amount - REAL(KIND=r8) :: wkl(ncol,mxmol,nlay) - REAL(KIND=r8) :: ref_wkl(ncol,mxmol,nlay) ! molecular amounts (mol/cm-2) - ! real(kind=r8) :: earth_sun ! function for Earth/Sun distance factor - ! Cosine of solar zenith angle - REAL(KIND=r8) :: adjflux(ncol,jpband) - REAL(KIND=r8) :: ref_adjflux(ncol,jpband) ! adjustment for current Earth/Sun distance - ! real(kind=r8) :: solvar(jpband) ! solar constant scaling factor from rrtmg_sw - ! default value of 1368.22 Wm-2 at 1 AU - ! surface albedo, direct ! zalbp - ! surface albedo, diffuse ! zalbd - REAL(KIND=r8) :: taua(ncol,nlay,nbndsw) - REAL(KIND=r8) :: ref_taua(ncol,nlay,nbndsw) ! Aerosol optical depth - REAL(KIND=r8) :: ssaa(ncol,nlay,nbndsw) - REAL(KIND=r8) :: ref_ssaa(ncol,nlay,nbndsw) ! Aerosol single scattering albedo - REAL(KIND=r8) :: asma(ncol,nlay,nbndsw) - REAL(KIND=r8) :: ref_asma(ncol,nlay,nbndsw) ! Aerosol asymmetry parameter - ! Atmosphere - setcoef - ! tropopause layer index - ! - ! - ! - ! - ! - ! column amount (h2o) - ! column amount (co2) - ! column amount (o3) - ! column amount (n2o) - ! column amount (ch4) - ! column amount (o2) - ! column amount - ! column amount - ! - ! Atmosphere/clouds - cldprop - ! number of cloud spectral bands - INTEGER :: inflag(ncol) - INTEGER :: ref_inflag(ncol) ! flag for cloud property method - INTEGER :: iceflag(ncol) - INTEGER :: ref_iceflag(ncol) ! flag for ice cloud properties - INTEGER :: liqflag(ncol) - INTEGER :: ref_liqflag(ncol) ! flag for liquid cloud properties - ! real(kind=r8) :: cldfrac(nlay) ! layer cloud fraction - ! real(kind=r8) :: tauc(nlay) ! cloud optical depth (non-delta scaled) - ! real(kind=r8) :: ssac(nlay) ! cloud single scattering albedo (non-delta scaled) - ! real(kind=r8) :: asmc(nlay) ! cloud asymmetry parameter (non-delta scaled) - ! real(kind=r8) :: ciwp(nlay) ! cloud ice water path - ! real(kind=r8) :: clwp(nlay) ! cloud liquid water path - ! real(kind=r8) :: rei(nlay) ! cloud ice particle size - ! real(kind=r8) :: rel(nlay) ! cloud liquid particle size - ! real(kind=r8) :: taucloud(nlay,jpband) ! cloud optical depth - ! real(kind=r8) :: taucldorig(nlay,jpband) ! cloud optical depth (non-delta scaled) - ! real(kind=r8) :: ssacloud(nlay,jpband) ! cloud single scattering albedo - ! real(kind=r8) :: asmcloud(nlay,jpband) ! cloud asymmetry parameter - ! Atmosphere/clouds - cldprmc [mcica] - REAL(KIND=r8) :: cldfmc(ncol,ngptsw,nlay) - REAL(KIND=r8) :: ref_cldfmc(ncol,ngptsw,nlay) ! cloud fraction [mcica] - REAL(KIND=r8) :: ciwpmc(ncol,ngptsw,nlay) - REAL(KIND=r8) :: ref_ciwpmc(ncol,ngptsw,nlay) ! cloud ice water path [mcica] - REAL(KIND=r8) :: clwpmc(ncol,ngptsw,nlay) - REAL(KIND=r8) :: ref_clwpmc(ncol,ngptsw,nlay) ! cloud liquid water path [mcica] - REAL(KIND=r8) :: relqmc(ncol,nlay) - REAL(KIND=r8) :: ref_relqmc(ncol,nlay) ! liquid particle size (microns) - REAL(KIND=r8) :: reicmc(ncol,nlay) - REAL(KIND=r8) :: ref_reicmc(ncol,nlay) ! ice particle effective radius (microns) - REAL(KIND=r8) :: dgesmc(ncol,nlay) - REAL(KIND=r8) :: ref_dgesmc(ncol,nlay) ! ice particle generalized effective size (microns) - REAL(KIND=r8) :: taucmc(ncol,ngptsw,nlay) - REAL(KIND=r8) :: ref_taucmc(ncol,ngptsw,nlay) ! cloud optical depth [mcica] - ! unscaled cloud optical depth [mcica] - REAL(KIND=r8) :: ssacmc(ncol,ngptsw,nlay) - REAL(KIND=r8) :: ref_ssacmc(ncol,ngptsw,nlay) ! cloud single scattering albedo [mcica] - REAL(KIND=r8) :: asmcmc(ncol,ngptsw,nlay) - REAL(KIND=r8) :: ref_asmcmc(ncol,ngptsw,nlay) ! cloud asymmetry parameter [mcica] - REAL(KIND=r8) :: fsfcmc(ncol,ngptsw,nlay) - REAL(KIND=r8) :: ref_fsfcmc(ncol,ngptsw,nlay) ! cloud forward scattering fraction [mcica] - ! Atmosphere/clouds/aerosol - spcvrt,spcvmc - ! cloud optical depth - ! unscaled cloud optical depth - ! cloud asymmetry parameter - ! (first moment of phase function) - ! cloud single scattering albedo - ! total aerosol optical depth - ! total aerosol asymmetry parameter - ! total aerosol single scattering albedo - ! cloud fraction [mcica] - ! cloud optical depth [mcica] - ! unscaled cloud optical depth [mcica] - ! cloud asymmetry parameter [mcica] - ! cloud single scattering albedo [mcica] - ! temporary upward shortwave flux (w/m2) - ! temporary downward shortwave flux (w/m2) - ! temporary clear sky upward shortwave flux (w/m2) - ! temporary clear sky downward shortwave flux (w/m2) - ! temporary downward direct shortwave flux (w/m2) - ! temporary clear sky downward direct shortwave flux (w/m2) - ! temporary UV downward shortwave flux (w/m2) - ! temporary clear sky UV downward shortwave flux (w/m2) - ! temporary UV downward direct shortwave flux (w/m2) - ! temporary clear sky UV downward direct shortwave flux (w/m2) - ! temporary near-IR downward shortwave flux (w/m2) - ! temporary clear sky near-IR downward shortwave flux (w/m2) - ! temporary near-IR downward direct shortwave flux (w/m2) - ! temporary clear sky near-IR downward direct shortwave flux (w/m2) - ! Added for near-IR flux diagnostic - ! temporary near-IR downward shortwave flux (w/m2) - ! temporary clear sky near-IR downward shortwave flux (w/m2) - ! Optional output fields - ! Total sky shortwave net flux (W/m2) - ! Clear sky shortwave net flux (W/m2) - ! Direct downward shortwave surface flux - ! Diffuse downward shortwave surface flux - ! Total sky downward shortwave flux, UV/vis - ! Total sky downward shortwave flux, near-IR - ! temporary upward shortwave flux spectral (w/m2) - ! temporary downward shortwave flux spectral (w/m2) - ! Output - inactive - ! real(kind=r8) :: zuvfu(nlay+2) ! temporary upward UV shortwave flux (w/m2) - ! real(kind=r8) :: zuvfd(nlay+2) ! temporary downward UV shortwave flux (w/m2) - ! real(kind=r8) :: zuvcu(nlay+2) ! temporary clear sky upward UV shortwave flux (w/m2) - ! real(kind=r8) :: zuvcd(nlay+2) ! temporary clear sky downward UV shortwave flux (w/m2) - ! real(kind=r8) :: zvsfu(nlay+2) ! temporary upward visible shortwave flux (w/m2) - ! real(kind=r8) :: zvsfd(nlay+2) ! temporary downward visible shortwave flux (w/m2) - ! real(kind=r8) :: zvscu(nlay+2) ! temporary clear sky upward visible shortwave flux (w/m2) - ! real(kind=r8) :: zvscd(nlay+2) ! temporary clear sky downward visible shortwave flux (w/m2) - ! real(kind=r8) :: znifu(nlay+2) ! temporary upward near-IR shortwave flux (w/m2) - ! real(kind=r8) :: znifd(nlay+2) ! temporary downward near-IR shortwave flux (w/m2) - ! real(kind=r8) :: znicu(nlay+2) ! temporary clear sky upward near-IR shortwave flux (w/m2) - ! real(kind=r8) :: znicd(nlay+2) ! temporary clear sky downward near-IR shortwave flux (w/m2) - ! Initializations - ! In a GCM with or without McICA, set nlon to the longitude dimension - ! - ! Set imca to select calculation type: - ! imca = 0, use standard forward model calculation (clear and overcast only) - ! imca = 1, use McICA for Monte Carlo treatment of sub-grid cloud variability - ! (clear, overcast or partial cloud conditions) - ! *** This version uses McICA (imca = 1) *** - ! Set icld to select of clear or cloud calculation and cloud - ! overlap method (read by subroutine readprof from input file INPUT_RRTM): - ! icld = 0, clear only - ! icld = 1, with clouds using random cloud overlap (McICA only) - ! icld = 2, with clouds using maximum/random cloud overlap (McICA only) - ! icld = 3, with clouds using maximum cloud overlap (McICA only) - ! Set iaer to select aerosol option - ! iaer = 0, no aerosols - ! iaer = 6, use six ECMWF aerosol types - ! input aerosol optical depth at 0.55 microns for each aerosol type (ecaer) - ! iaer = 10, input total aerosol optical depth, single scattering albedo - ! and asymmetry parameter (tauaer, ssaaer, asmaer) directly - ! Set idelm to select between delta-M scaled or unscaled output direct and diffuse fluxes - ! NOTE: total downward fluxes are always delta scaled - ! idelm = 0, output direct and diffuse flux components are not delta scaled - ! (direct flux does not include forward scattering peak) - ! idelm = 1, output direct and diffuse flux components are delta scaled (default) - ! (direct flux includes part or most of forward scattering peak) - ! Call model and data initialization, compute lookup tables, perform - ! reduction of g-points from 224 to 112 for input absorption - ! coefficient data and other arrays. - ! - ! In a GCM this call should be placed in the model initialization - ! area, since this has to be called only once. - ! call rrtmg_sw_ini - ! This is the main longitude/column loop in RRTMG. - ! Modify to loop over all columns (nlon) or over daylight columns - !JMD #define OLD_INATM_SW 1 - tolerance = 1.E-14 - CALL kgen_init_check(check_status, tolerance) - READ(UNIT=kgen_unit) iaer - READ(UNIT=kgen_unit) pavel - READ(UNIT=kgen_unit) tavel - READ(UNIT=kgen_unit) pz - READ(UNIT=kgen_unit) tz - READ(UNIT=kgen_unit) tbound - READ(UNIT=kgen_unit) pdp - READ(UNIT=kgen_unit) coldry - READ(UNIT=kgen_unit) wkl - READ(UNIT=kgen_unit) adjflux - READ(UNIT=kgen_unit) taua - READ(UNIT=kgen_unit) ssaa - READ(UNIT=kgen_unit) asma - READ(UNIT=kgen_unit) inflag - READ(UNIT=kgen_unit) iceflag - READ(UNIT=kgen_unit) liqflag - READ(UNIT=kgen_unit) cldfmc - READ(UNIT=kgen_unit) ciwpmc - READ(UNIT=kgen_unit) clwpmc - READ(UNIT=kgen_unit) relqmc - READ(UNIT=kgen_unit) reicmc - READ(UNIT=kgen_unit) dgesmc - READ(UNIT=kgen_unit) taucmc - READ(UNIT=kgen_unit) ssacmc - READ(UNIT=kgen_unit) asmcmc - READ(UNIT=kgen_unit) fsfcmc - - READ(UNIT=kgen_unit) ref_pavel - READ(UNIT=kgen_unit) ref_tavel - READ(UNIT=kgen_unit) ref_pz - READ(UNIT=kgen_unit) ref_tz - READ(UNIT=kgen_unit) ref_tbound - READ(UNIT=kgen_unit) ref_pdp - READ(UNIT=kgen_unit) ref_coldry - READ(UNIT=kgen_unit) ref_wkl - READ(UNIT=kgen_unit) ref_adjflux - READ(UNIT=kgen_unit) ref_taua - READ(UNIT=kgen_unit) ref_ssaa - READ(UNIT=kgen_unit) ref_asma - READ(UNIT=kgen_unit) ref_inflag - READ(UNIT=kgen_unit) ref_iceflag - READ(UNIT=kgen_unit) ref_liqflag - READ(UNIT=kgen_unit) ref_cldfmc - READ(UNIT=kgen_unit) ref_ciwpmc - READ(UNIT=kgen_unit) ref_clwpmc - READ(UNIT=kgen_unit) ref_relqmc - READ(UNIT=kgen_unit) ref_reicmc - READ(UNIT=kgen_unit) ref_dgesmc - READ(UNIT=kgen_unit) ref_taucmc - READ(UNIT=kgen_unit) ref_ssacmc - READ(UNIT=kgen_unit) ref_asmcmc - READ(UNIT=kgen_unit) ref_fsfcmc - - - ! call to kernel - call inatm_sw (1,ncol,nlay, icld, iaer, & - play, plev, tlay, tlev, tsfc, & - h2ovmr, o3vmr, co2vmr, ch4vmr, o2vmr, n2ovmr, adjes, dyofyr, solvar, & - inflgsw, iceflgsw, liqflgsw, & - cldfmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl, ciwpmcl, clwpmcl, & - reicmcl, relqmcl, tauaer, ssaaer, asmaer, & - pavel, pz, pdp, tavel, tz, tbound, coldry, wkl, & - adjflux, inflag, iceflag, liqflag, cldfmc, taucmc, & - ssacmc, asmcmc, fsfcmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, & - taua, ssaa, asma) - ! kernel verification for output variables - CALL kgen_verify_real_r8_dim2( "pavel", check_status, pavel, ref_pavel) - CALL kgen_verify_real_r8_dim2( "tavel", check_status, tavel, ref_tavel) - CALL kgen_verify_real_r8_dim2( "pz", check_status, pz, ref_pz) - CALL kgen_verify_real_r8_dim2( "tz", check_status, tz, ref_tz) - CALL kgen_verify_real_r8_dim1( "tbound", check_status, tbound, ref_tbound) - CALL kgen_verify_real_r8_dim2( "pdp", check_status, pdp, ref_pdp) - CALL kgen_verify_real_r8_dim2( "coldry", check_status, coldry, ref_coldry) - CALL kgen_verify_real_r8_dim3( "wkl", check_status, wkl, ref_wkl) - CALL kgen_verify_real_r8_dim2( "adjflux", check_status, adjflux, ref_adjflux) - CALL kgen_verify_real_r8_dim3( "taua", check_status, taua, ref_taua) - CALL kgen_verify_real_r8_dim3( "ssaa", check_status, ssaa, ref_ssaa) - CALL kgen_verify_real_r8_dim3( "asma", check_status, asma, ref_asma) - CALL kgen_verify_integer_4_dim1( "inflag", check_status, inflag, ref_inflag) - CALL kgen_verify_integer_4_dim1( "iceflag", check_status, iceflag, ref_iceflag) - CALL kgen_verify_integer_4_dim1( "liqflag", check_status, liqflag, ref_liqflag) - CALL kgen_verify_real_r8_dim3( "cldfmc", check_status, cldfmc, ref_cldfmc) - CALL kgen_verify_real_r8_dim3( "ciwpmc", check_status, ciwpmc, ref_ciwpmc) - CALL kgen_verify_real_r8_dim3( "clwpmc", check_status, clwpmc, ref_clwpmc) - CALL kgen_verify_real_r8_dim2( "relqmc", check_status, relqmc, ref_relqmc) - CALL kgen_verify_real_r8_dim2( "reicmc", check_status, reicmc, ref_reicmc) - CALL kgen_verify_real_r8_dim2( "dgesmc", check_status, dgesmc, ref_dgesmc) - CALL kgen_verify_real_r8_dim3( "taucmc", check_status, taucmc, ref_taucmc) - CALL kgen_verify_real_r8_dim3( "ssacmc", check_status, ssacmc, ref_ssacmc) - CALL kgen_verify_real_r8_dim3( "asmcmc", check_status, asmcmc, ref_asmcmc) - CALL kgen_verify_real_r8_dim3( "fsfcmc", check_status, fsfcmc, ref_fsfcmc) - CALL kgen_print_check("inatm_sw", check_status) - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,maxiter - CALL inatm_sw(1, ncol, nlay, icld, iaer, play, plev, tlay, tlev, tsfc, h2ovmr, o3vmr, co2vmr, & -ch4vmr, o2vmr, n2ovmr, adjes, dyofyr, solvar, inflgsw, iceflgsw, liqflgsw, cldfmcl, taucmcl, ssacmcl, asmcmcl, & -fsfcmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, tauaer, ssaaer, asmaer, pavel, pz, pdp, tavel, tz, tbound, coldry, & -wkl, adjflux, inflag, iceflag, liqflag, cldfmc, taucmc, ssacmc, asmcmc, fsfcmc, ciwpmc, clwpmc, reicmc, dgesmc, & -relqmc, taua, ssaa, asma) - END DO - CALL system_clock(stop_clock, rate_clock) - WRITE(*,*) - PRINT *, TRIM(kname), ": Time per call (usec): ", 1.0e6*(stop_clock - start_clock)/REAL(rate_clock*real(maxiter,kind=r8)) - ! For cloudy atmosphere, use cldprop to set cloud optical properties based on - ! input cloud physical properties. Select method based on choices described - ! in cldprop. Cloud fraction, water path, liquid droplet and ice particle - ! effective radius must be passed in cldprop. Cloud fraction and cloud - ! optical properties are transferred to rrtmg_sw arrays in cldprop. - ! Calculate coefficients for the temperature and pressure dependence of the - ! molecular absorption coefficients by interpolating data from stored - !do iplon = 1, ncol ! reference atmospheres. - ! call setcoef_sw(nlay, pavel(iplon,:), tavel(iplon,:), pz(iplon,:), tz(iplon,:), tbound(iplon), coldry(iplon,:), wkl( - ! iplon,:,:), & - ! laytrop(iplon), layswtch(iplon), laylow(iplon), jp(iplon,:), jt(iplon,:), jt1(iplon,:), & - ! co2mult(iplon,:), colch4(iplon,:), colco2(iplon,:), colh2o(iplon,:), colmol(iplon,:), coln2o(iplon,:) - ! , & - ! colo2(iplon,:), colo3(iplon,:), fac00(iplon,:), fac01(iplon,:), fac10(iplon,:), fac11(iplon,:), & - ! selffac(iplon,:), selffrac(iplon,:), indself(iplon,:), forfac(iplon,:), forfrac(iplon,:), indfor( - ! iplon,:)) - !end do - ! Cosine of the solar zenith angle - ! Prevent using value of zero; ideally, SW model is not called from host model when sun - ! is below horizon - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_r8_dim2(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim2 - - SUBROUTINE kgen_read_real_r8_dim1(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim1 - - SUBROUTINE kgen_read_real_r8_dim3(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2,idx3 - INTEGER, DIMENSION(2,3) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim3 - - SUBROUTINE kgen_read_integer_4_dim1(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - integer(KIND=4), INTENT(OUT), ALLOCATABLE, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_integer_4_dim1 - - - ! verify subroutines - SUBROUTINE kgen_verify_real_r8_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim2 - - SUBROUTINE kgen_verify_real_r8_dim1( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1))) - allocate(temp2(SIZE(var,dim=1))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim1 - - SUBROUTINE kgen_verify_real_r8_dim3( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim3 - - SUBROUTINE kgen_verify_integer_4_dim1( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in), DIMENSION(:) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - end if - - check_status%numFatal = check_status%numFatal+1 - END IF - END SUBROUTINE kgen_verify_integer_4_dim1 - - END SUBROUTINE rrtmg_sw - !************************************************************************* - - real(kind=r8) FUNCTION earth_sun(idn) - !************************************************************************* - ! - ! Purpose: Function to calculate the correction factor of Earth's orbit - ! for current day of the year - ! idn : Day of the year - ! earth_sun : square of the ratio of mean to actual Earth-Sun distance - ! ------- Modules ------- - USE rrsw_con, ONLY: pi - INTEGER, intent(in) :: idn - REAL(KIND=r8) :: gamma - gamma = 2._r8*pi*(idn-1)/365._r8 - ! Use Iqbal's equation 1.2.1 - earth_sun = 1.000110_r8 + .034221_r8 * cos(gamma) + .001289_r8 * sin(gamma) + & - .000719_r8 * cos(2._r8*gamma) + .000077_r8 * sin(2._r8*gamma) - END FUNCTION earth_sun - !*************************************************************************** - - SUBROUTINE inatm_sw(istart, iend, nlay, icld, iaer, play, plev, tlay, tlev, tsfc, h2ovmr, o3vmr, co2vmr, ch4vmr, o2vmr, & - n2ovmr, adjes, dyofyr, solvar, inflgsw, iceflgsw, liqflgsw, cldfmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl, ciwpmcl, clwpmcl,& - reicmcl, relqmcl, tauaer, ssaaer, asmaer, pavel, pz, pdp, tavel, tz, tbound, coldry, wkl, adjflux, inflag, iceflag, & - liqflag, cldfmc, taucmc, ssacmc, asmcmc, fsfcmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, taua, ssaa, asma) - !*************************************************************************** - ! - ! Input atmospheric profile from GCM, and prepare it for use in RRTMG_SW. - ! Set other RRTMG_SW input parameters. - ! - !*************************************************************************** - ! --------- Modules ---------- - USE parrrsw, ONLY: jpb1 - USE parrrsw, ONLY: jpb2 - USE parrrsw, ONLY: nmol - USE parrrsw, ONLY: nbndsw - USE parrrsw, ONLY: ngptsw - USE rrsw_con, ONLY: grav - USE rrsw_con, ONLY: avogad - ! ------- Declarations ------- - ! ----- Input ----- - INTEGER, intent(in) :: istart ! column start index - INTEGER, intent(in) :: iend ! column end index - INTEGER, intent(in) :: nlay ! number of model layers - INTEGER, intent(in) :: icld ! clear/cloud and cloud overlap flag - INTEGER, intent(in) :: iaer ! aerosol option flag - REAL(KIND=r8), intent(in) :: play(:,:) ! Layer pressures (hPa, mb) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: plev(:,:) ! Interface pressures (hPa, mb) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(in) :: tlay(:,:) ! Layer temperatures (K) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: tlev(:,:) ! Interface temperatures (K) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(in) :: tsfc(:) ! Surface temperature (K) - ! Dimensions: (ncol) - REAL(KIND=r8), intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: o2vmr(:,:) ! O2 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio - ! Dimensions: (ncol,nlay) - INTEGER, intent(in) :: dyofyr ! Day of the year (used to get Earth/Sun - ! distance if adjflx not provided) - REAL(KIND=r8), intent(in) :: adjes ! Flux adjustment for Earth/Sun distance - REAL(KIND=r8), intent(in) :: solvar(jpb1:jpb2) ! Solar constant (Wm-2) scaling per band - INTEGER, intent(in) :: inflgsw ! Flag for cloud optical properties - INTEGER, intent(in) :: iceflgsw ! Flag for ice particle specification - INTEGER, intent(in) :: liqflgsw ! Flag for liquid droplet specification - REAL(KIND=r8), intent(in) :: cldfmcl(:,:,:) ! Cloud fraction - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: taucmcl(:,:,:) ! Cloud optical depth (optional) - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: ssacmcl(:,:,:) ! Cloud single scattering albedo - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: asmcmcl(:,:,:) ! Cloud asymmetry parameter - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: fsfcmcl(:,:,:) ! Cloud forward scattering fraction - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: ciwpmcl(:,:,:) ! Cloud ice water path (g/m2) - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: clwpmcl(:,:,:) ! Cloud liquid water path (g/m2) - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: reicmcl(:,:) ! Cloud ice effective radius (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: tauaer(:,:,:) ! Aerosol optical depth - ! Dimensions: (ncol,nlay,nbndsw) - REAL(KIND=r8), intent(in) :: ssaaer(:,:,:) ! Aerosol single scattering albedo - ! Dimensions: (ncol,nlay,nbndsw) - REAL(KIND=r8), intent(in) :: asmaer(:,:,:) ! Aerosol asymmetry parameter - ! Dimensions: (ncol,nlay,nbndsw) - ! Atmosphere - REAL(KIND=r8), intent(out) :: pavel(:,:) ! layer pressures (mb) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: tavel(:,:) ! layer temperatures (K) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: pz(:,0:) ! level (interface) pressures (hPa, mb) - ! Dimensions: (ncol,0:nlay) - REAL(KIND=r8), intent(out) :: tz(:,0:) ! level (interface) temperatures (K) - ! Dimensions: (ncol,0:nlay) - REAL(KIND=r8), intent(out) :: tbound(:) ! surface temperature (K) - ! Dimensions: (ncol) - REAL(KIND=r8), intent(out) :: pdp(:,:) ! layer pressure thickness (hPa, mb) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: coldry(:,:) ! dry air column density (mol/cm2) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: wkl(:,:,:) ! molecular amounts (mol/cm-2) - ! Dimensions: (ncol,mxmol,nlay) - REAL(KIND=r8), intent(out) :: adjflux(:,:) ! adjustment for current Earth/Sun distance - ! Dimensions: (ncol,jpband) - ! real(kind=r8), intent(out) :: solvar(:) ! solar constant scaling factor from rrtmg_sw - ! Dimensions: (jpband) - ! default value of 1368.22 Wm-2 at 1 AU - REAL(KIND=r8), intent(out) :: taua(:,:,:) ! Aerosol optical depth - ! Dimensions: (ncol,nlay,nbndsw) - REAL(KIND=r8), intent(out) :: ssaa(:,:,:) ! Aerosol single scattering albedo - ! Dimensions: (ncol,nlay,nbndsw) - REAL(KIND=r8), intent(out) :: asma(:,:,:) ! Aerosol asymmetry parameter - ! Dimensions: (ncol,nlay,nbndsw) - ! Atmosphere/clouds - cldprop - INTEGER, intent(out) :: inflag(:) ! flag for cloud property method - ! Dimensions: (ncol) - INTEGER, intent(out) :: iceflag(:) ! flag for ice cloud properties - ! Dimensions: (ncol) - INTEGER, intent(out) :: liqflag(:) ! flag for liquid cloud properties - ! Dimensions: (ncol) - REAL(KIND=r8), intent(out) :: cldfmc(:,:,:) ! layer cloud fraction - ! Dimensions: (ncol,ngptsw,nlay) - REAL(KIND=r8), intent(out) :: taucmc(:,:,:) ! cloud optical depth (non-delta scaled) - ! Dimensions: (ncol,ngptsw,nlay) - REAL(KIND=r8), intent(out) :: ssacmc(:,:,:) ! cloud single scattering albedo (non-delta-scaled) - ! Dimensions: (ncol,ngptsw,nlay) - REAL(KIND=r8), intent(out) :: asmcmc(:,:,:) ! cloud asymmetry parameter (non-delta scaled) - REAL(KIND=r8), intent(out) :: fsfcmc(:,:,:) ! cloud forward scattering fraction (non-delta scaled) - ! Dimensions: (ncol,ngptsw,nlay) - REAL(KIND=r8), intent(out) :: ciwpmc(:,:,:) ! cloud ice water path - ! Dimensions: (ncol,ngptsw,nlay) - REAL(KIND=r8), intent(out) :: clwpmc(:,:,:) ! cloud liquid water path - ! Dimensions: (ncol,ngptsw,nlay) - REAL(KIND=r8), intent(out) :: reicmc(:,:) ! cloud ice particle effective radius - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: dgesmc(:,:) ! cloud ice particle effective radius - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: relqmc(:,:) ! cloud liquid particle size - ! Dimensions: (ncol,nlay) - ! ----- Local ----- - REAL(KIND=r8), parameter :: amd = 28.9660_r8 ! Effective molecular weight of dry air (g/mol) - REAL(KIND=r8), parameter :: amw = 18.0160_r8 ! Molecular weight of water vapor (g/mol) - ! real(kind=r8), parameter :: amc = 44.0098_r8 ! Molecular weight of carbon dioxide (g/mol) - ! real(kind=r8), parameter :: amo = 47.9998_r8 ! Molecular weight of ozone (g/mol) - ! real(kind=r8), parameter :: amo2 = 31.9999_r8 ! Molecular weight of oxygen (g/mol) - ! real(kind=r8), parameter :: amch4 = 16.0430_r8 ! Molecular weight of methane (g/mol) - ! real(kind=r8), parameter :: amn2o = 44.0128_r8 ! Molecular weight of nitrous oxide (g/mol) - ! Set molecular weight ratios (for converting mmr to vmr) - ! e.g. h2ovmr = h2ommr * amdw) - ! Molecular weight of dry air / water vapor - ! Molecular weight of dry air / carbon dioxide - ! Molecular weight of dry air / ozone - ! Molecular weight of dry air / methane - ! Molecular weight of dry air / nitrous oxide - ! Stefan-Boltzmann constant (W/m2K4) - INTEGER :: ib - INTEGER :: l - INTEGER :: imol - INTEGER :: iplon - INTEGER :: ig ! Loop indices - REAL(KIND=r8) :: amm ! - REAL(KIND=r8) :: adjflx ! flux adjustment for Earth/Sun distance - ! real(kind=r8) :: earth_sun ! function for Earth/Sun distance adjustment - ! real(kind=r8) :: solar_band_irrad(jpb1:jpb2) ! rrtmg assumed-solar irradiance in each sw band - ! Initialize all molecular amounts to zero here, then pass input amounts - ! into RRTM array WKL below. - ! Set flux adjustment for current Earth/Sun distance (two options). - ! 1) Use Earth/Sun distance flux adjustment provided by GCM (input as adjes); - adjflx = adjes - ! - ! 2) Calculate Earth/Sun distance from DYOFYR, the cumulative day of the year. - ! (Set adjflx to 1. to use constant Earth/Sun distance of 1 AU). - if (dyofyr .gt. 0) then - adjflx = earth_sun(dyofyr) - endif - ! Set incoming solar flux adjustment to include adjustment for - ! current Earth/Sun distance (ADJFLX) and scaling of default internal - ! solar constant (rrsw_scon = 1368.22 Wm-2) by band (SOLVAR). SOLVAR can be set - ! to a single scaling factor as needed, or to a different value in each - ! band, which may be necessary for paleoclimate simulations. - ! - do iplon=istart,iend - adjflux(iplon,:) = 0._r8 - do ib = jpb1,jpb2 - adjflux(iplon,ib) = adjflx * solvar(ib) - enddo - ! Set surface temperature. - tbound(iplon) = tsfc(iplon) - ! Install input GCM arrays into RRTMG_SW arrays for pressure, temperature, - ! and molecular amounts. - ! Pressures are input in mb, or are converted to mb here. - ! Molecular amounts are input in volume mixing ratio, or are converted from - ! mass mixing ratio (or specific humidity for h2o) to volume mixing ratio - ! here. These are then converted to molecular amount (molec/cm2) below. - ! The dry air column COLDRY (in molec/cm2) is calculated from the level - ! pressures, pz (in mb), based on the hydrostatic equation and includes a - ! correction to account for h2o in the layer. The molecular weight of moist - ! air (amm) is calculated for each layer. - ! Note: In RRTMG, layer indexing goes from bottom to top, and coding below - ! assumes GCM input fields are also bottom to top. Input layer indexing - ! from GCM fields should be reversed here if necessary. - pz(iplon,0) = plev(iplon,nlay+1) - tz(iplon,0) = tlev(iplon,nlay+1) - do l = 1, nlay - pavel(iplon,l) = play(iplon,nlay-l+1) - tavel(iplon,l) = tlay(iplon,nlay-l+1) - pz(iplon,l) = plev(iplon,nlay-l+1) - tz(iplon,l) = tlev(iplon,nlay-l+1) - pdp(iplon,l) = pz(iplon,l-1) - pz(iplon,l) - ! For h2o input in vmr: - wkl(iplon,1,l) = h2ovmr(iplon,nlay-l+1) - ! For h2o input in mmr: - ! wkl(1,l) = h2o(iplon,nlayers-l)*amdw - ! For h2o input in specific humidity; - ! wkl(1,l) = (h2o(iplon,nlayers-l)/(1._r8 - h2o(iplon,nlayers-l)))*amdw - wkl(iplon,2,l) = co2vmr(iplon,nlay-l+1) - wkl(iplon,3,l) = o3vmr(iplon,nlay-l+1) - wkl(iplon,4,l) = n2ovmr(iplon,nlay-l+1) - wkl(iplon,5,l) = 0._r8 - wkl(iplon,6,l) = ch4vmr(iplon,nlay-l+1) - wkl(iplon,7,l) = o2vmr(iplon,nlay-l+1) - amm = (1._r8 - wkl(iplon,1,l)) * amd + wkl(iplon,1,l) * amw - coldry(iplon,l) = (pz(iplon,l-1)-pz(iplon,l)) * 1.e3_r8 * avogad / & - (1.e2_r8 * grav * amm * (1._r8 + wkl(iplon,1,l))) - enddo - coldry(iplon,nlay) = (pz(iplon,nlay-1)) * 1.e3_r8 * avogad / & - (1.e2_r8 * grav * amm * (1._r8 + wkl(iplon,1,nlay-1))) - ! At this point all molecular amounts in wkl are in volume mixing ratio; - ! convert to molec/cm2 based on coldry for use in rrtm. - do l = 1, nlay - do imol = 1, nmol - wkl(iplon,imol,l) = coldry(iplon,l) * wkl(iplon,imol,l) - enddo - enddo - ! Transfer aerosol optical properties to RRTM variables; - ! modify to reverse layer indexing here if necessary. - if (iaer .ge. 1) then - do l = 1, nlay-1 - do ib = 1, nbndsw - taua(iplon,l,ib) = tauaer(iplon,nlay-l,ib) - ssaa(iplon,l,ib) = ssaaer(iplon,nlay-l,ib) - asma(iplon,l,ib) = asmaer(iplon,nlay-l,ib) - enddo - enddo - endif - ! Transfer cloud fraction and cloud optical properties to RRTM variables; - ! modify to reverse layer indexing here if necessary. - if (icld .ge. 1) then - inflag(iplon) = inflgsw - iceflag(iplon) = iceflgsw - liqflag(iplon) = liqflgsw - ! Move incoming GCM cloud arrays to RRTMG cloud arrays. - ! For GCM input, incoming reice is in effective radius; for Fu parameterization (iceflag = 3) - ! convert effective radius to generalized effective size using method of Mitchell, JAS, 2002: - do l = 1, nlay-1 - do ig = 1, ngptsw - cldfmc(iplon,ig,l) = cldfmcl(ig,iplon,nlay-l) - taucmc(iplon,ig,l) = taucmcl(ig,iplon,nlay-l) - ssacmc(iplon,ig,l) = ssacmcl(ig,iplon,nlay-l) - asmcmc(iplon,ig,l) = asmcmcl(ig,iplon,nlay-l) - fsfcmc(iplon,ig,l) = fsfcmcl(ig,iplon,nlay-l) - ciwpmc(iplon,ig,l) = ciwpmcl(ig,iplon,nlay-l) - clwpmc(iplon,ig,l) = clwpmcl(ig,iplon,nlay-l) - enddo - reicmc(iplon,l) = reicmcl(iplon,nlay-l) - if (iceflag(iplon) .eq. 3) then - dgesmc(iplon,l) = 1.5396_r8 * reicmcl(iplon,nlay-l) - endif - relqmc(iplon,l) = relqmcl(iplon,nlay-l) - enddo - ! If an extra layer is being used in RRTMG, set all cloud properties to zero in the extra layer. - cldfmc(iplon,:,nlay) = 0.0_r8 - taucmc(iplon,:,nlay) = 0.0_r8 - ssacmc(iplon,:,nlay) = 1.0_r8 - asmcmc(iplon,:,nlay) = 0.0_r8 - fsfcmc(iplon,:,nlay) = 0.0_r8 - ciwpmc(iplon,:,nlay) = 0.0_r8 - clwpmc(iplon,:,nlay) = 0.0_r8 - reicmc(iplon,nlay) = 0.0_r8 - dgesmc(iplon,nlay) = 0.0_r8 - relqmc(iplon,nlay) = 0.0_r8 - taua(iplon,nlay,:) = 0.0_r8 - ssaa(iplon,nlay,:) = 1.0_r8 - asma(iplon,nlay,:) = 0.0_r8 - endif - enddo - END SUBROUTINE inatm_sw - END MODULE rrtmg_sw_rad diff --git a/test/ncar_kernels/PORT_sw_inatm/src/shr_kind_mod.f90 b/test/ncar_kernels/PORT_sw_inatm/src/shr_kind_mod.f90 deleted file mode 100644 index 868a2c0e7c..0000000000 --- a/test/ncar_kernels/PORT_sw_inatm/src/shr_kind_mod.f90 +++ /dev/null @@ -1,26 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : shr_kind_mod.f90 -! Generated at: 2015-07-27 00:31:37 -! KGEN version: 0.4.13 - - - - MODULE shr_kind_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - PUBLIC - INTEGER, parameter :: shr_kind_r8 = selected_real_kind(12) ! 8 byte real - ! 4 byte real - ! native real - ! 8 byte integer - ! 4 byte integer - ! native integer - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE shr_kind_mod diff --git a/test/ncar_kernels/PORT_sw_rad/CESM_license.txt b/test/ncar_kernels/PORT_sw_rad/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/PORT_sw_rad/data/rad_rrtmg_sw.1 b/test/ncar_kernels/PORT_sw_rad/data/rad_rrtmg_sw.1 deleted file mode 100644 index af3a3fb65e..0000000000 Binary files a/test/ncar_kernels/PORT_sw_rad/data/rad_rrtmg_sw.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_rad/data/rad_rrtmg_sw.2 b/test/ncar_kernels/PORT_sw_rad/data/rad_rrtmg_sw.2 deleted file mode 100644 index e6500f8e9b..0000000000 Binary files a/test/ncar_kernels/PORT_sw_rad/data/rad_rrtmg_sw.2 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_rad/inc/t1.mk b/test/ncar_kernels/PORT_sw_rad/inc/t1.mk deleted file mode 100644 index 292f166a5d..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/inc/t1.mk +++ /dev/null @@ -1,183 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# Intel default flags -# -# FC_FLAGS := -O1 -# -FC_FLAGS := $(OPT) - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - -# Makefile for KGEN-generated kernel - -ALL_OBJS := kernel_driver.o radiation.o kgen_utils.o radsw.o rrsw_kg28.o rrtmg_state.o rrsw_kg25.o rrsw_kg19.o rrtmg_sw_reftra.o rrsw_cld.o parrrsw.o physics_types.o rrsw_tbl.o rrtmg_sw_rad.o rrsw_kg23.o cmparray_mod.o rrsw_con.o rrsw_wvn.o rrsw_kg27.o rrsw_ref.o rrsw_kg24.o rrsw_kg16.o rrsw_vsn.o scamMod.o constituents.o shr_const_mod.o shr_kind_mod.o rrtmg_sw_cldprmc.o rrsw_kg17.o radconstants.o rrsw_kg20.o rrsw_kg29.o rrsw_kg22.o mcica_subcol_gen_sw.o rrtmg_sw_taumol.o camsrfexch.o ppgrid.o rrtmg_sw_vrtqdr.o rrsw_kg26.o rrsw_kg18.o rrsw_kg21.o rrtmg_sw_spcvmc.o physconst.o mcica_random_numbers.o rrtmg_sw_setcoef.o - -verify: - @(grep "verification.FAIL" $(TEST).rslt && echo "FAILED") || (grep "verification.PASS" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 radiation.o kgen_utils.o radsw.o rrsw_kg28.o rrtmg_state.o rrsw_kg25.o rrsw_kg19.o rrtmg_sw_reftra.o rrsw_cld.o parrrsw.o physics_types.o rrsw_tbl.o rrtmg_sw_rad.o rrsw_kg23.o cmparray_mod.o rrsw_con.o rrsw_wvn.o rrsw_kg27.o rrsw_ref.o rrsw_kg24.o rrsw_kg16.o rrsw_vsn.o scamMod.o constituents.o shr_const_mod.o shr_kind_mod.o rrtmg_sw_cldprmc.o rrsw_kg17.o radconstants.o rrsw_kg20.o rrsw_kg29.o rrsw_kg22.o mcica_subcol_gen_sw.o rrtmg_sw_taumol.o camsrfexch.o ppgrid.o rrtmg_sw_vrtqdr.o rrsw_kg26.o rrsw_kg18.o rrsw_kg21.o rrtmg_sw_spcvmc.o physconst.o mcica_random_numbers.o rrtmg_sw_setcoef.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -radiation.o: $(SRC_DIR)/radiation.F90 kgen_utils.o radsw.o ppgrid.o shr_kind_mod.o parrrsw.o rrtmg_state.o physics_types.o camsrfexch.o radconstants.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -radsw.o: $(SRC_DIR)/radsw.F90 kgen_utils.o shr_kind_mod.o ppgrid.o parrrsw.o rrtmg_state.o scamMod.o cmparray_mod.o mcica_subcol_gen_sw.o rrtmg_sw_rad.o physconst.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg28.o: $(SRC_DIR)/rrsw_kg28.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_state.o: $(SRC_DIR)/rrtmg_state.F90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg25.o: $(SRC_DIR)/rrsw_kg25.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg19.o: $(SRC_DIR)/rrsw_kg19.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_sw_reftra.o: $(SRC_DIR)/rrtmg_sw_reftra.f90 kgen_utils.o shr_kind_mod.o rrsw_vsn.o rrsw_tbl.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_cld.o: $(SRC_DIR)/rrsw_cld.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -parrrsw.o: $(SRC_DIR)/parrrsw.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -physics_types.o: $(SRC_DIR)/physics_types.F90 kgen_utils.o ppgrid.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_tbl.o: $(SRC_DIR)/rrsw_tbl.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_sw_rad.o: $(SRC_DIR)/rrtmg_sw_rad.F90 kgen_utils.o shr_kind_mod.o parrrsw.o rrsw_con.o rrtmg_sw_cldprmc.o rrtmg_sw_setcoef.o rrtmg_sw_spcvmc.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg23.o: $(SRC_DIR)/rrsw_kg23.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -cmparray_mod.o: $(SRC_DIR)/cmparray_mod.F90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_con.o: $(SRC_DIR)/rrsw_con.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_wvn.o: $(SRC_DIR)/rrsw_wvn.f90 kgen_utils.o parrrsw.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg27.o: $(SRC_DIR)/rrsw_kg27.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_ref.o: $(SRC_DIR)/rrsw_ref.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg24.o: $(SRC_DIR)/rrsw_kg24.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg16.o: $(SRC_DIR)/rrsw_kg16.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_vsn.o: $(SRC_DIR)/rrsw_vsn.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -scamMod.o: $(SRC_DIR)/scamMod.F90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -constituents.o: $(SRC_DIR)/constituents.F90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_const_mod.o: $(SRC_DIR)/shr_const_mod.F90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_kind_mod.o: $(SRC_DIR)/shr_kind_mod.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_sw_cldprmc.o: $(SRC_DIR)/rrtmg_sw_cldprmc.F90 kgen_utils.o shr_kind_mod.o parrrsw.o rrsw_vsn.o rrsw_wvn.o rrsw_cld.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg17.o: $(SRC_DIR)/rrsw_kg17.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -radconstants.o: $(SRC_DIR)/radconstants.F90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg20.o: $(SRC_DIR)/rrsw_kg20.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg29.o: $(SRC_DIR)/rrsw_kg29.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg22.o: $(SRC_DIR)/rrsw_kg22.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mcica_subcol_gen_sw.o: $(SRC_DIR)/mcica_subcol_gen_sw.f90 kgen_utils.o shr_kind_mod.o parrrsw.o mcica_random_numbers.o rrsw_wvn.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_sw_taumol.o: $(SRC_DIR)/rrtmg_sw_taumol.f90 kgen_utils.o shr_kind_mod.o rrsw_vsn.o rrsw_kg16.o rrsw_con.o rrsw_wvn.o parrrsw.o rrsw_kg17.o rrsw_kg18.o rrsw_kg19.o rrsw_kg20.o rrsw_kg21.o rrsw_kg22.o rrsw_kg23.o rrsw_kg24.o rrsw_kg25.o rrsw_kg26.o rrsw_kg27.o rrsw_kg28.o rrsw_kg29.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -camsrfexch.o: $(SRC_DIR)/camsrfexch.F90 kgen_utils.o shr_kind_mod.o ppgrid.o constituents.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -ppgrid.o: $(SRC_DIR)/ppgrid.F90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_sw_vrtqdr.o: $(SRC_DIR)/rrtmg_sw_vrtqdr.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg26.o: $(SRC_DIR)/rrsw_kg26.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg18.o: $(SRC_DIR)/rrsw_kg18.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg21.o: $(SRC_DIR)/rrsw_kg21.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_sw_spcvmc.o: $(SRC_DIR)/rrtmg_sw_spcvmc.f90 kgen_utils.o shr_kind_mod.o parrrsw.o rrtmg_sw_taumol.o rrsw_wvn.o rrsw_tbl.o rrtmg_sw_reftra.o rrtmg_sw_vrtqdr.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -physconst.o: $(SRC_DIR)/physconst.F90 kgen_utils.o shr_kind_mod.o shr_const_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mcica_random_numbers.o: $(SRC_DIR)/mcica_random_numbers.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_sw_setcoef.o: $(SRC_DIR)/rrtmg_sw_setcoef.f90 kgen_utils.o shr_kind_mod.o rrsw_ref.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -kgen_utils.o: $(SRC_DIR)/kgen_utils.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.oo *.rslt diff --git a/test/ncar_kernels/PORT_sw_rad/lit/runmake b/test/ncar_kernels/PORT_sw_rad/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/PORT_sw_rad/lit/t1.sh b/test/ncar_kernels/PORT_sw_rad/lit/t1.sh deleted file mode 100644 index 33c953a156..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/lit/t1.sh +++ /dev/null @@ -1,9 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -# Shared lit script for each tests. Run bash commands that run tests with make. - -# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t -# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/PORT_sw_rad/makefile b/test/ncar_kernels/PORT_sw_rad/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/PORT_sw_rad/src/camsrfexch.F90 b/test/ncar_kernels/PORT_sw_rad/src/camsrfexch.F90 deleted file mode 100644 index 10936ebe11..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/camsrfexch.F90 +++ /dev/null @@ -1,899 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : camsrfexch.F90 -! Generated at: 2015-07-07 00:48:25 -! KGEN version: 0.4.13 - - - - MODULE camsrfexch - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !----------------------------------------------------------------------- - ! - ! Module to handle data that is exchanged between the CAM atmosphere - ! model and the surface models (land, sea-ice, and ocean). - ! - !----------------------------------------------------------------------- - ! - ! USES: - ! - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - USE constituents, ONLY: pcnst - USE ppgrid, ONLY: pcols - IMPLICIT NONE - !----------------------------------------------------------------------- - ! PRIVATE: Make default data and interfaces private - !----------------------------------------------------------------------- - PRIVATE ! By default all data is private to this module - ! - ! Public interfaces - ! - ! Atmosphere to surface data allocation method - ! Merged hub surface to atmosphere data allocation method - ! Set options to allocate optional parts of data type - ! - ! Public data types - ! - PUBLIC cam_out_t ! Data from atmosphere - PUBLIC cam_in_t ! Merged surface data - !--------------------------------------------------------------------------- - ! This is the data that is sent from the atmosphere to the surface models - !--------------------------------------------------------------------------- - TYPE cam_out_t - INTEGER :: lchnk ! chunk index - INTEGER :: ncol ! number of columns in chunk - REAL(KIND=r8) :: tbot(pcols) ! bot level temperature - REAL(KIND=r8) :: zbot(pcols) ! bot level height above surface - REAL(KIND=r8) :: ubot(pcols) ! bot level u wind - REAL(KIND=r8) :: vbot(pcols) ! bot level v wind - REAL(KIND=r8) :: qbot(pcols,pcnst) ! bot level specific humidity - REAL(KIND=r8) :: pbot(pcols) ! bot level pressure - REAL(KIND=r8) :: rho(pcols) ! bot level density - REAL(KIND=r8) :: netsw(pcols) ! - REAL(KIND=r8) :: flwds(pcols) ! - REAL(KIND=r8) :: precsc(pcols) ! - REAL(KIND=r8) :: precsl(pcols) ! - REAL(KIND=r8) :: precc(pcols) ! - REAL(KIND=r8) :: precl(pcols) ! - REAL(KIND=r8) :: soll(pcols) ! - REAL(KIND=r8) :: sols(pcols) ! - REAL(KIND=r8) :: solld(pcols) ! - REAL(KIND=r8) :: solsd(pcols) ! - REAL(KIND=r8) :: thbot(pcols) ! - REAL(KIND=r8) :: co2prog(pcols) ! prognostic co2 - REAL(KIND=r8) :: co2diag(pcols) ! diagnostic co2 - REAL(KIND=r8) :: psl(pcols) - REAL(KIND=r8) :: bcphiwet(pcols) ! wet deposition of hydrophilic black carbon - REAL(KIND=r8) :: bcphidry(pcols) ! dry deposition of hydrophilic black carbon - REAL(KIND=r8) :: bcphodry(pcols) ! dry deposition of hydrophobic black carbon - REAL(KIND=r8) :: ocphiwet(pcols) ! wet deposition of hydrophilic organic carbon - REAL(KIND=r8) :: ocphidry(pcols) ! dry deposition of hydrophilic organic carbon - REAL(KIND=r8) :: ocphodry(pcols) ! dry deposition of hydrophobic organic carbon - REAL(KIND=r8) :: dstwet1(pcols) ! wet deposition of dust (bin1) - REAL(KIND=r8) :: dstdry1(pcols) ! dry deposition of dust (bin1) - REAL(KIND=r8) :: dstwet2(pcols) ! wet deposition of dust (bin2) - REAL(KIND=r8) :: dstdry2(pcols) ! dry deposition of dust (bin2) - REAL(KIND=r8) :: dstwet3(pcols) ! wet deposition of dust (bin3) - REAL(KIND=r8) :: dstdry3(pcols) ! dry deposition of dust (bin3) - REAL(KIND=r8) :: dstwet4(pcols) ! wet deposition of dust (bin4) - REAL(KIND=r8) :: dstdry4(pcols) ! dry deposition of dust (bin4) - END TYPE cam_out_t - !--------------------------------------------------------------------------- - ! This is the merged state of sea-ice, land and ocean surface parameterizations - !--------------------------------------------------------------------------- - TYPE cam_in_t - INTEGER :: lchnk ! chunk index - INTEGER :: ncol ! number of active columns - REAL(KIND=r8) :: asdir(pcols) ! albedo: shortwave, direct - REAL(KIND=r8) :: asdif(pcols) ! albedo: shortwave, diffuse - REAL(KIND=r8) :: aldir(pcols) ! albedo: longwave, direct - REAL(KIND=r8) :: aldif(pcols) ! albedo: longwave, diffuse - REAL(KIND=r8) :: lwup(pcols) ! longwave up radiative flux - REAL(KIND=r8) :: lhf(pcols) ! latent heat flux - REAL(KIND=r8) :: shf(pcols) ! sensible heat flux - REAL(KIND=r8) :: wsx(pcols) ! surface u-stress (N) - REAL(KIND=r8) :: wsy(pcols) ! surface v-stress (N) - REAL(KIND=r8) :: tref(pcols) ! ref height surface air temp - REAL(KIND=r8) :: qref(pcols) ! ref height specific humidity - REAL(KIND=r8) :: u10(pcols) ! 10m wind speed - REAL(KIND=r8) :: ts(pcols) ! merged surface temp - REAL(KIND=r8) :: sst(pcols) ! sea surface temp - REAL(KIND=r8) :: snowhland(pcols) ! snow depth (liquid water equivalent) over land - REAL(KIND=r8) :: snowhice(pcols) ! snow depth over ice - REAL(KIND=r8) :: fco2_lnd(pcols) ! co2 flux from lnd - REAL(KIND=r8) :: fco2_ocn(pcols) ! co2 flux from ocn - REAL(KIND=r8) :: fdms(pcols) ! dms flux - REAL(KIND=r8) :: landfrac(pcols) ! land area fraction - REAL(KIND=r8) :: icefrac(pcols) ! sea-ice areal fraction - REAL(KIND=r8) :: ocnfrac(pcols) ! ocean areal fraction - REAL(KIND=r8), pointer, dimension(:) :: ram1 !aerodynamical resistance (s/m) (pcols) - REAL(KIND=r8), pointer, dimension(:) :: fv !friction velocity (m/s) (pcols) - REAL(KIND=r8), pointer, dimension(:) :: soilw !volumetric soil water (m3/m3) - REAL(KIND=r8) :: cflx(pcols,pcnst) ! constituent flux (evap) - REAL(KIND=r8) :: ustar(pcols) ! atm/ocn saved version of ustar - REAL(KIND=r8) :: re(pcols) ! atm/ocn saved version of re - REAL(KIND=r8) :: ssq(pcols) ! atm/ocn saved version of ssq - REAL(KIND=r8), pointer, dimension(:,:) :: depvel ! deposition velocities - END TYPE cam_in_t - ! .true. => aerosol dust package is being used - !=============================================================================== - - ! read interface - PUBLIC kgen_read - INTERFACE kgen_read - MODULE PROCEDURE kgen_read_cam_out_t - MODULE PROCEDURE kgen_read_cam_in_t - END INTERFACE kgen_read - - PUBLIC kgen_verify - INTERFACE kgen_verify - MODULE PROCEDURE kgen_verify_cam_out_t - MODULE PROCEDURE kgen_verify_cam_in_t - END INTERFACE kgen_verify - - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_r8_dim1_ptr(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), POINTER, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim1_ptr - - SUBROUTINE kgen_read_real_r8_dim2_ptr(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), POINTER, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim2_ptr - - ! No module extern variables - SUBROUTINE kgen_read_cam_out_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(cam_out_t), INTENT(out) :: var - READ(UNIT=kgen_unit) var%lchnk - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%lchnk **", var%lchnk - END IF - READ(UNIT=kgen_unit) var%ncol - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%ncol **", var%ncol - END IF - READ(UNIT=kgen_unit) var%tbot - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%tbot **", var%tbot - END IF - READ(UNIT=kgen_unit) var%zbot - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%zbot **", var%zbot - END IF - READ(UNIT=kgen_unit) var%ubot - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%ubot **", var%ubot - END IF - READ(UNIT=kgen_unit) var%vbot - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%vbot **", var%vbot - END IF - READ(UNIT=kgen_unit) var%qbot - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%qbot **", var%qbot - END IF - READ(UNIT=kgen_unit) var%pbot - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%pbot **", var%pbot - END IF - READ(UNIT=kgen_unit) var%rho - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%rho **", var%rho - END IF - READ(UNIT=kgen_unit) var%netsw - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%netsw **", var%netsw - END IF - READ(UNIT=kgen_unit) var%flwds - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%flwds **", var%flwds - END IF - READ(UNIT=kgen_unit) var%precsc - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%precsc **", var%precsc - END IF - READ(UNIT=kgen_unit) var%precsl - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%precsl **", var%precsl - END IF - READ(UNIT=kgen_unit) var%precc - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%precc **", var%precc - END IF - READ(UNIT=kgen_unit) var%precl - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%precl **", var%precl - END IF - READ(UNIT=kgen_unit) var%soll - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%soll **", var%soll - END IF - READ(UNIT=kgen_unit) var%sols - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%sols **", var%sols - END IF - READ(UNIT=kgen_unit) var%solld - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%solld **", var%solld - END IF - READ(UNIT=kgen_unit) var%solsd - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%solsd **", var%solsd - END IF - READ(UNIT=kgen_unit) var%thbot - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%thbot **", var%thbot - END IF - READ(UNIT=kgen_unit) var%co2prog - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%co2prog **", var%co2prog - END IF - READ(UNIT=kgen_unit) var%co2diag - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%co2diag **", var%co2diag - END IF - READ(UNIT=kgen_unit) var%psl - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%psl **", var%psl - END IF - READ(UNIT=kgen_unit) var%bcphiwet - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%bcphiwet **", var%bcphiwet - END IF - READ(UNIT=kgen_unit) var%bcphidry - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%bcphidry **", var%bcphidry - END IF - READ(UNIT=kgen_unit) var%bcphodry - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%bcphodry **", var%bcphodry - END IF - READ(UNIT=kgen_unit) var%ocphiwet - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%ocphiwet **", var%ocphiwet - END IF - READ(UNIT=kgen_unit) var%ocphidry - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%ocphidry **", var%ocphidry - END IF - READ(UNIT=kgen_unit) var%ocphodry - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%ocphodry **", var%ocphodry - END IF - READ(UNIT=kgen_unit) var%dstwet1 - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dstwet1 **", var%dstwet1 - END IF - READ(UNIT=kgen_unit) var%dstdry1 - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dstdry1 **", var%dstdry1 - END IF - READ(UNIT=kgen_unit) var%dstwet2 - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dstwet2 **", var%dstwet2 - END IF - READ(UNIT=kgen_unit) var%dstdry2 - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dstdry2 **", var%dstdry2 - END IF - READ(UNIT=kgen_unit) var%dstwet3 - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dstwet3 **", var%dstwet3 - END IF - READ(UNIT=kgen_unit) var%dstdry3 - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dstdry3 **", var%dstdry3 - END IF - READ(UNIT=kgen_unit) var%dstwet4 - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dstwet4 **", var%dstwet4 - END IF - READ(UNIT=kgen_unit) var%dstdry4 - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dstdry4 **", var%dstdry4 - END IF - END SUBROUTINE - SUBROUTINE kgen_read_cam_in_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(cam_in_t), INTENT(out) :: var - READ(UNIT=kgen_unit) var%lchnk - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%lchnk **", var%lchnk - END IF - READ(UNIT=kgen_unit) var%ncol - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%ncol **", var%ncol - END IF - READ(UNIT=kgen_unit) var%asdir - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%asdir **", var%asdir - END IF - READ(UNIT=kgen_unit) var%asdif - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%asdif **", var%asdif - END IF - READ(UNIT=kgen_unit) var%aldir - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%aldir **", var%aldir - END IF - READ(UNIT=kgen_unit) var%aldif - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%aldif **", var%aldif - END IF - READ(UNIT=kgen_unit) var%lwup - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%lwup **", var%lwup - END IF - READ(UNIT=kgen_unit) var%lhf - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%lhf **", var%lhf - END IF - READ(UNIT=kgen_unit) var%shf - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%shf **", var%shf - END IF - READ(UNIT=kgen_unit) var%wsx - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%wsx **", var%wsx - END IF - READ(UNIT=kgen_unit) var%wsy - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%wsy **", var%wsy - END IF - READ(UNIT=kgen_unit) var%tref - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%tref **", var%tref - END IF - READ(UNIT=kgen_unit) var%qref - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%qref **", var%qref - END IF - READ(UNIT=kgen_unit) var%u10 - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%u10 **", var%u10 - END IF - READ(UNIT=kgen_unit) var%ts - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%ts **", var%ts - END IF - READ(UNIT=kgen_unit) var%sst - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%sst **", var%sst - END IF - READ(UNIT=kgen_unit) var%snowhland - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%snowhland **", var%snowhland - END IF - READ(UNIT=kgen_unit) var%snowhice - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%snowhice **", var%snowhice - END IF - READ(UNIT=kgen_unit) var%fco2_lnd - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%fco2_lnd **", var%fco2_lnd - END IF - READ(UNIT=kgen_unit) var%fco2_ocn - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%fco2_ocn **", var%fco2_ocn - END IF - READ(UNIT=kgen_unit) var%fdms - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%fdms **", var%fdms - END IF - READ(UNIT=kgen_unit) var%landfrac - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%landfrac **", var%landfrac - END IF - READ(UNIT=kgen_unit) var%icefrac - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%icefrac **", var%icefrac - END IF - READ(UNIT=kgen_unit) var%ocnfrac - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%ocnfrac **", var%ocnfrac - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim1_ptr(var%ram1, kgen_unit, printvar=printvar//"%ram1") - ELSE - CALL kgen_read_real_r8_dim1_ptr(var%ram1, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim1_ptr(var%fv, kgen_unit, printvar=printvar//"%fv") - ELSE - CALL kgen_read_real_r8_dim1_ptr(var%fv, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim1_ptr(var%soilw, kgen_unit, printvar=printvar//"%soilw") - ELSE - CALL kgen_read_real_r8_dim1_ptr(var%soilw, kgen_unit) - END IF - READ(UNIT=kgen_unit) var%cflx - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%cflx **", var%cflx - END IF - READ(UNIT=kgen_unit) var%ustar - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%ustar **", var%ustar - END IF - READ(UNIT=kgen_unit) var%re - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%re **", var%re - END IF - READ(UNIT=kgen_unit) var%ssq - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%ssq **", var%ssq - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_ptr(var%depvel, kgen_unit, printvar=printvar//"%depvel") - ELSE - CALL kgen_read_real_r8_dim2_ptr(var%depvel, kgen_unit) - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_cam_out_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(cam_out_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 -! -! Tolerance has to be changed to 1.0e-12 if FMA instructions are generated. -! Without FMA, tolerance can be set to 1.0e-13. -! Only array solld falls outside the default tolerance of 1.0e-15. -! - CALL kgen_init_check(dtype_check_status,tolerance=real(1.0e-12,kind=kgen_dp)) - CALL kgen_verify_integer("lchnk", dtype_check_status, var%lchnk, ref_var%lchnk) - CALL kgen_verify_integer("ncol", dtype_check_status, var%ncol, ref_var%ncol) - CALL kgen_verify_real_r8_dim1("tbot", dtype_check_status, var%tbot, ref_var%tbot) - CALL kgen_verify_real_r8_dim1("zbot", dtype_check_status, var%zbot, ref_var%zbot) - CALL kgen_verify_real_r8_dim1("ubot", dtype_check_status, var%ubot, ref_var%ubot) - CALL kgen_verify_real_r8_dim1("vbot", dtype_check_status, var%vbot, ref_var%vbot) - CALL kgen_verify_real_r8_dim2("qbot", dtype_check_status, var%qbot, ref_var%qbot) - CALL kgen_verify_real_r8_dim1("pbot", dtype_check_status, var%pbot, ref_var%pbot) - CALL kgen_verify_real_r8_dim1("rho", dtype_check_status, var%rho, ref_var%rho) - CALL kgen_verify_real_r8_dim1("netsw", dtype_check_status, var%netsw, ref_var%netsw) - CALL kgen_verify_real_r8_dim1("flwds", dtype_check_status, var%flwds, ref_var%flwds) - CALL kgen_verify_real_r8_dim1("precsc", dtype_check_status, var%precsc, ref_var%precsc) - CALL kgen_verify_real_r8_dim1("precsl", dtype_check_status, var%precsl, ref_var%precsl) - CALL kgen_verify_real_r8_dim1("precc", dtype_check_status, var%precc, ref_var%precc) - CALL kgen_verify_real_r8_dim1("precl", dtype_check_status, var%precl, ref_var%precl) - CALL kgen_verify_real_r8_dim1("soll", dtype_check_status, var%soll, ref_var%soll) - CALL kgen_verify_real_r8_dim1("sols", dtype_check_status, var%sols, ref_var%sols) - CALL kgen_verify_real_r8_dim1("solld", dtype_check_status, var%solld, ref_var%solld) - CALL kgen_verify_real_r8_dim1("solsd", dtype_check_status, var%solsd, ref_var%solsd) - CALL kgen_verify_real_r8_dim1("thbot", dtype_check_status, var%thbot, ref_var%thbot) - CALL kgen_verify_real_r8_dim1("co2prog", dtype_check_status, var%co2prog, ref_var%co2prog) - CALL kgen_verify_real_r8_dim1("co2diag", dtype_check_status, var%co2diag, ref_var%co2diag) - CALL kgen_verify_real_r8_dim1("psl", dtype_check_status, var%psl, ref_var%psl) - CALL kgen_verify_real_r8_dim1("bcphiwet", dtype_check_status, var%bcphiwet, ref_var%bcphiwet) - CALL kgen_verify_real_r8_dim1("bcphidry", dtype_check_status, var%bcphidry, ref_var%bcphidry) - CALL kgen_verify_real_r8_dim1("bcphodry", dtype_check_status, var%bcphodry, ref_var%bcphodry) - CALL kgen_verify_real_r8_dim1("ocphiwet", dtype_check_status, var%ocphiwet, ref_var%ocphiwet) - CALL kgen_verify_real_r8_dim1("ocphidry", dtype_check_status, var%ocphidry, ref_var%ocphidry) - CALL kgen_verify_real_r8_dim1("ocphodry", dtype_check_status, var%ocphodry, ref_var%ocphodry) - CALL kgen_verify_real_r8_dim1("dstwet1", dtype_check_status, var%dstwet1, ref_var%dstwet1) - CALL kgen_verify_real_r8_dim1("dstdry1", dtype_check_status, var%dstdry1, ref_var%dstdry1) - CALL kgen_verify_real_r8_dim1("dstwet2", dtype_check_status, var%dstwet2, ref_var%dstwet2) - CALL kgen_verify_real_r8_dim1("dstdry2", dtype_check_status, var%dstdry2, ref_var%dstdry2) - CALL kgen_verify_real_r8_dim1("dstwet3", dtype_check_status, var%dstwet3, ref_var%dstwet3) - CALL kgen_verify_real_r8_dim1("dstdry3", dtype_check_status, var%dstdry3, ref_var%dstdry3) - CALL kgen_verify_real_r8_dim1("dstwet4", dtype_check_status, var%dstwet4, ref_var%dstwet4) - CALL kgen_verify_real_r8_dim1("dstdry4", dtype_check_status, var%dstdry4, ref_var%dstdry4) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_cam_in_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(cam_in_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_integer("lchnk", dtype_check_status, var%lchnk, ref_var%lchnk) - CALL kgen_verify_integer("ncol", dtype_check_status, var%ncol, ref_var%ncol) - CALL kgen_verify_real_r8_dim1("asdir", dtype_check_status, var%asdir, ref_var%asdir) - CALL kgen_verify_real_r8_dim1("asdif", dtype_check_status, var%asdif, ref_var%asdif) - CALL kgen_verify_real_r8_dim1("aldir", dtype_check_status, var%aldir, ref_var%aldir) - CALL kgen_verify_real_r8_dim1("aldif", dtype_check_status, var%aldif, ref_var%aldif) - CALL kgen_verify_real_r8_dim1("lwup", dtype_check_status, var%lwup, ref_var%lwup) - CALL kgen_verify_real_r8_dim1("lhf", dtype_check_status, var%lhf, ref_var%lhf) - CALL kgen_verify_real_r8_dim1("shf", dtype_check_status, var%shf, ref_var%shf) - CALL kgen_verify_real_r8_dim1("wsx", dtype_check_status, var%wsx, ref_var%wsx) - CALL kgen_verify_real_r8_dim1("wsy", dtype_check_status, var%wsy, ref_var%wsy) - CALL kgen_verify_real_r8_dim1("tref", dtype_check_status, var%tref, ref_var%tref) - CALL kgen_verify_real_r8_dim1("qref", dtype_check_status, var%qref, ref_var%qref) - CALL kgen_verify_real_r8_dim1("u10", dtype_check_status, var%u10, ref_var%u10) - CALL kgen_verify_real_r8_dim1("ts", dtype_check_status, var%ts, ref_var%ts) - CALL kgen_verify_real_r8_dim1("sst", dtype_check_status, var%sst, ref_var%sst) - CALL kgen_verify_real_r8_dim1("snowhland", dtype_check_status, var%snowhland, ref_var%snowhland) - CALL kgen_verify_real_r8_dim1("snowhice", dtype_check_status, var%snowhice, ref_var%snowhice) - CALL kgen_verify_real_r8_dim1("fco2_lnd", dtype_check_status, var%fco2_lnd, ref_var%fco2_lnd) - CALL kgen_verify_real_r8_dim1("fco2_ocn", dtype_check_status, var%fco2_ocn, ref_var%fco2_ocn) - CALL kgen_verify_real_r8_dim1("fdms", dtype_check_status, var%fdms, ref_var%fdms) - CALL kgen_verify_real_r8_dim1("landfrac", dtype_check_status, var%landfrac, ref_var%landfrac) - CALL kgen_verify_real_r8_dim1("icefrac", dtype_check_status, var%icefrac, ref_var%icefrac) - CALL kgen_verify_real_r8_dim1("ocnfrac", dtype_check_status, var%ocnfrac, ref_var%ocnfrac) - CALL kgen_verify_real_r8_dim1_ptr("ram1", dtype_check_status, var%ram1, ref_var%ram1) - CALL kgen_verify_real_r8_dim1_ptr("fv", dtype_check_status, var%fv, ref_var%fv) - CALL kgen_verify_real_r8_dim1_ptr("soilw", dtype_check_status, var%soilw, ref_var%soilw) - CALL kgen_verify_real_r8_dim2("cflx", dtype_check_status, var%cflx, ref_var%cflx) - CALL kgen_verify_real_r8_dim1("ustar", dtype_check_status, var%ustar, ref_var%ustar) - CALL kgen_verify_real_r8_dim1("re", dtype_check_status, var%re, ref_var%re) - CALL kgen_verify_real_r8_dim1("ssq", dtype_check_status, var%ssq, ref_var%ssq) - CALL kgen_verify_real_r8_dim2_ptr("depvel", dtype_check_status, var%depvel, ref_var%depvel) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_integer( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - END SUBROUTINE kgen_verify_integer - - SUBROUTINE kgen_verify_real_r8_dim1( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1))) - allocate(temp2(SIZE(var,dim=1))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim1 - - SUBROUTINE kgen_verify_real_r8_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim2 - - SUBROUTINE kgen_verify_real_r8_dim1_ptr( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:), POINTER :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:) :: temp, temp2 - integer :: n - IF ( ASSOCIATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1))) - allocate(temp2(SIZE(var,dim=1))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END IF - END SUBROUTINE kgen_verify_real_r8_dim1_ptr - - SUBROUTINE kgen_verify_real_r8_dim2_ptr( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:), POINTER :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:) :: temp, temp2 - integer :: n - IF ( ASSOCIATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END IF - END SUBROUTINE kgen_verify_real_r8_dim2_ptr - - !=============================================================================== - !----------------------------------------------------------------------- - ! - ! BOP - ! - ! !IROUTINE: hub2atm_alloc - ! - ! !DESCRIPTION: - ! - ! Allocate space for the surface to atmosphere data type. And initialize - ! the values. - ! - !----------------------------------------------------------------------- - ! - ! !INTERFACE - ! - - ! - !=============================================================================== - ! - !----------------------------------------------------------------------- - ! - ! BOP - ! - ! !IROUTINE: atm2hub_alloc - ! - ! !DESCRIPTION: - ! - ! Allocate space for the atmosphere to surface data type. And initialize - ! the values. - ! - !----------------------------------------------------------------------- - ! - ! !INTERFACE - ! - - - - !====================================================================== - ! - ! BOP - ! - ! !IROUTINE: hub2atm_setopts - ! - ! !DESCRIPTION: - ! - ! Method for outside packages to influence what is allocated - ! (For now, just aerosol dust controls if fv, ram1, and soilw - ! arrays are allocated.) - ! - !----------------------------------------------------------------------- - ! - ! !INTERFACE - ! - - - END MODULE camsrfexch diff --git a/test/ncar_kernels/PORT_sw_rad/src/cmparray_mod.F90 b/test/ncar_kernels/PORT_sw_rad/src/cmparray_mod.F90 deleted file mode 100644 index 5a251b9d5d..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/cmparray_mod.F90 +++ /dev/null @@ -1,321 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : cmparray_mod.F90 -! Generated at: 2015-07-07 00:48:24 -! KGEN version: 0.4.13 - - - - MODULE cmparray_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - PRIVATE - PUBLIC cmpdaynite, expdaynite - - INTERFACE cmpdaynite - MODULE PROCEDURE cmpdaynite_1d_r - MODULE PROCEDURE cmpdaynite_2d_r - MODULE PROCEDURE cmpdaynite_3d_r - MODULE PROCEDURE cmpdaynite_1d_r_copy - MODULE PROCEDURE cmpdaynite_2d_r_copy - MODULE PROCEDURE cmpdaynite_3d_r_copy - MODULE PROCEDURE cmpdaynite_1d_i - MODULE PROCEDURE cmpdaynite_2d_i - MODULE PROCEDURE cmpdaynite_3d_i - END INTERFACE ! CmpDayNite - - INTERFACE expdaynite - MODULE PROCEDURE expdaynite_1d_r - MODULE PROCEDURE expdaynite_2d_r - MODULE PROCEDURE expdaynite_3d_r - MODULE PROCEDURE expdaynite_1d_i - MODULE PROCEDURE expdaynite_2d_i - MODULE PROCEDURE expdaynite_3d_i - END INTERFACE ! ExpDayNite - - ! cmparray - - ! chksum - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - - SUBROUTINE cmpdaynite_1d_r(array, nday, idxday, nnite, idxnite, il1, iu1) - INTEGER, intent(in) :: nnite - INTEGER, intent(in) :: nday - INTEGER, intent(in) :: il1 - INTEGER, intent(in) :: iu1 - INTEGER, intent(in), dimension(nday) :: idxday - INTEGER, intent(in), dimension(nnite) :: idxnite - REAL(KIND=r8), intent(inout), dimension(il1:iu1) :: array - call CmpDayNite_3d_R(Array, Nday, IdxDay, Nnite, IdxNite, il1, iu1, 1, 1, 1, 1) - return - END SUBROUTINE cmpdaynite_1d_r - - SUBROUTINE cmpdaynite_2d_r(array, nday, idxday, nnite, idxnite, il1, iu1, il2, iu2) - INTEGER, intent(in) :: nday - INTEGER, intent(in) :: nnite - INTEGER, intent(in) :: iu1 - INTEGER, intent(in) :: il1 - INTEGER, intent(in) :: il2 - INTEGER, intent(in) :: iu2 - INTEGER, intent(in), dimension(nday) :: idxday - INTEGER, intent(in), dimension(nnite) :: idxnite - REAL(KIND=r8), intent(inout), dimension(il1:iu1,il2:iu2) :: array - call CmpDayNite_3d_R(Array, Nday, IdxDay, Nnite, IdxNite, il1, iu1, il2, iu2, 1, 1) - return - END SUBROUTINE cmpdaynite_2d_r - - SUBROUTINE cmpdaynite_3d_r(array, nday, idxday, nnite, idxnite, il1, iu1, il2, iu2, il3, iu3) - INTEGER, intent(in) :: nday - INTEGER, intent(in) :: nnite - INTEGER, intent(in) :: il1 - INTEGER, intent(in) :: iu1 - INTEGER, intent(in) :: iu2 - INTEGER, intent(in) :: il2 - INTEGER, intent(in) :: il3 - INTEGER, intent(in) :: iu3 - INTEGER, intent(in), dimension(nday) :: idxday - INTEGER, intent(in), dimension(nnite) :: idxnite - REAL(KIND=r8), intent(inout), dimension(il1:iu1,il2:iu2,il3:iu3) :: array - REAL(KIND=r8), dimension(il1:iu1) :: tmp - INTEGER :: k - INTEGER :: j - do k = il3, iu3 - do j = il2, iu2 - tmp(1:Nnite) = Array(IdxNite(1:Nnite),j,k) - Array(il1:il1+Nday-1,j,k) = Array(IdxDay(1:Nday),j,k) - Array(il1+Nday:il1+Nday+Nnite-1,j,k) = tmp(1:Nnite) - end do - end do - return - END SUBROUTINE cmpdaynite_3d_r - - SUBROUTINE cmpdaynite_1d_r_copy(inarray, outarray, nday, idxday, nnite, idxnite, il1, iu1) - INTEGER, intent(in) :: nday - INTEGER, intent(in) :: nnite - INTEGER, intent(in) :: il1 - INTEGER, intent(in) :: iu1 - INTEGER, intent(in), dimension(nday) :: idxday - INTEGER, intent(in), dimension(nnite) :: idxnite - REAL(KIND=r8), intent(in), dimension(il1:iu1) :: inarray - REAL(KIND=r8), intent(out), dimension(il1:iu1) :: outarray - call CmpDayNite_3d_R_Copy(InArray, OutArray, Nday, IdxDay, Nnite, IdxNite, il1, iu1, 1, 1, 1, 1) - return - END SUBROUTINE cmpdaynite_1d_r_copy - - SUBROUTINE cmpdaynite_2d_r_copy(inarray, outarray, nday, idxday, nnite, idxnite, il1, iu1, il2, iu2) - INTEGER, intent(in) :: nnite - INTEGER, intent(in) :: nday - INTEGER, intent(in) :: il1 - INTEGER, intent(in) :: iu1 - INTEGER, intent(in) :: il2 - INTEGER, intent(in) :: iu2 - INTEGER, intent(in), dimension(nday) :: idxday - INTEGER, intent(in), dimension(nnite) :: idxnite - REAL(KIND=r8), intent(in), dimension(il1:iu1,il2:iu2) :: inarray - REAL(KIND=r8), intent(out), dimension(il1:iu1,il2:iu2) :: outarray - call CmpDayNite_3d_R_Copy(InArray, OutArray, Nday, IdxDay, Nnite, IdxNite, il1, iu1, il2, iu2, 1, 1) - return - END SUBROUTINE cmpdaynite_2d_r_copy - - SUBROUTINE cmpdaynite_3d_r_copy(inarray, outarray, nday, idxday, nnite, idxnite, il1, iu1, il2, iu2, il3, iu3) - INTEGER, intent(in) :: nday - INTEGER, intent(in) :: nnite - INTEGER, intent(in) :: il1 - INTEGER, intent(in) :: iu1 - INTEGER, intent(in) :: il2 - INTEGER, intent(in) :: iu2 - INTEGER, intent(in) :: il3 - INTEGER, intent(in) :: iu3 - INTEGER, intent(in), dimension(nday) :: idxday - INTEGER, intent(in), dimension(nnite) :: idxnite - REAL(KIND=r8), intent(in), dimension(il1:iu1,il2:iu2,il3:iu3) :: inarray - REAL(KIND=r8), intent(out), dimension(il1:iu1,il2:iu2,il3:iu3) :: outarray - INTEGER :: k - INTEGER :: j - INTEGER :: i - do k = il3, iu3 - do j = il2, iu2 - do i=il1,il1+Nday-1 - OutArray(i,j,k) = InArray(IdxDay(i-il1+1),j,k) - enddo - do i=il1+Nday,il1+Nday+Nnite-1 - OutArray(i,j,k) = InArray(IdxNite(i-(il1+Nday)+1),j,k) - enddo - end do - end do - return - END SUBROUTINE cmpdaynite_3d_r_copy - - SUBROUTINE cmpdaynite_1d_i(array, nday, idxday, nnite, idxnite, il1, iu1) - INTEGER, intent(in) :: nday - INTEGER, intent(in) :: nnite - INTEGER, intent(in) :: il1 - INTEGER, intent(in) :: iu1 - INTEGER, intent(in), dimension(nday) :: idxday - INTEGER, intent(in), dimension(nnite) :: idxnite - INTEGER, intent(inout), dimension(il1:iu1) :: array - call CmpDayNite_3d_I(Array, Nday, IdxDay, Nnite, IdxNite, il1, iu1, 1, 1, 1, 1) - return - END SUBROUTINE cmpdaynite_1d_i - - SUBROUTINE cmpdaynite_2d_i(array, nday, idxday, nnite, idxnite, il1, iu1, il2, iu2) - INTEGER, intent(in) :: nday - INTEGER, intent(in) :: nnite - INTEGER, intent(in) :: il1 - INTEGER, intent(in) :: iu1 - INTEGER, intent(in) :: il2 - INTEGER, intent(in) :: iu2 - INTEGER, intent(in), dimension(nday) :: idxday - INTEGER, intent(in), dimension(nnite) :: idxnite - INTEGER, intent(inout), dimension(il1:iu1,il2:iu2) :: array - call CmpDayNite_3d_I(Array, Nday, IdxDay, Nnite, IdxNite, il1, iu1, il2, iu2, 1, 1) - return - END SUBROUTINE cmpdaynite_2d_i - - SUBROUTINE cmpdaynite_3d_i(array, nday, idxday, nnite, idxnite, il1, iu1, il2, iu2, il3, iu3) - INTEGER, intent(in) :: nday - INTEGER, intent(in) :: nnite - INTEGER, intent(in) :: iu1 - INTEGER, intent(in) :: il1 - INTEGER, intent(in) :: il2 - INTEGER, intent(in) :: iu2 - INTEGER, intent(in) :: iu3 - INTEGER, intent(in) :: il3 - INTEGER, intent(in), dimension(nday) :: idxday - INTEGER, intent(in), dimension(nnite) :: idxnite - INTEGER, intent(inout), dimension(il1:iu1,il2:iu2,il3:iu3) :: array - INTEGER, dimension(il1:iu1) :: tmp - INTEGER :: k - INTEGER :: j - do k = il3, iu3 - do j = il2, iu2 - tmp(1:Nnite) = Array(IdxNite(1:Nnite),j,k) - Array(il1:il1+Nday-1,j,k) = Array(IdxDay(1:Nday),j,k) - Array(il1+Nday:il1+Nday+Nnite-1,j,k) = tmp(1:Nnite) - end do - end do - return - END SUBROUTINE cmpdaynite_3d_i - - SUBROUTINE expdaynite_1d_r(array, nday, idxday, nnite, idxnite, il1, iu1) - INTEGER, intent(in) :: nday - INTEGER, intent(in) :: nnite - INTEGER, intent(in) :: il1 - INTEGER, intent(in) :: iu1 - INTEGER, intent(in), dimension(nday) :: idxday - INTEGER, intent(in), dimension(nnite) :: idxnite - REAL(KIND=r8), intent(inout), dimension(il1:iu1) :: array - call ExpDayNite_3d_R(Array, Nday, IdxDay, Nnite, IdxNite, il1, iu1, 1, 1, 1, 1) - return - END SUBROUTINE expdaynite_1d_r - - SUBROUTINE expdaynite_2d_r(array, nday, idxday, nnite, idxnite, il1, iu1, il2, iu2) - INTEGER, intent(in) :: nday - INTEGER, intent(in) :: nnite - INTEGER, intent(in) :: iu1 - INTEGER, intent(in) :: il1 - INTEGER, intent(in) :: il2 - INTEGER, intent(in) :: iu2 - INTEGER, intent(in), dimension(nday) :: idxday - INTEGER, intent(in), dimension(nnite) :: idxnite - REAL(KIND=r8), intent(inout), dimension(il1:iu1,il2:iu2) :: array - call ExpDayNite_3d_R(Array, Nday, IdxDay, Nnite, IdxNite, il1, iu1, il2, iu2, 1, 1) - return - END SUBROUTINE expdaynite_2d_r - - SUBROUTINE expdaynite_3d_r(array, nday, idxday, nnite, idxnite, il1, iu1, il2, iu2, il3, iu3) - INTEGER, intent(in) :: nday - INTEGER, intent(in) :: nnite - INTEGER, intent(in) :: il1 - INTEGER, intent(in) :: iu1 - INTEGER, intent(in) :: il2 - INTEGER, intent(in) :: iu2 - INTEGER, intent(in) :: il3 - INTEGER, intent(in) :: iu3 - INTEGER, intent(in), dimension(nday) :: idxday - INTEGER, intent(in), dimension(nnite) :: idxnite - REAL(KIND=r8), intent(inout), dimension(il1:iu1,il2:iu2,il3:iu3) :: array - REAL(KIND=r8), dimension(il1:iu1) :: tmp - INTEGER :: k - INTEGER :: j - do k = il3, iu3 - do j = il2, iu2 - tmp(1:Nday) = Array(1:Nday,j,k) - Array(IdxNite(1:Nnite),j,k) = Array(il1+Nday:il1+Nday+Nnite-1,j,k) - Array(IdxDay(1:Nday),j,k) = tmp(1:Nday) - end do - end do - return - END SUBROUTINE expdaynite_3d_r - - SUBROUTINE expdaynite_1d_i(array, nday, idxday, nnite, idxnite, il1, iu1) - INTEGER, intent(in) :: nday - INTEGER, intent(in) :: nnite - INTEGER, intent(in) :: il1 - INTEGER, intent(in) :: iu1 - INTEGER, intent(in), dimension(nday) :: idxday - INTEGER, intent(in), dimension(nnite) :: idxnite - INTEGER, intent(inout), dimension(il1:iu1) :: array - call ExpDayNite_3d_I(Array, Nday, IdxDay, Nnite, IdxNite, il1, iu1, 1, 1, 1, 1) - return - END SUBROUTINE expdaynite_1d_i - - SUBROUTINE expdaynite_2d_i(array, nday, idxday, nnite, idxnite, il1, iu1, il2, iu2) - INTEGER, intent(in) :: nday - INTEGER, intent(in) :: nnite - INTEGER, intent(in) :: iu1 - INTEGER, intent(in) :: il1 - INTEGER, intent(in) :: il2 - INTEGER, intent(in) :: iu2 - INTEGER, intent(in), dimension(nday) :: idxday - INTEGER, intent(in), dimension(nnite) :: idxnite - INTEGER, intent(inout), dimension(il1:iu1,il2:iu2) :: array - call ExpDayNite_3d_I(Array, Nday, IdxDay, Nnite, IdxNite, il1, iu1, il2, iu2, 1, 1) - return - END SUBROUTINE expdaynite_2d_i - - SUBROUTINE expdaynite_3d_i(array, nday, idxday, nnite, idxnite, il1, iu1, il2, iu2, il3, iu3) - INTEGER, intent(in) :: nday - INTEGER, intent(in) :: nnite - INTEGER, intent(in) :: il1 - INTEGER, intent(in) :: iu1 - INTEGER, intent(in) :: iu2 - INTEGER, intent(in) :: il2 - INTEGER, intent(in) :: il3 - INTEGER, intent(in) :: iu3 - INTEGER, intent(in), dimension(nday) :: idxday - INTEGER, intent(in), dimension(nnite) :: idxnite - INTEGER, intent(inout), dimension(il1:iu1,il2:iu2,il3:iu3) :: array - INTEGER, dimension(il1:iu1) :: tmp - INTEGER :: k - INTEGER :: j - do k = il3, iu3 - do j = il2, iu2 - tmp(1:Nday) = Array(1:Nday,j,k) - Array(IdxNite(1:Nnite),j,k) = Array(il1+Nday:il1+Nday+Nnite-1,j,k) - Array(IdxDay(1:Nday),j,k) = tmp(1:Nday) - end do - end do - return - END SUBROUTINE expdaynite_3d_i - !******************************************************************************! - ! ! - ! DEBUG ! - ! ! - !******************************************************************************! - - - - - - - - - - END MODULE cmparray_mod diff --git a/test/ncar_kernels/PORT_sw_rad/src/constituents.F90 b/test/ncar_kernels/PORT_sw_rad/src/constituents.F90 deleted file mode 100644 index 8314852498..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/constituents.F90 +++ /dev/null @@ -1,101 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : constituents.F90 -! Generated at: 2015-07-07 00:48:24 -! KGEN version: 0.4.13 - - - - MODULE constituents - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !---------------------------------------------------------------------------------------------- - ! - ! Purpose: Contains data and functions for manipulating advected and non-advected constituents. - ! - ! Revision history: - ! B.A. Boville Original version - ! June 2003 P. Rasch Add wet/dry m.r. specifier - ! 2004-08-28 B. Eaton Add query function to allow turning off the default CAM output of - ! constituents so that chemistry module can make the outfld calls. - ! Allow cnst_get_ind to return without aborting when constituent not - ! found. - ! 2006-10-31 B. Eaton Remove 'non-advected' constituent functionality. - !---------------------------------------------------------------------------------------------- - IMPLICIT NONE - PRIVATE - ! - ! Public interfaces - ! - ! add a constituent to the list of advected constituents - ! returns the number of available slots in the constituent array - ! get the index of a constituent - ! get the type of a constituent - ! get the type of a constituent - ! get the molecular diffusion type of a constituent - ! query whether constituent initial values are read from initial file - ! check that number of constituents added equals dimensions (pcnst) - ! Returns true if default CAM output was specified in the cnst_add calls. - ! Public data - INTEGER, parameter, public :: pcnst = 25 ! number of advected constituents (including water vapor) - ! constituent names - ! long name of constituents - ! Namelist variables - ! true => obtain initial tracer data from IC file - ! - ! Constants for each tracer - ! specific heat at constant pressure (J/kg/K) - ! specific heat at constant volume (J/kg/K) - ! molecular weight (kg/kmole) - ! wet or dry mixing ratio - ! major or minor species molecular diffusion - ! gas constant () - ! minimum permitted constituent concentration (kg/kg) - ! for backward compatibility only - ! upper bndy condition = fixed ? - ! upper boundary non-zero fixed constituent flux - ! convective transport : phase 1 or phase 2? - !++bee - temporary... These names should be declared in the module that makes the addfld and outfld calls. - ! Lists of tracer names and diagnostics - ! constituents after physics (FV core only) - ! constituents before physics (FV core only) - ! names of horizontal advection tendencies - ! names of vertical advection tendencies - ! names of convection tendencies - ! names of species slt fixer tendencies - ! names of total tendencies of species - ! names of total physics tendencies of species - ! names of dme adjusted tracers (FV) - ! names of surface fluxes of species - ! names for horz + vert + fixer tendencies - ! Private data - ! index pointer to last advected tracer - ! true => read initial values from initial file - ! true => default CAM output of constituents in kg/kg - ! false => chemistry is responsible for making outfld - ! calls for constituents - !============================================================================================== - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !============================================================================================== - - !============================================================================== - - !============================================================================== - - !============================================================================================== - - !============================================================================================== - - - !============================================================================== - - !============================================================================== - - !============================================================================== - - !============================================================================== - END MODULE constituents diff --git a/test/ncar_kernels/PORT_sw_rad/src/kernel_driver.f90 b/test/ncar_kernels/PORT_sw_rad/src/kernel_driver.f90 deleted file mode 100644 index 9aacbd2b91..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/kernel_driver.f90 +++ /dev/null @@ -1,156 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-07-07 00:48:23 -! KGEN version: 0.4.13 - - -PROGRAM kernel_driver - USE radiation, ONLY : radiation_tend - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - USE camsrfexch, ONLY: cam_in_t - USE physics_types, ONLY: physics_state - USE camsrfexch, ONLY: cam_out_t - USE rrsw_ref, ONLY : kgen_read_externs_rrsw_ref - USE rrsw_tbl, ONLY : kgen_read_externs_rrsw_tbl - USE rrsw_kg19, ONLY : kgen_read_externs_rrsw_kg19 - USE rrsw_kg18, ONLY : kgen_read_externs_rrsw_kg18 - USE rrsw_kg17, ONLY : kgen_read_externs_rrsw_kg17 - USE rrsw_kg16, ONLY : kgen_read_externs_rrsw_kg16 - USE rrsw_cld, ONLY : kgen_read_externs_rrsw_cld - USE rrsw_kg29, ONLY : kgen_read_externs_rrsw_kg29 - USE rrsw_wvn, ONLY : kgen_read_externs_rrsw_wvn - USE rrsw_vsn, ONLY : kgen_read_externs_rrsw_vsn - USE rrsw_kg24, ONLY : kgen_read_externs_rrsw_kg24 - USE rrsw_kg25, ONLY : kgen_read_externs_rrsw_kg25 - USE rrsw_kg26, ONLY : kgen_read_externs_rrsw_kg26 - USE rrsw_kg27, ONLY : kgen_read_externs_rrsw_kg27 - USE rrsw_kg20, ONLY : kgen_read_externs_rrsw_kg20 - USE rrsw_kg21, ONLY : kgen_read_externs_rrsw_kg21 - USE rrsw_kg22, ONLY : kgen_read_externs_rrsw_kg22 - USE rrsw_kg23, ONLY : kgen_read_externs_rrsw_kg23 - USE scammod, ONLY : kgen_read_externs_scammod - USE rrsw_kg28, ONLY : kgen_read_externs_rrsw_kg28 - USE radsw, ONLY : kgen_read_externs_radsw - USE rrtmg_state, ONLY : kgen_read_externs_rrtmg_state - USE rrsw_con, ONLY : kgen_read_externs_rrsw_con - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE physics_types, ONLY : kgen_read_mod42 => kgen_read - USE physics_types, ONLY : kgen_verify_mod42 => kgen_verify - USE camsrfexch, ONLY : kgen_read_mod43 => kgen_read - USE camsrfexch, ONLY : kgen_verify_mod43 => kgen_verify - - IMPLICIT NONE - - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(2), PARAMETER :: kgen_counter_at = (/ 1, 2 /) - CHARACTER(LEN=1024) :: kgen_filepath - REAL(KIND=r8), allocatable :: fsnt(:) - TYPE(cam_in_t) :: cam_in - REAL(KIND=r8), allocatable :: fsns(:) - TYPE(physics_state), target :: state - REAL(KIND=r8), allocatable :: fsds(:) - TYPE(cam_out_t) :: cam_out - - DO kgen_repeat_counter = 0, 1 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 2)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_filepath = "../data/rad_rrtmg_sw." // trim(adjustl(kgen_counter_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "** Verification against '" // trim(adjustl(kgen_filepath)) // "' **" - - CALL kgen_read_externs_rrsw_ref(kgen_unit) - CALL kgen_read_externs_rrsw_tbl(kgen_unit) - CALL kgen_read_externs_rrsw_kg19(kgen_unit) - CALL kgen_read_externs_rrsw_kg18(kgen_unit) - CALL kgen_read_externs_rrsw_kg17(kgen_unit) - CALL kgen_read_externs_rrsw_kg16(kgen_unit) - CALL kgen_read_externs_rrsw_cld(kgen_unit) - CALL kgen_read_externs_rrsw_kg29(kgen_unit) - CALL kgen_read_externs_rrsw_wvn(kgen_unit) - CALL kgen_read_externs_rrsw_vsn(kgen_unit) - CALL kgen_read_externs_rrsw_kg24(kgen_unit) - CALL kgen_read_externs_rrsw_kg25(kgen_unit) - CALL kgen_read_externs_rrsw_kg26(kgen_unit) - CALL kgen_read_externs_rrsw_kg27(kgen_unit) - CALL kgen_read_externs_rrsw_kg20(kgen_unit) - CALL kgen_read_externs_rrsw_kg21(kgen_unit) - CALL kgen_read_externs_rrsw_kg22(kgen_unit) - CALL kgen_read_externs_rrsw_kg23(kgen_unit) - CALL kgen_read_externs_scammod(kgen_unit) - CALL kgen_read_externs_rrsw_kg28(kgen_unit) - CALL kgen_read_externs_radsw(kgen_unit) - CALL kgen_read_externs_rrtmg_state(kgen_unit) - CALL kgen_read_externs_rrsw_con(kgen_unit) - - ! driver variables - CALL kgen_read_real_r8_dim1(fsns, kgen_unit) - CALL kgen_read_real_r8_dim1(fsnt, kgen_unit) - CALL kgen_read_real_r8_dim1(fsds, kgen_unit) - CALL kgen_read_mod42(state, kgen_unit) - CALL kgen_read_mod43(cam_out, kgen_unit) - CALL kgen_read_mod43(cam_in, kgen_unit) - - call radiation_tend(fsns, fsnt, fsds, state, cam_out, cam_in, kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_r8_dim1(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim1 - - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/PORT_sw_rad/src/kgen_utils.f90 b/test/ncar_kernels/PORT_sw_rad/src/kgen_utils.f90 deleted file mode 100644 index cfa8d114e0..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/kgen_utils.f90 +++ /dev/null @@ -1,61 +0,0 @@ -module kgen_utils_mod - -INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - -type check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - real(kind=kgen_dp) :: minvalue -end type check_t - -public kgen_dp, check_t, kgen_init_check, kgen_print_check - -contains - -subroutine kgen_init_check(check, tolerance, minvalue) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - real(kind=kgen_dp), intent(in), optional :: minvalue - - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.0D-15 - endif - if(present(minvalue)) then - check%minvalue = minvalue - else - check%minvalue = 1.0D-15 - endif -end subroutine kgen_init_check - -subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif -end subroutine kgen_print_check - -end module diff --git a/test/ncar_kernels/PORT_sw_rad/src/mcica_random_numbers.f90 b/test/ncar_kernels/PORT_sw_rad/src/mcica_random_numbers.f90 deleted file mode 100644 index 222c595c64..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/mcica_random_numbers.f90 +++ /dev/null @@ -1,371 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mcica_random_numbers.f90 -! Generated at: 2015-07-07 00:48:25 -! KGEN version: 0.4.13 - - - - MODULE mersennetwister - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! ------------------------------------------------------------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - IMPLICIT NONE - PRIVATE - ! Algorithm parameters - ! ------- - ! Period parameters - INTEGER, parameter :: blocksize = 624 - INTEGER, parameter :: lmask = 2147483647 - INTEGER, parameter :: umask = (-lmask) - 1 - INTEGER, parameter :: m = 397 - INTEGER, parameter :: matrix_a = -1727483681 - ! constant vector a (0x9908b0dfUL) - ! least significant r bits (0x7fffffffUL) - ! most significant w-r bits (0x80000000UL) - ! Tempering parameters - INTEGER, parameter :: tmaskb= -1658038656 - INTEGER, parameter :: tmaskc= -272236544 ! (0x9d2c5680UL) - ! (0xefc60000UL) - ! ------- - ! The type containing the state variable - TYPE randomnumbersequence - INTEGER :: currentelement ! = blockSize - INTEGER, dimension(0:blocksize -1) :: state ! = 0 - END TYPE randomnumbersequence - - INTERFACE new_randomnumbersequence - MODULE PROCEDURE initialize_scalar, initialize_vector - END INTERFACE new_randomnumbersequence - PUBLIC randomnumbersequence - PUBLIC new_randomnumbersequence, getrandomreal, getrandomint - ! ------------------------------------------------------------- - - ! read interface - PUBLIC kgen_read - INTERFACE kgen_read - MODULE PROCEDURE kgen_read_randomnumbersequence - END INTERFACE kgen_read - - PUBLIC kgen_verify - INTERFACE kgen_verify - MODULE PROCEDURE kgen_verify_randomnumbersequence - END INTERFACE kgen_verify - - CONTAINS - - ! write subroutines - ! No module extern variables - SUBROUTINE kgen_read_randomnumbersequence(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(randomnumbersequence), INTENT(out) :: var - READ(UNIT=kgen_unit) var%currentelement - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%currentelement **", var%currentelement - END IF - READ(UNIT=kgen_unit) var%state - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%state **", var%state - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_randomnumbersequence(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(randomnumbersequence), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_integer("currentelement", dtype_check_status, var%currentelement, ref_var%currentelement) - CALL kgen_verify_integer_4_dim1("state", dtype_check_status, var%state, ref_var%state) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_integer( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - END SUBROUTINE kgen_verify_integer - - SUBROUTINE kgen_verify_integer_4_dim1( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in), DIMENSION(:) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - end if - - check_status%numFatal = check_status%numFatal+1 - END IF - END SUBROUTINE kgen_verify_integer_4_dim1 - - ! ------------------------------------------------------------- - ! Private functions - ! --------------------------- - - FUNCTION mixbits(u, v) - INTEGER, intent( in) :: u - INTEGER, intent( in) :: v - INTEGER :: mixbits - mixbits = ior(iand(u, UMASK), iand(v, LMASK)) - END FUNCTION mixbits - ! --------------------------- - - FUNCTION twist(u, v) - INTEGER, intent( in) :: u - INTEGER, intent( in) :: v - INTEGER :: twist - ! Local variable - INTEGER, parameter, dimension(0:1) :: t_matrix = (/ 0, matrix_a /) - twist = ieor(ishft(mixbits(u, v), -1), t_matrix(iand(v, 1))) - twist = ieor(ishft(mixbits(u, v), -1), t_matrix(iand(v, 1))) - END FUNCTION twist - ! --------------------------- - - SUBROUTINE nextstate(twister) - TYPE(randomnumbersequence), intent(inout) :: twister - ! Local variables - INTEGER :: k - do k = 0, blockSize - M - 1 - twister%state(k) = ieor(twister%state(k + M), & - twist(twister%state(k), twister%state(k + 1))) - end do - do k = blockSize - M, blockSize - 2 - twister%state(k) = ieor(twister%state(k + M - blockSize), & - twist(twister%state(k), twister%state(k + 1))) - end do - twister%state(blockSize - 1) = ieor(twister%state(M - 1), & - twist(twister%state(blockSize - 1), twister%state(0))) - twister%currentElement = 0 - END SUBROUTINE nextstate - ! --------------------------- - - elemental FUNCTION temper(y) - INTEGER, intent(in) :: y - INTEGER :: temper - INTEGER :: x - ! Tempering - x = ieor(y, ishft(y, -11)) - x = ieor(x, iand(ishft(x, 7), TMASKB)) - x = ieor(x, iand(ishft(x, 15), TMASKC)) - temper = ieor(x, ishft(x, -18)) - END FUNCTION temper - ! ------------------------------------------------------------- - ! Public (but hidden) functions - ! -------------------- - - FUNCTION initialize_scalar(seed) RESULT ( twister ) - INTEGER, intent(in ) :: seed - TYPE(randomnumbersequence) :: twister - INTEGER :: i - ! See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. In the previous versions, - ! MSBs of the seed affect only MSBs of the array state[]. - ! 2002/01/09 modified by Makoto Matsumoto - twister%state(0) = iand(seed, -1) - do i = 1, blockSize - 1 ! ubound(twister%state) ! ubound(twister%state) - twister%state(i) = 1812433253 * ieor(twister%state(i-1), & - ishft(twister%state(i-1), -30)) + i - twister%state(i) = iand(twister%state(i), -1) ! for >32 bit machines ! for >32 bit machines - end do - twister%currentElement = blockSize - END FUNCTION initialize_scalar - ! ------------------------------------------------------------- - - FUNCTION initialize_vector(seed) RESULT ( twister ) - INTEGER, dimension(0:), intent(in) :: seed - TYPE(randomnumbersequence) :: twister - INTEGER :: nwraps - INTEGER :: nfirstloop - INTEGER :: k - INTEGER :: i - INTEGER :: j - nWraps = 0 - twister = initialize_scalar(19650218) - nFirstLoop = max(blockSize, size(seed)) - do k = 1, nFirstLoop - i = mod(k + nWraps, blockSize) - j = mod(k - 1, size(seed)) - if(i == 0) then - twister%state(i) = twister%state(blockSize - 1) - twister%state(1) = ieor(twister%state(1), & - ieor(twister%state(1-1), & - ishft(twister%state(1-1), -30)) * 1664525) + & - seed(j) + j ! Non-linear - ! Non-linear - twister%state(i) = iand(twister%state(i), -1) ! for >32 bit machines ! for >32 bit machines - nWraps = nWraps + 1 - else - twister%state(i) = ieor(twister%state(i), & - ieor(twister%state(i-1), & - ishft(twister%state(i-1), -30)) * 1664525) + & - seed(j) + j ! Non-linear - ! Non-linear - twister%state(i) = iand(twister%state(i), -1) ! for >32 bit machines ! for >32 bit machines - end if - end do - ! - ! Walk through the state array, beginning where we left off in the block above - ! - do i = mod(nFirstLoop, blockSize) + nWraps + 1, blockSize - 1 - twister%state(i) = ieor(twister%state(i), & - ieor(twister%state(i-1), & - ishft(twister%state(i-1), -30)) * 1566083941) - i ! Non-linear - ! Non-linear - twister%state(i) = iand(twister%state(i), -1) ! for >32 bit machines ! for >32 bit machines - end do - twister%state(0) = twister%state(blockSize - 1) - do i = 1, mod(nFirstLoop, blockSize) + nWraps - twister%state(i) = ieor(twister%state(i), & - ieor(twister%state(i-1), & - ishft(twister%state(i-1), -30)) * 1566083941) - i ! Non-linear - ! Non-linear - twister%state(i) = iand(twister%state(i), -1) ! for >32 bit machines ! for >32 bit machines - end do - twister%state(0) = UMASK - twister%currentElement = blockSize - END FUNCTION initialize_vector - ! ------------------------------------------------------------- - ! Public functions - ! -------------------- - - FUNCTION getrandomint(twister) - TYPE(randomnumbersequence), intent(inout) :: twister - INTEGER :: getrandomint - ! Generate a random integer on the interval [0,0xffffffff] - ! Equivalent to genrand_int32 in the C code. - ! Fortran doesn't have a type that's unsigned like C does, - ! so this is integers in the range -2**31 - 2**31 - ! All functions for getting random numbers call this one, - ! then manipulate the result - if(twister%currentElement >= blockSize) call nextState(twister) - getRandomInt = temper(twister%state(twister%currentElement)) - twister%currentElement = twister%currentElement + 1 - END FUNCTION getrandomint - ! -------------------- - - ! -------------------- - !! mji - modified Jan 2007, double converted to rrtmg real kind type - - FUNCTION getrandomreal(twister) - TYPE(randomnumbersequence), intent(inout) :: twister - ! double precision :: getRandomReal - REAL(KIND=r8) :: getrandomreal - ! Generate a random number on [0,1] - ! Equivalent to genrand_real1 in the C code - ! The result is stored as double precision but has 32 bit resolution - INTEGER :: localint - localInt = getRandomInt(twister) - if(localInt < 0) then - ! getRandomReal = dble(localInt + 2.0d0**32)/(2.0d0**32 - 1.0d0) - getRandomReal = (localInt + 2.0**32_r8)/(2.0**32_r8 - 1.0_r8) - else - ! getRandomReal = dble(localInt )/(2.0d0**32 - 1.0d0) - getRandomReal = (localInt )/(2.0**32_r8 - 1.0_r8) - end if - END FUNCTION getrandomreal - ! -------------------- - - ! -------------------- - END MODULE mersennetwister - - MODULE mcica_random_numbers - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! Generic module to wrap random number generators. - ! The module defines a type that identifies the particular stream of random - ! numbers, and has procedures for initializing it and getting real numbers - ! in the range 0 to 1. - ! This version uses the Mersenne Twister to generate random numbers on [0, 1]. - ! - ! The random number engine. - !! mji - !! use time_manager_mod, only: time_type, get_date - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - IMPLICIT NONE - PRIVATE - - - !! mji - !! initializeRandomNumberStream, getRandomNumbers, & - !! constructSeed - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - ! --------------------------------------------------------- - ! Initialization - ! --------------------------------------------------------- - - ! --------------------------------------------------------- - - ! --------------------------------------------------------- - ! Procedures for drawing random numbers - ! --------------------------------------------------------- - - ! --------------------------------------------------------- - - ! --------------------------------------------------------- - - ! mji - ! ! --------------------------------------------------------- - ! ! Constructing a unique seed from grid cell index and model date/time - ! ! Once we have the GFDL stuff we'll add the year, month, day, hour, minute - ! ! --------------------------------------------------------- - ! function constructSeed(i, j, time) result(seed) - ! integer, intent( in) :: i, j - ! type(time_type), intent( in) :: time - ! integer, dimension(8) :: seed - ! - ! ! Local variables - ! integer :: year, month, day, hour, minute, second - ! - ! - ! call get_date(time, year, month, day, hour, minute, second) - ! seed = (/ i, j, year, month, day, hour, minute, second /) - ! end function constructSeed - END MODULE mcica_random_numbers diff --git a/test/ncar_kernels/PORT_sw_rad/src/mcica_subcol_gen_sw.f90 b/test/ncar_kernels/PORT_sw_rad/src/mcica_subcol_gen_sw.f90 deleted file mode 100644 index add585c4af..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/mcica_subcol_gen_sw.f90 +++ /dev/null @@ -1,537 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mcica_subcol_gen_sw.f90 -! Generated at: 2015-07-07 00:48:24 -! KGEN version: 0.4.13 - - - - MODULE mcica_subcol_gen_sw - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2006-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! Purpose: Create McICA stochastic arrays for cloud physical or optical properties. - ! Two options are possible: - ! 1) Input cloud physical properties: cloud fraction, ice and liquid water - ! paths, ice fraction, and particle sizes. Output will be stochastic - ! arrays of these variables. (inflag = 1) - ! 2) Input cloud optical properties directly: cloud optical depth, single - ! scattering albedo and asymmetry parameter. Output will be stochastic - ! arrays of these variables. (inflag = 0) - ! --------- Modules ---------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - !use abortutils, only: endrun - ! use parkind, only : jpim, jprb - USE parrrsw, ONLY: ngptsw - USE rrsw_wvn, ONLY: ngb - IMPLICIT NONE - PRIVATE - ! public interfaces/functions/subroutines - PUBLIC mcica_subcol_sw, generate_stochastic_clouds_sw - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !------------------------------------------------------------------ - ! Public subroutines - !------------------------------------------------------------------ - - SUBROUTINE mcica_subcol_sw(lchnk, ncol, nlay, icld, permuteseed, play, cldfrac, ciwp, clwp, rei, rel, tauc, ssac, asmc, & - fsfc, cldfmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl) - ! ----- Input ----- - ! Control - INTEGER, intent(in) :: lchnk ! chunk identifier - INTEGER, intent(in) :: ncol ! number of columns - INTEGER, intent(in) :: nlay ! number of model layers - INTEGER, intent(in) :: icld ! clear/cloud, cloud overlap flag - INTEGER, intent(in) :: permuteseed ! if the cloud generator is called multiple times, - ! permute the seed between each call; - ! between calls for LW and SW, recommended - ! permuteseed differs by 'ngpt' - ! Atmosphere - REAL(KIND=r8), intent(in) :: play(:,:) ! layer pressures (mb) - ! Dimensions: (ncol,nlay) - ! Atmosphere/clouds - cldprop - REAL(KIND=r8), intent(in) :: cldfrac(:,:) ! layer cloud fraction - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: tauc(:,:,:) ! cloud optical depth - ! Dimensions: (nbndsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: ssac(:,:,:) ! cloud single scattering albedo (non-delta scaled) - ! Dimensions: (nbndsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: asmc(:,:,:) ! cloud asymmetry parameter (non-delta scaled) - ! Dimensions: (nbndsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: fsfc(:,:,:) ! cloud forward scattering fraction (non-delta scaled) - ! Dimensions: (nbndsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: ciwp(:,:) ! cloud ice water path - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: clwp(:,:) ! cloud liquid water path - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: rei(:,:) ! cloud ice particle size - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: rel(:,:) ! cloud liquid particle size - ! Dimensions: (ncol,nlay) - ! ----- Output ----- - ! Atmosphere/clouds - cldprmc [mcica] - REAL(KIND=r8), intent(out) :: cldfmcl(:,:,:) ! cloud fraction [mcica] - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(out) :: ciwpmcl(:,:,:) ! cloud ice water path [mcica] - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(out) :: clwpmcl(:,:,:) ! cloud liquid water path [mcica] - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(out) :: relqmcl(:,:) ! liquid particle size (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: reicmcl(:,:) ! ice partcle size (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: taucmcl(:,:,:) ! cloud optical depth [mcica] - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(out) :: ssacmcl(:,:,:) ! cloud single scattering albedo [mcica] - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(out) :: asmcmcl(:,:,:) ! cloud asymmetry parameter [mcica] - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(out) :: fsfcmcl(:,:,:) ! cloud forward scattering fraction [mcica] - ! Dimensions: (ngptsw,ncol,nlay) - ! ----- Local ----- - ! Stochastic cloud generator variables [mcica] - INTEGER, parameter :: nsubcsw = ngptsw ! number of sub-columns (g-point intervals) - ! loop indices - REAL(KIND=r8) :: pmid(ncol,nlay) ! layer pressures (Pa) - ! real(kind=r8) :: pdel(ncol,nlay) ! layer pressure thickness (Pa) - ! real(kind=r8) :: qi(ncol,nlay) ! ice water (specific humidity) - ! real(kind=r8) :: ql(ncol,nlay) ! liq water (specific humidity) - ! Return if clear sky; or stop if icld out of range - if (icld.eq.0) return - if (icld.lt.0.or.icld.gt.3) then - ! call endrun('MCICA_SUBCOL: INVALID ICLD') - endif - ! NOTE: For GCM mode, permuteseed must be offset between LW and SW by at least number of subcolumns - ! Pass particle sizes to new arrays, no subcolumns for these properties yet - ! Convert pressures from mb to Pa - reicmcl(:ncol,:nlay) = rei(:ncol,:nlay) - relqmcl(:ncol,:nlay) = rel(:ncol,:nlay) - pmid(:ncol,:nlay) = play(:ncol,:nlay)*1.e2_r8 - ! Convert input ice and liquid cloud water paths to specific humidity ice and liquid components - ! cwp = (q * pdel * 1000.) / gravit) - ! = (kg/kg * kg m-1 s-2 *1000.) / m s-2 - ! = (g m-2) - ! - ! q = (cwp * gravit) / (pdel *1000.) - ! = (g m-2 * m s-2) / (kg m-1 s-2 * 1000.) - ! = kg/kg - ! do km = 1, nlay - ! qi(km) = (ciwp(km) * grav) / (pdel(km) * 1000._r8) - ! ql(km) = (clwp(km) * grav) / (pdel(km) * 1000._r8) - ! enddo - ! Generate the stochastic subcolumns of cloud optical properties for the shortwave; - call generate_stochastic_clouds_sw (ncol, nlay, nsubcsw, icld, pmid, cldfrac, clwp, ciwp, tauc, & - ssac, asmc, fsfc, cldfmcl, clwpmcl, ciwpmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl, permuteseed) - END SUBROUTINE mcica_subcol_sw - !------------------------------------------------------------------------------------------------- - - SUBROUTINE generate_stochastic_clouds_sw(ncol, nlay, nsubcol, icld, pmid, cld, clwp, ciwp, tauc, ssac, asmc, fsfc, & - cld_stoch, clwp_stoch, ciwp_stoch, tauc_stoch, ssac_stoch, asmc_stoch, fsfc_stoch, changeseed) - !------------------------------------------------------------------------------------------------- - !---------------------------------------------------------------------------------------------------------------- - ! --------------------- - ! Contact: Cecile Hannay (hannay@ucar.edu) - ! - ! Original code: Based on Raisanen et al., QJRMS, 2004. - ! - ! Modifications: Generalized for use with RRTMG and added Mersenne Twister as the default - ! random number generator, which can be changed to the optional kissvec random number generator - ! with flag 'irnd' below . Some extra functionality has been commented or removed. - ! Michael J. Iacono, AER, Inc., February 2007 - ! - ! Given a profile of cloud fraction, cloud water and cloud ice, we produce a set of subcolumns. - ! Each layer within each subcolumn is homogeneous, with cloud fraction equal to zero or one - ! and uniform cloud liquid and cloud ice concentration. - ! The ensemble as a whole reproduces the probability function of cloud liquid and ice within each layer - ! and obeys an overlap assumption in the vertical. - ! - ! Overlap assumption: - ! The cloud are consistent with 4 overlap assumptions: random, maximum, maximum-random and exponential. - ! The default option is maximum-random (option 3) - ! The options are: 1=random overlap, 2=max/random, 3=maximum overlap, 4=exponential overlap - ! This is set with the variable "overlap" - !mji - Exponential overlap option (overlap=4) has been deactivated in this version - ! The exponential overlap uses also a length scale, Zo. (real, parameter :: Zo = 2500. ) - ! - ! Seed: - ! If the stochastic cloud generator is called several times during the same timestep, - ! one should change the seed between the call to insure that the subcolumns are different. - ! This is done by changing the argument 'changeSeed' - ! For example, if one wants to create a set of columns for the shortwave and another set for the longwave , - ! use 'changeSeed = 1' for the first call and'changeSeed = 2' for the second call - ! - ! PDF assumption: - ! We can use arbitrary complicated PDFS. - ! In the present version, we produce homogeneuous clouds (the simplest case). - ! Future developments include using the PDF scheme of Ben Johnson. - ! - ! History file: - ! Option to add diagnostics variables in the history file. (using FINCL in the namelist) - ! nsubcol = number of subcolumns - ! overlap = overlap type (1-3) - ! Zo = length scale - ! CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic) - ! CLDLIQ_S = mean of the subcolumn cloud water - ! CLDICE_S = mean of the subcolumn cloud ice - ! - ! Note: - ! Here: we force that the cloud condensate to be consistent with the cloud fraction - ! i.e we only have cloud condensate when the cell is cloudy. - ! In CAM: The cloud condensate and the cloud fraction are obtained from 2 different equations - ! and the 2 quantities can be inconsistent (i.e. CAM can produce cloud fraction - ! without cloud condensate or the opposite). - !--------------------------------------------------------------------------------------------------------------- - !USE mcica_random_numbers, only : r8 - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! The Mersenne Twister random number engine - USE mersennetwister, ONLY: randomnumbersequence - USE mersennetwister, ONLY: new_randomnumbersequence - USE mersennetwister, ONLY: getrandomreal - TYPE(randomnumbersequence) :: randomnumbers - ! -- Arguments - INTEGER, intent(in) :: ncol ! number of layers - INTEGER, intent(in) :: nlay ! number of layers - INTEGER, intent(in) :: icld ! clear/cloud, cloud overlap flag - INTEGER, intent(in) :: nsubcol ! number of sub-columns (g-point intervals) - INTEGER, optional, intent(in) :: changeseed ! allows permuting seed - ! Column state (cloud fraction, cloud water, cloud ice) + variables needed to read physics state - REAL(KIND=r8), intent(in) :: pmid(:,:) ! layer pressure (Pa) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: cld(:,:) ! cloud fraction - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: clwp(:,:) ! cloud liquid water path (g/m2) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: ciwp(:,:) ! cloud ice water path (g/m2) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: tauc(:,:,:) ! cloud optical depth (non-delta scaled) - ! Dimensions: (nbndsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: ssac(:,:,:) ! cloud single scattering albedo (non-delta scaled) - ! Dimensions: (nbndsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: asmc(:,:,:) ! cloud asymmetry parameter (non-delta scaled) - ! Dimensions: (nbndsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: fsfc(:,:,:) ! cloud forward scattering fraction (non-delta scaled) - ! Dimensions: (nbndsw,ncol,nlay) - REAL(KIND=r8), intent(out) :: cld_stoch(:,:,:) ! subcolumn cloud fraction - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(out) :: clwp_stoch(:,:,:) ! subcolumn cloud liquid water path - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(out) :: ciwp_stoch(:,:,:) ! subcolumn cloud ice water path - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(out) :: tauc_stoch(:,:,:) ! subcolumn cloud optical depth - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(out) :: ssac_stoch(:,:,:) ! subcolumn cloud single scattering albedo - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(out) :: asmc_stoch(:,:,:) ! subcolumn cloud asymmetry parameter - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(out) :: fsfc_stoch(:,:,:) ! subcolumn cloud forward scattering fraction - ! Dimensions: (ngptsw,ncol,nlay) - ! -- Local variables - REAL(KIND=r8) :: cldf(ncol,nlay) ! cloud fraction - ! Dimensions: (ncol,nlay) - ! Mean over the subcolumns (cloud fraction, cloud water , cloud ice) - inactive - ! real(kind=r8) :: mean_cld_stoch(ncol,nlay) ! cloud fraction - ! real(kind=r8) :: mean_clwp_stoch(ncol,nlay) ! cloud water - ! real(kind=r8) :: mean_ciwp_stoch(ncol,nlay) ! cloud ice - ! real(kind=r8) :: mean_tauc_stoch(ncol,nlay) ! cloud optical depth - ! real(kind=r8) :: mean_ssac_stoch(ncol,nlay) ! cloud single scattering albedo - ! real(kind=r8) :: mean_asmc_stoch(ncol,nlay) ! cloud asymmetry parameter - ! real(kind=r8) :: mean_fsfc_stoch(ncol,nlay) ! cloud forward scattering fraction - ! Set overlap - INTEGER :: overlap ! 1 = random overlap, 2 = maximum/random, - ! 3 = maximum overlap, - ! real(kind=r8), parameter :: Zo = 2500._r8 ! length scale (m) - ! real(kind=r8) :: zm(ncon,nlay) ! Height of midpoints (above surface) - ! real(kind=r8), dimension(nlay) :: alpha=0.0_r8 ! overlap parameter - ! Constants (min value for cloud fraction and cloud water and ice) - REAL(KIND=r8), parameter :: cldmin = 1.0e-80_r8 ! min cloud fraction - ! real(kind=r8), parameter :: qmin = 1.0e-10_r8 ! min cloud water and cloud ice (not used) - ! Variables related to random number and seed - INTEGER :: irnd ! flag for random number generator - ! 0 = kissvec - ! 1 = Mersenne Twister - REAL(KIND=r8), dimension(nsubcol, ncol, nlay) :: cdf ! random numbers - INTEGER, dimension(ncol) :: seed1 - INTEGER, dimension(ncol) :: seed2 - INTEGER, dimension(ncol) :: seed3 - INTEGER, dimension(ncol) :: seed4 ! seed to create random number - REAL(KIND=r8), dimension(ncol) :: rand_num ! random number (kissvec) - ! seed to create random number (Mersenne Twister) - REAL(KIND=r8) :: rand_num_mt ! random number (Mersenne Twister) - ! Flag to identify cloud fraction in subcolumns - LOGICAL, dimension(nsubcol, ncol, nlay) :: iscloudy ! flag that says whether a gridbox is cloudy - ! Indices - INTEGER :: i - INTEGER :: isubcol - INTEGER :: ilev - INTEGER :: ngbm - INTEGER :: n ! indices - !------------------------------------------------------------------------------------------ - ! Set randum number generator to use (0 = kissvec; 1 = mersennetwister) - irnd = 0 - ! irnd = 1 - ! Pass input cloud overlap setting to local variable - overlap = icld - ! ensure that cloud fractions are in bounds - cldf(:,:) = cld(:ncol,:nlay) - where (cldf(:,:) < cldmin) - cldf(:,:) = 0._r8 - END WHERE - ! ----- Create seed -------- - ! Advance randum number generator by changeseed values - if (irnd.eq.0) then - ! For kissvec, create a seed that depends on the state of the columns. Maybe not the best way, but it works. - ! Must use pmid from bottom four layers. - do i=1,ncol - if (pmid(i,nlay).lt.pmid(i,nlay-1)) then - ! call endrun('MCICA_SUBCOL: KISSVEC SEED GENERATOR REQUIRES PMID FROM BOTTOM FOUR LAYERS.') - endif - seed1(i) = (pmid(i,nlay) - int(pmid(i,nlay))) * 1000000000 - seed2(i) = (pmid(i,nlay-1) - int(pmid(i,nlay-1))) * 1000000000 - seed3(i) = (pmid(i,nlay-2) - int(pmid(i,nlay-2))) * 1000000000 - seed4(i) = (pmid(i,nlay-3) - int(pmid(i,nlay-3))) * 1000000000 - enddo - do i=1,changeSeed - call kissvec(seed1, seed2, seed3, seed4, rand_num) - enddo - elseif (irnd.eq.1) then - randomNumbers = new_RandomNumberSequence(seed = changeSeed) - endif - ! ------ Apply overlap assumption -------- - ! generate the random numbers - select case (overlap) - CASE ( 1 ) - ! Random overlap - ! i) pick a random value at every level - if (irnd.eq.0) then - do isubcol = 1,nsubcol - do ilev = 1,nlay - call kissvec(seed1, seed2, seed3, seed4, rand_num) - CDF(isubcol,:,ilev) = rand_num - enddo - enddo - elseif (irnd.eq.1) then - do isubcol = 1, nsubcol - do i = 1, ncol - do ilev = 1, nlay - rand_num_mt = getRandomReal(randomNumbers) - CDF(isubcol,i,ilev) = rand_num_mt - enddo - enddo - enddo - endif - CASE ( 2 ) - ! Maximum-Random overlap - ! i) pick a random number for top layer. - ! ii) walk down the column: - ! - if the layer above is cloudy, we use the same random number than in the layer above - ! - if the layer above is clear, we use a new random number - if (irnd.eq.0) then - do isubcol = 1,nsubcol - do ilev = 1,nlay - call kissvec(seed1, seed2, seed3, seed4, rand_num) - CDF(isubcol,:,ilev) = rand_num - enddo - enddo - elseif (irnd.eq.1) then - do isubcol = 1, nsubcol - do i = 1, ncol - do ilev = 1, nlay - rand_num_mt = getRandomReal(randomNumbers) - CDF(isubcol,i,ilev) = rand_num_mt - enddo - enddo - enddo - endif - do ilev = 2,nlay - do i = 1, ncol - do isubcol = 1, nsubcol - if (CDF(isubcol, i, ilev-1) > 1._r8 - cldf(i,ilev-1) ) then - CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev-1) - else - CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev) * (1._r8 - cldf(i,ilev-1)) - end if - end do - end do - enddo - CASE ( 3 ) - ! Maximum overlap - ! i) pick same random numebr at every level - if (irnd.eq.0) then - do isubcol = 1,nsubcol - call kissvec(seed1, seed2, seed3, seed4, rand_num) - do ilev = 1,nlay - CDF(isubcol,:,ilev) = rand_num - enddo - enddo - elseif (irnd.eq.1) then - do isubcol = 1, nsubcol - do i = 1, ncol - rand_num_mt = getRandomReal(randomNumbers) - do ilev = 1, nlay - CDF(isubcol,i,ilev) = rand_num_mt - enddo - enddo - enddo - endif - ! case(4) - inactive - ! ! Exponential overlap: weighting between maximum and random overlap increases with the distance. - ! ! The random numbers for exponential overlap verify: - ! ! j=1 RAN(j)=RND1 - ! ! j>1 if RND1 < alpha(j,j-1) => RAN(j) = RAN(j-1) - ! ! RAN(j) = RND2 - ! ! alpha is obtained from the equation - ! ! alpha = exp(- (Zi-Zj-1)/Zo) where Zo is a characteristic length scale - ! ! compute alpha - ! zm = state%zm - ! alpha(:, 1) = 0._r8 - ! do ilev = 2,nlay - ! alpha(:, ilev) = exp( -( zm (:, ilev-1) - zm (:, ilev)) / Zo) - ! end do - ! ! generate 2 streams of random numbers - ! do isubcol = 1,nsubcol - ! do ilev = 1,nlay - ! call kissvec(seed1, seed2, seed3, seed4, rand_num) - ! CDF(isubcol, :, ilev) = rand_num - ! call kissvec(seed1, seed2, seed3, seed4, rand_num) - ! CDF2(isubcol, :, ilev) = rand_num - ! end do - ! end do - ! ! generate random numbers - ! do ilev = 2,nlay - ! where (CDF2(:, :, ilev) < spread(alpha (:,ilev), dim=1, nCopies=nsubcol) ) - ! CDF(:,:,ilev) = CDF(:,:,ilev-1) - ! end where - ! end do - end select - ! -- generate subcolumns for homogeneous clouds ----- - do ilev = 1, nlay - isCloudy(:,:,ilev) = (CDF(:,:,ilev) >= 1._r8 - spread(cldf(:,ilev), dim=1, nCopies=nsubcol) ) - enddo - ! where the subcolumn is cloudy, the subcolumn cloud fraction is 1; - ! where the subcolumn is not cloudy, the subcolumn cloud fraction is 0 - do ilev = 1, nlay - do i = 1, ncol - do isubcol = 1, nsubcol - if (iscloudy(isubcol,i,ilev) ) then - cld_stoch(isubcol,i,ilev) = 1._r8 - else - cld_stoch(isubcol,i,ilev) = 0._r8 - endif - end do - end do - enddo - ! where there is a cloud, set the subcolumn cloud properties; - ! Incoming clwp, ciwp and tauc should be in-cloud quantites and not grid-averaged quantities - do ilev = 1, nlay - do i = 1, ncol - do isubcol = 1, nsubcol - if ( iscloudy(isubcol,i,ilev) .and. (cldf(i,ilev) > 0._r8) ) then - clwp_stoch(isubcol,i,ilev) = clwp(i,ilev) - ciwp_stoch(isubcol,i,ilev) = ciwp(i,ilev) - else - clwp_stoch(isubcol,i,ilev) = 0._r8 - ciwp_stoch(isubcol,i,ilev) = 0._r8 - end if - end do - end do - enddo - ngbm = ngb(1) - 1 - do ilev = 1,nlay - do i = 1, ncol - do isubcol = 1, nsubcol - if ( iscloudy(isubcol,i,ilev) .and. (cldf(i,ilev) > 0._r8) ) then - n = ngb(isubcol) - ngbm - tauc_stoch(isubcol,i,ilev) = tauc(n,i,ilev) - ssac_stoch(isubcol,i,ilev) = ssac(n,i,ilev) - asmc_stoch(isubcol,i,ilev) = asmc(n,i,ilev) - fsfc_stoch(isubcol,i,ilev) = fsfc(n,i,ilev) - else - tauc_stoch(isubcol,i,ilev) = 0._r8 - ssac_stoch(isubcol,i,ilev) = 1._r8 - asmc_stoch(isubcol,i,ilev) = 0._r8 - fsfc_stoch(isubcol,i,ilev) = 0._r8 - endif - enddo - enddo - enddo - ! -- compute the means of the subcolumns --- - ! mean_cld_stoch(:,:) = 0._r8 - ! mean_clwp_stoch(:,:) = 0._r8 - ! mean_ciwp_stoch(:,:) = 0._r8 - ! mean_tauc_stoch(:,:) = 0._r8 - ! mean_ssac_stoch(:,:) = 0._r8 - ! mean_asmc_stoch(:,:) = 0._r8 - ! mean_fsfc_stoch(:,:) = 0._r8 - ! do i = 1, nsubcol - ! mean_cld_stoch(:,:) = cld_stoch(i,:,:) + mean_cld_stoch(:,:) - ! mean_clwp_stoch(:,:) = clwp_stoch( i,:,:) + mean_clwp_stoch(:,:) - ! mean_ciwp_stoch(:,:) = ciwp_stoch( i,:,:) + mean_ciwp_stoch(:,:) - ! mean_tauc_stoch(:,:) = tauc_stoch( i,:,:) + mean_tauc_stoch(:,:) - ! mean_ssac_stoch(:,:) = ssac_stoch( i,:,:) + mean_ssac_stoch(:,:) - ! mean_asmc_stoch(:,:) = asmc_stoch( i,:,:) + mean_asmc_stoch(:,:) - ! mean_fsfc_stoch(:,:) = fsfc_stoch( i,:,:) + mean_fsfc_stoch(:,:) - ! end do - ! mean_cld_stoch(:,:) = mean_cld_stoch(:,:) / nsubcol - ! mean_clwp_stoch(:,:) = mean_clwp_stoch(:,:) / nsubcol - ! mean_ciwp_stoch(:,:) = mean_ciwp_stoch(:,:) / nsubcol - ! mean_tauc_stoch(:,:) = mean_tauc_stoch(:,:) / nsubcol - ! mean_ssac_stoch(:,:) = mean_ssac_stoch(:,:) / nsubcol - ! mean_asmc_stoch(:,:) = mean_asmc_stoch(:,:) / nsubcol - ! mean_fsfc_stoch(:,:) = mean_fsfc_stoch(:,:) / nsubcol - END SUBROUTINE generate_stochastic_clouds_sw - !------------------------------------------------------------------ - ! Private subroutines - !------------------------------------------------------------------ - !-------------------------------------------------------------------------------------------------- - - SUBROUTINE kissvec(seed1, seed2, seed3, seed4, ran_arr) - !-------------------------------------------------------------------------------------------------- - ! public domain code - ! made available from http://www.fortran.com/ - ! downloaded by pjr on 03/16/04 for NCAR CAM - ! converted to vector form, functions inlined by pjr,mvr on 05/10/2004 - ! safeguard against integer overflow, statement function changed to - ! internal function by santos, Nov. 2012 - ! The KISS (Keep It Simple Stupid) random number generator. Combines: - ! (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32. - ! (2) A 3-shift shift-register generator, period 2^32-1, - ! (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59 - ! Overall period>2^123; - ! - USE shr_kind_mod, ONLY: i8 => shr_kind_i8 - REAL(KIND=r8), dimension(:), intent(inout) :: ran_arr - INTEGER, dimension(:), intent(inout) :: seed1 - INTEGER, dimension(:), intent(inout) :: seed2 - INTEGER, dimension(:), intent(inout) :: seed3 - INTEGER, dimension(:), intent(inout) :: seed4 - INTEGER(KIND=i8) :: kiss - INTEGER :: i - do i = 1, size(ran_arr) - kiss = 69069_i8 * seed1(i) + 1327217885 - seed1(i) = transfer(kiss,1) - seed2(i) = m (m (m (seed2(i), 13), - 17), 5) - seed3(i) = 18000 * iand (seed3(i), 65535) + ishft (seed3(i), - 16) - seed4(i) = 30903 * iand (seed4(i), 65535) + ishft (seed4(i), - 16) - kiss = int(seed1(i), i8) + seed2(i) + ishft (seed3(i), 16) + seed4(i) - ran_arr(i) = transfer(kiss,1)*2.328306e-10_r8 + 0.5_r8 - end do - CONTAINS - - pure integer FUNCTION m(k, n) - INTEGER, intent(in) :: k - INTEGER, intent(in) :: n - m = ieor (k, ishft (k, n) ) - END FUNCTION m - END SUBROUTINE kissvec - END MODULE mcica_subcol_gen_sw diff --git a/test/ncar_kernels/PORT_sw_rad/src/parrrsw.f90 b/test/ncar_kernels/PORT_sw_rad/src/parrrsw.f90 deleted file mode 100644 index 9b4dde5c7f..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/parrrsw.f90 +++ /dev/null @@ -1,111 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : parrrsw.f90 -! Generated at: 2015-07-07 00:48:23 -! KGEN version: 0.4.13 - - - - MODULE parrrsw - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw main parameters - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! mxlay : integer: maximum number of layers - ! mg : integer: number of original g-intervals per spectral band - ! nbndsw : integer: number of spectral bands - ! naerec : integer: number of aerosols (iaer=6, ecmwf aerosol option) - ! ngptsw : integer: total number of reduced g-intervals for rrtmg_lw - ! ngNN : integer: number of reduced g-intervals per spectral band - ! ngsNN : integer: cumulative number of g-intervals per band - !------------------------------------------------------------------ - ! Settings for single column mode. - ! For GCM use, set nlon to number of longitudes, and - ! mxlay to number of model layers - !jplay, klev - !jpg - INTEGER, parameter :: nbndsw = 14 !jpsw, ksw - !jpaer - INTEGER, parameter :: mxmol = 38 - INTEGER, parameter :: nmol = 7 - ! Use for 112 g-point model - INTEGER, parameter :: ngptsw = 112 !jpgpt - ! Use for 224 g-point model - ! integer, parameter :: ngptsw = 224 !jpgpt - ! may need to rename these - from v2.6 - INTEGER, parameter :: jpband = 29 - INTEGER, parameter :: jpb1 = 16 !istart - INTEGER, parameter :: jpb2 = 29 !iend - ! ^ - ! Use for 112 g-point model - INTEGER, parameter :: ng16 = 6 - INTEGER, parameter :: ng17 = 12 - INTEGER, parameter :: ng18 = 8 - INTEGER, parameter :: ng19 = 8 - INTEGER, parameter :: ng20 = 10 - INTEGER, parameter :: ng21 = 10 - INTEGER, parameter :: ng22 = 2 - INTEGER, parameter :: ng23 = 10 - INTEGER, parameter :: ng24 = 8 - INTEGER, parameter :: ng25 = 6 - INTEGER, parameter :: ng26 = 6 - INTEGER, parameter :: ng27 = 8 - INTEGER, parameter :: ng28 = 6 - INTEGER, parameter :: ng29 = 12 - INTEGER, parameter :: ngs16 = 6 - INTEGER, parameter :: ngs17 = 18 - INTEGER, parameter :: ngs18 = 26 - INTEGER, parameter :: ngs19 = 34 - INTEGER, parameter :: ngs20 = 44 - INTEGER, parameter :: ngs21 = 54 - INTEGER, parameter :: ngs22 = 56 - INTEGER, parameter :: ngs23 = 66 - INTEGER, parameter :: ngs24 = 74 - INTEGER, parameter :: ngs25 = 80 - INTEGER, parameter :: ngs26 = 86 - INTEGER, parameter :: ngs27 = 94 - INTEGER, parameter :: ngs28 = 100 - ! Use for 224 g-point model - ! integer, parameter :: ng16 = 16 - ! integer, parameter :: ng17 = 16 - ! integer, parameter :: ng18 = 16 - ! integer, parameter :: ng19 = 16 - ! integer, parameter :: ng20 = 16 - ! integer, parameter :: ng21 = 16 - ! integer, parameter :: ng22 = 16 - ! integer, parameter :: ng23 = 16 - ! integer, parameter :: ng24 = 16 - ! integer, parameter :: ng25 = 16 - ! integer, parameter :: ng26 = 16 - ! integer, parameter :: ng27 = 16 - ! integer, parameter :: ng28 = 16 - ! integer, parameter :: ng29 = 16 - ! integer, parameter :: ngs16 = 16 - ! integer, parameter :: ngs17 = 32 - ! integer, parameter :: ngs18 = 48 - ! integer, parameter :: ngs19 = 64 - ! integer, parameter :: ngs20 = 80 - ! integer, parameter :: ngs21 = 96 - ! integer, parameter :: ngs22 = 112 - ! integer, parameter :: ngs23 = 128 - ! integer, parameter :: ngs24 = 144 - ! integer, parameter :: ngs25 = 160 - ! integer, parameter :: ngs26 = 176 - ! integer, parameter :: ngs27 = 192 - ! integer, parameter :: ngs28 = 208 - ! integer, parameter :: ngs29 = 224 - ! Source function solar constant - ! W/m2 - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE parrrsw diff --git a/test/ncar_kernels/PORT_sw_rad/src/physconst.F90 b/test/ncar_kernels/PORT_sw_rad/src/physconst.F90 deleted file mode 100644 index 41d640231a..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/physconst.F90 +++ /dev/null @@ -1,84 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : physconst.F90 -! Generated at: 2015-07-07 00:48:25 -! KGEN version: 0.4.13 - - - - MODULE physconst - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! Physical constants. Use CCSM shared values whenever available. - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - USE shr_const_mod, ONLY: shr_const_cpdair - ! Dimensions and chunk bounds - IMPLICIT NONE - PRIVATE - ! Constants based off share code or defined in physconst - ! Avogadro's number (molecules/kmole) - ! Boltzman's constant (J/K/molecule) - ! sec in calendar day ~ sec - REAL(KIND=r8), public, parameter :: cpair = shr_const_cpdair ! specific heat of dry air (J/K/kg) - ! specific heat of fresh h2o (J/K/kg) - ! Von Karman constant - ! Latent heat of fusion (J/kg) - ! Latent heat of vaporization (J/kg) - ! 3.14... - ! Standard pressure (Pascals) - ! Universal gas constant (J/K/kmol) - ! Density of liquid water (STP) - !special value - ! Stefan-Boltzmann's constant (W/m^2/K^4) - ! Triple point temperature of water (K) - ! Speed of light in a vacuum (m/s) - ! Planck's constant (J.s) - ! Molecular weights - ! molecular weight co2 - ! molecular weight n2o - ! molecular weight ch4 - ! molecular weight cfc11 - ! molecular weight cfc12 - ! molecular weight O3 - ! modifiable physical constants for aquaplanet - ! gravitational acceleration (m/s**2) - ! sec in siderial day ~ sec - ! molecular weight h2o - ! specific heat of water vapor (J/K/kg) - ! molecular weight dry air - ! radius of earth (m) - ! Freezing point of water (K) - !--------------- Variables below here are derived from those above ----------------------- - ! reciprocal of gravit - ! reciprocal of earth radius - ! earth rot ~ rad/sec - ! Water vapor gas constant ~ J/K/kg - ! Dry air gas constant ~ J/K/kg - ! ratio of h2o to dry air molecular weights - ! (rh2o/rair) - 1 - ! CPWV/CPDAIR - 1.0 - ! density of dry air at STP ~ kg/m^3 - ! R/Cp - ! Coriolis expansion coeff -> omega/sqrt(0.375) - !--------------- Variables below here are for WACCM-X ----------------------- - ! composition dependent specific heat at constant pressure - ! composition dependent gas "constant" - ! rairv/cpairv - ! composition dependent atmosphere mean mass - ! molecular viscosity kg/m/s - ! molecular conductivity J/m/s/K - !--------------- Variables below here are for turbulent mountain stress ----------------------- - !================================================================================================ - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !================================================================================================ - - !============================================================================== - ! Read namelist variables. - - !=============================================================================== - - END MODULE physconst diff --git a/test/ncar_kernels/PORT_sw_rad/src/physics_types.F90 b/test/ncar_kernels/PORT_sw_rad/src/physics_types.F90 deleted file mode 100644 index 3f3e4f5e17..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/physics_types.F90 +++ /dev/null @@ -1,844 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : physics_types.F90 -! Generated at: 2015-07-07 00:48:23 -! KGEN version: 0.4.13 - - - - MODULE physics_types - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - USE ppgrid, ONLY: pcols - USE ppgrid, ONLY: psubcols - IMPLICIT NONE - PRIVATE ! Make default type private to the module - ! Public types: - PUBLIC physics_state - ! Public interfaces - ! Check state object for invalid data. - ! adjust dry mass and energy for change in water - ! cannot be applied to eul or sld dycores - ! copy a physics_state object - ! copy a physics_ptend object - ! accumulate physics_ptend objects - ! initialize a physics_tend object - ! calculate dry air masses in state variable - ! allocate individual components within state - ! allocate components set by dycore - ! deallocate individual components within state - ! allocate individual components within tend - ! deallocate individual components within tend - ! allocate individual components within tend - ! deallocate individual components within tend - !------------------------------------------------------------------------------- - TYPE physics_state - INTEGER :: lchnk, ngrdcol, nsubcol(pcols), psetcols=0, ncol=0, indcol(pcols*psubcols) - ! chunk index - ! -- Grid -- number of active columns (on the grid) - ! -- Sub-columns -- number of active sub-columns in each grid column - ! -- -- max number of columns set - if subcols = pcols*psubcols, else = pcols - ! -- -- sum of nsubcol for all ngrdcols - number of active columns - ! -- -- indices for mapping from subcols to grid cols - REAL(KIND=r8), dimension(:), allocatable :: lat, lon, ps, psdry, phis, ulat, ulon - ! latitude (radians) - ! longitude (radians) - ! surface pressure - ! dry surface pressure - ! surface geopotential - ! unique latitudes (radians) - ! unique longitudes (radians) - REAL(KIND=r8), dimension(:,:), allocatable :: t, u, v, s, omega, pmid, pmiddry, pdel, pdeldry, rpdel, rpdeldry, & - lnpmid, lnpmiddry, exner, zm - ! temperature (K) - ! zonal wind (m/s) - ! meridional wind (m/s) - ! dry static energy - ! vertical pressure velocity (Pa/s) - ! midpoint pressure (Pa) - ! midpoint pressure dry (Pa) - ! layer thickness (Pa) - ! layer thickness dry (Pa) - ! reciprocal of layer thickness (Pa) - ! recipricol layer thickness dry (Pa) - ! ln(pmid) - ! log midpoint pressure dry (Pa) - ! inverse exner function w.r.t. surface pressure (ps/p)^(R/cp) - ! geopotential height above surface at midpoints (m) - REAL(KIND=r8), dimension(:,:,:), allocatable :: q - ! constituent mixing ratio (kg/kg moist or dry air depending on type) - REAL(KIND=r8), dimension(:,:), allocatable :: pint, pintdry, lnpint, lnpintdry, zi - ! interface pressure (Pa) - ! interface pressure dry (Pa) - ! ln(pint) - ! log interface pressure dry (Pa) - ! geopotential height above surface at interfaces (m) - REAL(KIND=r8), dimension(:), allocatable :: te_ini, te_cur, tw_ini, tw_cur - ! vertically integrated total (kinetic + static) energy of initial state - ! vertically integrated total (kinetic + static) energy of current state - ! vertically integrated total water of initial state - ! vertically integrated total water of new state - INTEGER :: count ! count of values with significant energy or water imbalances - INTEGER, dimension(:), allocatable :: latmapback, lonmapback, cid - ! map from column to unique lat for that column - ! map from column to unique lon for that column - ! unique column id - INTEGER :: ulatcnt, uloncnt ! number of unique lats in chunk - ! number of unique lons in chunk - ! Whether allocation from dycore has happened. - LOGICAL :: dycore_alloc = .false. - ! WACCM variables set by dycore - REAL(KIND=r8), dimension(:,:), allocatable :: uzm, frontgf, frontga - ! zonal wind for qbo (m/s) - ! frontogenesis function - ! frontogenesis angle - END TYPE physics_state - !------------------------------------------------------------------------------- - !------------------------------------------------------------------------------- - ! This is for tendencies returned from individual parameterizations - !=============================================================================== - - ! read interface - PUBLIC kgen_read - INTERFACE kgen_read - MODULE PROCEDURE kgen_read_physics_state - END INTERFACE kgen_read - - PUBLIC kgen_verify - INTERFACE kgen_verify - MODULE PROCEDURE kgen_verify_physics_state - END INTERFACE kgen_verify - - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_r8_dim1_alloc(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim1_alloc - - SUBROUTINE kgen_read_real_r8_dim2_alloc(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim2_alloc - - SUBROUTINE kgen_read_integer_4_dim1_alloc(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - integer(KIND=4), INTENT(OUT), ALLOCATABLE, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_integer_4_dim1_alloc - - SUBROUTINE kgen_read_real_r8_dim3_alloc(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2,idx3 - INTEGER, DIMENSION(2,3) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim3_alloc - - ! No module extern variables - SUBROUTINE kgen_read_physics_state(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(physics_state), INTENT(out) :: var - READ(UNIT=kgen_unit) var%lchnk - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%lchnk **", var%lchnk - END IF - READ(UNIT=kgen_unit) var%ngrdcol - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%ngrdcol **", var%ngrdcol - END IF - READ(UNIT=kgen_unit) var%nsubcol - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%nsubcol **", var%nsubcol - END IF - READ(UNIT=kgen_unit) var%psetcols - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%psetcols **", var%psetcols - END IF - READ(UNIT=kgen_unit) var%ncol - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%ncol **", var%ncol - END IF - READ(UNIT=kgen_unit) var%indcol - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%indcol **", var%indcol - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim1_alloc(var%lat, kgen_unit, printvar=printvar//"%lat") - ELSE - CALL kgen_read_real_r8_dim1_alloc(var%lat, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim1_alloc(var%lon, kgen_unit, printvar=printvar//"%lon") - ELSE - CALL kgen_read_real_r8_dim1_alloc(var%lon, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim1_alloc(var%ps, kgen_unit, printvar=printvar//"%ps") - ELSE - CALL kgen_read_real_r8_dim1_alloc(var%ps, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim1_alloc(var%psdry, kgen_unit, printvar=printvar//"%psdry") - ELSE - CALL kgen_read_real_r8_dim1_alloc(var%psdry, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim1_alloc(var%phis, kgen_unit, printvar=printvar//"%phis") - ELSE - CALL kgen_read_real_r8_dim1_alloc(var%phis, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim1_alloc(var%ulat, kgen_unit, printvar=printvar//"%ulat") - ELSE - CALL kgen_read_real_r8_dim1_alloc(var%ulat, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim1_alloc(var%ulon, kgen_unit, printvar=printvar//"%ulon") - ELSE - CALL kgen_read_real_r8_dim1_alloc(var%ulon, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%t, kgen_unit, printvar=printvar//"%t") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%t, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%u, kgen_unit, printvar=printvar//"%u") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%u, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%v, kgen_unit, printvar=printvar//"%v") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%v, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%s, kgen_unit, printvar=printvar//"%s") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%s, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%omega, kgen_unit, printvar=printvar//"%omega") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%omega, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%pmid, kgen_unit, printvar=printvar//"%pmid") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%pmid, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%pmiddry, kgen_unit, printvar=printvar//"%pmiddry") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%pmiddry, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%pdel, kgen_unit, printvar=printvar//"%pdel") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%pdel, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%pdeldry, kgen_unit, printvar=printvar//"%pdeldry") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%pdeldry, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%rpdel, kgen_unit, printvar=printvar//"%rpdel") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%rpdel, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%rpdeldry, kgen_unit, printvar=printvar//"%rpdeldry") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%rpdeldry, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%lnpmid, kgen_unit, printvar=printvar//"%lnpmid") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%lnpmid, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%lnpmiddry, kgen_unit, printvar=printvar//"%lnpmiddry") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%lnpmiddry, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%exner, kgen_unit, printvar=printvar//"%exner") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%exner, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%zm, kgen_unit, printvar=printvar//"%zm") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%zm, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim3_alloc(var%q, kgen_unit, printvar=printvar//"%q") - ELSE - CALL kgen_read_real_r8_dim3_alloc(var%q, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%pint, kgen_unit, printvar=printvar//"%pint") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%pint, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%pintdry, kgen_unit, printvar=printvar//"%pintdry") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%pintdry, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%lnpint, kgen_unit, printvar=printvar//"%lnpint") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%lnpint, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%lnpintdry, kgen_unit, printvar=printvar//"%lnpintdry") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%lnpintdry, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%zi, kgen_unit, printvar=printvar//"%zi") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%zi, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim1_alloc(var%te_ini, kgen_unit, printvar=printvar//"%te_ini") - ELSE - CALL kgen_read_real_r8_dim1_alloc(var%te_ini, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim1_alloc(var%te_cur, kgen_unit, printvar=printvar//"%te_cur") - ELSE - CALL kgen_read_real_r8_dim1_alloc(var%te_cur, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim1_alloc(var%tw_ini, kgen_unit, printvar=printvar//"%tw_ini") - ELSE - CALL kgen_read_real_r8_dim1_alloc(var%tw_ini, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim1_alloc(var%tw_cur, kgen_unit, printvar=printvar//"%tw_cur") - ELSE - CALL kgen_read_real_r8_dim1_alloc(var%tw_cur, kgen_unit) - END IF - READ(UNIT=kgen_unit) var%count - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%count **", var%count - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_integer_4_dim1_alloc(var%latmapback, kgen_unit, printvar=printvar//"%latmapback") - ELSE - CALL kgen_read_integer_4_dim1_alloc(var%latmapback, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_integer_4_dim1_alloc(var%lonmapback, kgen_unit, printvar=printvar//"%lonmapback") - ELSE - CALL kgen_read_integer_4_dim1_alloc(var%lonmapback, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_integer_4_dim1_alloc(var%cid, kgen_unit, printvar=printvar//"%cid") - ELSE - CALL kgen_read_integer_4_dim1_alloc(var%cid, kgen_unit) - END IF - READ(UNIT=kgen_unit) var%ulatcnt - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%ulatcnt **", var%ulatcnt - END IF - READ(UNIT=kgen_unit) var%uloncnt - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%uloncnt **", var%uloncnt - END IF - READ(UNIT=kgen_unit) var%dycore_alloc - IF ( PRESENT(printvar) ) THEN - print *, "** " // printvar // "%dycore_alloc **", var%dycore_alloc - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%uzm, kgen_unit, printvar=printvar//"%uzm") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%uzm, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%frontgf, kgen_unit, printvar=printvar//"%frontgf") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%frontgf, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%frontga, kgen_unit, printvar=printvar//"%frontga") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%frontga, kgen_unit) - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_physics_state(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(physics_state), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_integer("lchnk", dtype_check_status, var%lchnk, ref_var%lchnk) - CALL kgen_verify_integer("ngrdcol", dtype_check_status, var%ngrdcol, ref_var%ngrdcol) - CALL kgen_verify_integer_4_dim1("nsubcol", dtype_check_status, var%nsubcol, ref_var%nsubcol) - CALL kgen_verify_integer("psetcols", dtype_check_status, var%psetcols, ref_var%psetcols) - CALL kgen_verify_integer("ncol", dtype_check_status, var%ncol, ref_var%ncol) - CALL kgen_verify_integer_4_dim1("indcol", dtype_check_status, var%indcol, ref_var%indcol) - CALL kgen_verify_real_r8_dim1_alloc("lat", dtype_check_status, var%lat, ref_var%lat) - CALL kgen_verify_real_r8_dim1_alloc("lon", dtype_check_status, var%lon, ref_var%lon) - CALL kgen_verify_real_r8_dim1_alloc("ps", dtype_check_status, var%ps, ref_var%ps) - CALL kgen_verify_real_r8_dim1_alloc("psdry", dtype_check_status, var%psdry, ref_var%psdry) - CALL kgen_verify_real_r8_dim1_alloc("phis", dtype_check_status, var%phis, ref_var%phis) - CALL kgen_verify_real_r8_dim1_alloc("ulat", dtype_check_status, var%ulat, ref_var%ulat) - CALL kgen_verify_real_r8_dim1_alloc("ulon", dtype_check_status, var%ulon, ref_var%ulon) - CALL kgen_verify_real_r8_dim2_alloc("t", dtype_check_status, var%t, ref_var%t) - CALL kgen_verify_real_r8_dim2_alloc("u", dtype_check_status, var%u, ref_var%u) - CALL kgen_verify_real_r8_dim2_alloc("v", dtype_check_status, var%v, ref_var%v) - CALL kgen_verify_real_r8_dim2_alloc("s", dtype_check_status, var%s, ref_var%s) - CALL kgen_verify_real_r8_dim2_alloc("omega", dtype_check_status, var%omega, ref_var%omega) - CALL kgen_verify_real_r8_dim2_alloc("pmid", dtype_check_status, var%pmid, ref_var%pmid) - CALL kgen_verify_real_r8_dim2_alloc("pmiddry", dtype_check_status, var%pmiddry, ref_var%pmiddry) - CALL kgen_verify_real_r8_dim2_alloc("pdel", dtype_check_status, var%pdel, ref_var%pdel) - CALL kgen_verify_real_r8_dim2_alloc("pdeldry", dtype_check_status, var%pdeldry, ref_var%pdeldry) - CALL kgen_verify_real_r8_dim2_alloc("rpdel", dtype_check_status, var%rpdel, ref_var%rpdel) - CALL kgen_verify_real_r8_dim2_alloc("rpdeldry", dtype_check_status, var%rpdeldry, ref_var%rpdeldry) - CALL kgen_verify_real_r8_dim2_alloc("lnpmid", dtype_check_status, var%lnpmid, ref_var%lnpmid) - CALL kgen_verify_real_r8_dim2_alloc("lnpmiddry", dtype_check_status, var%lnpmiddry, ref_var%lnpmiddry) - CALL kgen_verify_real_r8_dim2_alloc("exner", dtype_check_status, var%exner, ref_var%exner) - CALL kgen_verify_real_r8_dim2_alloc("zm", dtype_check_status, var%zm, ref_var%zm) - CALL kgen_verify_real_r8_dim3_alloc("q", dtype_check_status, var%q, ref_var%q) - CALL kgen_verify_real_r8_dim2_alloc("pint", dtype_check_status, var%pint, ref_var%pint) - CALL kgen_verify_real_r8_dim2_alloc("pintdry", dtype_check_status, var%pintdry, ref_var%pintdry) - CALL kgen_verify_real_r8_dim2_alloc("lnpint", dtype_check_status, var%lnpint, ref_var%lnpint) - CALL kgen_verify_real_r8_dim2_alloc("lnpintdry", dtype_check_status, var%lnpintdry, ref_var%lnpintdry) - CALL kgen_verify_real_r8_dim2_alloc("zi", dtype_check_status, var%zi, ref_var%zi) - CALL kgen_verify_real_r8_dim1_alloc("te_ini", dtype_check_status, var%te_ini, ref_var%te_ini) - CALL kgen_verify_real_r8_dim1_alloc("te_cur", dtype_check_status, var%te_cur, ref_var%te_cur) - CALL kgen_verify_real_r8_dim1_alloc("tw_ini", dtype_check_status, var%tw_ini, ref_var%tw_ini) - CALL kgen_verify_real_r8_dim1_alloc("tw_cur", dtype_check_status, var%tw_cur, ref_var%tw_cur) - CALL kgen_verify_integer("count", dtype_check_status, var%count, ref_var%count) - CALL kgen_verify_integer_4_dim1_alloc("latmapback", dtype_check_status, var%latmapback, ref_var%latmapback) - CALL kgen_verify_integer_4_dim1_alloc("lonmapback", dtype_check_status, var%lonmapback, ref_var%lonmapback) - CALL kgen_verify_integer_4_dim1_alloc("cid", dtype_check_status, var%cid, ref_var%cid) - CALL kgen_verify_integer("ulatcnt", dtype_check_status, var%ulatcnt, ref_var%ulatcnt) - CALL kgen_verify_integer("uloncnt", dtype_check_status, var%uloncnt, ref_var%uloncnt) - CALL kgen_verify_logical("dycore_alloc", dtype_check_status, var%dycore_alloc, ref_var%dycore_alloc) - CALL kgen_verify_real_r8_dim2_alloc("uzm", dtype_check_status, var%uzm, ref_var%uzm) - CALL kgen_verify_real_r8_dim2_alloc("frontgf", dtype_check_status, var%frontgf, ref_var%frontgf) - CALL kgen_verify_real_r8_dim2_alloc("frontga", dtype_check_status, var%frontga, ref_var%frontga) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_integer_4_dim1( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in), DIMENSION(:) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - end if - - check_status%numFatal = check_status%numFatal+1 - END IF - END SUBROUTINE kgen_verify_integer_4_dim1 - - SUBROUTINE kgen_verify_real_r8_dim1_alloc( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:), ALLOCATABLE :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:) :: temp, temp2 - integer :: n - IF ( ALLOCATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1))) - allocate(temp2(SIZE(var,dim=1))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END IF - END SUBROUTINE kgen_verify_real_r8_dim1_alloc - - SUBROUTINE kgen_verify_real_r8_dim2_alloc( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:), ALLOCATABLE :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:) :: temp, temp2 - integer :: n - IF ( ALLOCATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END IF - END SUBROUTINE kgen_verify_real_r8_dim2_alloc - - SUBROUTINE kgen_verify_real_r8_dim3_alloc( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:,:), ALLOCATABLE :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:,:) :: temp, temp2 - integer :: n - IF ( ALLOCATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END IF - END SUBROUTINE kgen_verify_real_r8_dim3_alloc - - SUBROUTINE kgen_verify_integer( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - END SUBROUTINE kgen_verify_integer - - SUBROUTINE kgen_verify_integer_4_dim1_alloc( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in), DIMENSION(:), ALLOCATABLE :: var, ref_var - IF ( ALLOCATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - end if - - check_status%numFatal = check_status%numFatal+1 - END IF - END IF - END SUBROUTINE kgen_verify_integer_4_dim1_alloc - - SUBROUTINE kgen_verify_logical( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - logical, intent(in) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( var .EQV. ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - END SUBROUTINE kgen_verify_logical - - !=============================================================================== - - !=============================================================================== - - - !=============================================================================== - - !=============================================================================== - - !=============================================================================== - - !=============================================================================== - - !=============================================================================== - - !=============================================================================== - - - !=============================================================================== - - !----------------------------------------------------------------------- - !=============================================================================== - - !=============================================================================== - - !=============================================================================== - - !=============================================================================== - - !=============================================================================== - - !=============================================================================== - - !=============================================================================== - - !=============================================================================== - - !=============================================================================== - - !=============================================================================== - - !=============================================================================== - - !=============================================================================== - - END MODULE physics_types diff --git a/test/ncar_kernels/PORT_sw_rad/src/ppgrid.F90 b/test/ncar_kernels/PORT_sw_rad/src/ppgrid.F90 deleted file mode 100644 index d7df82a20f..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/ppgrid.F90 +++ /dev/null @@ -1,46 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : ppgrid.F90 -! Generated at: 2015-07-07 00:48:25 -! KGEN version: 0.4.13 - - - - MODULE ppgrid - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !----------------------------------------------------------------------- - ! - ! Purpose: - ! Initialize physics grid resolution parameters - ! for a chunked data structure - ! - ! Author: - ! - !----------------------------------------------------------------------- - IMPLICIT NONE - PRIVATE - PUBLIC pcols - PUBLIC psubcols - PUBLIC pver - PUBLIC pverp - ! Grid point resolution parameters - INTEGER :: pcols ! number of columns (max) - INTEGER :: psubcols ! number of sub-columns (max) - INTEGER :: pver ! number of vertical levels - INTEGER :: pverp ! pver + 1 - PARAMETER (pcols = 16) - PARAMETER (psubcols = 1) - PARAMETER (pver = 30) - PARAMETER (pverp = pver + 1) - ! - ! start, end indices for chunks owned by a given MPI task - ! (set in phys_grid_init). - ! - ! - ! - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE ppgrid diff --git a/test/ncar_kernels/PORT_sw_rad/src/radconstants.F90 b/test/ncar_kernels/PORT_sw_rad/src/radconstants.F90 deleted file mode 100644 index 2dc207583e..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/radconstants.F90 +++ /dev/null @@ -1,97 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : radconstants.F90 -! Generated at: 2015-07-07 00:48:24 -! KGEN version: 0.4.13 - - - - MODULE radconstants - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! This module contains constants that are specific to the radiative transfer - ! code used in the RRTMG model. - IMPLICIT NONE - PRIVATE - ! SHORTWAVE DATA - ! number of shorwave spectral intervals - INTEGER, parameter, public :: nswbands = 14 - ! Wavenumbers of band boundaries - ! - ! Note: Currently rad_solar_var extends the lowest band down to - ! 100 cm^-1 if it is too high to cover the far-IR. Any changes meant - ! to affect IR solar variability should take note of this. - ! in cm^-1 - ! in cm^-1 - ! Solar irradiance at 1 A.U. in W/m^2 assumed by radiation code - ! Rescaled so that sum is precisely 1368.22 and fractional amounts sum to 1.0 - ! None of the following comment appears to be the case any more? This - ! should be reevalutated and/or removed. - ! rrtmg (coarse) reference solar flux in rrtmg is initialized as the following - ! reference data inside rrtmg seems to indicate 1366.44 instead - ! This data references 1366.442114152342 - !real(r8), parameter :: solar_ref_band_irradiance(nbndsw) = & - ! (/ & - ! 12.10956827000000_r8, 20.36508467999999_r8, 23.72973826333333_r8, & - ! 22.42769644333333_r8, 55.62661262000000_r8, 102.9314315544444_r8, 24.29361887666667_r8, & - ! 345.7425138000000_r8, 218.1870300666667_r8, 347.1923147000001_r8, & - ! 129.4950181200000_r8, 48.37217043000000_r8, 3.079938997898001_r8, 12.88937733000000_r8 & - ! /) - ! Kurucz (fine) reference would seem to imply the following but the above values are from rrtmg_sw_init - ! (/12.109559, 20.365097, 23.729752, 22.427697, 55.626622, 102.93142, 24.293593, & - ! 345.73655, 218.18416, 347.18406, 129.49407, 50.147238, 3.1197130, 12.793834 /) - ! These are indices to the band for diagnostic output - ! index to sw visible band - ! index to sw near infrared (778-1240 nm) band - ! index to sw uv (345-441 nm) band - ! rrtmg band for .67 micron - ! Number of evenly spaced intervals in rh - ! The globality of this mesh may not be necessary - ! Perhaps it could be specific to the aerosol - ! But it is difficult to see how refined it must be - ! for lookup. This value was found to be sufficient - ! for Sulfate and probably necessary to resolve the - ! high variation near rh = 1. Alternative methods - ! were found to be too slow. - ! Optimal approach would be for cam to specify size of aerosol - ! based on each aerosol's characteristics. Radiation - ! should know nothing about hygroscopic growth! - ! LONGWAVE DATA - ! These are indices to the band for diagnostic output - ! index to (H20 window) LW band - ! rrtmg band for 10.5 micron - ! number of lw bands - ! Longwave spectral band limits (cm-1) - ! Longwave spectral band limits (cm-1) - !These can go away when old camrt disappears - ! Index of volc. abs., H2O non-window - ! Index of volc. abs., H2O window - ! Index of volc. cnt. abs. 0500--0650 cm-1 - ! Index of volc. cnt. abs. 0650--0800 cm-1 - ! Index of volc. cnt. abs. 0800--1000 cm-1 - ! Index of volc. cnt. abs. 1000--1200 cm-1 - ! Index of volc. cnt. abs. 1200--2000 cm-1 - ! GASES TREATED BY RADIATION (line spectrae) - ! gasses required by radiation - ! what is the minimum mass mixing ratio that can be supported by radiation implementation? - ! Length of "optics type" string specified in optics files. - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !------------------------------------------------------------------------------ - - !------------------------------------------------------------------------------ - - !------------------------------------------------------------------------------ - - !------------------------------------------------------------------------------ - - !------------------------------------------------------------------------------ - - !------------------------------------------------------------------------------ - - !------------------------------------------------------------------------------ - - END MODULE radconstants diff --git a/test/ncar_kernels/PORT_sw_rad/src/radiation.F90 b/test/ncar_kernels/PORT_sw_rad/src/radiation.F90 deleted file mode 100644 index 858e61270d..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/radiation.F90 +++ /dev/null @@ -1,768 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : radiation.F90 -! Generated at: 2015-07-07 00:48:23 -! KGEN version: 0.4.13 - - - - MODULE radiation - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE physics_types, ONLY : kgen_read_mod42 => kgen_read - USE physics_types, ONLY : kgen_verify_mod42 => kgen_verify - USE camsrfexch, ONLY : kgen_read_mod43 => kgen_read - USE camsrfexch, ONLY : kgen_verify_mod43 => kgen_verify - USE rrtmg_state, ONLY : kgen_read_mod6 => kgen_read - USE rrtmg_state, ONLY : kgen_verify_mod6 => kgen_verify - !--------------------------------------------------------------------------------- - ! Purpose: - ! - ! CAM interface to RRTMG - ! - ! Revision history: - ! May 2004, D. B. Coleman, Initial version of interface module. - ! July 2004, B. Eaton, Use interfaces from new shortwave, longwave, and ozone modules. - ! Feb 2005, B. Eaton, Add namelist variables and control of when calcs are done. - ! May 2008, Mike Iacono Initial version for RRTMG - ! Nov 2010, J. Kay Add COSP simulator calls - !--------------------------------------------------------------------------------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - USE radconstants, ONLY: nswbands - IMPLICIT NONE - PRIVATE - integer, parameter :: maxiter = 1 - character(len=80), parameter :: kname = "rad_rrtmg_sw" - PUBLIC radiation_tend - ! registers radiation physics buffer fields - ! set default values of namelist variables in runtime_opts - ! set namelist values from runtime_opts - ! print namelist values to log - ! provide read access to private module data - ! calendar day of next radiation calculation - ! query which radiation calcs are done this timestep - ! calls radini - ! moved from radctl.F90 - ! counter for cosp - !initial value for cosp counter - ! Private module data - ! Default values for namelist variables - ! freq. of shortwave radiation calc in time steps (positive) - ! or hours (negative). - ! frequency of longwave rad. calc. in time steps (positive) - ! or hours (negative). - ! Specifies length of time in timesteps (positive) - ! or hours (negative) SW/LW radiation will be - ! run continuously from the start of an - ! initial or restart run - ! calculate fluxes (up and down) per band. - ! diagnostic brightness temperatures at the top of the - ! atmosphere for 7 TOVS/HIRS channels (2,4,6,8,10,11,12) and 4 TOVS/MSU - ! channels (1,2,3,4). - ! frequency (timesteps) of brightness temperature calcs - !=============================================================================== - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !=============================================================================== - - !================================================================================================ - - !================================================================================================ - - !=============================================================================== - - !================================================================================================ - - !================================================================================================ - - !================================================================================================ - - !================================================================================================ - - !=============================================================================== - - SUBROUTINE radiation_tend(fsns, fsnt, fsds, state, cam_out, cam_in, kgen_unit) - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !----------------------------------------------------------------------- - ! - ! Purpose: - ! Driver for radiation computation. - ! - ! Method: - ! Radiation uses cgs units, so conversions must be done from - ! model fields to radiation fields. - ! - ! Revision history: - ! May 2004 D.B. Coleman Merge of code from radctl.F90 and parts of tphysbc.F90. - ! 2004-08-09 B. Eaton Add pointer variables for constituents. - ! 2004-08-24 B. Eaton Access O3 and GHG constituents from chem_get_cnst. - ! 2004-08-30 B. Eaton Replace chem_get_cnst by rad_constituent_get. - ! 2007-11-05 M. Iacono Install rrtmg_lw and sw as radiation model. - ! 2007-12-27 M. Iacono Modify to use CAM cloud optical properties with rrtmg. - !----------------------------------------------------------------------- - USE physics_types, ONLY: physics_state - USE camsrfexch, ONLY: cam_out_t - USE camsrfexch, ONLY: cam_in_t - USE parrrsw, ONLY: nbndsw - USE ppgrid, only : pcols - USE ppgrid, only : pver - USE ppgrid, only : pverp - USE radsw, ONLY: rad_rrtmg_sw - USE rrtmg_state, ONLY: num_rrtmg_levs - USE rrtmg_state, ONLY: rrtmg_state_t - ! Arguments - integer, intent(in) :: kgen_unit - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - ! land fraction - ! land fraction ramp - ! land fraction - ! Snow depth (liquid water equivalent) - REAL(KIND=r8), intent(inout) :: fsns(pcols) - REAL(KIND=r8) :: ref_fsns(pcols) ! Surface solar absorbed flux - REAL(KIND=r8), intent(inout) :: fsnt(pcols) - REAL(KIND=r8) :: ref_fsnt(pcols) ! Net column abs solar flux at model top - ! Srf longwave cooling (up-down) flux - ! Net outgoing lw flux at model top - REAL(KIND=r8), intent(inout) :: fsds(pcols) - REAL(KIND=r8) :: ref_fsds(pcols) ! Surface solar down flux - TYPE(physics_state), intent(in), target :: state - TYPE(cam_out_t), intent(inout) :: cam_out - TYPE(cam_out_t) :: ref_cam_out - TYPE(cam_in_t), intent(in) :: cam_in - ! Local variables - ! current timestep number - ! Microwave brightness temperature - ! Infrared brightness temperature - ! surface temperature - ! Model interface pressures (hPa) - ! Land surface flag, sea=0, land=1 - ! Number of maximally overlapped regions - ! Maximum values of pressure for each - ! maximally overlapped region. - ! 0->pmxrgn(i,1) is range of pressure for - ! 1st region,pmxrgn(i,1)->pmxrgn(i,2) for - ! 2nd region, etc - ! Cloud longwave emissivity - ! Cloud longwave optical depth - ! in-cloud cloud ice water path - ! in-cloud cloud liquid water path - ! Diagnostic total cloud cover - ! " low cloud cover - ! " mid cloud cover - ! " hgh cloud cover - ! Temporary workspace for outfld variables - ! combined cloud radiative parameters are "in cloud" not "in cell" - REAL(KIND=r8) :: c_cld_tau (nbndsw,pcols,pver) ! cloud extinction optical depth - REAL(KIND=r8) :: c_cld_tau_w (nbndsw,pcols,pver) ! cloud single scattering albedo * tau - REAL(KIND=r8) :: c_cld_tau_w_g(nbndsw,pcols,pver) ! cloud assymetry parameter * w * tau - REAL(KIND=r8) :: c_cld_tau_w_f(nbndsw,pcols,pver) ! cloud forward scattered fraction * w * tau - ! cloud absorption optics depth (LW) - ! cloud radiative parameters are "in cloud" not "in cell" - ! cloud extinction optical depth - ! cloud single scattering albedo * tau - ! cloud assymetry parameter * w * tau - ! cloud forward scattered fraction * w * tau - ! cloud absorption optics depth (LW) - ! cloud radiative parameters are "in cloud" not "in cell" - ! ice extinction optical depth - ! ice single scattering albedo * tau - ! ice assymetry parameter * tau * w - ! ice forward scattered fraction * tau * w - ! ice absorption optics depth (LW) - ! cloud radiative parameters are "in cloud" not "in cell" - ! snow extinction optical depth - ! snow single scattering albedo * tau - ! snow assymetry parameter * tau * w - ! snow forward scattered fraction * tau * w - ! snow absorption optics depth (LW) - ! grid-box mean snow_tau for COSP only - ! grid-box mean LW snow optical depth for COSP only - ! cloud radiative parameters are "in cloud" not "in cell" - ! liquid extinction optical depth - ! liquid single scattering albedo * tau - ! liquid assymetry parameter * tau * w - ! liquid forward scattered fraction * tau * w - ! liquid absorption optics depth (LW) - ! tot gbx cloud visible sw optical depth for output on history files - ! tot in-cloud visible sw optical depth for output on history files - ! liq in-cloud visible sw optical depth for output on history files - ! ice in-cloud visible sw optical depth for output on history files - ! snow in-cloud visible sw optical depth for output on history files - ! cloud fraction - ! cloud fraction of just "snow clouds- whatever they are" - REAL(KIND=r8) :: cldfprime(pcols,pver) ! combined cloud fraction (snow plus regular) - REAL(KIND=r8), pointer, dimension(:,:) :: qrs - REAL(KIND=r8), pointer :: ref_qrs(:,:) => NULL() ! shortwave radiative heating rate - ! longwave radiative heating rate - REAL(KIND=r8) :: qrsc(pcols,pver) - REAL(KIND=r8) :: ref_qrsc(pcols,pver) ! clearsky shortwave radiative heating rate - ! clearsky longwave radiative heating rate - INTEGER :: ncol - INTEGER :: lchnk - ! current calendar day - ! current latitudes(radians) - ! current longitudes(radians) - REAL(KIND=r8) :: coszrs(pcols) ! Cosine solar zenith angle - ! flag to carry (QRS,QRL)*dp across time steps - ! Local variables from radctl - ! index - REAL(KIND=r8) :: solin(pcols) - REAL(KIND=r8) :: ref_solin(pcols) ! Solar incident flux - REAL(KIND=r8) :: fsntoa(pcols) - REAL(KIND=r8) :: ref_fsntoa(pcols) ! Net solar flux at TOA - REAL(KIND=r8) :: fsutoa(pcols) - REAL(KIND=r8) :: ref_fsutoa(pcols) ! Upwelling solar flux at TOA - REAL(KIND=r8) :: fsntoac(pcols) - REAL(KIND=r8) :: ref_fsntoac(pcols) ! Clear sky net solar flux at TOA - REAL(KIND=r8) :: fsnirt(pcols) - REAL(KIND=r8) :: ref_fsnirt(pcols) ! Near-IR flux absorbed at toa - REAL(KIND=r8) :: fsnrtc(pcols) - REAL(KIND=r8) :: ref_fsnrtc(pcols) ! Clear sky near-IR flux absorbed at toa - REAL(KIND=r8) :: fsnirtsq(pcols) - REAL(KIND=r8) :: ref_fsnirtsq(pcols) ! Near-IR flux absorbed at toa >= 0.7 microns - REAL(KIND=r8) :: fsntc(pcols) - REAL(KIND=r8) :: ref_fsntc(pcols) ! Clear sky total column abs solar flux - REAL(KIND=r8) :: fsnsc(pcols) - REAL(KIND=r8) :: ref_fsnsc(pcols) ! Clear sky surface abs solar flux - REAL(KIND=r8) :: fsdsc(pcols) - REAL(KIND=r8) :: ref_fsdsc(pcols) ! Clear sky surface downwelling solar flux - ! Upward flux at top of model - ! longwave cloud forcing - ! shortwave cloud forcing - ! Upward Clear Sky flux at top of model - ! Clear sky lw flux at model top - ! Clear sky lw flux at srf (up-down) - ! Clear sky lw flux at srf (down) - ! net longwave flux interpolated to 200 mb - ! net clearsky longwave flux interpolated to 200 mb - REAL(KIND=r8) :: fns(pcols,pverp) - REAL(KIND=r8) :: ref_fns(pcols,pverp) ! net shortwave flux - REAL(KIND=r8) :: fcns(pcols,pverp) - REAL(KIND=r8) :: ref_fcns(pcols,pverp) ! net clear-sky shortwave flux - ! fns interpolated to 200 mb - ! fcns interpolated to 200 mb - ! net longwave flux - ! net clear-sky longwave flux - ! Model mid-level pressures (dynes/cm2) - ! Model interface pressures (dynes/cm2) - REAL(KIND=r8) :: eccf ! Earth/sun distance factor - ! Upward longwave flux in cgs units - ! Temporary layer pressure thickness - ! Model interface temperature - REAL(KIND=r8) :: sfac(1:nswbands) ! time varying scaling factors due to Solar Spectral Irrad at 1 A.U. per band - ! Ozone mass mixing ratio - ! co2 mass mixing ratio - ! co2 column mean mmr - ! specific humidity - REAL(KIND=r8), pointer, dimension(:,:,:) :: su => null() - REAL(KIND=r8), pointer :: ref_su(:,:,:) => NULL() ! shortwave spectral flux up - REAL(KIND=r8), pointer, dimension(:,:,:) :: sd => null() - REAL(KIND=r8), pointer :: ref_sd(:,:,:) => NULL() ! shortwave spectral flux down - ! longwave spectral flux up - ! longwave spectral flux down - ! Aerosol radiative properties - REAL(KIND=r8) :: aer_tau (pcols,0:pver,nbndsw) ! aerosol extinction optical depth - REAL(KIND=r8) :: aer_tau_w (pcols,0:pver,nbndsw) ! aerosol single scattering albedo * tau - REAL(KIND=r8) :: aer_tau_w_g(pcols,0:pver,nbndsw) ! aerosol assymetry parameter * w * tau - REAL(KIND=r8) :: aer_tau_w_f(pcols,0:pver,nbndsw) ! aerosol forward scattered fraction * w * tau - ! aerosol absorption optics depth (LW) - ! Gathered indicies of day and night columns - ! chunk_column_index = IdxDay(daylight_column_index) - INTEGER :: nday ! Number of daylight columns - INTEGER :: nnite ! Number of night columns - INTEGER, dimension(pcols) :: idxday ! Indicies of daylight coumns - INTEGER, dimension(pcols) :: idxnite ! Indicies of night coumns - ! index through climate/diagnostic radiation calls - TYPE(rrtmg_state_t), pointer :: r_state ! contains the atm concentratiosn in layers needed for RRTMG - !---------------------------------------------------------------------- - ! For CRM, make cloud equal to input observations: - ! - ! Cosine solar zenith angle for current time step - ! - ! Gather night/day column indices. - ! do shortwave heating calc this timestep? - ! do longwave heating calc this timestep? - tolerance = 8.E-13 - CALL kgen_init_check(check_status, tolerance) - READ(UNIT=kgen_unit) c_cld_tau - READ(UNIT=kgen_unit) c_cld_tau_w - READ(UNIT=kgen_unit) c_cld_tau_w_g - READ(UNIT=kgen_unit) c_cld_tau_w_f - READ(UNIT=kgen_unit) cldfprime - CALL kgen_read_real_r8_dim2_ptr(qrs, kgen_unit) - READ(UNIT=kgen_unit) qrsc - READ(UNIT=kgen_unit) ncol - READ(UNIT=kgen_unit) lchnk - READ(UNIT=kgen_unit) coszrs - READ(UNIT=kgen_unit) solin - READ(UNIT=kgen_unit) fsntoa - READ(UNIT=kgen_unit) fsutoa - READ(UNIT=kgen_unit) fsntoac - READ(UNIT=kgen_unit) fsnirt - READ(UNIT=kgen_unit) fsnrtc - READ(UNIT=kgen_unit) fsnirtsq - READ(UNIT=kgen_unit) fsntc - READ(UNIT=kgen_unit) fsnsc - READ(UNIT=kgen_unit) fsdsc - READ(UNIT=kgen_unit) fns - READ(UNIT=kgen_unit) fcns - READ(UNIT=kgen_unit) eccf - READ(UNIT=kgen_unit) sfac - CALL kgen_read_real_r8_dim3_ptr(su, kgen_unit) - CALL kgen_read_real_r8_dim3_ptr(sd, kgen_unit) - READ(UNIT=kgen_unit) aer_tau - READ(UNIT=kgen_unit) aer_tau_w - READ(UNIT=kgen_unit) aer_tau_w_g - READ(UNIT=kgen_unit) aer_tau_w_f - READ(UNIT=kgen_unit) nday - READ(UNIT=kgen_unit) nnite - READ(UNIT=kgen_unit) idxday - READ(UNIT=kgen_unit) idxnite - CALL kgen_read_rrtmg_state_t_ptr(r_state, kgen_unit) - - READ(UNIT=kgen_unit) ref_fsns - READ(UNIT=kgen_unit) ref_fsnt - READ(UNIT=kgen_unit) ref_fsds - CALL kgen_read_real_r8_dim2_ptr(ref_qrs, kgen_unit) - READ(UNIT=kgen_unit) ref_qrsc - READ(UNIT=kgen_unit) ref_solin - READ(UNIT=kgen_unit) ref_fsntoa - READ(UNIT=kgen_unit) ref_fsutoa - READ(UNIT=kgen_unit) ref_fsntoac - READ(UNIT=kgen_unit) ref_fsnirt - READ(UNIT=kgen_unit) ref_fsnrtc - READ(UNIT=kgen_unit) ref_fsnirtsq - READ(UNIT=kgen_unit) ref_fsntc - READ(UNIT=kgen_unit) ref_fsnsc - READ(UNIT=kgen_unit) ref_fsdsc - READ(UNIT=kgen_unit) ref_fns - READ(UNIT=kgen_unit) ref_fcns - CALL kgen_read_real_r8_dim3_ptr(ref_su, kgen_unit) - CALL kgen_read_real_r8_dim3_ptr(ref_sd, kgen_unit) - CALL kgen_read_mod43(ref_cam_out, kgen_unit) - - - ! call to kernel - call rad_rrtmg_sw( & - lchnk, ncol, num_rrtmg_levs, r_state, & - state%pmid, cldfprime, & - aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f, & - eccf, coszrs, solin, sfac, & - cam_in%asdir, cam_in%asdif, cam_in%aldir, cam_in%aldif, & - qrs, qrsc, fsnt, fsntc, fsntoa, fsutoa, & - fsntoac, fsnirt, fsnrtc, fsnirtsq, fsns, & - fsnsc, fsdsc, fsds, cam_out%sols, cam_out%soll, & - cam_out%solsd,cam_out%solld,fns, fcns, & - Nday, Nnite, IdxDay, IdxNite, & - su, sd, & - E_cld_tau=c_cld_tau, E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, E_cld_tau_w_f=c_cld_tau_w_f, & - old_convert = .false.) - ! kernel verification for output variables - CALL kgen_verify_real_r8_dim1( "fsns", check_status, fsns, ref_fsns) - CALL kgen_verify_real_r8_dim1( "fsnt", check_status, fsnt, ref_fsnt) - CALL kgen_verify_real_r8_dim1( "fsds", check_status, fsds, ref_fsds) - CALL kgen_verify_mod43( "cam_out", check_status, cam_out, ref_cam_out) - CALL kgen_verify_real_r8_dim2_ptr( "qrs", check_status, qrs, ref_qrs) - CALL kgen_verify_real_r8_dim2( "qrsc", check_status, qrsc, ref_qrsc) - CALL kgen_verify_real_r8_dim1( "solin", check_status, solin, ref_solin) - CALL kgen_verify_real_r8_dim1( "fsntoa", check_status, fsntoa, ref_fsntoa) - CALL kgen_verify_real_r8_dim1( "fsutoa", check_status, fsutoa, ref_fsutoa) - CALL kgen_verify_real_r8_dim1( "fsntoac", check_status, fsntoac, ref_fsntoac) - CALL kgen_verify_real_r8_dim1( "fsnirt", check_status, fsnirt, ref_fsnirt) - CALL kgen_verify_real_r8_dim1( "fsnrtc", check_status, fsnrtc, ref_fsnrtc) - CALL kgen_verify_real_r8_dim1( "fsnirtsq", check_status, fsnirtsq, ref_fsnirtsq) - CALL kgen_verify_real_r8_dim1( "fsntc", check_status, fsntc, ref_fsntc) - CALL kgen_verify_real_r8_dim1( "fsnsc", check_status, fsnsc, ref_fsnsc) - CALL kgen_verify_real_r8_dim1( "fsdsc", check_status, fsdsc, ref_fsdsc) - CALL kgen_verify_real_r8_dim2( "fns", check_status, fns, ref_fns) - CALL kgen_verify_real_r8_dim2( "fcns", check_status, fcns, ref_fcns) - CALL kgen_verify_real_r8_dim3_ptr( "su", check_status, su, ref_su) - CALL kgen_verify_real_r8_dim3_ptr( "sd", check_status, sd, ref_sd) - CALL kgen_print_check("rad_rrtmg_sw", check_status) - CALL system_clock(start_clock, rate_clock) - print *,'ncol: ',ncol - print *,'num_rrtmg_levs: ',num_rrtmg_levs - DO kgen_intvar=1,maxiter - CALL rad_rrtmg_sw(lchnk, ncol, num_rrtmg_levs, r_state, state % pmid, cldfprime, & -aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f, eccf, coszrs, solin, sfac, cam_in % asdir, cam_in % asdif, & -cam_in % aldir, cam_in % aldif, qrs, qrsc, fsnt, fsntc, fsntoa, fsutoa, fsntoac, fsnirt, fsnrtc, fsnirtsq, & -fsns, fsnsc, fsdsc, fsds, cam_out % sols, cam_out % soll, cam_out % solsd, cam_out % solld, fns, fcns, & -nday, nnite, idxday, idxnite, su, sd, e_cld_tau = c_cld_tau, e_cld_tau_w = c_cld_tau_w, & -e_cld_tau_w_g = c_cld_tau_w_g, e_cld_tau_w_f = c_cld_tau_w_f, old_convert = .FALSE.) - END DO - CALL system_clock(stop_clock, rate_clock) - WRITE(*,*) - PRINT *, TRIM(kname), ": Total time (sec): ", (stop_clock - start_clock)/REAL(rate_clock) - PRINT *, TRIM(kname), ": Elapsed time (usec): ", 1.0e6*(stop_clock - start_clock)/REAL(rate_clock*maxiter) - ! if (dosw .or. dolw) then - ! output rad inputs and resulting heating rates - ! Compute net radiative heating tendency - ! Compute heating rate for dtheta/dt - ! convert radiative heating rates to Q*dp for energy conservation - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_r8_dim1(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim1 - - SUBROUTINE kgen_read_real_r8_dim2_ptr(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), POINTER, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim2_ptr - - SUBROUTINE kgen_read_real_r8_dim2(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim2 - - SUBROUTINE kgen_read_real_r8_dim3_ptr(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), POINTER, DIMENSION(:,:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2,idx3 - INTEGER, DIMENSION(2,3) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim3_ptr - - SUBROUTINE kgen_read_rrtmg_state_t_ptr(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(rrtmg_state_t), INTENT(OUT), POINTER :: var - LOGICAL :: is_true - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - ALLOCATE(var) - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_mod6(var, kgen_unit, printvar=printvar//"%rrtmg_state") - ELSE - CALL kgen_read_mod6(var, kgen_unit) - END IF - END IF - END SUBROUTINE kgen_read_rrtmg_state_t_ptr - - - ! verify subroutines - SUBROUTINE kgen_verify_real_r8_dim1( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1))) - allocate(temp2(SIZE(var,dim=1))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim1 - - SUBROUTINE kgen_verify_real_r8_dim2_ptr( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:), POINTER :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:) :: temp, temp2 - integer :: n - IF ( ASSOCIATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END IF - END SUBROUTINE kgen_verify_real_r8_dim2_ptr - - SUBROUTINE kgen_verify_real_r8_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim2 - - SUBROUTINE kgen_verify_real_r8_dim3_ptr( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:,:), POINTER :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:,:) :: temp, temp2 - integer :: n - IF ( ASSOCIATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END IF - END SUBROUTINE kgen_verify_real_r8_dim3_ptr - - END SUBROUTINE radiation_tend - !=============================================================================== - - !=============================================================================== - - !=============================================================================== - END MODULE radiation diff --git a/test/ncar_kernels/PORT_sw_rad/src/radsw.F90 b/test/ncar_kernels/PORT_sw_rad/src/radsw.F90 deleted file mode 100644 index ccb00bedc1..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/radsw.F90 +++ /dev/null @@ -1,565 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : radsw.F90 -! Generated at: 2015-07-07 00:48:23 -! KGEN version: 0.4.13 - - - - MODULE radsw - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !----------------------------------------------------------------------- - ! - ! Purpose: Solar radiation calculations. - ! - !----------------------------------------------------------------------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - USE ppgrid, ONLY: pcols - USE ppgrid, ONLY: pver - USE ppgrid, ONLY: pverp - USE scammod, ONLY: single_column - USE scammod, ONLY: scm_crm_mode - USE scammod, ONLY: have_asdir - USE scammod, ONLY: asdirobs - USE scammod, ONLY: have_asdif - USE scammod, ONLY: asdifobs - USE scammod, ONLY: have_aldir - USE scammod, ONLY: aldirobs - USE scammod, ONLY: have_aldif - USE scammod, ONLY: aldifobs - USE parrrsw, ONLY: nbndsw - USE parrrsw, ONLY: ngptsw - USE rrtmg_sw_rad, ONLY: rrtmg_sw - IMPLICIT NONE - PRIVATE - ! fraction of solar irradiance in each band - REAL(KIND=r8) :: solar_band_irrad(1:nbndsw) ! rrtmg-assumed solar irradiance in each sw band - ! Public methods - PUBLIC rad_rrtmg_sw - ! initialize constants - ! driver for solar radiation code - !=============================================================================== - PUBLIC kgen_read_externs_radsw - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_radsw(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) solar_band_irrad - END SUBROUTINE kgen_read_externs_radsw - - !=============================================================================== - - SUBROUTINE rad_rrtmg_sw(lchnk, ncol, rrtmg_levs, r_state, e_pmid, e_cld, e_aer_tau, e_aer_tau_w, e_aer_tau_w_g, & - e_aer_tau_w_f, eccf, e_coszrs, solin, sfac, e_asdir, e_asdif, e_aldir, e_aldif, qrs, qrsc, fsnt, fsntc, fsntoa, fsutoa, & - fsntoac, fsnirtoa, fsnrtoac, fsnrtoaq, fsns, fsnsc, fsdsc, fsds, sols, soll, solsd, solld, fns, fcns, nday, nnite, idxday,& - idxnite, su, sd, e_cld_tau, e_cld_tau_w, e_cld_tau_w_g, e_cld_tau_w_f, old_convert) - !----------------------------------------------------------------------- - ! - ! Purpose: - ! Solar radiation code - ! - ! Method: - ! mji/rrtmg - ! RRTMG, two-stream, with McICA - ! - ! Divides solar spectrum into 14 intervals from 0.2-12.2 micro-meters. - ! solar flux fractions specified for each interval. allows for - ! seasonally and diurnally varying solar input. Includes molecular, - ! cloud, aerosol, and surface scattering, along with h2o,o3,co2,o2,cloud, - ! and surface absorption. Computes delta-eddington reflections and - ! transmissions assuming homogeneously mixed layers. Adds the layers - ! assuming scattering between layers to be isotropic, and distinguishes - ! direct solar beam from scattered radiation. - ! - ! Longitude loops are broken into 1 or 2 sections, so that only daylight - ! (i.e. coszrs > 0) computations are done. - ! - ! Note that an extra layer above the model top layer is added. - ! - ! mks units are used. - ! - ! Special diagnostic calculation of the clear sky surface and total column - ! absorbed flux is also done for cloud forcing diagnostics. - ! - !----------------------------------------------------------------------- - USE cmparray_mod, ONLY: cmpdaynite - USE cmparray_mod, ONLY: expdaynite - USE mcica_subcol_gen_sw, ONLY: mcica_subcol_sw - USE physconst, ONLY: cpair - USE rrtmg_state, ONLY: rrtmg_state_t - ! Minimum cloud amount (as a fraction of the grid-box area) to - ! distinguish from clear sky - ! Decimal precision of cloud amount (0 -> preserve full resolution; - ! 10^-n -> preserve n digits of cloud amount) - ! Input arguments - INTEGER, intent(in) :: lchnk ! chunk identifier - INTEGER, intent(in) :: ncol ! number of atmospheric columns - INTEGER, intent(in) :: rrtmg_levs ! number of levels rad is applied - TYPE(rrtmg_state_t), intent(in) :: r_state - INTEGER, intent(in) :: nday ! Number of daylight columns - INTEGER, intent(in) :: nnite ! Number of night columns - INTEGER, intent(in), dimension(pcols) :: idxday ! Indicies of daylight coumns - INTEGER, intent(in), dimension(pcols) :: idxnite ! Indicies of night coumns - REAL(KIND=r8), intent(in) :: e_pmid(pcols,pver) ! Level pressure (Pascals) - REAL(KIND=r8), intent(in) :: e_cld(pcols,pver) ! Fractional cloud cover - REAL(KIND=r8), intent(in) :: e_aer_tau (pcols, 0:pver, nbndsw) ! aerosol optical depth - REAL(KIND=r8), intent(in) :: e_aer_tau_w (pcols, 0:pver, nbndsw) ! aerosol OD * ssa - REAL(KIND=r8), intent(in) :: e_aer_tau_w_g(pcols, 0:pver, nbndsw) ! aerosol OD * ssa * asm - REAL(KIND=r8), intent(in) :: e_aer_tau_w_f(pcols, 0:pver, nbndsw) ! aerosol OD * ssa * fwd - REAL(KIND=r8), intent(in) :: eccf ! Eccentricity factor (1./earth-sun dist^2) - REAL(KIND=r8), intent(in) :: e_coszrs(pcols) ! Cosine solar zenith angle - REAL(KIND=r8), intent(in) :: e_asdir(pcols) ! 0.2-0.7 micro-meter srfc alb: direct rad - REAL(KIND=r8), intent(in) :: e_aldir(pcols) ! 0.7-5.0 micro-meter srfc alb: direct rad - REAL(KIND=r8), intent(in) :: e_asdif(pcols) ! 0.2-0.7 micro-meter srfc alb: diffuse rad - REAL(KIND=r8), intent(in) :: e_aldif(pcols) ! 0.7-5.0 micro-meter srfc alb: diffuse rad - REAL(KIND=r8), intent(in) :: sfac(nbndsw) ! factor to account for solar variability in each band - REAL(KIND=r8), optional, intent(in) :: e_cld_tau (nbndsw, pcols, pver) ! cloud optical depth - REAL(KIND=r8), optional, intent(in) :: e_cld_tau_w (nbndsw, pcols, pver) ! cloud optical - REAL(KIND=r8), optional, intent(in) :: e_cld_tau_w_g(nbndsw, pcols, pver) ! cloud optical - REAL(KIND=r8), optional, intent(in) :: e_cld_tau_w_f(nbndsw, pcols, pver) ! cloud optical - LOGICAL, optional, intent(in) :: old_convert - ! Output arguments - REAL(KIND=r8), intent(out) :: solin(pcols) ! Incident solar flux - REAL(KIND=r8), intent(out) :: qrs (pcols,pver) ! Solar heating rate - REAL(KIND=r8), intent(out) :: qrsc(pcols,pver) ! Clearsky solar heating rate - REAL(KIND=r8), intent(out) :: fsns(pcols) ! Surface absorbed solar flux - REAL(KIND=r8), intent(out) :: fsnt(pcols) ! Total column absorbed solar flux - REAL(KIND=r8), intent(out) :: fsntoa(pcols) ! Net solar flux at TOA - REAL(KIND=r8), intent(out) :: fsutoa(pcols) ! Upward solar flux at TOA - REAL(KIND=r8), intent(out) :: fsds(pcols) ! Flux shortwave downwelling surface - REAL(KIND=r8), intent(out) :: fsnsc(pcols) ! Clear sky surface absorbed solar flux - REAL(KIND=r8), intent(out) :: fsdsc(pcols) ! Clear sky surface downwelling solar flux - REAL(KIND=r8), intent(out) :: fsntc(pcols) ! Clear sky total column absorbed solar flx - REAL(KIND=r8), intent(out) :: fsntoac(pcols) ! Clear sky net solar flx at TOA - REAL(KIND=r8), intent(out) :: sols(pcols) ! Direct solar rad on surface (< 0.7) - REAL(KIND=r8), intent(out) :: soll(pcols) ! Direct solar rad on surface (>= 0.7) - REAL(KIND=r8), intent(out) :: solsd(pcols) ! Diffuse solar rad on surface (< 0.7) - REAL(KIND=r8), intent(out) :: solld(pcols) ! Diffuse solar rad on surface (>= 0.7) - REAL(KIND=r8), intent(out) :: fsnirtoa(pcols) ! Near-IR flux absorbed at toa - REAL(KIND=r8), intent(out) :: fsnrtoac(pcols) ! Clear sky near-IR flux absorbed at toa - REAL(KIND=r8), intent(out) :: fsnrtoaq(pcols) ! Net near-IR flux at toa >= 0.7 microns - REAL(KIND=r8), intent(out) :: fns(pcols,pverp) ! net flux at interfaces - REAL(KIND=r8), intent(out) :: fcns(pcols,pverp) ! net clear-sky flux at interfaces - REAL(KIND=r8), pointer, dimension(:,:,:) :: su ! shortwave spectral flux up - REAL(KIND=r8), pointer, dimension(:,:,:) :: sd ! shortwave spectral flux down - !---------------------------Local variables----------------------------- - ! Local and reordered copies of the intent(in) variables - REAL(KIND=r8) :: pmid(pcols,pver) ! Level pressure (Pascals) - REAL(KIND=r8) :: cld(pcols,rrtmg_levs-1) ! Fractional cloud cover - REAL(KIND=r8) :: cicewp(pcols,rrtmg_levs-1) ! in-cloud cloud ice water path - REAL(KIND=r8) :: cliqwp(pcols,rrtmg_levs-1) ! in-cloud cloud liquid water path - REAL(KIND=r8) :: rel(pcols,rrtmg_levs-1) ! Liquid effective drop size (microns) - REAL(KIND=r8) :: rei(pcols,rrtmg_levs-1) ! Ice effective drop size (microns) - REAL(KIND=r8) :: coszrs(pcols) ! Cosine solar zenith angle - REAL(KIND=r8) :: asdir(pcols) ! 0.2-0.7 micro-meter srfc alb: direct rad - REAL(KIND=r8) :: aldir(pcols) ! 0.7-5.0 micro-meter srfc alb: direct rad - REAL(KIND=r8) :: asdif(pcols) ! 0.2-0.7 micro-meter srfc alb: diffuse rad - REAL(KIND=r8) :: aldif(pcols) ! 0.7-5.0 micro-meter srfc alb: diffuse rad - REAL(KIND=r8) :: h2ovmr(pcols,rrtmg_levs) ! h2o volume mixing ratio - REAL(KIND=r8) :: o3vmr(pcols,rrtmg_levs) ! o3 volume mixing ratio - REAL(KIND=r8) :: co2vmr(pcols,rrtmg_levs) ! co2 volume mixing ratio - REAL(KIND=r8) :: ch4vmr(pcols,rrtmg_levs) ! ch4 volume mixing ratio - REAL(KIND=r8) :: o2vmr(pcols,rrtmg_levs) ! o2 volume mixing ratio - REAL(KIND=r8) :: n2ovmr(pcols,rrtmg_levs) ! n2o volume mixing ratio - REAL(KIND=r8) :: tsfc(pcols) ! surface temperature - INTEGER :: inflgsw ! flag for cloud parameterization method - INTEGER :: iceflgsw ! flag for ice cloud parameterization method - INTEGER :: liqflgsw ! flag for liquid cloud parameterization method - INTEGER :: icld ! Flag for cloud overlap method - ! 0=clear, 1=random, 2=maximum/random, 3=maximum - INTEGER :: dyofyr ! Set to day of year for Earth/Sun distance calculation in - ! rrtmg_sw, or pass in adjustment directly into adjes - REAL(KIND=r8) :: solvar(nbndsw) ! solar irradiance variability in each band - INTEGER, parameter :: nsubcsw = ngptsw ! rrtmg_sw g-point (quadrature point) dimension - INTEGER :: permuteseed ! permute seed for sub-column generator - ! cloud optical depth - diagnostic temp variable - REAL(KIND=r8) :: tauc_sw(nbndsw, pcols, rrtmg_levs-1) ! cloud optical depth - REAL(KIND=r8) :: ssac_sw(nbndsw, pcols, rrtmg_levs-1) ! cloud single scat. albedo - REAL(KIND=r8) :: asmc_sw(nbndsw, pcols, rrtmg_levs-1) ! cloud asymmetry parameter - REAL(KIND=r8) :: fsfc_sw(nbndsw, pcols, rrtmg_levs-1) ! cloud forward scattering fraction - REAL(KIND=r8) :: tau_aer_sw(pcols, rrtmg_levs-1, nbndsw) ! aer optical depth - REAL(KIND=r8) :: ssa_aer_sw(pcols, rrtmg_levs-1, nbndsw) ! aer single scat. albedo - REAL(KIND=r8) :: asm_aer_sw(pcols, rrtmg_levs-1, nbndsw) ! aer asymmetry parameter - REAL(KIND=r8) :: cld_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud fraction - REAL(KIND=r8) :: rei_stosw(pcols, rrtmg_levs-1) ! stochastic ice particle size - REAL(KIND=r8) :: rel_stosw(pcols, rrtmg_levs-1) ! stochastic liquid particle size - REAL(KIND=r8) :: cicewp_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud ice water path - REAL(KIND=r8) :: cliqwp_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud liquid wter path - REAL(KIND=r8) :: tauc_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud optical depth (optional) - REAL(KIND=r8) :: ssac_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud single scat. albedo (optional) - REAL(KIND=r8) :: asmc_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud asymmetry parameter (optional) - REAL(KIND=r8) :: fsfc_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud forward scattering fraction (optional) - REAL(KIND=r8), parameter :: dps = 1._r8/86400._r8 ! Inverse of seconds per day - REAL(KIND=r8) :: swuflx(pcols,rrtmg_levs+1) ! Total sky shortwave upward flux (W/m2) - REAL(KIND=r8) :: swdflx(pcols,rrtmg_levs+1) ! Total sky shortwave downward flux (W/m2) - REAL(KIND=r8) :: swhr(pcols,rrtmg_levs) ! Total sky shortwave radiative heating rate (K/d) - REAL(KIND=r8) :: swuflxc(pcols,rrtmg_levs+1) ! Clear sky shortwave upward flux (W/m2) - REAL(KIND=r8) :: swdflxc(pcols,rrtmg_levs+1) ! Clear sky shortwave downward flux (W/m2) - REAL(KIND=r8) :: swhrc(pcols,rrtmg_levs) ! Clear sky shortwave radiative heating rate (K/d) - REAL(KIND=r8) :: swuflxs(nbndsw,pcols,rrtmg_levs+1) ! Shortwave spectral flux up - REAL(KIND=r8) :: swdflxs(nbndsw,pcols,rrtmg_levs+1) ! Shortwave spectral flux down - REAL(KIND=r8) :: dirdnuv(pcols,rrtmg_levs+1) ! Direct downward shortwave flux, UV/vis - REAL(KIND=r8) :: difdnuv(pcols,rrtmg_levs+1) ! Diffuse downward shortwave flux, UV/vis - REAL(KIND=r8) :: dirdnir(pcols,rrtmg_levs+1) ! Direct downward shortwave flux, near-IR - REAL(KIND=r8) :: difdnir(pcols,rrtmg_levs+1) ! Diffuse downward shortwave flux, near-IR - ! Added for net near-IR diagnostic - REAL(KIND=r8) :: ninflx(pcols,rrtmg_levs+1) ! Net shortwave flux, near-IR - REAL(KIND=r8) :: ninflxc(pcols,rrtmg_levs+1) ! Net clear sky shortwave flux, near-IR - ! Other - INTEGER :: ns - INTEGER :: k - INTEGER :: i ! indices - ! Cloud radiative property arrays - ! water cloud extinction optical depth - ! ice cloud extinction optical depth - ! liquid cloud single scattering albedo - ! liquid cloud asymmetry parameter - ! liquid cloud forward scattered fraction - ! ice cloud single scattering albedo - ! ice cloud asymmetry parameter - ! ice cloud forward scattered fraction - ! Aerosol radiative property arrays - ! aerosol extinction optical depth - ! aerosol single scattering albedo - ! aerosol assymetry parameter - ! aerosol forward scattered fraction - ! CRM - REAL(KIND=r8) :: fus(pcols,pverp) ! Upward flux (added for CRM) - REAL(KIND=r8) :: fds(pcols,pverp) ! Downward flux (added for CRM) - REAL(KIND=r8) :: fusc(pcols,pverp) ! Upward clear-sky flux (added for CRM) - REAL(KIND=r8) :: fdsc(pcols,pverp) ! Downward clear-sky flux (added for CRM) - INTEGER :: kk - REAL(KIND=r8) :: pmidmb(pcols,rrtmg_levs) ! Level pressure (hPa) - REAL(KIND=r8) :: pintmb(pcols,rrtmg_levs+1) ! Model interface pressure (hPa) - REAL(KIND=r8) :: tlay(pcols,rrtmg_levs) ! mid point temperature - REAL(KIND=r8) :: tlev(pcols,rrtmg_levs+1) ! interface temperature - !----------------------------------------------------------------------- - ! START OF CALCULATION - !----------------------------------------------------------------------- - ! Initialize output fields: - fsds(1:ncol) = 0.0_r8 - fsnirtoa(1:ncol) = 0.0_r8 - fsnrtoac(1:ncol) = 0.0_r8 - fsnrtoaq(1:ncol) = 0.0_r8 - fsns(1:ncol) = 0.0_r8 - fsnsc(1:ncol) = 0.0_r8 - fsdsc(1:ncol) = 0.0_r8 - fsnt(1:ncol) = 0.0_r8 - fsntc(1:ncol) = 0.0_r8 - fsntoa(1:ncol) = 0.0_r8 - fsutoa(1:ncol) = 0.0_r8 - fsntoac(1:ncol) = 0.0_r8 - solin(1:ncol) = 0.0_r8 - sols(1:ncol) = 0.0_r8 - soll(1:ncol) = 0.0_r8 - solsd(1:ncol) = 0.0_r8 - solld(1:ncol) = 0.0_r8 - qrs (1:ncol,1:pver) = 0.0_r8 - qrsc(1:ncol,1:pver) = 0.0_r8 - fns(1:ncol,1:pverp) = 0.0_r8 - fcns(1:ncol,1:pverp) = 0.0_r8 - if (single_column.and.scm_crm_mode) then - fus(1:ncol,1:pverp) = 0.0_r8 - fds(1:ncol,1:pverp) = 0.0_r8 - fusc(:ncol,:pverp) = 0.0_r8 - fdsc(:ncol,:pverp) = 0.0_r8 - endif - if (associated(su)) su(1:ncol,:,:) = 0.0_r8 - if (associated(sd)) sd(1:ncol,:,:) = 0.0_r8 - ! If night everywhere, return: - if ( Nday == 0 ) then - return - endif - ! Rearrange input arrays - call CmpDayNite(E_pmid(:,pverp-rrtmg_levs+1:pver), pmid(:,1:rrtmg_levs-1), & - Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs-1) - call CmpDayNite(E_cld(:,pverp-rrtmg_levs+1:pver), cld(:,1:rrtmg_levs-1), & - Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs-1) - call CmpDayNite(r_state%pintmb, pintmb, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs+1) - call CmpDayNite(r_state%pmidmb, pmidmb, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs) - call CmpDayNite(r_state%h2ovmr, h2ovmr, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs) - call CmpDayNite(r_state%o3vmr, o3vmr, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs) - call CmpDayNite(r_state%co2vmr, co2vmr, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs) - call CmpDayNite(E_coszrs, coszrs, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call CmpDayNite(E_asdir, asdir, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call CmpDayNite(E_aldir, aldir, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call CmpDayNite(E_asdif, asdif, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call CmpDayNite(E_aldif, aldif, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call CmpDayNite(r_state%tlay, tlay, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs) - call CmpDayNite(r_state%tlev, tlev, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs+1) - call CmpDayNite(r_state%ch4vmr, ch4vmr, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs) - call CmpDayNite(r_state%o2vmr, o2vmr, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs) - call CmpDayNite(r_state%n2ovmr, n2ovmr, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs) - ! These fields are no longer input by CAM. - cicewp = 0.0_r8 - cliqwp = 0.0_r8 - rel = 0.0_r8 - rei = 0.0_r8 - ! Aerosol daylight map - ! Also convert to optical properties of rrtmg interface, even though - ! these quantities are later multiplied back together inside rrtmg ! - ! Why does rrtmg use the factored quantities? - ! There are several different ways this factoring could be done. - ! Other ways might allow for better optimization - do ns = 1, nbndsw - do k = 1, rrtmg_levs-1 - kk=(pverp-rrtmg_levs) + k - do i = 1, Nday - if(E_aer_tau_w(IdxDay(i),kk,ns) > 1.e-80_r8) then - asm_aer_sw(i,k,ns) = E_aer_tau_w_g(IdxDay(i),kk,ns)/E_aer_tau_w(IdxDay(i),kk,ns) - else - asm_aer_sw(i,k,ns) = 0._r8 - endif - if(E_aer_tau(IdxDay(i),kk,ns) > 0._r8) then - ssa_aer_sw(i,k,ns) = E_aer_tau_w(IdxDay(i),kk,ns)/E_aer_tau(IdxDay(i),kk,ns) - tau_aer_sw(i,k,ns) = E_aer_tau(IdxDay(i),kk,ns) - else - ssa_aer_sw(i,k,ns) = 1._r8 - tau_aer_sw(i,k,ns) = 0._r8 - endif - enddo - enddo - enddo - if (scm_crm_mode) then - ! overwrite albedos for CRM - if(have_asdir) asdir = asdirobs(1) - if(have_asdif) asdif = asdifobs(1) - if(have_aldir) aldir = aldirobs(1) - if(have_aldif) aldif = aldifobs(1) - endif - ! Define solar incident radiation - do i = 1, Nday - solin(i) = sum(sfac(:)*solar_band_irrad(:)) * eccf * coszrs(i) - end do - ! Calculate cloud optical properties here if using CAM method, or if using one of the - ! methods in RRTMG_SW, then pass in cloud physical properties and zero out cloud optical - ! properties here - ! Zero optional cloud optical property input arrays tauc_sw, ssac_sw, asmc_sw, - ! if inputting cloud physical properties to RRTMG_SW - !tauc_sw(:,:,:) = 0.0_r8 - !ssac_sw(:,:,:) = 1.0_r8 - !asmc_sw(:,:,:) = 0.0_r8 - !fsfc_sw(:,:,:) = 0.0_r8 - ! - ! Or, calculate and pass in CAM cloud shortwave optical properties to RRTMG_SW - !if (present(old_convert)) print *, 'old_convert',old_convert - !if (present(ancientmethod)) print *, 'ancientmethod',ancientmethod - if (present(old_convert))then - if (old_convert)then ! convert without limits ! convert without limits - do i = 1, Nday - do k = 1, rrtmg_levs-1 - kk=(pverp-rrtmg_levs) + k - do ns = 1, nbndsw - if (E_cld_tau_w(ns,IdxDay(i),kk) > 0._r8) then - fsfc_sw(ns,i,k)=E_cld_tau_w_f(ns,IdxDay(i),kk)/E_cld_tau_w(ns,IdxDay(i),kk) - asmc_sw(ns,i,k)=E_cld_tau_w_g(ns,IdxDay(i),kk)/E_cld_tau_w(ns,IdxDay(i),kk) - else - fsfc_sw(ns,i,k) = 0._r8 - asmc_sw(ns,i,k) = 0._r8 - endif - tauc_sw(ns,i,k)=E_cld_tau(ns,IdxDay(i),kk) - if (tauc_sw(ns,i,k) > 0._r8) then - ssac_sw(ns,i,k)=E_cld_tau_w(ns,IdxDay(i),kk)/tauc_sw(ns,i,k) - else - tauc_sw(ns,i,k) = 0._r8 - fsfc_sw(ns,i,k) = 0._r8 - asmc_sw(ns,i,k) = 0._r8 - ssac_sw(ns,i,k) = 1._r8 - endif - enddo - enddo - enddo - else - ! eventually, when we are done with archaic versions, This set of code will become the default. - do i = 1, Nday - do k = 1, rrtmg_levs-1 - kk=(pverp-rrtmg_levs) + k - do ns = 1, nbndsw - if (E_cld_tau_w(ns,IdxDay(i),kk) > 0._r8) then - fsfc_sw(ns,i,k)=E_cld_tau_w_f(ns,IdxDay(i),kk)/max(E_cld_tau_w(ns,IdxDay(i),kk), 1.e-80_r8) - asmc_sw(ns,i,k)=E_cld_tau_w_g(ns,IdxDay(i),kk)/max(E_cld_tau_w(ns,IdxDay(i),kk), 1.e-80_r8) - else - fsfc_sw(ns,i,k) = 0._r8 - asmc_sw(ns,i,k) = 0._r8 - endif - tauc_sw(ns,i,k)=E_cld_tau(ns,IdxDay(i),kk) - if (tauc_sw(ns,i,k) > 0._r8) then - ssac_sw(ns,i,k)=max(E_cld_tau_w(ns,IdxDay(i),kk),1.e-80_r8)/max(tauc_sw(ns,i,k),1.e-80_r8) - else - tauc_sw(ns,i,k) = 0._r8 - fsfc_sw(ns,i,k) = 0._r8 - asmc_sw(ns,i,k) = 0._r8 - ssac_sw(ns,i,k) = 1._r8 - endif - enddo - enddo - enddo - endif - else - do i = 1, Nday - do k = 1, rrtmg_levs-1 - kk=(pverp-rrtmg_levs) + k - do ns = 1, nbndsw - if (E_cld_tau_w(ns,IdxDay(i),kk) > 0._r8) then - fsfc_sw(ns,i,k)=E_cld_tau_w_f(ns,IdxDay(i),kk)/max(E_cld_tau_w(ns,IdxDay(i),kk), 1.e-80_r8) - asmc_sw(ns,i,k)=E_cld_tau_w_g(ns,IdxDay(i),kk)/max(E_cld_tau_w(ns,IdxDay(i),kk), 1.e-80_r8) - else - fsfc_sw(ns,i,k) = 0._r8 - asmc_sw(ns,i,k) = 0._r8 - endif - tauc_sw(ns,i,k)=E_cld_tau(ns,IdxDay(i),kk) - if (tauc_sw(ns,i,k) > 0._r8) then - ssac_sw(ns,i,k)=max(E_cld_tau_w(ns,IdxDay(i),kk),1.e-80_r8)/max(tauc_sw(ns,i,k),1.e-80_r8) - else - tauc_sw(ns,i,k) = 0._r8 - fsfc_sw(ns,i,k) = 0._r8 - asmc_sw(ns,i,k) = 0._r8 - ssac_sw(ns,i,k) = 1._r8 - endif - enddo - enddo - enddo - endif - ! Call mcica sub-column generator for RRTMG_SW - ! Call sub-column generator for McICA in radiation - ! Select cloud overlap approach (1=random, 2=maximum-random, 3=maximum) - icld = 2 - ! Set permute seed (must be offset between LW and SW by at least 140 to insure - ! effective randomization) - permuteseed = 1 - call mcica_subcol_sw(lchnk, Nday, rrtmg_levs-1, icld, permuteseed, pmid, & - cld, cicewp, cliqwp, rei, rel, tauc_sw, ssac_sw, asmc_sw, fsfc_sw, & - cld_stosw, cicewp_stosw, cliqwp_stosw, rei_stosw, rel_stosw, & - tauc_stosw, ssac_stosw, asmc_stosw, fsfc_stosw) - ! Call RRTMG_SW for all layers for daylight columns - ! Select parameterization of cloud ice and liquid optical depths - ! Use CAM shortwave cloud optical properties directly - inflgsw = 0 - iceflgsw = 0 - liqflgsw = 0 - ! Use E&C param for ice to mimic CAM3 for now - ! inflgsw = 2 - ! iceflgsw = 1 - ! liqflgsw = 1 - ! Use merged Fu and E&C params for ice - ! inflgsw = 2 - ! iceflgsw = 3 - ! liqflgsw = 1 - ! Set day of year for Earth/Sun distance calculation in rrtmg_sw, or - ! set to zero and pass E/S adjustment (eccf) directly into array adjes - dyofyr = 0 - tsfc(:ncol) = tlev(:ncol,rrtmg_levs+1) - solvar(1:nbndsw) = sfac(1:nbndsw) - call rrtmg_sw(lchnk, Nday, rrtmg_levs, icld, & - pmidmb, pintmb, tlay, tlev, tsfc, & - h2ovmr, o3vmr, co2vmr, ch4vmr, o2vmr, n2ovmr, & - asdir, asdif, aldir, aldif, & - coszrs, eccf, dyofyr, solvar, & - inflgsw, iceflgsw, liqflgsw, & - cld_stosw, tauc_stosw, ssac_stosw, asmc_stosw, fsfc_stosw, & - cicewp_stosw, cliqwp_stosw, rei, rel, & - tau_aer_sw, ssa_aer_sw, asm_aer_sw, & - swuflx, swdflx, swhr, swuflxc, swdflxc, swhrc, & - dirdnuv, dirdnir, difdnuv, difdnir, ninflx, ninflxc, swuflxs, swdflxs) - ! Flux units are in W/m2 on output from rrtmg_sw and contain output for - ! extra layer above model top with vertical indexing from bottom to top. - ! - ! Heating units are in J/kg/s on output from rrtmg_sw and contain output - ! for extra layer above model top with vertical indexing from bottom to top. - ! - ! Reverse vertical indexing to go from top to bottom for CAM output. - ! Set the net absorted shortwave flux at TOA (top of extra layer) - fsntoa(1:Nday) = swdflx(1:Nday,rrtmg_levs+1) - swuflx(1:Nday,rrtmg_levs+1) - fsutoa(1:Nday) = swuflx(1:Nday,rrtmg_levs+1) - fsntoac(1:Nday) = swdflxc(1:Nday,rrtmg_levs+1) - swuflxc(1:Nday,rrtmg_levs+1) - ! Set net near-IR flux at top of the model - fsnirtoa(1:Nday) = ninflx(1:Nday,rrtmg_levs) - fsnrtoaq(1:Nday) = ninflx(1:Nday,rrtmg_levs) - fsnrtoac(1:Nday) = ninflxc(1:Nday,rrtmg_levs) - ! Set the net absorbed shortwave flux at the model top level - fsnt(1:Nday) = swdflx(1:Nday,rrtmg_levs) - swuflx(1:Nday,rrtmg_levs) - fsntc(1:Nday) = swdflxc(1:Nday,rrtmg_levs) - swuflxc(1:Nday,rrtmg_levs) - ! Set the downwelling flux at the surface - fsds(1:Nday) = swdflx(1:Nday,1) - fsdsc(1:Nday) = swdflxc(1:Nday,1) - ! Set the net shortwave flux at the surface - fsns(1:Nday) = swdflx(1:Nday,1) - swuflx(1:Nday,1) - fsnsc(1:Nday) = swdflxc(1:Nday,1) - swuflxc(1:Nday,1) - ! Set the UV/vis and near-IR direct and dirruse downward shortwave flux at surface - sols(1:Nday) = dirdnuv(1:Nday,1) - soll(1:Nday) = dirdnir(1:Nday,1) - solsd(1:Nday) = difdnuv(1:Nday,1) - solld(1:Nday) = difdnir(1:Nday,1) - ! Set the net, up and down fluxes at model interfaces - fns (1:Nday,pverp-rrtmg_levs+1:pverp) = swdflx(1:Nday,rrtmg_levs:1:-1) - swuflx(1:Nday,rrtmg_levs:1:-1) - fcns(1:Nday,pverp-rrtmg_levs+1:pverp) = swdflxc(1:Nday,rrtmg_levs:1:-1) - swuflxc(1:Nday,rrtmg_levs:1:-1) - fus (1:Nday,pverp-rrtmg_levs+1:pverp) = swuflx(1:Nday,rrtmg_levs:1:-1) - fusc(1:Nday,pverp-rrtmg_levs+1:pverp) = swuflxc(1:Nday,rrtmg_levs:1:-1) - fds (1:Nday,pverp-rrtmg_levs+1:pverp) = swdflx(1:Nday,rrtmg_levs:1:-1) - fdsc(1:Nday,pverp-rrtmg_levs+1:pverp) = swdflxc(1:Nday,rrtmg_levs:1:-1) - ! Set solar heating, reverse layering - ! Pass shortwave heating to CAM arrays and convert from K/d to J/kg/s - qrs (1:Nday,pverp-rrtmg_levs+1:pver) = swhr (1:Nday,rrtmg_levs-1:1:-1)*cpair*dps - qrsc(1:Nday,pverp-rrtmg_levs+1:pver) = swhrc(1:Nday,rrtmg_levs-1:1:-1)*cpair*dps - ! Set spectral fluxes, reverse layering - ! order=(/3,1,2/) maps the first index of swuflxs to the third index of su. - if (associated(su)) then - su(1:Nday,pverp-rrtmg_levs+1:pverp,:) = reshape(swuflxs(:,1:Nday,rrtmg_levs:1:-1), & - (/Nday,rrtmg_levs,nbndsw/), order=(/3,1,2/)) - end if - if (associated(sd)) then - sd(1:Nday,pverp-rrtmg_levs+1:pverp,:) = reshape(swdflxs(:,1:Nday,rrtmg_levs:1:-1), & - (/Nday,rrtmg_levs,nbndsw/), order=(/3,1,2/)) - end if - ! Rearrange output arrays. - ! - ! intent(out) - call ExpDayNite(solin, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(qrs, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pver) - call ExpDayNite(qrsc, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pver) - call ExpDayNite(fns, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) - call ExpDayNite(fcns, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) - call ExpDayNite(fsns, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(fsnt, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(fsntoa, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(fsutoa, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(fsds, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(fsnsc, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(fsdsc, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(fsntc, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(fsntoac, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(sols, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(soll, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(solsd, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(solld, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(fsnirtoa, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(fsnrtoac, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(fsnrtoaq, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - if (associated(su)) then - call ExpDayNite(su, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp, 1, nbndsw) - end if - if (associated(sd)) then - call ExpDayNite(sd, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp, 1, nbndsw) - end if - ! these outfld calls don't work for spmd only outfield in scm mode (nonspmd) - if (single_column .and. scm_crm_mode) then - ! Following outputs added for CRM - call ExpDayNite(fus,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) - call ExpDayNite(fds,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) - call ExpDayNite(fusc,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) - call ExpDayNite(fdsc,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) - ! call outfld('FUS ',fus * 1.e-3_r8 ,pcols,lchnk) - ! call outfld('FDS ',fds * 1.e-3_r8 ,pcols,lchnk) - ! call outfld('FUSC ',fusc,pcols,lchnk) - ! call outfld('FDSC ',fdsc,pcols,lchnk) - endif - END SUBROUTINE rad_rrtmg_sw - !------------------------------------------------------------------------------- - - !------------------------------------------------------------------------------- - END MODULE radsw diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrsw_cld.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrsw_cld.f90 deleted file mode 100644 index 2f63888af3..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrsw_cld.f90 +++ /dev/null @@ -1,84 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_cld.f90 -! Generated at: 2015-07-07 00:48:23 -! KGEN version: 0.4.13 - - - - MODULE rrsw_cld - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw cloud property coefficients - ! - ! Initial: J.-J. Morcrette, ECMWF, oct1999 - ! Revised: J. Delamere/MJIacono, AER, aug2005 - ! Revised: MJIacono, AER, nov2005 - ! Revised: MJIacono, AER, jul2006 - !------------------------------------------------------------------ - ! - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! xxxliq1 : real : optical properties (extinction coefficient, single - ! scattering albedo, assymetry factor) from - ! Hu & Stamnes, j. clim., 6, 728-742, 1993. - ! xxxice2 : real : optical properties (extinction coefficient, single - ! scattering albedo, assymetry factor) from streamer v3.0, - ! Key, streamer user's guide, cooperative institude - ! for meteorological studies, 95 pp., 2001. - ! xxxice3 : real : optical properties (extinction coefficient, single - ! scattering albedo, assymetry factor) from - ! Fu, j. clim., 9, 1996. - ! xbari : real : optical property coefficients for five spectral - ! intervals (2857-4000, 4000-5263, 5263-7692, 7692-14285, - ! and 14285-40000 wavenumbers) following - ! Ebert and Curry, jgr, 97, 3831-3836, 1992. - !------------------------------------------------------------------ - REAL(KIND=r8) :: extliq1(58,16:29) - REAL(KIND=r8) :: ssaliq1(58,16:29) - REAL(KIND=r8) :: asyliq1(58,16:29) - REAL(KIND=r8) :: extice2(43,16:29) - REAL(KIND=r8) :: ssaice2(43,16:29) - REAL(KIND=r8) :: asyice2(43,16:29) - REAL(KIND=r8) :: extice3(46,16:29) - REAL(KIND=r8) :: ssaice3(46,16:29) - REAL(KIND=r8) :: asyice3(46,16:29) - REAL(KIND=r8) :: fdlice3(46,16:29) - REAL(KIND=r8) :: abari(5) - REAL(KIND=r8) :: bbari(5) - REAL(KIND=r8) :: dbari(5) - REAL(KIND=r8) :: cbari(5) - REAL(KIND=r8) :: ebari(5) - REAL(KIND=r8) :: fbari(5) - PUBLIC kgen_read_externs_rrsw_cld - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_cld(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) extliq1 - READ(UNIT=kgen_unit) ssaliq1 - READ(UNIT=kgen_unit) asyliq1 - READ(UNIT=kgen_unit) extice2 - READ(UNIT=kgen_unit) ssaice2 - READ(UNIT=kgen_unit) asyice2 - READ(UNIT=kgen_unit) extice3 - READ(UNIT=kgen_unit) ssaice3 - READ(UNIT=kgen_unit) asyice3 - READ(UNIT=kgen_unit) fdlice3 - READ(UNIT=kgen_unit) abari - READ(UNIT=kgen_unit) bbari - READ(UNIT=kgen_unit) dbari - READ(UNIT=kgen_unit) cbari - READ(UNIT=kgen_unit) ebari - READ(UNIT=kgen_unit) fbari - END SUBROUTINE kgen_read_externs_rrsw_cld - - END MODULE rrsw_cld diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrsw_con.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrsw_con.f90 deleted file mode 100644 index ad961fc8f1..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrsw_con.f90 +++ /dev/null @@ -1,57 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_con.f90 -! Generated at: 2015-07-07 00:48:24 -! KGEN version: 0.4.13 - - - - MODULE rrsw_con - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw constants - ! Initial version: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! fluxfac: real : radiance to flux conversion factor - ! heatfac: real : flux to heating rate conversion factor - !oneminus: real : 1.-1.e-6 - ! pi : real : pi - ! grav : real : acceleration of gravity (m/s2) - ! planck : real : planck constant - ! boltz : real : boltzman constant - ! clight : real : speed of light - ! avogad : real : avogadro's constant - ! alosmt : real : - ! gascon : real : gas constant - ! radcn1 : real : - ! radcn2 : real : - !------------------------------------------------------------------ - REAL(KIND=r8) :: heatfac - REAL(KIND=r8) :: oneminus - REAL(KIND=r8) :: pi - REAL(KIND=r8) :: grav - REAL(KIND=r8) :: avogad - PUBLIC kgen_read_externs_rrsw_con - CONTAINS - - ! write subroutines - ! No subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_con(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) heatfac - READ(UNIT=kgen_unit) oneminus - READ(UNIT=kgen_unit) pi - READ(UNIT=kgen_unit) grav - READ(UNIT=kgen_unit) avogad - END SUBROUTINE kgen_read_externs_rrsw_con - - END MODULE rrsw_con diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg16.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg16.f90 deleted file mode 100644 index c5a7c9594c..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg16.f90 +++ /dev/null @@ -1,77 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg16.f90 -! Generated at: 2015-07-07 00:48:24 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg16 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng16 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 16 - ! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: strrat1 - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 16 - ! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(585,ng16) - REAL(KIND=r8) :: absb(235,ng16) - REAL(KIND=r8) :: forref(3,ng16) - REAL(KIND=r8) :: selfref(10,ng16) - REAL(KIND=r8) :: sfluxref(ng16) - PUBLIC kgen_read_externs_rrsw_kg16 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg16(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) strrat1 - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) sfluxref - END SUBROUTINE kgen_read_externs_rrsw_kg16 - - END MODULE rrsw_kg16 diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg17.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg17.f90 deleted file mode 100644 index 0ec3e552e8..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg17.f90 +++ /dev/null @@ -1,77 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg17.f90 -! Generated at: 2015-07-07 00:48:24 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg17 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng17 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 17 - ! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: strrat - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 17 - ! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(585,ng17) - REAL(KIND=r8) :: absb(1175,ng17) - REAL(KIND=r8) :: selfref(10,ng17) - REAL(KIND=r8) :: forref(4,ng17) - REAL(KIND=r8) :: sfluxref(ng17,5) - PUBLIC kgen_read_externs_rrsw_kg17 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg17(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) strrat - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) sfluxref - END SUBROUTINE kgen_read_externs_rrsw_kg17 - - END MODULE rrsw_kg17 diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg18.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg18.f90 deleted file mode 100644 index f4ebd3b50d..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg18.f90 +++ /dev/null @@ -1,77 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg18.f90 -! Generated at: 2015-07-07 00:48:25 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg18 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng18 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 18 - ! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: strrat - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 18 - ! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(585,ng18) - REAL(KIND=r8) :: absb(235,ng18) - REAL(KIND=r8) :: forref(3,ng18) - REAL(KIND=r8) :: selfref(10,ng18) - REAL(KIND=r8) :: sfluxref(ng18,9) - PUBLIC kgen_read_externs_rrsw_kg18 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg18(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) strrat - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) sfluxref - END SUBROUTINE kgen_read_externs_rrsw_kg18 - - END MODULE rrsw_kg18 diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg19.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg19.f90 deleted file mode 100644 index f6d092ba01..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg19.f90 +++ /dev/null @@ -1,77 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg19.f90 -! Generated at: 2015-07-07 00:48:23 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg19 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng19 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 19 - ! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: strrat - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 19 - ! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(585,ng19) - REAL(KIND=r8) :: absb(235,ng19) - REAL(KIND=r8) :: selfref(10,ng19) - REAL(KIND=r8) :: forref(3,ng19) - REAL(KIND=r8) :: sfluxref(ng19,9) - PUBLIC kgen_read_externs_rrsw_kg19 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg19(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) strrat - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) sfluxref - END SUBROUTINE kgen_read_externs_rrsw_kg19 - - END MODULE rrsw_kg19 diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg20.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg20.f90 deleted file mode 100644 index ecf6cc854f..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg20.f90 +++ /dev/null @@ -1,79 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg20.f90 -! Generated at: 2015-07-07 00:48:24 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg20 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng20 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 20 - ! band 20: 5150-6150 cm-1 (low - h2o; high - h2o) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - ! absch4o : real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 20 - ! band 20: 5150-6150 cm-1 (low - h2o; high - h2o) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - ! absch4 : real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(65,ng20) - REAL(KIND=r8) :: absb(235,ng20) - REAL(KIND=r8) :: forref(4,ng20) - REAL(KIND=r8) :: selfref(10,ng20) - REAL(KIND=r8) :: sfluxref(ng20) - REAL(KIND=r8) :: absch4(ng20) - PUBLIC kgen_read_externs_rrsw_kg20 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg20(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) sfluxref - READ(UNIT=kgen_unit) absch4 - END SUBROUTINE kgen_read_externs_rrsw_kg20 - - END MODULE rrsw_kg20 diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg21.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg21.f90 deleted file mode 100644 index 04660be3b4..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg21.f90 +++ /dev/null @@ -1,77 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg21.f90 -! Generated at: 2015-07-07 00:48:25 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg21 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng21 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 21 - ! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: strrat - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 21 - ! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(585,ng21) - REAL(KIND=r8) :: absb(1175,ng21) - REAL(KIND=r8) :: forref(4,ng21) - REAL(KIND=r8) :: selfref(10,ng21) - REAL(KIND=r8) :: sfluxref(ng21,9) - PUBLIC kgen_read_externs_rrsw_kg21 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg21(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) strrat - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) sfluxref - END SUBROUTINE kgen_read_externs_rrsw_kg21 - - END MODULE rrsw_kg21 diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg22.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg22.f90 deleted file mode 100644 index cca8d22987..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg22.f90 +++ /dev/null @@ -1,77 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg22.f90 -! Generated at: 2015-07-07 00:48:24 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg22 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng22 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 22 - ! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: strrat - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 22 - ! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(585,ng22) - REAL(KIND=r8) :: absb(235,ng22) - REAL(KIND=r8) :: forref(3,ng22) - REAL(KIND=r8) :: selfref(10,ng22) - REAL(KIND=r8) :: sfluxref(ng22,9) - PUBLIC kgen_read_externs_rrsw_kg22 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg22(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) strrat - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) sfluxref - END SUBROUTINE kgen_read_externs_rrsw_kg22 - - END MODULE rrsw_kg22 diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg23.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg23.f90 deleted file mode 100644 index 034aac6cd7..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg23.f90 +++ /dev/null @@ -1,75 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg23.f90 -! Generated at: 2015-07-07 00:48:24 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg23 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng23 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 23 - ! band 23: 8050-12850 cm-1 (low - h2o; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: givfac - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 23 - ! band 23: 8050-12850 cm-1 (low - h2o; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(65,ng23) - REAL(KIND=r8) :: forref(3,ng23) - REAL(KIND=r8) :: selfref(10,ng23) - REAL(KIND=r8) :: rayl(ng23) - REAL(KIND=r8) :: sfluxref(ng23) - PUBLIC kgen_read_externs_rrsw_kg23 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg23(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) givfac - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) sfluxref - END SUBROUTINE kgen_read_externs_rrsw_kg23 - - END MODULE rrsw_kg23 diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg24.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg24.f90 deleted file mode 100644 index d468521605..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg24.f90 +++ /dev/null @@ -1,91 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg24.f90 -! Generated at: 2015-07-07 00:48:24 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg24 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng24 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 24 - ! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - ! abso3ao : real - ! abso3bo : real - ! raylao : real - ! raylbo : real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: strrat - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 24 - ! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - ! abso3a : real - ! abso3b : real - ! rayla : real - ! raylb : real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(585,ng24) - REAL(KIND=r8) :: absb(235,ng24) - REAL(KIND=r8) :: forref(3,ng24) - REAL(KIND=r8) :: selfref(10,ng24) - REAL(KIND=r8) :: sfluxref(ng24,9) - REAL(KIND=r8) :: abso3a(ng24) - REAL(KIND=r8) :: abso3b(ng24) - REAL(KIND=r8) :: rayla(ng24,9) - REAL(KIND=r8) :: raylb(ng24) - PUBLIC kgen_read_externs_rrsw_kg24 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg24(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) strrat - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) sfluxref - READ(UNIT=kgen_unit) abso3a - READ(UNIT=kgen_unit) abso3b - READ(UNIT=kgen_unit) rayla - READ(UNIT=kgen_unit) raylb - END SUBROUTINE kgen_read_externs_rrsw_kg24 - - END MODULE rrsw_kg24 diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg25.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg25.f90 deleted file mode 100644 index 8fae27dd3b..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg25.f90 +++ /dev/null @@ -1,72 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg25.f90 -! Generated at: 2015-07-07 00:48:23 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg25 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng25 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 25 - ! band 25: 16000-22650 cm-1 (low - h2o; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - !sfluxrefo: real - ! abso3ao : real - ! abso3bo : real - ! raylo : real - !----------------------------------------------------------------- - INTEGER :: layreffr - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 25 - ! band 25: 16000-22650 cm-1 (low - h2o; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! absa : real - ! sfluxref: real - ! abso3a : real - ! abso3b : real - ! rayl : real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(65,ng25) - REAL(KIND=r8) :: sfluxref(ng25) - REAL(KIND=r8) :: abso3a(ng25) - REAL(KIND=r8) :: abso3b(ng25) - REAL(KIND=r8) :: rayl(ng25) - PUBLIC kgen_read_externs_rrsw_kg25 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg25(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) sfluxref - READ(UNIT=kgen_unit) abso3a - READ(UNIT=kgen_unit) abso3b - READ(UNIT=kgen_unit) rayl - END SUBROUTINE kgen_read_externs_rrsw_kg25 - - END MODULE rrsw_kg25 diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg26.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg26.f90 deleted file mode 100644 index 8fe34ef9aa..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg26.f90 +++ /dev/null @@ -1,57 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg26.f90 -! Generated at: 2015-07-07 00:48:25 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg26 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng26 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 26 - ! band 26: 22650-29000 cm-1 (low - nothing; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !sfluxrefo: real - ! raylo : real - !----------------------------------------------------------------- - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 26 - ! band 26: 22650-29000 cm-1 (low - nothing; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! sfluxref: real - ! rayl : real - !----------------------------------------------------------------- - REAL(KIND=r8) :: sfluxref(ng26) - REAL(KIND=r8) :: rayl(ng26) - PUBLIC kgen_read_externs_rrsw_kg26 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg26(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) sfluxref - READ(UNIT=kgen_unit) rayl - END SUBROUTINE kgen_read_externs_rrsw_kg26 - - END MODULE rrsw_kg26 diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg27.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg27.f90 deleted file mode 100644 index 936b8edc55..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg27.f90 +++ /dev/null @@ -1,71 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg27.f90 -! Generated at: 2015-07-07 00:48:24 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg27 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng27 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 27 - ! band 27: 29000-38000 cm-1 (low - o3; high - o3) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - !sfluxrefo: real - ! raylo : real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: scalekur - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 27 - ! band 27: 29000-38000 cm-1 (low - o3; high - o3) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! sfluxref: real - ! rayl : real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(65,ng27) - REAL(KIND=r8) :: absb(235,ng27) - REAL(KIND=r8) :: sfluxref(ng27) - REAL(KIND=r8) :: rayl(ng27) - PUBLIC kgen_read_externs_rrsw_kg27 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg27(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) scalekur - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) sfluxref - READ(UNIT=kgen_unit) rayl - END SUBROUTINE kgen_read_externs_rrsw_kg27 - - END MODULE rrsw_kg27 diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg28.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg28.f90 deleted file mode 100644 index abcda2afe6..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg28.f90 +++ /dev/null @@ -1,67 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg28.f90 -! Generated at: 2015-07-07 00:48:23 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg28 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng28 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 28 - ! band 28: 38000-50000 cm-1 (low - o3, o2; high - o3, o2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - !sfluxrefo: real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: strrat - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 28 - ! band 28: 38000-50000 cm-1 (low - o3, o2; high - o3, o2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! sfluxref: real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(585,ng28) - REAL(KIND=r8) :: absb(1175,ng28) - REAL(KIND=r8) :: sfluxref(ng28,5) - PUBLIC kgen_read_externs_rrsw_kg28 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg28(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) strrat - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) sfluxref - END SUBROUTINE kgen_read_externs_rrsw_kg28 - - END MODULE rrsw_kg28 diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg29.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg29.f90 deleted file mode 100644 index e9036e0f6d..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg29.f90 +++ /dev/null @@ -1,81 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg29.f90 -! Generated at: 2015-07-07 00:48:24 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg29 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng29 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 29 - ! band 29: 820-2600 cm-1 (low - h2o; high - co2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - ! absh2oo : real - ! absco2o : real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 29 - ! band 29: 820-2600 cm-1 (low - h2o; high - co2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! selfref : real - ! forref : real - ! sfluxref: real - ! absh2o : real - ! absco2 : real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(65,ng29) - REAL(KIND=r8) :: absb(235,ng29) - REAL(KIND=r8) :: forref(4,ng29) - REAL(KIND=r8) :: selfref(10,ng29) - REAL(KIND=r8) :: sfluxref(ng29) - REAL(KIND=r8) :: absco2(ng29) - REAL(KIND=r8) :: absh2o(ng29) - PUBLIC kgen_read_externs_rrsw_kg29 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg29(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) sfluxref - READ(UNIT=kgen_unit) absco2 - READ(UNIT=kgen_unit) absh2o - END SUBROUTINE kgen_read_externs_rrsw_kg29 - - END MODULE rrsw_kg29 diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrsw_ref.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrsw_ref.f90 deleted file mode 100644 index 701432af92..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrsw_ref.f90 +++ /dev/null @@ -1,43 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_ref.f90 -! Generated at: 2015-07-07 00:48:24 -! KGEN version: 0.4.13 - - - - MODULE rrsw_ref - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw reference atmosphere - ! Based on standard mid-latitude summer profile - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! pref : real : Reference pressure levels - ! preflog: real : Reference pressure levels, ln(pref) - ! tref : real : Reference temperature levels for MLS profile - !------------------------------------------------------------------ - REAL(KIND=r8), dimension(59) :: preflog - REAL(KIND=r8), dimension(59) :: tref - PUBLIC kgen_read_externs_rrsw_ref - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_ref(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) preflog - READ(UNIT=kgen_unit) tref - END SUBROUTINE kgen_read_externs_rrsw_ref - - END MODULE rrsw_ref diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrsw_tbl.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrsw_tbl.f90 deleted file mode 100644 index adccbe8016..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrsw_tbl.f90 +++ /dev/null @@ -1,49 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_tbl.f90 -! Generated at: 2015-07-07 00:48:23 -! KGEN version: 0.4.13 - - - - MODULE rrsw_tbl - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw lookup table arrays - ! Initial version: MJIacono, AER, may2007 - ! Revised: MJIacono, AER, aug2007 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! ntbl : integer: Lookup table dimension - ! tblint : real : Lookup table conversion factor - ! tau_tbl: real : Clear-sky optical depth - ! exp_tbl: real : Exponential lookup table for transmittance - ! od_lo : real : Value of tau below which expansion is used - ! : in place of lookup table - ! pade : real : Pade approximation constant - ! bpade : real : Inverse of Pade constant - !------------------------------------------------------------------ - INTEGER, parameter :: ntbl = 10000 - REAL(KIND=r8), parameter :: tblint = 10000.0 - REAL(KIND=r8), parameter :: od_lo = 0.06 - REAL(KIND=r8), dimension(0:ntbl) :: exp_tbl - REAL(KIND=r8) :: bpade - PUBLIC kgen_read_externs_rrsw_tbl - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_tbl(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) exp_tbl - READ(UNIT=kgen_unit) bpade - END SUBROUTINE kgen_read_externs_rrsw_tbl - - END MODULE rrsw_tbl diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrsw_vsn.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrsw_vsn.f90 deleted file mode 100644 index 2ff978f47b..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrsw_vsn.f90 +++ /dev/null @@ -1,69 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_vsn.f90 -! Generated at: 2015-07-07 00:48:24 -! KGEN version: 0.4.13 - - - - MODULE rrsw_vsn - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw version information - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jul2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - !hnamrtm :character: - !hnamini :character: - !hnamcld :character: - !hnamclc :character: - !hnamrft :character: - !hnamspv :character: - !hnamspc :character: - !hnamset :character: - !hnamtau :character: - !hnamvqd :character: - !hnamatm :character: - !hnamutl :character: - !hnamext :character: - !hnamkg :character: - ! - ! hvrrtm :character: - ! hvrini :character: - ! hvrcld :character: - ! hvrclc :character: - ! hvrrft :character: - ! hvrspv :character: - ! hvrspc :character: - ! hvrset :character: - ! hvrtau :character: - ! hvrvqd :character: - ! hvratm :character: - ! hvrutl :character: - ! hvrext :character: - ! hvrkg :character: - !------------------------------------------------------------------ - CHARACTER(LEN=18) :: hvrclc - CHARACTER(LEN=18) :: hvrtau - CHARACTER(LEN=18) :: hvrrft - PUBLIC kgen_read_externs_rrsw_vsn - CONTAINS - - ! write subroutines - ! No subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_vsn(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) hvrclc - READ(UNIT=kgen_unit) hvrtau - READ(UNIT=kgen_unit) hvrrft - END SUBROUTINE kgen_read_externs_rrsw_vsn - - END MODULE rrsw_vsn diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrsw_wvn.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrsw_wvn.f90 deleted file mode 100644 index a499da7118..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrsw_wvn.f90 +++ /dev/null @@ -1,68 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_wvn.f90 -! Generated at: 2015-07-07 00:48:24 -! KGEN version: 0.4.13 - - - - MODULE rrsw_wvn - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE parrrsw, ONLY: ngptsw - USE parrrsw, ONLY: jpb1 - USE parrrsw, ONLY: jpb2 - USE parrrsw, ONLY: nbndsw - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw spectral information - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jul2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! ng : integer: Number of original g-intervals in each spectral band - ! nspa : integer: - ! nspb : integer: - !wavenum1: real : Spectral band lower boundary in wavenumbers - !wavenum2: real : Spectral band upper boundary in wavenumbers - ! delwave: real : Spectral band width in wavenumbers - ! - ! ngc : integer: The number of new g-intervals in each band - ! ngs : integer: The cumulative sum of new g-intervals for each band - ! ngm : integer: The index of each new g-interval relative to the - ! original 16 g-intervals in each band - ! ngn : integer: The number of original g-intervals that are - ! combined to make each new g-intervals in each band - ! ngb : integer: The band index for each new g-interval - ! wt : real : RRTM weights for the original 16 g-intervals - ! rwgt : real : Weights for combining original 16 g-intervals - ! (224 total) into reduced set of g-intervals - ! (112 total) - !------------------------------------------------------------------ - INTEGER :: nspa(jpb1:jpb2) - INTEGER :: nspb(jpb1:jpb2) - REAL(KIND=r8) :: wavenum2(jpb1:jpb2) - INTEGER :: ngc(nbndsw) - INTEGER :: ngs(nbndsw) - INTEGER :: ngb(ngptsw) - PUBLIC kgen_read_externs_rrsw_wvn - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_wvn(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) nspa - READ(UNIT=kgen_unit) nspb - READ(UNIT=kgen_unit) wavenum2 - READ(UNIT=kgen_unit) ngc - READ(UNIT=kgen_unit) ngs - READ(UNIT=kgen_unit) ngb - END SUBROUTINE kgen_read_externs_rrsw_wvn - - END MODULE rrsw_wvn diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrtmg_state.F90 b/test/ncar_kernels/PORT_sw_rad/src/rrtmg_state.F90 deleted file mode 100644 index 3cf7ae0229..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrtmg_state.F90 +++ /dev/null @@ -1,271 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_state.F90 -! Generated at: 2015-07-07 00:48:23 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_state - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - PRIVATE - PUBLIC rrtmg_state_t - PUBLIC num_rrtmg_levs - TYPE rrtmg_state_t - REAL(KIND=r8), allocatable :: h2ovmr(:,:) ! h2o volume mixing ratio - REAL(KIND=r8), allocatable :: o3vmr(:,:) ! o3 volume mixing ratio - REAL(KIND=r8), allocatable :: co2vmr(:,:) ! co2 volume mixing ratio - REAL(KIND=r8), allocatable :: ch4vmr(:,:) ! ch4 volume mixing ratio - REAL(KIND=r8), allocatable :: o2vmr(:,:) ! o2 volume mixing ratio - REAL(KIND=r8), allocatable :: n2ovmr(:,:) ! n2o volume mixing ratio - REAL(KIND=r8), allocatable :: cfc11vmr(:,:) ! cfc11 volume mixing ratio - REAL(KIND=r8), allocatable :: cfc12vmr(:,:) ! cfc12 volume mixing ratio - REAL(KIND=r8), allocatable :: cfc22vmr(:,:) ! cfc22 volume mixing ratio - REAL(KIND=r8), allocatable :: ccl4vmr(:,:) ! ccl4 volume mixing ratio - REAL(KIND=r8), allocatable :: pmidmb(:,:) ! Level pressure (hPa) - REAL(KIND=r8), allocatable :: pintmb(:,:) ! Model interface pressure (hPa) - REAL(KIND=r8), allocatable :: tlay(:,:) ! mid point temperature - REAL(KIND=r8), allocatable :: tlev(:,:) ! interface temperature - END TYPE rrtmg_state_t - INTEGER :: num_rrtmg_levs ! number of pressure levels greate than 1.e-4_r8 mbar - ! Molecular weight of dry air / water vapor - ! Molecular weight of dry air / carbon dioxide - ! Molecular weight of dry air / ozone - ! Molecular weight of dry air / methane - ! Molecular weight of dry air / nitrous oxide - ! Molecular weight of dry air / oxygen - ! Molecular weight of dry air / CFC11 - ! Molecular weight of dry air / CFC12 - PUBLIC kgen_read_externs_rrtmg_state - - ! read interface - PUBLIC kgen_read - INTERFACE kgen_read - MODULE PROCEDURE kgen_read_rrtmg_state_t - END INTERFACE kgen_read - - PUBLIC kgen_verify - INTERFACE kgen_verify - MODULE PROCEDURE kgen_verify_rrtmg_state_t - END INTERFACE kgen_verify - - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_r8_dim2_alloc(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim2_alloc - - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrtmg_state(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) num_rrtmg_levs - END SUBROUTINE kgen_read_externs_rrtmg_state - - SUBROUTINE kgen_read_rrtmg_state_t(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - TYPE(rrtmg_state_t), INTENT(out) :: var - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%h2ovmr, kgen_unit, printvar=printvar//"%h2ovmr") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%h2ovmr, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%o3vmr, kgen_unit, printvar=printvar//"%o3vmr") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%o3vmr, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%co2vmr, kgen_unit, printvar=printvar//"%co2vmr") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%co2vmr, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%ch4vmr, kgen_unit, printvar=printvar//"%ch4vmr") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%ch4vmr, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%o2vmr, kgen_unit, printvar=printvar//"%o2vmr") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%o2vmr, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%n2ovmr, kgen_unit, printvar=printvar//"%n2ovmr") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%n2ovmr, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%cfc11vmr, kgen_unit, printvar=printvar//"%cfc11vmr") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%cfc11vmr, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%cfc12vmr, kgen_unit, printvar=printvar//"%cfc12vmr") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%cfc12vmr, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%cfc22vmr, kgen_unit, printvar=printvar//"%cfc22vmr") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%cfc22vmr, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%ccl4vmr, kgen_unit, printvar=printvar//"%ccl4vmr") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%ccl4vmr, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%pmidmb, kgen_unit, printvar=printvar//"%pmidmb") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%pmidmb, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%pintmb, kgen_unit, printvar=printvar//"%pintmb") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%pintmb, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%tlay, kgen_unit, printvar=printvar//"%tlay") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%tlay, kgen_unit) - END IF - IF ( PRESENT(printvar) ) THEN - CALL kgen_read_real_r8_dim2_alloc(var%tlev, kgen_unit, printvar=printvar//"%tlev") - ELSE - CALL kgen_read_real_r8_dim2_alloc(var%tlev, kgen_unit) - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_rrtmg_state_t(varname, check_status, var, ref_var) - CHARACTER(*), INTENT(IN) :: varname - TYPE(check_t), INTENT(INOUT) :: check_status - TYPE(check_t) :: dtype_check_status - TYPE(rrtmg_state_t), INTENT(IN) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - CALL kgen_init_check(dtype_check_status) - CALL kgen_verify_real_r8_dim2_alloc("h2ovmr", dtype_check_status, var%h2ovmr, ref_var%h2ovmr) - CALL kgen_verify_real_r8_dim2_alloc("o3vmr", dtype_check_status, var%o3vmr, ref_var%o3vmr) - CALL kgen_verify_real_r8_dim2_alloc("co2vmr", dtype_check_status, var%co2vmr, ref_var%co2vmr) - CALL kgen_verify_real_r8_dim2_alloc("ch4vmr", dtype_check_status, var%ch4vmr, ref_var%ch4vmr) - CALL kgen_verify_real_r8_dim2_alloc("o2vmr", dtype_check_status, var%o2vmr, ref_var%o2vmr) - CALL kgen_verify_real_r8_dim2_alloc("n2ovmr", dtype_check_status, var%n2ovmr, ref_var%n2ovmr) - CALL kgen_verify_real_r8_dim2_alloc("cfc11vmr", dtype_check_status, var%cfc11vmr, ref_var%cfc11vmr) - CALL kgen_verify_real_r8_dim2_alloc("cfc12vmr", dtype_check_status, var%cfc12vmr, ref_var%cfc12vmr) - CALL kgen_verify_real_r8_dim2_alloc("cfc22vmr", dtype_check_status, var%cfc22vmr, ref_var%cfc22vmr) - CALL kgen_verify_real_r8_dim2_alloc("ccl4vmr", dtype_check_status, var%ccl4vmr, ref_var%ccl4vmr) - CALL kgen_verify_real_r8_dim2_alloc("pmidmb", dtype_check_status, var%pmidmb, ref_var%pmidmb) - CALL kgen_verify_real_r8_dim2_alloc("pintmb", dtype_check_status, var%pintmb, ref_var%pintmb) - CALL kgen_verify_real_r8_dim2_alloc("tlay", dtype_check_status, var%tlay, ref_var%tlay) - CALL kgen_verify_real_r8_dim2_alloc("tlev", dtype_check_status, var%tlev, ref_var%tlev) - IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - ELSE IF ( dtype_check_status%numFatal > 0 ) THEN - check_status%numFatal = check_status%numFatal + 1 - ELSE IF ( dtype_check_status%numWarning > 0 ) THEN - check_status%numWarning = check_status%numWarning + 1 - END IF - END SUBROUTINE - SUBROUTINE kgen_verify_real_r8_dim2_alloc( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:), ALLOCATABLE :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:) :: temp, temp2 - integer :: n - IF ( ALLOCATED(var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END IF - END SUBROUTINE kgen_verify_real_r8_dim2_alloc - - !-------------------------------------------------------------------------------- - ! sets the number of model levels RRTMG operates - !-------------------------------------------------------------------------------- - - !-------------------------------------------------------------------------------- - ! creates (alloacates) an rrtmg_state object - !-------------------------------------------------------------------------------- - - !-------------------------------------------------------------------------------- - ! updates the concentration fields - !-------------------------------------------------------------------------------- - - !-------------------------------------------------------------------------------- - ! de-allocates an rrtmg_state object - !-------------------------------------------------------------------------------- - - END MODULE rrtmg_state diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_cldprmc.F90 b/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_cldprmc.F90 deleted file mode 100644 index 30ee0243cb..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_cldprmc.F90 +++ /dev/null @@ -1,717 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_sw_cldprmc.f90 -! Generated at: 2015-07-07 00:48:24 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_sw_cldprmc - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! ------- Modules ------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE parrrsw, ONLY: ngptsw - USE rrsw_cld, ONLY: abari - USE rrsw_cld, ONLY: bbari - USE rrsw_cld, ONLY: dbari - USE rrsw_cld, ONLY: cbari - USE rrsw_cld, ONLY: ebari - USE rrsw_cld, ONLY: fbari - USE rrsw_cld, ONLY: extice2 - USE rrsw_cld, ONLY: ssaice2 - USE rrsw_cld, ONLY: asyice2 - USE rrsw_cld, ONLY: extice3 - USE rrsw_cld, ONLY: ssaice3 - USE rrsw_cld, ONLY: asyice3 - USE rrsw_cld, ONLY: fdlice3 - USE rrsw_cld, ONLY: extliq1 - USE rrsw_cld, ONLY: ssaliq1 - USE rrsw_cld, ONLY: asyliq1 - USE rrsw_wvn, ONLY: ngb - USE rrsw_wvn, ONLY: wavenum2 - USE rrsw_vsn, ONLY: hvrclc - IMPLICIT NONE - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - ! ---------------------------------------------------------------------------- -#ifdef OLD_CLDPRMC_SW - SUBROUTINE cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, taormc, taucmc, & - ssacmc, asmcmc, fsfcmc) - ! ---------------------------------------------------------------------------- - ! Purpose: Compute the cloud optical properties for each cloudy layer - ! and g-point interval for use by the McICA method. - ! Note: Only inflag = 0 and inflag=2/liqflag=1/iceflag=2,3 are available; - ! (Hu & Stamnes, Key, and Fu) are implemented. - ! ------- Input ------- - INTEGER, intent(in) :: nlayers ! total number of layers - INTEGER, intent(in) :: inflag ! see definitions - INTEGER, intent(in) :: iceflag ! see definitions - INTEGER, intent(in) :: liqflag ! see definitions - REAL(KIND=r8), intent(in) :: cldfmc(:,:) ! cloud fraction [mcica] - ! Dimensions: (ngptsw,nlayers) - REAL(KIND=r8), intent(in) :: ciwpmc(:,:) ! cloud ice water path [mcica] - ! Dimensions: (ngptsw,nlayers) - REAL(KIND=r8), intent(in) :: clwpmc(:,:) ! cloud liquid water path [mcica] - ! Dimensions: (ngptsw,nlayers) - REAL(KIND=r8), intent(in) :: relqmc(:) ! cloud liquid particle effective radius (microns) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: reicmc(:) ! cloud ice particle effective radius (microns) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: dgesmc(:) ! cloud ice particle generalized effective size (microns) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: fsfcmc(:,:) ! cloud forward scattering fraction - ! Dimensions: (ngptsw,nlayers) - ! ------- Output ------- - REAL(KIND=r8), intent(inout) :: taucmc(:,:) ! cloud optical depth (delta scaled) - ! Dimensions: (ngptsw,nlayers) - REAL(KIND=r8), intent(inout) :: ssacmc(:,:) ! single scattering albedo (delta scaled) - ! Dimensions: (ngptsw,nlayers) - REAL(KIND=r8), intent(inout) :: asmcmc(:,:) ! asymmetry parameter (delta scaled) - ! Dimensions: (ngptsw,nlayers) - REAL(KIND=r8), intent(out) :: taormc(:,:) ! cloud optical depth (non-delta scaled) - ! Dimensions: (ngptsw,nlayers) - ! ------- Local ------- - ! integer :: ncbands - INTEGER :: lay, index - INTEGER :: ig - INTEGER :: ib - INTEGER :: icx - INTEGER :: istr - REAL(KIND=r8), parameter :: eps = 1.e-06_r8 ! epsilon - REAL(KIND=r8), parameter :: cldmin = 1.e-80_r8 ! minimum value for cloud quantities - REAL(KIND=r8) :: cwp ! total cloud water path - REAL(KIND=r8) :: radliq ! cloud liquid droplet radius (microns) - REAL(KIND=r8) :: radice ! cloud ice effective radius (microns) - REAL(KIND=r8) :: dgeice ! cloud ice generalized effective size (microns) - REAL(KIND=r8) :: factor - REAL(KIND=r8) :: fint - REAL(KIND=r8) :: taucldorig_a - REAL(KIND=r8) :: ffp - REAL(KIND=r8) :: ffp1 - REAL(KIND=r8) :: ffpssa - REAL(KIND=r8) :: ssacloud_a - REAL(KIND=r8) :: taucloud_a - REAL(KIND=r8) :: tauliqorig - REAL(KIND=r8) :: tauiceorig - REAL(KIND=r8) :: ssaliq - REAL(KIND=r8) :: tauliq - REAL(KIND=r8) :: ssaice - REAL(KIND=r8) :: tauice - REAL(KIND=r8) :: scatliq - REAL(KIND=r8) :: scatice - REAL(KIND=r8) :: fdelta(ngptsw) - REAL(KIND=r8) :: extcoice(ngptsw) - REAL(KIND=r8) :: gice(ngptsw) - REAL(KIND=r8) :: ssacoice(ngptsw) - REAL(KIND=r8) :: forwice(ngptsw) - REAL(KIND=r8) :: extcoliq(ngptsw) - REAL(KIND=r8) :: gliq(ngptsw) - REAL(KIND=r8) :: ssacoliq(ngptsw) - REAL(KIND=r8) :: forwliq(ngptsw) - ! Initialize - hvrclc = '$Revision: 1.4 $' - ! Initialize - ! Some of these initializations are done in rrtmg_sw.f90. - do lay = 1, nlayers - do ig = 1, ngptsw - taormc(ig,lay) = taucmc(ig,lay) - ! taucmc(ig,lay) = 0.0_r8 - ! ssacmc(ig,lay) = 1.0_r8 - ! asmcmc(ig,lay) = 0.0_r8 - enddo - enddo - ! Main layer loop - do lay = 1, nlayers - ! Main g-point interval loop - do ig = 1, ngptsw - cwp = ciwpmc(ig,lay) + clwpmc(ig,lay) - if (cldfmc(ig,lay) .ge. cldmin .and. & - (cwp .ge. cldmin .or. taucmc(ig,lay) .ge. cldmin)) then - ! (inflag=0): Cloud optical properties input directly - if (inflag .eq. 0) then - ! Cloud optical properties already defined in taucmc, ssacmc, asmcmc are unscaled; - ! Apply delta-M scaling here (using Henyey-Greenstein approximation) - taucldorig_a = taucmc(ig,lay) - ffp = fsfcmc(ig,lay) - ffp1 = 1.0_r8 - ffp - ffpssa = 1.0_r8 - ffp * ssacmc(ig,lay) - ssacloud_a = ffp1 * ssacmc(ig,lay) / ffpssa - taucloud_a = ffpssa * taucldorig_a - taormc(ig,lay) = taucldorig_a - ssacmc(ig,lay) = ssacloud_a - taucmc(ig,lay) = taucloud_a - asmcmc(ig,lay) = (asmcmc(ig,lay) - ffp) / (ffp1) - elseif (inflag .eq. 1) then - stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA' - ! (inflag=2): Separate treatement of ice clouds and water clouds. - elseif (inflag .eq. 2) then - radice = reicmc(lay) - ! Calculation of absorption coefficients due to ice clouds. - if (ciwpmc(ig,lay) .eq. 0.0) then - extcoice(ig) = 0.0_r8 - ssacoice(ig) = 0.0_r8 - gice(ig) = 0.0_r8 - forwice(ig) = 0.0_r8 - ! (iceflag = 1): - ! Note: This option uses Ebert and Curry approach for all particle sizes similar to - ! CAM3 implementation, though this is somewhat unjustified for large ice particles - elseif (iceflag .eq. 1) then - ib = ngb(ig) - if (wavenum2(ib) .gt. 1.43e04_r8) then - icx = 1 - elseif (wavenum2(ib) .gt. 7.7e03_r8) then - icx = 2 - elseif (wavenum2(ib) .gt. 5.3e03_r8) then - icx = 3 - elseif (wavenum2(ib) .gt. 4.0e03_r8) then - icx = 4 - elseif (wavenum2(ib) .ge. 2.5e03_r8) then - icx = 5 - endif - extcoice(ig) = (abari(icx) + bbari(icx)/radice) - ssacoice(ig) = 1._r8 - cbari(icx) - dbari(icx) * radice - gice(ig) = ebari(icx) + fbari(icx) * radice - ! Check to ensure upper limit of gice is within physical limits for large particles - if (gice(ig).ge.1._r8) gice(ig) = 1._r8 - eps - forwice(ig) = gice(ig)*gice(ig) - ! Check to ensure all calculated quantities are within physical limits. - if (extcoice(ig) .lt. 0.0_r8) stop 'ICE EXTINCTION LESS THAN 0.0' - if (ssacoice(ig) .gt. 1.0_r8) stop 'ICE SSA GRTR THAN 1.0' - if (ssacoice(ig) .lt. 0.0_r8) stop 'ICE SSA LESS THAN 0.0' - if (gice(ig) .gt. 1.0_r8) stop 'ICE ASYM GRTR THAN 1.0' - if (gice(ig) .lt. 0.0_r8) stop 'ICE ASYM LESS THAN 0.0' - ! For iceflag=2 option, combine with iceflag=0 option to handle large particle sizes. - ! Use iceflag=2 option for ice particle effective radii from 5.0 to 131.0 microns - ! and use iceflag=0 option for ice particles greater than 131.0 microns. - ! *** NOTE: Transition between two methods has not been smoothed. - elseif (iceflag .eq. 2) then - if (radice .lt. 5.0_r8) stop 'ICE RADIUS OUT OF BOUNDS' - if (radice .ge. 5.0_r8 .and. radice .le. 131._r8) then - factor = (radice - 2._r8)/3._r8 - index = int(factor) - if (index .eq. 43) index = 42 - fint = factor - float(index) - ib = ngb(ig) - extcoice(ig) = extice2(index,ib) + fint * & - (extice2(index+1,ib) - extice2(index,ib)) - ssacoice(ig) = ssaice2(index,ib) + fint * & - (ssaice2(index+1,ib) - ssaice2(index,ib)) - gice(ig) = asyice2(index,ib) + fint * & - (asyice2(index+1,ib) - asyice2(index,ib)) - forwice(ig) = gice(ig)*gice(ig) - ! Check to ensure all calculated quantities are within physical limits. - if (extcoice(ig) .lt. 0.0_r8) stop 'ICE EXTINCTION LESS THAN 0.0' - if (ssacoice(ig) .gt. 1.0_r8) stop 'ICE SSA GRTR THAN 1.0' - if (ssacoice(ig) .lt. 0.0_r8) stop 'ICE SSA LESS THAN 0.0' - if (gice(ig) .gt. 1.0_r8) stop 'ICE ASYM GRTR THAN 1.0' - if (gice(ig) .lt. 0.0_r8) stop 'ICE ASYM LESS THAN 0.0' - elseif (radice .gt. 131._r8) then - ib = ngb(ig) - if (wavenum2(ib) .gt. 1.43e04_r8) then - icx = 1 - elseif (wavenum2(ib) .gt. 7.7e03_r8) then - icx = 2 - elseif (wavenum2(ib) .gt. 5.3e03_r8) then - icx = 3 - elseif (wavenum2(ib) .gt. 4.0e03_r8) then - icx = 4 - elseif (wavenum2(ib) .ge. 2.5e03_r8) then - icx = 5 - endif - extcoice(ig) = (abari(icx) + bbari(icx)/radice) - ssacoice(ig) = 1._r8 - cbari(icx) - dbari(icx) * radice - gice(ig) = ebari(icx) + fbari(icx) * radice - ! Check to ensure upper limit of gice is within physical limits for large particles - if (gice(ig).ge.1.0_r8) gice(ig) = 1.0_r8-eps - forwice(ig) = gice(ig)*gice(ig) - ! Check to ensure all calculated quantities are within physical limits. - if (extcoice(ig) .lt. 0.0_r8) stop 'ICE EXTINCTION LESS THAN 0.0' - if (ssacoice(ig) .gt. 1.0_r8) stop 'ICE SSA GRTR THAN 1.0' - if (ssacoice(ig) .lt. 0.0_r8) stop 'ICE SSA LESS THAN 0.0' - if (gice(ig) .gt. 1.0_r8) stop 'ICE ASYM GRTR THAN 1.0' - if (gice(ig) .lt. 0.0_r8) stop 'ICE ASYM LESS THAN 0.0' - endif - ! For iceflag=3 option, combine with iceflag=0 option to handle large particle sizes - ! Use iceflag=3 option for ice particle effective radii from 3.2 to 91.0 microns - ! (generalized effective size, dge, from 5 to 140 microns), and use iceflag=0 option - ! for ice particle effective radii greater than 91.0 microns (dge = 140 microns). - ! *** NOTE: Fu parameterization requires particle size in generalized effective size. - ! *** NOTE: Transition between two methods has not been smoothed. - elseif (iceflag .eq. 3) then - dgeice = dgesmc(lay) - if (dgeice .lt. 5.0_r8) stop 'ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' - if (dgeice .ge. 5.0_r8 .and. dgeice .le. 140._r8) then - factor = (dgeice - 2._r8)/3._r8 - index = int(factor) - if (index .eq. 46) index = 45 - fint = factor - float(index) - ib = ngb(ig) - extcoice(ig) = extice3(index,ib) + fint * & - (extice3(index+1,ib) - extice3(index,ib)) - ssacoice(ig) = ssaice3(index,ib) + fint * & - (ssaice3(index+1,ib) - ssaice3(index,ib)) - gice(ig) = asyice3(index,ib) + fint * & - (asyice3(index+1,ib) - asyice3(index,ib)) - fdelta(ig) = fdlice3(index,ib) + fint * & - (fdlice3(index+1,ib) - fdlice3(index,ib)) - if (fdelta(ig) .lt. 0.0_r8) stop 'FDELTA LESS THAN 0.0' - if (fdelta(ig) .gt. 1.0_r8) stop 'FDELTA GT THAN 1.0' - forwice(ig) = fdelta(ig) + 0.5_r8 / ssacoice(ig) - ! See Fu 1996 p. 2067 - if (forwice(ig) .gt. gice(ig)) forwice(ig) = gice(ig) - ! Check to ensure all calculated quantities are within physical limits. - if (extcoice(ig) .lt. 0.0_r8) stop 'ICE EXTINCTION LESS THAN 0.0' - if (ssacoice(ig) .gt. 1.0_r8) stop 'ICE SSA GRTR THAN 1.0' - if (ssacoice(ig) .lt. 0.0_r8) stop 'ICE SSA LESS THAN 0.0' - if (gice(ig) .gt. 1.0_r8) stop 'ICE ASYM GRTR THAN 1.0' - if (gice(ig) .lt. 0.0_r8) stop 'ICE ASYM LESS THAN 0.0' - elseif (dgeice .gt. 140._r8) then - ib = ngb(ig) - if (wavenum2(ib) .gt. 1.43e04_r8) then - icx = 1 - elseif (wavenum2(ib) .gt. 7.7e03_r8) then - icx = 2 - elseif (wavenum2(ib) .gt. 5.3e03_r8) then - icx = 3 - elseif (wavenum2(ib) .gt. 4.0e03_r8) then - icx = 4 - elseif (wavenum2(ib) .ge. 2.5e03_r8) then - icx = 5 - endif - extcoice(ig) = (abari(icx) + bbari(icx)/radice) - ssacoice(ig) = 1._r8 - cbari(icx) - dbari(icx) * radice - gice(ig) = ebari(icx) + fbari(icx) * radice - ! Check to ensure upper limit of gice is within physical limits for large particles - if (gice(ig).ge.1._r8) gice(ig) = 1._r8 - eps - forwice(ig) = gice(ig)*gice(ig) - ! Check to ensure all calculated quantities are within physical limits. - if (extcoice(ig) .lt. 0.0_r8) stop 'ICE EXTINCTION LESS THAN 0.0' - if (ssacoice(ig) .gt. 1.0_r8) stop 'ICE SSA GRTR THAN 1.0' - if (ssacoice(ig) .lt. 0.0_r8) stop 'ICE SSA LESS THAN 0.0' - if (gice(ig) .gt. 1.0_r8) stop 'ICE ASYM GRTR THAN 1.0' - if (gice(ig) .lt. 0.0_r8) stop 'ICE ASYM LESS THAN 0.0' - endif - endif - ! Calculation of absorption coefficients due to water clouds. - if (clwpmc(ig,lay) .eq. 0.0_r8) then - extcoliq(ig) = 0.0_r8 - ssacoliq(ig) = 0.0_r8 - gliq(ig) = 0.0_r8 - forwliq(ig) = 0.0_r8 - elseif (liqflag .eq. 1) then - radliq = relqmc(lay) - if (radliq .lt. 1.5_r8 .or. radliq .gt. 60._r8) stop & - 'liquid effective radius out of bounds' - index = int(radliq - 1.5_r8) - if (index .eq. 0) index = 1 - if (index .eq. 58) index = 57 - fint = radliq - 1.5_r8 - float(index) - ib = ngb(ig) - extcoliq(ig) = extliq1(index,ib) + fint * & - (extliq1(index+1,ib) - extliq1(index,ib)) - ssacoliq(ig) = ssaliq1(index,ib) + fint * & - (ssaliq1(index+1,ib) - ssaliq1(index,ib)) - if (fint .lt. 0._r8 .and. ssacoliq(ig) .gt. 1._r8) & - ssacoliq(ig) = ssaliq1(index,ib) - gliq(ig) = asyliq1(index,ib) + fint * & - (asyliq1(index+1,ib) - asyliq1(index,ib)) - forwliq(ig) = gliq(ig)*gliq(ig) - ! Check to ensure all calculated quantities are within physical limits. - if (extcoliq(ig) .lt. 0.0_r8) stop 'LIQUID EXTINCTION LESS THAN 0.0' - if (ssacoliq(ig) .gt. 1.0_r8) stop 'LIQUID SSA GRTR THAN 1.0' - if (ssacoliq(ig) .lt. 0.0_r8) stop 'LIQUID SSA LESS THAN 0.0' - if (gliq(ig) .gt. 1.0_r8) stop 'LIQUID ASYM GRTR THAN 1.0' - if (gliq(ig) .lt. 0.0_r8) stop 'LIQUID ASYM LESS THAN 0.0' - endif - tauliqorig = clwpmc(ig,lay) * extcoliq(ig) - tauiceorig = ciwpmc(ig,lay) * extcoice(ig) - taormc(ig,lay) = tauliqorig + tauiceorig - ssaliq = ssacoliq(ig) * (1._r8 - forwliq(ig)) / & - (1._r8 - forwliq(ig) * ssacoliq(ig)) - tauliq = (1._r8 - forwliq(ig) * ssacoliq(ig)) * tauliqorig - ssaice = ssacoice(ig) * (1._r8 - forwice(ig)) / & - (1._r8 - forwice(ig) * ssacoice(ig)) - tauice = (1._r8 - forwice(ig) * ssacoice(ig)) * tauiceorig - scatliq = ssaliq * tauliq - scatice = ssaice * tauice - taucmc(ig,lay) = tauliq + tauice - ! Ensure non-zero taucmc and scatice - if(taucmc(ig,lay).eq.0.) taucmc(ig,lay) = cldmin - if(scatice.eq.0.) scatice = cldmin - ssacmc(ig,lay) = (scatliq + scatice) / taucmc(ig,lay) - if (iceflag .eq. 3) then - ! In accordance with the 1996 Fu paper, equation A.3, - ! the moments for ice were calculated depending on whether using spheres - ! or hexagonal ice crystals. - ! Set asymetry parameter to first moment (istr=1) - istr = 1 - asmcmc(ig,lay) = (1.0_r8/(scatliq+scatice))* & - (scatliq*(gliq(ig)**istr - forwliq(ig)) / & - (1.0_r8 - forwliq(ig)) + scatice * ((gice(ig)-forwice(ig))/ & - (1.0_r8 - forwice(ig)))**istr) - else - ! This code is the standard method for delta-m scaling. - ! Set asymetry parameter to first moment (istr=1) - istr = 1 - asmcmc(ig,lay) = (scatliq * & - (gliq(ig)**istr - forwliq(ig)) / & - (1.0_r8 - forwliq(ig)) + scatice * (gice(ig)**istr - forwice(ig)) / & - (1.0_r8 - forwice(ig)))/(scatliq + scatice) - endif - endif - endif - ! End g-point interval loop - enddo - ! End layer loop - enddo - END SUBROUTINE cldprmc_sw -#else - SUBROUTINE cldprmc_sw(ncol,nlayers, inflag, iceflag, liqflag, cldfmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, taormc, taucmc, & - ssacmc, asmcmc, fsfcmc) - ! ---------------------------------------------------------------------------- - ! Purpose: Compute the cloud optical properties for each cloudy layer - ! and g-point interval for use by the McICA method. - ! Note: Only inflag = 0 and inflag=2/liqflag=1/iceflag=2,3 are available; - ! (Hu & Stamnes, Key, and Fu) are implemented. - ! ------- Input ------- - INTEGER, intent(in) :: nlayers ! total number of layers - INTEGER, intent(in) :: ncol ! total number of layers - INTEGER, intent(in) :: inflag(:) ! see definitions - INTEGER, intent(in) :: iceflag(:) ! see definitions - INTEGER, intent(in) :: liqflag(:) ! see definitions - REAL(KIND=r8), intent(in) :: cldfmc(:,:,:) ! cloud fraction [mcica] - ! Dimensions: (ngptsw,nlayers) - REAL(KIND=r8), intent(in) :: ciwpmc(:,:,:) ! cloud ice water path [mcica] - ! Dimensions: (ngptsw,nlayers) - REAL(KIND=r8), intent(in) :: clwpmc(:,:,:) ! cloud liquid water path [mcica] - ! Dimensions: (ngptsw,nlayers) - REAL(KIND=r8), intent(in) :: relqmc(:,:) ! cloud liquid particle effective radius (microns) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: reicmc(:,:) ! cloud ice particle effective radius (microns) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: dgesmc(:,:) ! cloud ice particle generalized effective size (microns) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: fsfcmc(:,:,:) ! cloud forward scattering fraction - ! Dimensions: (ngptsw,nlayers) - ! ------- Output ------- - REAL(KIND=r8), intent(inout) :: taucmc(:,:,:) ! cloud optical depth (delta scaled) - ! Dimensions: (ngptsw,nlayers) - REAL(KIND=r8), intent(inout) :: ssacmc(:,:,:) ! single scattering albedo (delta scaled) - ! Dimensions: (ngptsw,nlayers) - REAL(KIND=r8), intent(inout) :: asmcmc(:,:,:) ! asymmetry parameter (delta scaled) - ! Dimensions: (ngptsw,nlayers) - REAL(KIND=r8), intent(out) :: taormc(:,:) ! cloud optical depth (non-delta scaled) - ! Dimensions: (ngptsw,nlayers) - ! ------- Local ------- - ! integer :: ncbands - INTEGER :: lay, index - INTEGER :: ig - INTEGER :: ib - INTEGER :: icx - INTEGER :: istr,iplon - REAL(KIND=r8), parameter :: eps = 1.e-06_r8 ! epsilon - REAL(KIND=r8), parameter :: cldmin = 1.e-80_r8 ! minimum value for cloud quantities - REAL(KIND=r8) :: cwp ! total cloud water path - REAL(KIND=r8) :: radliq ! cloud liquid droplet radius (microns) - REAL(KIND=r8) :: radice ! cloud ice effective radius (microns) - REAL(KIND=r8) :: dgeice ! cloud ice generalized effective size (microns) - REAL(KIND=r8) :: factor - REAL(KIND=r8) :: fint - REAL(KIND=r8) :: taucldorig_a - REAL(KIND=r8) :: ffp - REAL(KIND=r8) :: ffp1 - REAL(KIND=r8) :: ffpssa - REAL(KIND=r8) :: ssacloud_a - REAL(KIND=r8) :: taucloud_a - REAL(KIND=r8) :: tauliqorig - REAL(KIND=r8) :: tauiceorig - REAL(KIND=r8) :: ssaliq - REAL(KIND=r8) :: tauliq - REAL(KIND=r8) :: ssaice - REAL(KIND=r8) :: tauice - REAL(KIND=r8) :: scatliq - REAL(KIND=r8) :: scatice - REAL(KIND=r8) :: fdelta(ngptsw) - REAL(KIND=r8) :: extcoice(ngptsw) - REAL(KIND=r8) :: gice(ngptsw) - REAL(KIND=r8) :: ssacoice(ngptsw) - REAL(KIND=r8) :: forwice(ngptsw) - REAL(KIND=r8) :: extcoliq(ngptsw) - REAL(KIND=r8) :: gliq(ngptsw) - REAL(KIND=r8) :: ssacoliq(ngptsw) - REAL(KIND=r8) :: forwliq(ngptsw) - ! Initialize - hvrclc = '$Revision: 1.4 $' - ! Initialize - ! Some of these initializations are done in rrtmg_sw.f90. - do iplon =1,ncol - do lay = 1, nlayers - do ig = 1, ngptsw - taormc(ig,lay) = taucmc(iplon,ig,lay) - ! taucmc(ig,lay) = 0.0_r8 - ! ssacmc(ig,lay) = 1.0_r8 - ! asmcmc(ig,lay) = 0.0_r8 - enddo - enddo - ! Main layer loop - do lay = 1, nlayers - ! Main g-point interval loop - do ig = 1, ngptsw - cwp = ciwpmc(iplon,ig,lay) + clwpmc(iplon,ig,lay) - if (cldfmc(iplon,ig,lay) .ge. cldmin .and. & - (cwp .ge. cldmin .or. taucmc(iplon,ig,lay) .ge. cldmin)) then - ! (inflag=0): Cloud optical properties input directly - if (inflag(iplon) .eq. 0) then - ! Cloud optical properties already defined in taucmc, ssacmc, asmcmc are unscaled; - ! Apply delta-M scaling here (using Henyey-Greenstein approximation) - taucldorig_a = taucmc(iplon,ig,lay) - ffp = fsfcmc(iplon,ig,lay) - ffp1 = 1.0_r8 - ffp - ffpssa = 1.0_r8 - ffp * ssacmc(iplon,ig,lay) - ssacloud_a = ffp1 * ssacmc(iplon,ig,lay) / ffpssa - taucloud_a = ffpssa * taucldorig_a - taormc(ig,lay) = taucldorig_a - ssacmc(iplon,ig,lay) = ssacloud_a - taucmc(iplon,ig,lay) = taucloud_a - asmcmc(iplon,ig,lay) = (asmcmc(iplon,ig,lay) - ffp) / (ffp1) - elseif (inflag(iplon) .eq. 1) then - stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA' - ! (inflag=2): Separate treatement of ice clouds and water clouds. - elseif (inflag(iplon) .eq. 2) then - radice = reicmc(iplon,lay) - ! Calculation of absorption coefficients due to ice clouds. - if (ciwpmc(iplon,ig,lay) .eq. 0.0) then - extcoice(ig) = 0.0_r8 - ssacoice(ig) = 0.0_r8 - gice(ig) = 0.0_r8 - forwice(ig) = 0.0_r8 - ! (iceflag = 1): - ! Note: This option uses Ebert and Curry approach for all particle sizes similar to - ! CAM3 implementation, though this is somewhat unjustified for large ice particles - elseif (iceflag(iplon) .eq. 1) then - ib = ngb(ig) - if (wavenum2(ib) .gt. 1.43e04_r8) then - icx = 1 - elseif (wavenum2(ib) .gt. 7.7e03_r8) then - icx = 2 - elseif (wavenum2(ib) .gt. 5.3e03_r8) then - icx = 3 - elseif (wavenum2(ib) .gt. 4.0e03_r8) then - icx = 4 - elseif (wavenum2(ib) .ge. 2.5e03_r8) then - icx = 5 - endif - extcoice(ig) = (abari(icx) + bbari(icx)/radice) - ssacoice(ig) = 1._r8 - cbari(icx) - dbari(icx) * radice - gice(ig) = ebari(icx) + fbari(icx) * radice - ! Check to ensure upper limit of gice is within physical limits for large particles - if (gice(ig).ge.1._r8) gice(ig) = 1._r8 - eps - forwice(ig) = gice(ig)*gice(ig) - ! Check to ensure all calculated quantities are within physical limits. - if (extcoice(ig) .lt. 0.0_r8) stop 'ICE EXTINCTION LESS THAN 0.0' - if (ssacoice(ig) .gt. 1.0_r8) stop 'ICE SSA GRTR THAN 1.0' - if (ssacoice(ig) .lt. 0.0_r8) stop 'ICE SSA LESS THAN 0.0' - if (gice(ig) .gt. 1.0_r8) stop 'ICE ASYM GRTR THAN 1.0' - if (gice(ig) .lt. 0.0_r8) stop 'ICE ASYM LESS THAN 0.0' - ! For iceflag=2 option, combine with iceflag=0 option to handle large particle sizes. - ! Use iceflag=2 option for ice particle effective radii from 5.0 to 131.0 microns - ! and use iceflag=0 option for ice particles greater than 131.0 microns. - ! *** NOTE: Transition between two methods has not been smoothed. - elseif (iceflag(iplon) .eq. 2) then - if (radice .lt. 5.0_r8) stop 'ICE RADIUS OUT OF BOUNDS' - if (radice .ge. 5.0_r8 .and. radice .le. 131._r8) then - factor = (radice - 2._r8)/3._r8 - index = int(factor) - if (index .eq. 43) index = 42 - fint = factor - float(index) - ib = ngb(ig) - extcoice(ig) = extice2(index,ib) + fint * & - (extice2(index+1,ib) - extice2(index,ib)) - ssacoice(ig) = ssaice2(index,ib) + fint * & - (ssaice2(index+1,ib) - ssaice2(index,ib)) - gice(ig) = asyice2(index,ib) + fint * & - (asyice2(index+1,ib) - asyice2(index,ib)) - forwice(ig) = gice(ig)*gice(ig) - ! Check to ensure all calculated quantities are within physical limits. - if (extcoice(ig) .lt. 0.0_r8) stop 'ICE EXTINCTION LESS THAN 0.0' - if (ssacoice(ig) .gt. 1.0_r8) stop 'ICE SSA GRTR THAN 1.0' - if (ssacoice(ig) .lt. 0.0_r8) stop 'ICE SSA LESS THAN 0.0' - if (gice(ig) .gt. 1.0_r8) stop 'ICE ASYM GRTR THAN 1.0' - if (gice(ig) .lt. 0.0_r8) stop 'ICE ASYM LESS THAN 0.0' - elseif (radice .gt. 131._r8) then - ib = ngb(ig) - if (wavenum2(ib) .gt. 1.43e04_r8) then - icx = 1 - elseif (wavenum2(ib) .gt. 7.7e03_r8) then - icx = 2 - elseif (wavenum2(ib) .gt. 5.3e03_r8) then - icx = 3 - elseif (wavenum2(ib) .gt. 4.0e03_r8) then - icx = 4 - elseif (wavenum2(ib) .ge. 2.5e03_r8) then - icx = 5 - endif - extcoice(ig) = (abari(icx) + bbari(icx)/radice) - ssacoice(ig) = 1._r8 - cbari(icx) - dbari(icx) * radice - gice(ig) = ebari(icx) + fbari(icx) * radice - ! Check to ensure upper limit of gice is within physical limits for large particles - if (gice(ig).ge.1.0_r8) gice(ig) = 1.0_r8-eps - forwice(ig) = gice(ig)*gice(ig) - ! Check to ensure all calculated quantities are within physical limits. - if (extcoice(ig) .lt. 0.0_r8) stop 'ICE EXTINCTION LESS THAN 0.0' - if (ssacoice(ig) .gt. 1.0_r8) stop 'ICE SSA GRTR THAN 1.0' - if (ssacoice(ig) .lt. 0.0_r8) stop 'ICE SSA LESS THAN 0.0' - if (gice(ig) .gt. 1.0_r8) stop 'ICE ASYM GRTR THAN 1.0' - if (gice(ig) .lt. 0.0_r8) stop 'ICE ASYM LESS THAN 0.0' - endif - ! For iceflag=3 option, combine with iceflag=0 option to handle large particle sizes - ! Use iceflag=3 option for ice particle effective radii from 3.2 to 91.0 microns - ! (generalized effective size, dge, from 5 to 140 microns), and use iceflag=0 option - ! for ice particle effective radii greater than 91.0 microns (dge = 140 microns). - ! *** NOTE: Fu parameterization requires particle size in generalized effective size. - ! *** NOTE: Transition between two methods has not been smoothed. - elseif (iceflag(iplon) .eq. 3) then - dgeice = dgesmc(iplon,lay) - if (dgeice .lt. 5.0_r8) stop 'ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' - if (dgeice .ge. 5.0_r8 .and. dgeice .le. 140._r8) then - factor = (dgeice - 2._r8)/3._r8 - index = int(factor) - if (index .eq. 46) index = 45 - fint = factor - float(index) - ib = ngb(ig) - extcoice(ig) = extice3(index,ib) + fint * & - (extice3(index+1,ib) - extice3(index,ib)) - ssacoice(ig) = ssaice3(index,ib) + fint * & - (ssaice3(index+1,ib) - ssaice3(index,ib)) - gice(ig) = asyice3(index,ib) + fint * & - (asyice3(index+1,ib) - asyice3(index,ib)) - fdelta(ig) = fdlice3(index,ib) + fint * & - (fdlice3(index+1,ib) - fdlice3(index,ib)) - if (fdelta(ig) .lt. 0.0_r8) stop 'FDELTA LESS THAN 0.0' - if (fdelta(ig) .gt. 1.0_r8) stop 'FDELTA GT THAN 1.0' - forwice(ig) = fdelta(ig) + 0.5_r8 / ssacoice(ig) - ! See Fu 1996 p. 2067 - if (forwice(ig) .gt. gice(ig)) forwice(ig) = gice(ig) - ! Check to ensure all calculated quantities are within physical limits. - if (extcoice(ig) .lt. 0.0_r8) stop 'ICE EXTINCTION LESS THAN 0.0' - if (ssacoice(ig) .gt. 1.0_r8) stop 'ICE SSA GRTR THAN 1.0' - if (ssacoice(ig) .lt. 0.0_r8) stop 'ICE SSA LESS THAN 0.0' - if (gice(ig) .gt. 1.0_r8) stop 'ICE ASYM GRTR THAN 1.0' - if (gice(ig) .lt. 0.0_r8) stop 'ICE ASYM LESS THAN 0.0' - elseif (dgeice .gt. 140._r8) then - ib = ngb(ig) - if (wavenum2(ib) .gt. 1.43e04_r8) then - icx = 1 - elseif (wavenum2(ib) .gt. 7.7e03_r8) then - icx = 2 - elseif (wavenum2(ib) .gt. 5.3e03_r8) then - icx = 3 - elseif (wavenum2(ib) .gt. 4.0e03_r8) then - icx = 4 - elseif (wavenum2(ib) .ge. 2.5e03_r8) then - icx = 5 - endif - extcoice(ig) = (abari(icx) + bbari(icx)/radice) - ssacoice(ig) = 1._r8 - cbari(icx) - dbari(icx) * radice - gice(ig) = ebari(icx) + fbari(icx) * radice - ! Check to ensure upper limit of gice is within physical limits for large particles - if (gice(ig).ge.1._r8) gice(ig) = 1._r8 - eps - forwice(ig) = gice(ig)*gice(ig) - ! Check to ensure all calculated quantities are within physical limits. - if (extcoice(ig) .lt. 0.0_r8) stop 'ICE EXTINCTION LESS THAN 0.0' - if (ssacoice(ig) .gt. 1.0_r8) stop 'ICE SSA GRTR THAN 1.0' - if (ssacoice(ig) .lt. 0.0_r8) stop 'ICE SSA LESS THAN 0.0' - if (gice(ig) .gt. 1.0_r8) stop 'ICE ASYM GRTR THAN 1.0' - if (gice(ig) .lt. 0.0_r8) stop 'ICE ASYM LESS THAN 0.0' - endif - endif - ! Calculation of absorption coefficients due to water clouds. - if (clwpmc(iplon,ig,lay) .eq. 0.0_r8) then - extcoliq(ig) = 0.0_r8 - ssacoliq(ig) = 0.0_r8 - gliq(ig) = 0.0_r8 - forwliq(ig) = 0.0_r8 - elseif (liqflag(iplon) .eq. 1) then - radliq = relqmc(iplon,lay) - if (radliq .lt. 1.5_r8 .or. radliq .gt. 60._r8) stop & - 'liquid effective radius out of bounds' - index = int(radliq - 1.5_r8) - if (index .eq. 0) index = 1 - if (index .eq. 58) index = 57 - fint = radliq - 1.5_r8 - float(index) - ib = ngb(ig) - extcoliq(ig) = extliq1(index,ib) + fint * & - (extliq1(index+1,ib) - extliq1(index,ib)) - ssacoliq(ig) = ssaliq1(index,ib) + fint * & - (ssaliq1(index+1,ib) - ssaliq1(index,ib)) - if (fint .lt. 0._r8 .and. ssacoliq(ig) .gt. 1._r8) & - ssacoliq(ig) = ssaliq1(index,ib) - gliq(ig) = asyliq1(index,ib) + fint * & - (asyliq1(index+1,ib) - asyliq1(index,ib)) - forwliq(ig) = gliq(ig)*gliq(ig) - ! Check to ensure all calculated quantities are within physical limits. - if (extcoliq(ig) .lt. 0.0_r8) stop 'LIQUID EXTINCTION LESS THAN 0.0' - if (ssacoliq(ig) .gt. 1.0_r8) stop 'LIQUID SSA GRTR THAN 1.0' - if (ssacoliq(ig) .lt. 0.0_r8) stop 'LIQUID SSA LESS THAN 0.0' - if (gliq(ig) .gt. 1.0_r8) stop 'LIQUID ASYM GRTR THAN 1.0' - if (gliq(ig) .lt. 0.0_r8) stop 'LIQUID ASYM LESS THAN 0.0' - endif - tauliqorig = clwpmc(iplon,ig,lay) * extcoliq(ig) - tauiceorig = ciwpmc(iplon,ig,lay) * extcoice(ig) - taormc(ig,lay) = tauliqorig + tauiceorig - ssaliq = ssacoliq(ig) * (1._r8 - forwliq(ig)) / & - (1._r8 - forwliq(ig) * ssacoliq(ig)) - tauliq = (1._r8 - forwliq(ig) * ssacoliq(ig)) * tauliqorig - ssaice = ssacoice(ig) * (1._r8 - forwice(ig)) / & - (1._r8 - forwice(ig) * ssacoice(ig)) - tauice = (1._r8 - forwice(ig) * ssacoice(ig)) * tauiceorig - scatliq = ssaliq * tauliq - scatice = ssaice * tauice - taucmc(iplon,ig,lay) = tauliq + tauice - ! Ensure non-zero taucmc and scatice - if(taucmc(iplon,ig,lay).eq.0.) taucmc(iplon,ig,lay) = cldmin - if(scatice.eq.0.) scatice = cldmin - ssacmc(iplon,ig,lay) = (scatliq + scatice) / taucmc(iplon,ig,lay) - if (iceflag(iplon) .eq. 3) then - ! In accordance with the 1996 Fu paper, equation A.3, - ! the moments for ice were calculated depending on whether using spheres - ! or hexagonal ice crystals. - ! Set asymetry parameter to first moment (istr=1) - istr = 1 - asmcmc(iplon,ig,lay) = (1.0_r8/(scatliq+scatice))* & - (scatliq*(gliq(ig)**istr - forwliq(ig)) / & - (1.0_r8 - forwliq(ig)) + scatice * ((gice(ig)-forwice(ig))/ & - (1.0_r8 - forwice(ig)))**istr) - else - ! This code is the standard method for delta-m scaling. - ! Set asymetry parameter to first moment (istr=1) - istr = 1 - asmcmc(iplon,ig,lay) = (scatliq * & - (gliq(ig)**istr - forwliq(ig)) / & - (1.0_r8 - forwliq(ig)) + scatice * (gice(ig)**istr - forwice(ig)) / & - (1.0_r8 - forwice(ig)))/(scatliq + scatice) - endif - endif - endif - ! End g-point interval loop - enddo - ! End layer loop - enddo - end do - END SUBROUTINE cldprmc_sw -#endif - END MODULE rrtmg_sw_cldprmc diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_rad.F90 b/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_rad.F90 deleted file mode 100644 index a4d964d4ec..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_rad.F90 +++ /dev/null @@ -1,1287 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_sw_rad.f90 -! Generated at: 2015-07-07 00:48:23 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_sw_rad - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! - ! **************************************************************************** - ! * * - ! * RRTMG_SW * - ! * * - ! * * - ! * * - ! * a rapid radiative transfer model * - ! * for the solar spectral region * - ! * for application to general circulation models * - ! * * - ! * * - ! * Atmospheric and Environmental Research, Inc. * - ! * 131 Hartwell Avenue * - ! * Lexington, MA 02421 * - ! * * - ! * * - ! * Eli J. Mlawer * - ! * Jennifer S. Delamere * - ! * Michael J. Iacono * - ! * Shepard A. Clough * - ! * * - ! * * - ! * * - ! * * - ! * * - ! * * - ! * email: miacono@aer.com * - ! * email: emlawer@aer.com * - ! * email: jdelamer@aer.com * - ! * * - ! * The authors wish to acknowledge the contributions of the * - ! * following people: Steven J. Taubman, Patrick D. Brown, * - ! * Ronald E. Farren, Luke Chen, Robert Bergstrom. * - ! * * - ! **************************************************************************** - ! --------- Modules --------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE rrtmg_sw_cldprmc, ONLY: cldprmc_sw - ! Move call to rrtmg_sw_ini and following use association to - ! GCM initialization area - ! use rrtmg_sw_init, only: rrtmg_sw_ini - USE rrtmg_sw_setcoef, ONLY: setcoef_sw - USE rrtmg_sw_spcvmc, ONLY: spcvmc_sw - IMPLICIT NONE - ! public interfaces/functions/subroutines - ! public :: rrtmg_sw, inatm_sw, earth_sun - PUBLIC rrtmg_sw - !------------------------------------------------------------------ - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !------------------------------------------------------------------ - !------------------------------------------------------------------ - ! Public subroutines - !------------------------------------------------------------------ - - SUBROUTINE rrtmg_sw(lchnk, ncol, nlay, icld, play, plev, tlay, tlev, tsfc, h2ovmr, o3vmr, co2vmr, ch4vmr, o2vmr, n2ovmr, & - asdir, asdif, aldir, aldif, coszen, adjes, dyofyr, solvar, inflgsw, iceflgsw, liqflgsw, cldfmcl, taucmcl, ssacmcl, & - asmcmcl, fsfcmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, tauaer, ssaaer, asmaer, swuflx, swdflx, swhr, swuflxc, swdflxc, & - swhrc, dirdnuv, dirdnir, difdnuv, difdnir, ninflx, ninflxc, swuflxs, swdflxs) - ! ------- Description ------- - ! This program is the driver for RRTMG_SW, the AER SW radiation model for - ! application to GCMs, that has been adapted from RRTM_SW for improved - ! efficiency and to provide fractional cloudiness and cloud overlap - ! capability using McICA. - ! - ! Note: The call to RRTMG_SW_INI should be moved to the GCM initialization - ! area, since this has to be called only once. - ! - ! This routine - ! b) calls INATM_SW to read in the atmospheric profile; - ! all layering in RRTMG is ordered from surface to toa. - ! c) calls CLDPRMC_SW to set cloud optical depth for McICA based - ! on input cloud properties - ! d) calls SETCOEF_SW to calculate various quantities needed for - ! the radiative transfer algorithm - ! e) calls SPCVMC to call the two-stream model that in turn - ! calls TAUMOL to calculate gaseous optical depths for each - ! of the 16 spectral bands and to perform the radiative transfer - ! using McICA, the Monte-Carlo Independent Column Approximation, - ! to represent sub-grid scale cloud variability - ! f) passes the calculated fluxes and cooling rates back to GCM - ! - ! Two modes of operation are possible: - ! The mode is chosen by using either rrtmg_sw.nomcica.f90 (to not use - ! McICA) or rrtmg_sw.f90 (to use McICA) to interface with a GCM. - ! - ! 1) Standard, single forward model calculation (imca = 0); this is - ! valid only for clear sky or fully overcast clouds - ! 2) Monte Carlo Independent Column Approximation (McICA, Pincus et al., - ! JC, 2003) method is applied to the forward model calculation (imca = 1) - ! This method is valid for clear sky or partial cloud conditions. - ! - ! This call to RRTMG_SW must be preceeded by a call to the module - ! mcica_subcol_gen_sw.f90 to run the McICA sub-column cloud generator, - ! which will provide the cloud physical or cloud optical properties - ! on the RRTMG quadrature point (ngptsw) dimension. - ! - ! Two methods of cloud property input are possible: - ! Cloud properties can be input in one of two ways (controlled by input - ! flags inflag, iceflag and liqflag; see text file rrtmg_sw_instructions - ! and subroutine rrtmg_sw_cldprop.f90 for further details): - ! - ! 1) Input cloud fraction, cloud optical depth, single scattering albedo - ! and asymmetry parameter directly (inflgsw = 0) - ! 2) Input cloud fraction and cloud physical properties: ice fracion, - ! ice and liquid particle sizes (inflgsw = 1 or 2); - ! cloud optical properties are calculated by cldprop or cldprmc based - ! on input settings of iceflgsw and liqflgsw - ! - ! Two methods of aerosol property input are possible: - ! Aerosol properties can be input in one of two ways (controlled by input - ! flag iaer, see text file rrtmg_sw_instructions for further details): - ! - ! 1) Input aerosol optical depth, single scattering albedo and asymmetry - ! parameter directly by layer and spectral band (iaer=10) - ! 2) Input aerosol optical depth and 0.55 micron directly by layer and use - ! one or more of six ECMWF aerosol types (iaer=6) - ! - ! - ! ------- Modifications ------- - ! - ! This version of RRTMG_SW has been modified from RRTM_SW to use a reduced - ! set of g-point intervals and a two-stream model for application to GCMs. - ! - !-- Original version (derived from RRTM_SW) - ! 2002: AER. Inc. - !-- Conversion to F90 formatting; addition of 2-stream radiative transfer - ! Feb 2003: J.-J. Morcrette, ECMWF - !-- Additional modifications for GCM application - ! Aug 2003: M. J. Iacono, AER Inc. - !-- Total number of g-points reduced from 224 to 112. Original - ! set of 224 can be restored by exchanging code in module parrrsw.f90 - ! and in file rrtmg_sw_init.f90. - ! Apr 2004: M. J. Iacono, AER, Inc. - !-- Modifications to include output for direct and diffuse - ! downward fluxes. There are output as "true" fluxes without - ! any delta scaling applied. Code can be commented to exclude - ! this calculation in source file rrtmg_sw_spcvrt.f90. - ! Jan 2005: E. J. Mlawer, M. J. Iacono, AER, Inc. - !-- Revised to add McICA capability. - ! Nov 2005: M. J. Iacono, AER, Inc. - !-- Reformatted for consistency with rrtmg_lw. - ! Feb 2007: M. J. Iacono, AER, Inc. - !-- Modifications to formatting to use assumed-shape arrays. - ! Aug 2007: M. J. Iacono, AER, Inc. - !-- Modified to output direct and diffuse fluxes either with or without - ! delta scaling based on setting of idelm flag - ! Dec 2008: M. J. Iacono, AER, Inc. - ! --------- Modules --------- - USE parrrsw, ONLY: nbndsw - USE parrrsw, ONLY: mxmol - USE parrrsw, ONLY: jpband - USE parrrsw, ONLY: ngptsw - USE parrrsw, ONLY: jpb1 - USE parrrsw, ONLY: jpb2 - USE rrsw_con, ONLY: oneminus - USE rrsw_con, ONLY: pi - USE rrsw_con, ONLY: heatfac - ! ------- Declarations - ! ----- Input ----- - INTEGER, intent(in) :: lchnk ! chunk identifier - INTEGER, intent(in) :: ncol ! Number of horizontal columns - INTEGER, intent(in) :: nlay ! Number of model layers - INTEGER, intent(inout) :: icld ! Cloud overlap method - ! 0: Clear only - ! 1: Random - ! 2: Maximum/random - ! 3: Maximum - REAL(KIND=r8), intent(in) :: play(:,:) ! Layer pressures (hPa, mb) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: plev(:,:) ! Interface pressures (hPa, mb) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(in) :: tlay(:,:) ! Layer temperatures (K) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: tlev(:,:) ! Interface temperatures (K) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(in) :: tsfc(:) ! Surface temperature (K) - ! Dimensions: (ncol) - REAL(KIND=r8), intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: o2vmr(:,:) ! O2 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: asdir(:) ! UV/vis surface albedo direct rad - ! Dimensions: (ncol) - REAL(KIND=r8), intent(in) :: aldir(:) ! Near-IR surface albedo direct rad - ! Dimensions: (ncol) - REAL(KIND=r8), intent(in) :: asdif(:) ! UV/vis surface albedo: diffuse rad - ! Dimensions: (ncol) - REAL(KIND=r8), intent(in) :: aldif(:) ! Near-IR surface albedo: diffuse rad - ! Dimensions: (ncol) - INTEGER, intent(in) :: dyofyr ! Day of the year (used to get Earth/Sun - ! distance if adjflx not provided) - REAL(KIND=r8), intent(in) :: adjes ! Flux adjustment for Earth/Sun distance - REAL(KIND=r8), intent(in) :: coszen(:) ! Cosine of solar zenith angle - ! Dimensions: (ncol) - REAL(KIND=r8), intent(in) :: solvar(1:nbndsw) ! Solar constant (Wm-2) scaling per band - INTEGER, intent(in) :: inflgsw ! Flag for cloud optical properties - INTEGER, intent(in) :: iceflgsw ! Flag for ice particle specification - INTEGER, intent(in) :: liqflgsw ! Flag for liquid droplet specification - REAL(KIND=r8), intent(in) :: cldfmcl(:,:,:) ! Cloud fraction - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: taucmcl(:,:,:) ! Cloud optical depth - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: ssacmcl(:,:,:) ! Cloud single scattering albedo - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: asmcmcl(:,:,:) ! Cloud asymmetry parameter - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: fsfcmcl(:,:,:) ! Cloud forward scattering parameter - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: ciwpmcl(:,:,:) ! Cloud ice water path (g/m2) - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: clwpmcl(:,:,:) ! Cloud liquid water path (g/m2) - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: reicmcl(:,:) ! Cloud ice effective radius (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: tauaer(:,:,:) ! Aerosol optical depth (iaer=10 only) - ! Dimensions: (ncol,nlay,nbndsw) - ! (non-delta scaled) - REAL(KIND=r8), intent(in) :: ssaaer(:,:,:) ! Aerosol single scattering albedo (iaer=10 only) - ! Dimensions: (ncol,nlay,nbndsw) - ! (non-delta scaled) - REAL(KIND=r8), intent(in) :: asmaer(:,:,:) ! Aerosol asymmetry parameter (iaer=10 only) - ! Dimensions: (ncol,nlay,nbndsw) - ! (non-delta scaled) - ! real(kind=r8), intent(in) :: ecaer(:,:,:) ! Aerosol optical depth at 0.55 micron (iaer=6 only) - ! Dimensions: (ncol,nlay,naerec) - ! (non-delta scaled) - ! ----- Output ----- - REAL(KIND=r8), intent(out) :: swuflx(:,:) ! Total sky shortwave upward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(out) :: swdflx(:,:) ! Total sky shortwave downward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(out) :: swhr(:,:) ! Total sky shortwave radiative heating rate (K/d) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: swuflxc(:,:) ! Clear sky shortwave upward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(out) :: swdflxc(:,:) ! Clear sky shortwave downward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(out) :: swhrc(:,:) ! Clear sky shortwave radiative heating rate (K/d) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: dirdnuv(:,:) ! Direct downward shortwave flux, UV/vis - REAL(KIND=r8), intent(out) :: difdnuv(:,:) ! Diffuse downward shortwave flux, UV/vis - REAL(KIND=r8), intent(out) :: dirdnir(:,:) ! Direct downward shortwave flux, near-IR - REAL(KIND=r8), intent(out) :: difdnir(:,:) ! Diffuse downward shortwave flux, near-IR - REAL(KIND=r8), intent(out) :: ninflx(:,:) ! Net shortwave flux, near-IR - REAL(KIND=r8), intent(out) :: ninflxc(:,:) ! Net clear sky shortwave flux, near-IR - REAL(KIND=r8), intent(out) :: swuflxs(:,:,:) ! shortwave spectral flux up - REAL(KIND=r8), intent(out) :: swdflxs(:,:,:) ! shortwave spectral flux down - ! ----- Local ----- - ! Control - INTEGER :: istart ! beginning band of calculation - INTEGER :: iend ! ending band of calculation - INTEGER :: icpr ! cldprop/cldprmc use flag - INTEGER :: iout = 0 ! output option flag (inactive) - INTEGER :: iaer ! aerosol option flag - INTEGER :: idelm ! delta-m scaling flag - ! [0 = direct and diffuse fluxes are unscaled] - ! [1 = direct and diffuse fluxes are scaled] - ! (total downward fluxes are always delta scaled) - ! instrumental cosine response flag (inactive) - INTEGER :: iplon ! column loop index - INTEGER :: i ! layer loop index ! jk - INTEGER :: ib ! band loop index ! jsw - INTEGER :: ig ! indices - ! layer loop index - INTEGER :: ims ! value for changing mcica permute seed - ! flag for mcica [0=off, 1=on] - REAL(KIND=r8) :: zepsec - REAL(KIND=r8) :: zepzen ! epsilon - REAL(KIND=r8) :: zdpgcp ! flux to heating conversion ratio - ! Atmosphere - REAL(KIND=r8) :: pavel(ncol,nlay) ! layer pressures (mb) - REAL(KIND=r8) :: tavel(ncol,nlay) ! layer temperatures (K) - REAL(KIND=r8) :: pz(ncol,0:nlay) ! level (interface) pressures (hPa, mb) - REAL(KIND=r8) :: tz(ncol,0:nlay) ! level (interface) temperatures (K) - REAL(KIND=r8) :: tbound(ncol) ! surface temperature (K) - REAL(KIND=r8) :: pdp(ncol,nlay) ! layer pressure thickness (hPa, mb) - REAL(KIND=r8) :: coldry(ncol,nlay) ! dry air column amount - REAL(KIND=r8) :: wkl(ncol,mxmol,nlay) ! molecular amounts (mol/cm-2) - ! real(kind=r8) :: earth_sun ! function for Earth/Sun distance factor - REAL(KIND=r8) :: cossza(ncol) ! Cosine of solar zenith angle - REAL(KIND=r8) :: adjflux(ncol,jpband) ! adjustment for current Earth/Sun distance - ! real(kind=r8) :: solvar(jpband) ! solar constant scaling factor from rrtmg_sw - ! default value of 1368.22 Wm-2 at 1 AU - REAL(KIND=r8) :: albdir(ncol,nbndsw) ! surface albedo, direct ! zalbp - REAL(KIND=r8) :: albdif(ncol,nbndsw) ! surface albedo, diffuse ! zalbd - REAL(KIND=r8) :: taua(ncol,nlay,nbndsw) ! Aerosol optical depth - REAL(KIND=r8) :: ssaa(ncol,nlay,nbndsw) ! Aerosol single scattering albedo - REAL(KIND=r8) :: asma(ncol,nlay,nbndsw) ! Aerosol asymmetry parameter - ! Atmosphere - setcoef - INTEGER :: laytrop(ncol) ! tropopause layer index - INTEGER :: layswtch(ncol) ! - INTEGER :: laylow(ncol) ! - INTEGER :: jp(ncol,nlay) ! - INTEGER :: jt(ncol,nlay) ! - INTEGER :: jt1(ncol,nlay) ! - REAL(KIND=r8) :: colh2o(ncol,nlay) ! column amount (h2o) - REAL(KIND=r8) :: colco2(ncol,nlay) ! column amount (co2) - REAL(KIND=r8) :: colo3(ncol,nlay) ! column amount (o3) - REAL(KIND=r8) :: coln2o(ncol,nlay) ! column amount (n2o) - REAL(KIND=r8) :: colch4(ncol,nlay) ! column amount (ch4) - REAL(KIND=r8) :: colo2(ncol,nlay) ! column amount (o2) - REAL(KIND=r8) :: colmol(ncol,nlay) ! column amount - REAL(KIND=r8) :: co2mult(ncol,nlay) ! column amount - INTEGER :: indself(ncol,nlay) - INTEGER :: indfor(ncol,nlay) - REAL(KIND=r8) :: selffac(ncol,nlay) - REAL(KIND=r8) :: selffrac(ncol,nlay) - REAL(KIND=r8) :: forfac(ncol,nlay) - REAL(KIND=r8) :: forfrac(ncol,nlay) - REAL(KIND=r8) :: fac00(ncol,nlay) - REAL(KIND=r8) :: fac01(ncol,nlay) - REAL(KIND=r8) :: fac11(ncol,nlay) - REAL(KIND=r8) :: fac10(ncol,nlay) ! - ! Atmosphere/clouds - cldprop - ! number of cloud spectral bands - INTEGER :: inflag(ncol) ! flag for cloud property method - INTEGER :: iceflag(ncol) ! flag for ice cloud properties - INTEGER :: liqflag(ncol) ! flag for liquid cloud properties - ! real(kind=r8) :: cldfrac(nlay) ! layer cloud fraction - ! real(kind=r8) :: tauc(nlay) ! cloud optical depth (non-delta scaled) - ! real(kind=r8) :: ssac(nlay) ! cloud single scattering albedo (non-delta scaled) - ! real(kind=r8) :: asmc(nlay) ! cloud asymmetry parameter (non-delta scaled) - ! real(kind=r8) :: ciwp(nlay) ! cloud ice water path - ! real(kind=r8) :: clwp(nlay) ! cloud liquid water path - ! real(kind=r8) :: rei(nlay) ! cloud ice particle size - ! real(kind=r8) :: rel(nlay) ! cloud liquid particle size - ! real(kind=r8) :: taucloud(nlay,jpband) ! cloud optical depth - ! real(kind=r8) :: taucldorig(nlay,jpband) ! cloud optical depth (non-delta scaled) - ! real(kind=r8) :: ssacloud(nlay,jpband) ! cloud single scattering albedo - ! real(kind=r8) :: asmcloud(nlay,jpband) ! cloud asymmetry parameter - ! Atmosphere/clouds - cldprmc [mcica] - REAL(KIND=r8) :: cldfmc(ncol,ngptsw,nlay) ! cloud fraction [mcica] - REAL(KIND=r8) :: ciwpmc(ncol,ngptsw,nlay) ! cloud ice water path [mcica] - REAL(KIND=r8) :: clwpmc(ncol,ngptsw,nlay) ! cloud liquid water path [mcica] - REAL(KIND=r8) :: relqmc(ncol,nlay) ! liquid particle size (microns) - REAL(KIND=r8) :: reicmc(ncol,nlay) ! ice particle effective radius (microns) - REAL(KIND=r8) :: dgesmc(ncol,nlay) ! ice particle generalized effective size (microns) - REAL(KIND=r8) :: taucmc(ncol,ngptsw,nlay) ! cloud optical depth [mcica] - REAL(KIND=r8) :: taormc(ngptsw,nlay) ! unscaled cloud optical depth [mcica] - REAL(KIND=r8) :: ssacmc(ncol,ngptsw,nlay) ! cloud single scattering albedo [mcica] - REAL(KIND=r8) :: asmcmc(ncol,ngptsw,nlay) ! cloud asymmetry parameter [mcica] - REAL(KIND=r8) :: fsfcmc(ncol,ngptsw,nlay) ! cloud forward scattering fraction [mcica] - ! Atmosphere/clouds/aerosol - spcvrt,spcvmc - ! cloud optical depth - ! unscaled cloud optical depth - ! cloud asymmetry parameter - ! (first moment of phase function) - ! cloud single scattering albedo - REAL(KIND=r8) :: ztaua(ncol,nlay,nbndsw) ! total aerosol optical depth - REAL(KIND=r8) :: zasya(ncol,nlay,nbndsw) ! total aerosol asymmetry parameter - REAL(KIND=r8) :: zomga(ncol,nlay,nbndsw) ! total aerosol single scattering albedo - REAL(KIND=r8) :: zcldfmc(ncol,nlay,ngptsw) ! cloud fraction [mcica] - REAL(KIND=r8) :: ztaucmc(ncol,nlay,ngptsw) ! cloud optical depth [mcica] - REAL(KIND=r8) :: ztaormc(ncol,nlay,ngptsw) ! unscaled cloud optical depth [mcica] - REAL(KIND=r8) :: zasycmc(ncol,nlay,ngptsw) ! cloud asymmetry parameter [mcica] - REAL(KIND=r8) :: zomgcmc(ncol,nlay,ngptsw) ! cloud single scattering albedo [mcica] - REAL(KIND=r8) :: zbbfu(ncol,nlay+2) ! temporary upward shortwave flux (w/m2) - REAL(KIND=r8) :: zbbfd(ncol,nlay+2) ! temporary downward shortwave flux (w/m2) - REAL(KIND=r8) :: zbbcu(ncol,nlay+2) ! temporary clear sky upward shortwave flux (w/m2) - REAL(KIND=r8) :: zbbcd(ncol,nlay+2) ! temporary clear sky downward shortwave flux (w/m2) - REAL(KIND=r8) :: zbbfddir(ncol,nlay+2) ! temporary downward direct shortwave flux (w/m2) - REAL(KIND=r8) :: zbbcddir(ncol,nlay+2) ! temporary clear sky downward direct shortwave flux (w/m2) - REAL(KIND=r8) :: zuvfd(ncol,nlay+2) ! temporary UV downward shortwave flux (w/m2) - REAL(KIND=r8) :: zuvcd(ncol,nlay+2) ! temporary clear sky UV downward shortwave flux (w/m2) - REAL(KIND=r8) :: zuvfddir(ncol,nlay+2) ! temporary UV downward direct shortwave flux (w/m2) - REAL(KIND=r8) :: zuvcddir(ncol,nlay+2) ! temporary clear sky UV downward direct shortwave flux (w/m2) - REAL(KIND=r8) :: znifd(ncol,nlay+2) ! temporary near-IR downward shortwave flux (w/m2) - REAL(KIND=r8) :: znicd(ncol,nlay+2) ! temporary clear sky near-IR downward shortwave flux (w/m2) - REAL(KIND=r8) :: znifddir(ncol,nlay+2) ! temporary near-IR downward direct shortwave flux (w/m2) - REAL(KIND=r8) :: znicddir(ncol,nlay+2) ! temporary clear sky near-IR downward direct shortwave flux (w/m2) - ! Added for near-IR flux diagnostic - REAL(KIND=r8) :: znifu(ncol,nlay+2) ! temporary near-IR downward shortwave flux (w/m2) - REAL(KIND=r8) :: znicu(ncol,nlay+2) ! temporary clear sky near-IR downward shortwave flux (w/m2) - ! Optional output fields - REAL(KIND=r8) :: swnflx(nlay+2) ! Total sky shortwave net flux (W/m2) - REAL(KIND=r8) :: swnflxc(nlay+2) ! Clear sky shortwave net flux (W/m2) - REAL(KIND=r8) :: dirdflux(nlay+2) ! Direct downward shortwave surface flux - REAL(KIND=r8) :: difdflux(nlay+2) ! Diffuse downward shortwave surface flux - REAL(KIND=r8) :: uvdflx(nlay+2) ! Total sky downward shortwave flux, UV/vis - REAL(KIND=r8) :: nidflx(nlay+2) ! Total sky downward shortwave flux, near-IR - REAL(KIND=r8) :: zbbfsu(ncol,nbndsw,nlay+2) ! temporary upward shortwave flux spectral (w/m2) - REAL(KIND=r8) :: zbbfsd(ncol,nbndsw,nlay+2) ! temporary downward shortwave flux spectral (w/m2) - ! Output - inactive - ! real(kind=r8) :: zuvfu(nlay+2) ! temporary upward UV shortwave flux (w/m2) - ! real(kind=r8) :: zuvfd(nlay+2) ! temporary downward UV shortwave flux (w/m2) - ! real(kind=r8) :: zuvcu(nlay+2) ! temporary clear sky upward UV shortwave flux (w/m2) - ! real(kind=r8) :: zuvcd(nlay+2) ! temporary clear sky downward UV shortwave flux (w/m2) - ! real(kind=r8) :: zvsfu(nlay+2) ! temporary upward visible shortwave flux (w/m2) - ! real(kind=r8) :: zvsfd(nlay+2) ! temporary downward visible shortwave flux (w/m2) - ! real(kind=r8) :: zvscu(nlay+2) ! temporary clear sky upward visible shortwave flux (w/m2) - ! real(kind=r8) :: zvscd(nlay+2) ! temporary clear sky downward visible shortwave flux (w/m2) - ! real(kind=r8) :: znifu(nlay+2) ! temporary upward near-IR shortwave flux (w/m2) - ! real(kind=r8) :: znifd(nlay+2) ! temporary downward near-IR shortwave flux (w/m2) - ! real(kind=r8) :: znicu(nlay+2) ! temporary clear sky upward near-IR shortwave flux (w/m2) - ! real(kind=r8) :: znicd(nlay+2) ! temporary clear sky downward near-IR shortwave flux (w/m2) - ! Initializations - zepsec = 1.e-06_r8 - zepzen = 1.e-10_r8 - oneminus = 1.0_r8 - zepsec - pi = 2._r8 * asin(1._r8) - istart = jpb1 - iend = jpb2 - icpr = 0 - ims = 2 - ! In a GCM with or without McICA, set nlon to the longitude dimension - ! - ! Set imca to select calculation type: - ! imca = 0, use standard forward model calculation (clear and overcast only) - ! imca = 1, use McICA for Monte Carlo treatment of sub-grid cloud variability - ! (clear, overcast or partial cloud conditions) - ! *** This version uses McICA (imca = 1) *** - ! Set icld to select of clear or cloud calculation and cloud - ! overlap method (read by subroutine readprof from input file INPUT_RRTM): - ! icld = 0, clear only - ! icld = 1, with clouds using random cloud overlap (McICA only) - ! icld = 2, with clouds using maximum/random cloud overlap (McICA only) - ! icld = 3, with clouds using maximum cloud overlap (McICA only) - if (icld.lt.0.or.icld.gt.3) icld = 2 - ! Set iaer to select aerosol option - ! iaer = 0, no aerosols - ! iaer = 6, use six ECMWF aerosol types - ! input aerosol optical depth at 0.55 microns for each aerosol type (ecaer) - ! iaer = 10, input total aerosol optical depth, single scattering albedo - ! and asymmetry parameter (tauaer, ssaaer, asmaer) directly - iaer = 10 - ! Set idelm to select between delta-M scaled or unscaled output direct and diffuse fluxes - ! NOTE: total downward fluxes are always delta scaled - ! idelm = 0, output direct and diffuse flux components are not delta scaled - ! (direct flux does not include forward scattering peak) - ! idelm = 1, output direct and diffuse flux components are delta scaled (default) - ! (direct flux includes part or most of forward scattering peak) - idelm = 1 - ! Call model and data initialization, compute lookup tables, perform - ! reduction of g-points from 224 to 112 for input absorption - ! coefficient data and other arrays. - ! - ! In a GCM this call should be placed in the model initialization - ! area, since this has to be called only once. - ! call rrtmg_sw_ini - ! This is the main longitude/column loop in RRTMG. - ! Modify to loop over all columns (nlon) or over daylight columns -!JMD #define OLD_INATM_SW 1 -#ifdef OLD_INATM_SW - do iplon = 1, ncol - ! Prepare atmosphere profile from GCM for use in RRTMG, and define - ! other input parameters - call inatm_sw (iplon, nlay, icld, iaer, & - play, plev, tlay, tlev, tsfc, & - h2ovmr, o3vmr, co2vmr, ch4vmr, o2vmr, n2ovmr, adjes, dyofyr, solvar, & - inflgsw, iceflgsw, liqflgsw, & - cldfmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl, ciwpmcl, clwpmcl, & - reicmcl, relqmcl, tauaer, ssaaer, asmaer, & - pavel(iplon,:), pz(iplon,:), pdp(iplon,:), tavel(iplon,:), tz(iplon,:), tbound(iplon), coldry(iplon,:), wkl(iplon,:,:), & - adjflux(iplon,:), inflag(iplon), iceflag(iplon), liqflag(iplon), cldfmc(iplon,:,:), taucmc(iplon,:,:), & - ssacmc(iplon,:,:), asmcmc(iplon,:,:), fsfcmc(iplon,:,:), ciwpmc(iplon,:,:), clwpmc(iplon,:,:), reicmc(iplon,:), dgesmc(iplon,:), relqmc(iplon,:), & - taua(iplon,:,:), ssaa(iplon,:,:), asma(iplon,:,:)) - end do -#else - call inatm_sw_new (1,ncol,nlay, icld, iaer, & - play, plev, tlay, tlev, tsfc, & - h2ovmr, o3vmr, co2vmr, ch4vmr, o2vmr, n2ovmr, adjes, dyofyr, solvar, & - inflgsw, iceflgsw, liqflgsw, & - cldfmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl, ciwpmcl, clwpmcl, & - reicmcl, relqmcl, tauaer, ssaaer, asmaer, & - pavel, pz, pdp, tavel, tz, tbound, coldry, wkl, & - adjflux, inflag, iceflag, liqflag, cldfmc, taucmc, & - ssacmc, asmcmc, fsfcmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, & - taua, ssaa, asma) - ! For cloudy atmosphere, use cldprop to set cloud optical properties based on - ! input cloud physical properties. Select method based on choices described - ! in cldprop. Cloud fraction, water path, liquid droplet and ice particle - ! effective radius must be passed in cldprop. Cloud fraction and cloud - ! optical properties are transferred to rrtmg_sw arrays in cldprop. -#endif - -#ifdef OLD_CLDPRMC_SW - do iplon = 1, ncol - call cldprmc_sw(nlay, inflag(iplon), iceflag(iplon), liqflag(iplon), cldfmc(iplon,:,:), & - ciwpmc(iplon,:,:), clwpmc(iplon,:,:), reicmc(iplon,:), dgesmc(iplon,:), relqmc(iplon,:), & - taormc, taucmc(iplon,:,:), ssacmc(iplon,:,:), asmcmc(iplon,:,:), fsfcmc(iplon,:,:)) - end do -#else - - call cldprmc_sw(ncol,nlay, inflag, iceflag, liqflag, cldfmc, & - ciwpmc, clwpmc, reicmc, dgesmc, relqmc, & - taormc, taucmc, ssacmc, asmcmc, fsfcmc) -#endif - icpr = 1 - ! Calculate coefficients for the temperature and pressure dependence of the - ! molecular absorption coefficients by interpolating data from stored - call setcoef_sw(ncol,nlay, pavel, tavel, pz, tz, tbound, coldry, wkl, & - laytrop, layswtch, laylow, jp, jt, jt1, & - co2mult, colch4, colco2, colh2o, colmol, coln2o, & - colo2, colo3, fac00, fac01, fac10, fac11, & - selffac, selffrac, indself, forfac, forfrac, indfor) - ! Cosine of the solar zenith angle - ! Prevent using value of zero; ideally, SW model is not called from host model when sun - ! is below horizon - do iplon = 1, ncol - cossza(iplon) = coszen(iplon) - if (cossza(iplon) .lt. zepzen) cossza(iplon) = zepzen - ! Transfer albedo, cloud and aerosol properties into arrays for 2-stream radiative transfer - ! Surface albedo - ! Near-IR bands 16-24 and 29 (1-9 and 14), 820-16000 cm-1, 0.625-12.195 microns - ! do ib=1,9 - do ib=1,8 - albdir(iplon,ib) = aldir(iplon) - albdif(iplon,ib) = aldif(iplon) - enddo - albdir(iplon,nbndsw) = aldir(iplon) - albdif(iplon,nbndsw) = aldif(iplon) - ! Set band 24 (or, band 9 counting from 1) to use linear average of UV/visible - ! and near-IR values, since this band straddles 0.7 microns: - albdir(iplon,9) = 0.5*(aldir(iplon) + asdir(iplon)) - albdif(iplon,9) = 0.5*(aldif(iplon) + asdif(iplon)) - ! UV/visible bands 25-28 (10-13), 16000-50000 cm-1, 0.200-0.625 micron - do ib=10,13 - albdir(iplon,ib) = asdir(iplon) - albdif(iplon,ib) = asdif(iplon) - enddo - ! Clouds - if (icld.eq.0) then - zcldfmc(iplon,:,:) = 0._r8 - ztaucmc(iplon,:,:) = 0._r8 - ztaormc(iplon,:,:) = 0._r8 - zasycmc(iplon,:,:) = 0._r8 - zomgcmc(iplon,:,:) = 1._r8 - elseif (icld.ge.1) then - do i=1,nlay - do ig=1,ngptsw - zcldfmc(iplon,i,ig) = cldfmc(iplon,ig,i) - ztaucmc(iplon,i,ig) = taucmc(iplon,ig,i) - ztaormc(iplon,i,ig) = taormc(ig,i) - zasycmc(iplon,i,ig) = asmcmc(iplon,ig,i) - zomgcmc(iplon,i,ig) = ssacmc(iplon,ig,i) - enddo - enddo - endif - ! Aerosol - ! IAER = 0: no aerosols - if (iaer.eq.0) then - ztaua(iplon,:,:) = 0._r8 - zasya(iplon,:,:) = 0._r8 - zomga(iplon,:,:) = 1._r8 - ! IAER = 6: Use ECMWF six aerosol types. See rrsw_aer.f90 for details. - ! Input aerosol optical thickness at 0.55 micron for each aerosol type (ecaer), - ! or set manually here for each aerosol and layer. - elseif (iaer.eq.6) then - ! do nothing - elseif (iaer.eq.10) then - do i = 1 ,nlay - do ib = 1 ,nbndsw - ztaua(iplon,i,ib) = taua(iplon,i,ib) - zasya(iplon,i,ib) = asma(iplon,i,ib) - zomga(iplon,i,ib) = ssaa(iplon,i,ib) - enddo - enddo - endif - ! Call the 2-stream radiation transfer model - do i=1,nlay+1 - zbbcu(iplon,i) = 0._r8 - zbbcd(iplon,i) = 0._r8 - zbbfu(iplon,i) = 0._r8 - zbbfd(iplon,i) = 0._r8 - zbbcddir(iplon,i) = 0._r8 - zbbfddir(iplon,i) = 0._r8 - zuvcd(iplon,i) = 0._r8 - zuvfd(iplon,i) = 0._r8 - zuvcddir(iplon,i) = 0._r8 - zuvfddir(iplon,i) = 0._r8 - znicd(iplon,i) = 0._r8 - znifd(iplon,i) = 0._r8 - znicddir(iplon,i) = 0._r8 - znifddir(iplon,i) = 0._r8 - znicu(iplon,i) = 0._r8 - znifu(iplon,i) = 0._r8 - zbbfsu(iplon,:,i) = 0._r8 - zbbfsd(iplon,:,i) = 0._r8 - enddo - end do - !do iplon=1,ncol - ! call spcvmc_sw & - ! (lchnk, iplon, nlay, istart, iend, icpr, idelm, iout, & - ! pavel(iplon,:), tavel(iplon,:), pz(iplon,:), tz(iplon,:), tbound(iplon), albdif(iplon,:), albdir(iplon,:), & - ! zcldfmc(iplon,:,:), ztaucmc(iplon,:,:), zasycmc(iplon,:,:), zomgcmc(iplon,:,:), ztaormc(iplon,:,:), & - ! ztaua(iplon,:,:), zasya(iplon,:,:), zomga(iplon,:,:), cossza(iplon), coldry(iplon,:), wkl(iplon,:,:), adjflux(iplon,:), & - ! laytrop(iplon), layswtch(iplon), laylow(iplon), jp(iplon,:), jt(iplon,:), jt1(iplon,:), & - ! co2mult(iplon,:), colch4(iplon,:), colco2(iplon,:), colh2o(iplon,:), colmol(iplon,:), coln2o(iplon,:), colo2(iplon,:), colo3(iplon,:), & - ! fac00(iplon,:), fac01(iplon,:), fac10(iplon,:), fac11(iplon,:), & - ! selffac(iplon,:), selffrac(iplon,:), indself(iplon,:), forfac(iplon,:), forfrac(iplon,:), indfor(iplon,:), & - ! zbbfd(iplon,:), zbbfu(iplon,:), zbbcd(iplon,:), zbbcu(iplon,:), zuvfd(iplon,:), zuvcd(iplon,:), znifd(iplon,:), znicd(iplon,:), znifu(iplon,:), znicu(iplon,:), & - ! zbbfddir(iplon,:), zbbcddir(iplon,:), zuvfddir(iplon,:), zuvcddir(iplon,:), znifddir(iplon,:), znicddir(iplon,:), zbbfsu(iplon,:,:), zbbfsd(iplon,:,:)) - ! ! Transfer up and down, clear and total sky fluxes to output arrays. - ! ! Vertical indexing goes from bottom to top - !end do - call spcvmc_sw & - (lchnk, ncol, nlay, istart, iend, icpr, idelm, iout, & - pavel, tavel, pz, tz, tbound, albdif, albdir, & - zcldfmc, ztaucmc, zasycmc, zomgcmc, ztaormc, & - ztaua, zasya, zomga, cossza, coldry, wkl, adjflux, & - laytrop, layswtch, laylow, jp, jt, jt1, & - co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3, & - fac00, fac01, fac10, fac11, & - selffac, selffrac, indself, forfac, forfrac, indfor, & - zbbfd, zbbfu, zbbcd, zbbcu, zuvfd, zuvcd, znifd, znicd, znifu, znicu, & - zbbfddir, zbbcddir, zuvfddir, zuvcddir, znifddir, znicddir, zbbfsu, zbbfsd) - ! Transfer up and down, clear and total sky fluxes to output arrays. - ! Vertical indexing goes from bottom to top - do iplon=1,ncol - do i = 1, nlay+1 - swuflxc(iplon,i) = zbbcu(iplon,i) - swdflxc(iplon,i) = zbbcd(iplon,i) - swuflx(iplon,i) = zbbfu(iplon,i) - swdflx(iplon,i) = zbbfd(iplon,i) - swuflxs(:,iplon,i) = zbbfsu(iplon,:,i) - swdflxs(:,iplon,i) = zbbfsd(iplon,:,i) - uvdflx(i) = zuvfd(iplon,i) - nidflx(i) = znifd(iplon,i) - ! Direct/diffuse fluxes - dirdflux(i) = zbbfddir(iplon,i) - difdflux(i) = swdflx(iplon,i) - dirdflux(i) - ! UV/visible direct/diffuse fluxes - dirdnuv(iplon,i) = zuvfddir(iplon,i) - difdnuv(iplon,i) = zuvfd(iplon,i) - dirdnuv(iplon,i) - ! Near-IR direct/diffuse fluxes - dirdnir(iplon,i) = znifddir(iplon,i) - difdnir(iplon,i) = znifd(iplon,i) - dirdnir(iplon,i) - ! Added for net near-IR diagnostic - ninflx(iplon,i) = znifd(iplon,i) - znifu(iplon,i) - ninflxc(iplon,i) = znicd(iplon,i) - znicu(iplon,i) - enddo - ! Total and clear sky net fluxes - do i = 1, nlay+1 - swnflxc(i) = swdflxc(iplon,i) - swuflxc(iplon,i) - swnflx(i) = swdflx(iplon,i) - swuflx(iplon,i) - enddo - ! Total and clear sky heating rates - ! Heating units are in K/d. Flux units are in W/m2. - do i = 1, nlay - zdpgcp = heatfac / pdp(iplon,i) - swhrc(iplon,i) = (swnflxc(i+1) - swnflxc(i)) * zdpgcp - swhr(iplon,i) = (swnflx(i+1) - swnflx(i)) * zdpgcp - enddo - swhrc(iplon,nlay) = 0._r8 - swhr(iplon,nlay) = 0._r8 - ! End longitude loop - enddo - END SUBROUTINE rrtmg_sw - !************************************************************************* - - real(kind=r8) FUNCTION earth_sun(idn) - !************************************************************************* - ! - ! Purpose: Function to calculate the correction factor of Earth's orbit - ! for current day of the year - ! idn : Day of the year - ! earth_sun : square of the ratio of mean to actual Earth-Sun distance - ! ------- Modules ------- - USE rrsw_con, ONLY: pi - INTEGER, intent(in) :: idn - REAL(KIND=r8) :: gamma - gamma = 2._r8*pi*(idn-1)/365._r8 - ! Use Iqbal's equation 1.2.1 - earth_sun = 1.000110_r8 + .034221_r8 * cos(gamma) + .001289_r8 * sin(gamma) + & - .000719_r8 * cos(2._r8*gamma) + .000077_r8 * sin(2._r8*gamma) - END FUNCTION earth_sun - !*************************************************************************** -!DIR$ ATTRIBUTES FORCEINLINE :: inatm_sw - SUBROUTINE inatm_sw(iplon, nlay, icld, iaer, play, plev, tlay, tlev, tsfc, h2ovmr, o3vmr, co2vmr, ch4vmr, o2vmr, n2ovmr, & - adjes, dyofyr, solvar, inflgsw, iceflgsw, liqflgsw, cldfmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl, ciwpmcl, clwpmcl, & - reicmcl, relqmcl, tauaer, ssaaer, asmaer, pavel, pz, pdp, tavel, tz, tbound, coldry, wkl, adjflux, inflag, iceflag, & - liqflag, cldfmc, taucmc, ssacmc, asmcmc, fsfcmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, taua, ssaa, asma) - !*************************************************************************** - ! - ! Input atmospheric profile from GCM, and prepare it for use in RRTMG_SW. - ! Set other RRTMG_SW input parameters. - ! - !*************************************************************************** - ! --------- Modules ---------- - USE parrrsw, ONLY: jpb1 - USE parrrsw, ONLY: jpb2 - USE parrrsw, ONLY: nmol - USE parrrsw, ONLY: nbndsw - USE parrrsw, ONLY: ngptsw - USE rrsw_con, ONLY: avogad - USE rrsw_con, ONLY: grav - ! ------- Declarations ------- - ! ----- Input ----- - INTEGER, intent(in) :: iplon ! column loop index - INTEGER, intent(in) :: nlay ! number of model layers - INTEGER, intent(in) :: icld ! clear/cloud and cloud overlap flag - INTEGER, intent(in) :: iaer ! aerosol option flag - REAL(KIND=r8), intent(in) :: play(:,:) ! Layer pressures (hPa, mb) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: plev(:,:) ! Interface pressures (hPa, mb) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(in) :: tlay(:,:) ! Layer temperatures (K) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: tlev(:,:) ! Interface temperatures (K) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(in) :: tsfc(:) ! Surface temperature (K) - ! Dimensions: (ncol) - REAL(KIND=r8), intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: o2vmr(:,:) ! O2 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio - ! Dimensions: (ncol,nlay) - INTEGER, intent(in) :: dyofyr ! Day of the year (used to get Earth/Sun - ! distance if adjflx not provided) - REAL(KIND=r8), intent(in) :: adjes ! Flux adjustment for Earth/Sun distance - REAL(KIND=r8), intent(in) :: solvar(jpb1:jpb2) ! Solar constant (Wm-2) scaling per band - INTEGER, intent(in) :: inflgsw ! Flag for cloud optical properties - INTEGER, intent(in) :: iceflgsw ! Flag for ice particle specification - INTEGER, intent(in) :: liqflgsw ! Flag for liquid droplet specification - REAL(KIND=r8), intent(in) :: cldfmcl(:,:,:) ! Cloud fraction - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: taucmcl(:,:,:) ! Cloud optical depth (optional) - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: ssacmcl(:,:,:) ! Cloud single scattering albedo - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: asmcmcl(:,:,:) ! Cloud asymmetry parameter - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: fsfcmcl(:,:,:) ! Cloud forward scattering fraction - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: ciwpmcl(:,:,:) ! Cloud ice water path (g/m2) - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: clwpmcl(:,:,:) ! Cloud liquid water path (g/m2) - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: reicmcl(:,:) ! Cloud ice effective radius (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: tauaer(:,:,:) ! Aerosol optical depth - ! Dimensions: (ncol,nlay,nbndsw) - REAL(KIND=r8), intent(in) :: ssaaer(:,:,:) ! Aerosol single scattering albedo - ! Dimensions: (ncol,nlay,nbndsw) - REAL(KIND=r8), intent(in) :: asmaer(:,:,:) ! Aerosol asymmetry parameter - ! Dimensions: (ncol,nlay,nbndsw) - ! Atmosphere - REAL(KIND=r8), intent(out) :: pavel(:) ! layer pressures (mb) - ! Dimensions: (nlay) - REAL(KIND=r8), intent(out) :: tavel(:) ! layer temperatures (K) - ! Dimensions: (nlay) - REAL(KIND=r8), intent(out) :: pz(0:) ! level (interface) pressures (hPa, mb) - ! Dimensions: (0:nlay) - REAL(KIND=r8), intent(out) :: tz(0:) ! level (interface) temperatures (K) - ! Dimensions: (0:nlay) - REAL(KIND=r8), intent(out) :: tbound ! surface temperature (K) - REAL(KIND=r8), intent(out) :: pdp(:) ! layer pressure thickness (hPa, mb) - ! Dimensions: (nlay) - REAL(KIND=r8), intent(out) :: coldry(:) ! dry air column density (mol/cm2) - ! Dimensions: (nlay) - REAL(KIND=r8), intent(out) :: wkl(:,:) ! molecular amounts (mol/cm-2) - ! Dimensions: (mxmol,nlay) - REAL(KIND=r8), intent(out) :: adjflux(:) ! adjustment for current Earth/Sun distance - ! Dimensions: (jpband) - ! real(kind=r8), intent(out) :: solvar(:) ! solar constant scaling factor from rrtmg_sw - ! Dimensions: (jpband) - ! default value of 1368.22 Wm-2 at 1 AU - REAL(KIND=r8), intent(out) :: taua(:,:) ! Aerosol optical depth - ! Dimensions: (nlay,nbndsw) - REAL(KIND=r8), intent(out) :: ssaa(:,:) ! Aerosol single scattering albedo - ! Dimensions: (nlay,nbndsw) - REAL(KIND=r8), intent(out) :: asma(:,:) ! Aerosol asymmetry parameter - ! Dimensions: (nlay,nbndsw) - ! Atmosphere/clouds - cldprop - INTEGER, intent(out) :: inflag ! flag for cloud property method - INTEGER, intent(out) :: iceflag ! flag for ice cloud properties - INTEGER, intent(out) :: liqflag ! flag for liquid cloud properties - REAL(KIND=r8), intent(out) :: cldfmc(:,:) ! layer cloud fraction - ! Dimensions: (ngptsw,nlay) - REAL(KIND=r8), intent(out) :: taucmc(:,:) ! cloud optical depth (non-delta scaled) - ! Dimensions: (ngptsw,nlay) - REAL(KIND=r8), intent(out) :: ssacmc(:,:) ! cloud single scattering albedo (non-delta-scaled) - ! Dimensions: (ngptsw,nlay) - REAL(KIND=r8), intent(out) :: asmcmc(:,:) ! cloud asymmetry parameter (non-delta scaled) - REAL(KIND=r8), intent(out) :: fsfcmc(:,:) ! cloud forward scattering fraction (non-delta scaled) - ! Dimensions: (ngptsw,nlay) - REAL(KIND=r8), intent(out) :: ciwpmc(:,:) ! cloud ice water path - ! Dimensions: (ngptsw,nlay) - REAL(KIND=r8), intent(out) :: clwpmc(:,:) ! cloud liquid water path - ! Dimensions: (ngptsw,nlay) - REAL(KIND=r8), intent(out) :: reicmc(:) ! cloud ice particle effective radius - ! Dimensions: (nlay) - REAL(KIND=r8), intent(out) :: dgesmc(:) ! cloud ice particle effective radius - ! Dimensions: (nlay) - REAL(KIND=r8), intent(out) :: relqmc(:) ! cloud liquid particle size - ! Dimensions: (nlay) - ! ----- Local ----- - REAL(KIND=r8), parameter :: amd = 28.9660_r8 ! Effective molecular weight of dry air (g/mol) - REAL(KIND=r8), parameter :: amw = 18.0160_r8 ! Molecular weight of water vapor (g/mol) - ! real(kind=r8), parameter :: amc = 44.0098_r8 ! Molecular weight of carbon dioxide (g/mol) - ! real(kind=r8), parameter :: amo = 47.9998_r8 ! Molecular weight of ozone (g/mol) - ! real(kind=r8), parameter :: amo2 = 31.9999_r8 ! Molecular weight of oxygen (g/mol) - ! real(kind=r8), parameter :: amch4 = 16.0430_r8 ! Molecular weight of methane (g/mol) - ! real(kind=r8), parameter :: amn2o = 44.0128_r8 ! Molecular weight of nitrous oxide (g/mol) - ! Set molecular weight ratios (for converting mmr to vmr) - ! e.g. h2ovmr = h2ommr * amdw) - ! Molecular weight of dry air / water vapor - ! Molecular weight of dry air / carbon dioxide - ! Molecular weight of dry air / ozone - ! Molecular weight of dry air / methane - ! Molecular weight of dry air / nitrous oxide - ! Stefan-Boltzmann constant (W/m2K4) - INTEGER :: ib - INTEGER :: l - INTEGER :: imol - INTEGER :: ig ! Loop indices - REAL(KIND=r8) :: amm ! - REAL(KIND=r8) :: adjflx ! flux adjustment for Earth/Sun distance - ! real(kind=r8) :: earth_sun ! function for Earth/Sun distance adjustment - ! real(kind=r8) :: solar_band_irrad(jpb1:jpb2) ! rrtmg assumed-solar irradiance in each sw band - ! Initialize all molecular amounts to zero here, then pass input amounts - ! into RRTM array WKL below. - wkl(:,:) = 0.0_r8 - cldfmc(:,:) = 0.0_r8 - taucmc(:,:) = 0.0_r8 - ssacmc(:,:) = 1.0_r8 - asmcmc(:,:) = 0.0_r8 - fsfcmc(:,:) = 0.0_r8 - ciwpmc(:,:) = 0.0_r8 - clwpmc(:,:) = 0.0_r8 - reicmc(:) = 0.0_r8 - dgesmc(:) = 0.0_r8 - relqmc(:) = 0.0_r8 - taua(:,:) = 0.0_r8 - ssaa(:,:) = 1.0_r8 - asma(:,:) = 0.0_r8 - ! Set flux adjustment for current Earth/Sun distance (two options). - ! 1) Use Earth/Sun distance flux adjustment provided by GCM (input as adjes); - adjflx = adjes - ! - ! 2) Calculate Earth/Sun distance from DYOFYR, the cumulative day of the year. - ! (Set adjflx to 1. to use constant Earth/Sun distance of 1 AU). - if (dyofyr .gt. 0) then - adjflx = earth_sun(dyofyr) - endif - ! Set incoming solar flux adjustment to include adjustment for - ! current Earth/Sun distance (ADJFLX) and scaling of default internal - ! solar constant (rrsw_scon = 1368.22 Wm-2) by band (SOLVAR). SOLVAR can be set - ! to a single scaling factor as needed, or to a different value in each - ! band, which may be necessary for paleoclimate simulations. - ! - adjflux(:) = 0._r8 - do ib = jpb1,jpb2 - adjflux(ib) = adjflx * solvar(ib) - enddo - ! Set surface temperature. - tbound = tsfc(iplon) - ! Install input GCM arrays into RRTMG_SW arrays for pressure, temperature, - ! and molecular amounts. - ! Pressures are input in mb, or are converted to mb here. - ! Molecular amounts are input in volume mixing ratio, or are converted from - ! mass mixing ratio (or specific humidity for h2o) to volume mixing ratio - ! here. These are then converted to molecular amount (molec/cm2) below. - ! The dry air column COLDRY (in molec/cm2) is calculated from the level - ! pressures, pz (in mb), based on the hydrostatic equation and includes a - ! correction to account for h2o in the layer. The molecular weight of moist - ! air (amm) is calculated for each layer. - ! Note: In RRTMG, layer indexing goes from bottom to top, and coding below - ! assumes GCM input fields are also bottom to top. Input layer indexing - ! from GCM fields should be reversed here if necessary. - pz(0) = plev(iplon,nlay+1) - tz(0) = tlev(iplon,nlay+1) - do l = 1, nlay - pavel(l) = play(iplon,nlay-l+1) - tavel(l) = tlay(iplon,nlay-l+1) - pz(l) = plev(iplon,nlay-l+1) - tz(l) = tlev(iplon,nlay-l+1) - pdp(l) = pz(l-1) - pz(l) - ! For h2o input in vmr: - wkl(1,l) = h2ovmr(iplon,nlay-l+1) - ! For h2o input in mmr: - ! wkl(1,l) = h2o(iplon,nlayers-l)*amdw - ! For h2o input in specific humidity; - ! wkl(1,l) = (h2o(iplon,nlayers-l)/(1._r8 - h2o(iplon,nlayers-l)))*amdw - wkl(2,l) = co2vmr(iplon,nlay-l+1) - wkl(3,l) = o3vmr(iplon,nlay-l+1) - wkl(4,l) = n2ovmr(iplon,nlay-l+1) - wkl(6,l) = ch4vmr(iplon,nlay-l+1) - wkl(7,l) = o2vmr(iplon,nlay-l+1) - amm = (1._r8 - wkl(1,l)) * amd + wkl(1,l) * amw - coldry(l) = (pz(l-1)-pz(l)) * 1.e3_r8 * avogad / & - (1.e2_r8 * grav * amm * (1._r8 + wkl(1,l))) - enddo - coldry(nlay) = (pz(nlay-1)) * 1.e3_r8 * avogad / & - (1.e2_r8 * grav * amm * (1._r8 + wkl(1,nlay-1))) - ! At this point all molecular amounts in wkl are in volume mixing ratio; - ! convert to molec/cm2 based on coldry for use in rrtm. - do l = 1, nlay - do imol = 1, nmol - wkl(imol,l) = coldry(l) * wkl(imol,l) - enddo - enddo - ! Transfer aerosol optical properties to RRTM variables; - ! modify to reverse layer indexing here if necessary. - if (iaer .ge. 1) then - do l = 1, nlay-1 - do ib = 1, nbndsw - taua(l,ib) = tauaer(iplon,nlay-l,ib) - ssaa(l,ib) = ssaaer(iplon,nlay-l,ib) - asma(l,ib) = asmaer(iplon,nlay-l,ib) - enddo - enddo - endif - ! Transfer cloud fraction and cloud optical properties to RRTM variables; - ! modify to reverse layer indexing here if necessary. - if (icld .ge. 1) then - inflag = inflgsw - iceflag = iceflgsw - liqflag = liqflgsw - ! Move incoming GCM cloud arrays to RRTMG cloud arrays. - ! For GCM input, incoming reice is in effective radius; for Fu parameterization (iceflag = 3) - ! convert effective radius to generalized effective size using method of Mitchell, JAS, 2002: - do l = 1, nlay-1 - do ig = 1, ngptsw - cldfmc(ig,l) = cldfmcl(ig,iplon,nlay-l) - taucmc(ig,l) = taucmcl(ig,iplon,nlay-l) - ssacmc(ig,l) = ssacmcl(ig,iplon,nlay-l) - asmcmc(ig,l) = asmcmcl(ig,iplon,nlay-l) - fsfcmc(ig,l) = fsfcmcl(ig,iplon,nlay-l) - ciwpmc(ig,l) = ciwpmcl(ig,iplon,nlay-l) - clwpmc(ig,l) = clwpmcl(ig,iplon,nlay-l) - enddo - reicmc(l) = reicmcl(iplon,nlay-l) - if (iceflag .eq. 3) then - dgesmc(l) = 1.5396_r8 * reicmcl(iplon,nlay-l) - endif - relqmc(l) = relqmcl(iplon,nlay-l) - enddo - ! If an extra layer is being used in RRTMG, set all cloud properties to zero in the extra layer. - cldfmc(:,nlay) = 0.0_r8 - taucmc(:,nlay) = 0.0_r8 - ssacmc(:,nlay) = 1.0_r8 - asmcmc(:,nlay) = 0.0_r8 - fsfcmc(:,nlay) = 0.0_r8 - ciwpmc(:,nlay) = 0.0_r8 - clwpmc(:,nlay) = 0.0_r8 - reicmc(nlay) = 0.0_r8 - dgesmc(nlay) = 0.0_r8 - relqmc(nlay) = 0.0_r8 - taua(nlay,:) = 0.0_r8 - ssaa(nlay,:) = 1.0_r8 - asma(nlay,:) = 0.0_r8 - endif - END SUBROUTINE inatm_sw -!DIR$ ATTRIBUTES NOINLINE :: inatm_sw_new - SUBROUTINE inatm_sw_new(istart, iend, nlay, icld, iaer, play, plev, tlay, tlev, tsfc, h2ovmr, o3vmr, co2vmr, ch4vmr, o2vmr, n2ovmr, & - adjes, dyofyr, solvar, inflgsw, iceflgsw, liqflgsw, cldfmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl, ciwpmcl, clwpmcl, & - reicmcl, relqmcl, tauaer, ssaaer, asmaer, pavel, pz, pdp, tavel, tz, tbound, coldry, wkl, adjflux, inflag, iceflag, & - liqflag, cldfmc, taucmc, ssacmc, asmcmc, fsfcmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, taua, ssaa, asma) - !*************************************************************************** - ! - ! Input atmospheric profile from GCM, and prepare it for use in RRTMG_SW. - ! Set other RRTMG_SW input parameters. - ! - !*************************************************************************** - ! --------- Modules ---------- - USE parrrsw, ONLY: jpb1 - USE parrrsw, ONLY: jpb2 - USE parrrsw, ONLY: nmol - USE parrrsw, ONLY: nbndsw - USE parrrsw, ONLY: ngptsw - USE rrsw_con, ONLY: avogad - USE rrsw_con, ONLY: grav - ! ------- Declarations ------- - ! ----- Input ----- - INTEGER, intent(in) :: istart! column start index - INTEGER, intent(in) :: iend ! column end index - INTEGER, intent(in) :: nlay ! number of model layers - INTEGER, intent(in) :: icld ! clear/cloud and cloud overlap flag - INTEGER, intent(in) :: iaer ! aerosol option flag - REAL(KIND=r8), intent(in) :: play(:,:) ! Layer pressures (hPa, mb) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: plev(:,:) ! Interface pressures (hPa, mb) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(in) :: tlay(:,:) ! Layer temperatures (K) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: tlev(:,:) ! Interface temperatures (K) - ! Dimensions: (ncol,nlay+1) - REAL(KIND=r8), intent(in) :: tsfc(:) ! Surface temperature (K) - ! Dimensions: (ncol) - REAL(KIND=r8), intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: o2vmr(:,:) ! O2 volume mixing ratio - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio - ! Dimensions: (ncol,nlay) - INTEGER, intent(in) :: dyofyr ! Day of the year (used to get Earth/Sun - ! distance if adjflx not provided) - REAL(KIND=r8), intent(in) :: adjes ! Flux adjustment for Earth/Sun distance - REAL(KIND=r8), intent(in) :: solvar(jpb1:jpb2) ! Solar constant (Wm-2) scaling per band - INTEGER, intent(in) :: inflgsw ! Flag for cloud optical properties - INTEGER, intent(in) :: iceflgsw ! Flag for ice particle specification - INTEGER, intent(in) :: liqflgsw ! Flag for liquid droplet specification - REAL(KIND=r8), intent(in) :: cldfmcl(:,:,:) ! Cloud fraction - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: taucmcl(:,:,:) ! Cloud optical depth (optional) - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: ssacmcl(:,:,:) ! Cloud single scattering albedo - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: asmcmcl(:,:,:) ! Cloud asymmetry parameter - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: fsfcmcl(:,:,:) ! Cloud forward scattering fraction - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: ciwpmcl(:,:,:) ! Cloud ice water path (g/m2) - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: clwpmcl(:,:,:) ! Cloud liquid water path (g/m2) - ! Dimensions: (ngptsw,ncol,nlay) - REAL(KIND=r8), intent(in) :: reicmcl(:,:) ! Cloud ice effective radius (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(in) :: tauaer(:,:,:) ! Aerosol optical depth - ! Dimensions: (ncol,nlay,nbndsw) - REAL(KIND=r8), intent(in) :: ssaaer(:,:,:) ! Aerosol single scattering albedo - ! Dimensions: (ncol,nlay,nbndsw) - REAL(KIND=r8), intent(in) :: asmaer(:,:,:) ! Aerosol asymmetry parameter - ! Dimensions: (ncol,nlay,nbndsw) - ! Atmosphere - REAL(KIND=r8), intent(out) :: pavel(:,:) ! layer pressures (mb) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: tavel(:,:) ! layer temperatures (K) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: pz(:,0:) ! level (interface) pressures (hPa, mb) - ! Dimensions: (ncol,0:nlay) - REAL(KIND=r8), intent(out) :: tz(:,0:) ! level (interface) temperatures (K) - ! Dimensions: (ncol,0:nlay) - REAL(KIND=r8), intent(out) :: tbound(:) ! surface temperature (K) - ! Dimensions: (ncol) - REAL(KIND=r8), intent(out) :: pdp(:,:) ! layer pressure thickness (hPa, mb) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: coldry(:,:) ! dry air column density (mol/cm2) - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: wkl(:,:,:) ! molecular amounts (mol/cm-2) - ! Dimensions: (ncol,mxmol,nlay) - REAL(KIND=r8), intent(out) :: adjflux(:,:) ! adjustment for current Earth/Sun distance - ! Dimensions: (ncol,jpband) - ! real(kind=r8), intent(out) :: solvar(:) ! solar constant scaling factor from rrtmg_sw - ! Dimensions: (jpband) - ! default value of 1368.22 Wm-2 at 1 AU - REAL(KIND=r8), intent(out) :: taua(:,:,:) ! Aerosol optical depth - ! Dimensions: (ncol,nlay,nbndsw) - REAL(KIND=r8), intent(out) :: ssaa(:,:,:) ! Aerosol single scattering albedo - ! Dimensions: (ncol,nlay,nbndsw) - REAL(KIND=r8), intent(out) :: asma(:,:,:) ! Aerosol asymmetry parameter - ! Dimensions: (ncol,nlay,nbndsw) - ! Atmosphere/clouds - cldprop - INTEGER, intent(out) :: inflag(:) ! flag for cloud property method - ! Dimensions: (ncol) - INTEGER, intent(out) :: iceflag(:) ! flag for ice cloud properties - ! Dimensions: (ncol) - INTEGER, intent(out) :: liqflag(:) ! flag for liquid cloud properties - ! Dimensions: (ncol) - REAL(KIND=r8), intent(out) :: cldfmc(:,:,:) ! layer cloud fraction - ! Dimensions: (ncol,ngptsw,nlay) - REAL(KIND=r8), intent(out) :: taucmc(:,:,:) ! cloud optical depth (non-delta scaled) - ! Dimensions: (ncol,ngptsw,nlay) - REAL(KIND=r8), intent(out) :: ssacmc(:,:,:) ! cloud single scattering albedo (non-delta-scaled) - ! Dimensions: (ncol,ngptsw,nlay) - REAL(KIND=r8), intent(out) :: asmcmc(:,:,:) ! cloud asymmetry parameter (non-delta scaled) - REAL(KIND=r8), intent(out) :: fsfcmc(:,:,:) ! cloud forward scattering fraction (non-delta scaled) - ! Dimensions: (ncol,ngptsw,nlay) - REAL(KIND=r8), intent(out) :: ciwpmc(:,:,:) ! cloud ice water path - ! Dimensions: (ncol,ngptsw,nlay) - REAL(KIND=r8), intent(out) :: clwpmc(:,:,:) ! cloud liquid water path - ! Dimensions: (ncol,ngptsw,nlay) - REAL(KIND=r8), intent(out) :: reicmc(:,:) ! cloud ice particle effective radius - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: dgesmc(:,:) ! cloud ice particle effective radius - ! Dimensions: (ncol,nlay) - REAL(KIND=r8), intent(out) :: relqmc(:,:) ! cloud liquid particle size - ! Dimensions: (ncol,nlay) - ! ----- Local ----- - REAL(KIND=r8), parameter :: amd = 28.9660_r8 ! Effective molecular weight of dry air (g/mol) - REAL(KIND=r8), parameter :: amw = 18.0160_r8 ! Molecular weight of water vapor (g/mol) - ! real(kind=r8), parameter :: amc = 44.0098_r8 ! Molecular weight of carbon dioxide (g/mol) - ! real(kind=r8), parameter :: amo = 47.9998_r8 ! Molecular weight of ozone (g/mol) - ! real(kind=r8), parameter :: amo2 = 31.9999_r8 ! Molecular weight of oxygen (g/mol) - ! real(kind=r8), parameter :: amch4 = 16.0430_r8 ! Molecular weight of methane (g/mol) - ! real(kind=r8), parameter :: amn2o = 44.0128_r8 ! Molecular weight of nitrous oxide (g/mol) - ! Set molecular weight ratios (for converting mmr to vmr) - ! e.g. h2ovmr = h2ommr * amdw) - ! Molecular weight of dry air / water vapor - ! Molecular weight of dry air / carbon dioxide - ! Molecular weight of dry air / ozone - ! Molecular weight of dry air / methane - ! Molecular weight of dry air / nitrous oxide - ! Stefan-Boltzmann constant (W/m2K4) - INTEGER :: ib - INTEGER :: l - INTEGER :: imol - INTEGER :: iplon - INTEGER :: ig ! Loop indices - REAL(KIND=r8) :: amm ! - REAL(KIND=r8) :: adjflx ! flux adjustment for Earth/Sun distance - ! real(kind=r8) :: earth_sun ! function for Earth/Sun distance adjustment - ! real(kind=r8) :: solar_band_irrad(jpb1:jpb2) ! rrtmg assumed-solar irradiance in each sw band - ! Initialize all molecular amounts to zero here, then pass input amounts - ! into RRTM array WKL below. -#if 0 - wkl(:,:,:) = 0.0_r8 - cldfmc(:,:,:) = 0.0_r8 - taucmc(:,:,:) = 0.0_r8 - ssacmc(:,:,:) = 1.0_r8 - asmcmc(:,:,:) = 0.0_r8 - fsfcmc(:,:,:) = 0.0_r8 - ciwpmc(:,:,:) = 0.0_r8 - clwpmc(:,:,:) = 0.0_r8 - reicmc(:,:) = 0.0_r8 - dgesmc(:,:) = 0.0_r8 - relqmc(:,:) = 0.0_r8 - taua(:,:,:) = 0.0_r8 - ssaa(:,:,:) = 1.0_r8 - asma(:,:,:) = 0.0_r8 -#endif - ! Set flux adjustment for current Earth/Sun distance (two options). - ! 1) Use Earth/Sun distance flux adjustment provided by GCM (input as adjes); - adjflx = adjes - ! - ! 2) Calculate Earth/Sun distance from DYOFYR, the cumulative day of the year. - ! (Set adjflx to 1. to use constant Earth/Sun distance of 1 AU). - if (dyofyr .gt. 0) then - adjflx = earth_sun(dyofyr) - endif - ! Set incoming solar flux adjustment to include adjustment for - ! current Earth/Sun distance (ADJFLX) and scaling of default internal - ! solar constant (rrsw_scon = 1368.22 Wm-2) by band (SOLVAR). SOLVAR can be set - ! to a single scaling factor as needed, or to a different value in each - ! band, which may be necessary for paleoclimate simulations. - ! - do iplon=istart,iend - adjflux(iplon,:) = 0._r8 - do ib = jpb1,jpb2 - adjflux(iplon,ib) = adjflx * solvar(ib) - enddo - ! Set surface temperature. - tbound(iplon) = tsfc(iplon) - ! Install input GCM arrays into RRTMG_SW arrays for pressure, temperature, - ! and molecular amounts. - ! Pressures are input in mb, or are converted to mb here. - ! Molecular amounts are input in volume mixing ratio, or are converted from - ! mass mixing ratio (or specific humidity for h2o) to volume mixing ratio - ! here. These are then converted to molecular amount (molec/cm2) below. - ! The dry air column COLDRY (in molec/cm2) is calculated from the level - ! pressures, pz (in mb), based on the hydrostatic equation and includes a - ! correction to account for h2o in the layer. The molecular weight of moist - ! air (amm) is calculated for each layer. - ! Note: In RRTMG, layer indexing goes from bottom to top, and coding below - ! assumes GCM input fields are also bottom to top. Input layer indexing - ! from GCM fields should be reversed here if necessary. - pz(iplon,0) = plev(iplon,nlay+1) - tz(iplon,0) = tlev(iplon,nlay+1) - do l = 1, nlay - pavel(iplon,l) = play(iplon,nlay-l+1) - tavel(iplon,l) = tlay(iplon,nlay-l+1) - pz(iplon,l) = plev(iplon,nlay-l+1) - tz(iplon,l) = tlev(iplon,nlay-l+1) - pdp(iplon,l) = pz(iplon,l-1) - pz(iplon,l) - ! For h2o input in vmr: - wkl(iplon,1,l) = h2ovmr(iplon,nlay-l+1) - ! For h2o input in mmr: - ! wkl(1,l) = h2o(iplon,nlayers-l)*amdw - ! For h2o input in specific humidity; - ! wkl(1,l) = (h2o(iplon,nlayers-l)/(1._r8 - h2o(iplon,nlayers-l)))*amdw - wkl(iplon,2,l) = co2vmr(iplon,nlay-l+1) - wkl(iplon,3,l) = o3vmr(iplon,nlay-l+1) - wkl(iplon,4,l) = n2ovmr(iplon,nlay-l+1) - wkl(iplon,5,l) = 0._r8 - wkl(iplon,6,l) = ch4vmr(iplon,nlay-l+1) - wkl(iplon,7,l) = o2vmr(iplon,nlay-l+1) - amm = (1._r8 - wkl(iplon,1,l)) * amd + wkl(iplon,1,l) * amw - coldry(iplon,l) = (pz(iplon,l-1)-pz(iplon,l)) * 1.e3_r8 * avogad / & - (1.e2_r8 * grav * amm * (1._r8 + wkl(iplon,1,l))) - enddo - coldry(iplon,nlay) = (pz(iplon,nlay-1)) * 1.e3_r8 * avogad / & - (1.e2_r8 * grav * amm * (1._r8 + wkl(iplon,1,nlay-1))) - ! At this point all molecular amounts in wkl are in volume mixing ratio; - ! convert to molec/cm2 based on coldry for use in rrtm. - do l = 1, nlay - do imol = 1, nmol - wkl(iplon,imol,l) = coldry(iplon,l) * wkl(iplon,imol,l) - enddo - enddo - ! Transfer aerosol optical properties to RRTM variables; - ! modify to reverse layer indexing here if necessary. - if (iaer .ge. 1) then - do l = 1, nlay-1 - do ib = 1, nbndsw - taua(iplon,l,ib) = tauaer(iplon,nlay-l,ib) - ssaa(iplon,l,ib) = ssaaer(iplon,nlay-l,ib) - asma(iplon,l,ib) = asmaer(iplon,nlay-l,ib) - enddo - enddo - endif - ! Transfer cloud fraction and cloud optical properties to RRTM variables; - ! modify to reverse layer indexing here if necessary. - if (icld .ge. 1) then - inflag(iplon) = inflgsw - iceflag(iplon) = iceflgsw - liqflag(iplon) = liqflgsw - ! Move incoming GCM cloud arrays to RRTMG cloud arrays. - ! For GCM input, incoming reice is in effective radius; for Fu parameterization (iceflag = 3) - ! convert effective radius to generalized effective size using method of Mitchell, JAS, 2002: - do l = 1, nlay-1 - do ig = 1, ngptsw - cldfmc(iplon,ig,l) = cldfmcl(ig,iplon,nlay-l) - taucmc(iplon,ig,l) = taucmcl(ig,iplon,nlay-l) - ssacmc(iplon,ig,l) = ssacmcl(ig,iplon,nlay-l) - asmcmc(iplon,ig,l) = asmcmcl(ig,iplon,nlay-l) - fsfcmc(iplon,ig,l) = fsfcmcl(ig,iplon,nlay-l) - ciwpmc(iplon,ig,l) = ciwpmcl(ig,iplon,nlay-l) - clwpmc(iplon,ig,l) = clwpmcl(ig,iplon,nlay-l) - enddo - reicmc(iplon,l) = reicmcl(iplon,nlay-l) - if (iceflag(iplon) .eq. 3) then - dgesmc(iplon,l) = 1.5396_r8 * reicmcl(iplon,nlay-l) - endif - relqmc(iplon,l) = relqmcl(iplon,nlay-l) - enddo - ! If an extra layer is being used in RRTMG, set all cloud properties to zero in the extra layer. - cldfmc(iplon,:,nlay) = 0.0_r8 - taucmc(iplon,:,nlay) = 0.0_r8 - ssacmc(iplon,:,nlay) = 1.0_r8 - asmcmc(iplon,:,nlay) = 0.0_r8 - fsfcmc(iplon,:,nlay) = 0.0_r8 - ciwpmc(iplon,:,nlay) = 0.0_r8 - clwpmc(iplon,:,nlay) = 0.0_r8 - reicmc(iplon,nlay) = 0.0_r8 - dgesmc(iplon,nlay) = 0.0_r8 - relqmc(iplon,nlay) = 0.0_r8 - taua(iplon,nlay,:) = 0.0_r8 - ssaa(iplon,nlay,:) = 1.0_r8 - asma(iplon,nlay,:) = 0.0_r8 - endif - enddo - END SUBROUTINE inatm_sw_new - END MODULE rrtmg_sw_rad diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_reftra.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_reftra.f90 deleted file mode 100644 index 3b9f39dd3e..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_reftra.f90 +++ /dev/null @@ -1,298 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_sw_reftra.f90 -! Generated at: 2015-07-07 00:48:23 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_sw_reftra - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! ------- Modules ------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE rrsw_tbl, ONLY: od_lo - USE rrsw_tbl, ONLY: bpade - USE rrsw_tbl, ONLY: tblint - USE rrsw_tbl, ONLY: exp_tbl - USE rrsw_vsn, ONLY: hvrrft - IMPLICIT NONE - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - ! -------------------------------------------------------------------- - - SUBROUTINE reftra_sw(nlayers, ncol, lrtchk, pgg, prmuz, ptau, pw, pref, prefd, ptra, ptrad) - ! -------------------------------------------------------------------- - ! Purpose: computes the reflectivity and transmissivity of a clear or - ! cloudy layer using a choice of various approximations. - ! - ! Interface: *rrtmg_sw_reftra* is called by *rrtmg_sw_spcvrt* - ! - ! Description: - ! explicit arguments : - ! -------------------- - ! inputs - ! ------ - ! lrtchk = .t. for all layers in clear profile - ! lrtchk = .t. for cloudy layers in cloud profile - ! = .f. for clear layers in cloud profile - ! pgg = assymetry factor - ! prmuz(icol) = cosine solar zenith angle - ! ptau = optical thickness - ! pw = single scattering albedo - ! - ! outputs - ! ------- - ! pref : collimated beam reflectivity - ! prefd : diffuse beam reflectivity - ! ptra : collimated beam transmissivity - ! ptrad : diffuse beam transmissivity - ! - ! - ! Method: - ! ------- - ! standard delta-eddington, p.i.f.m., or d.o.m. layer calculations. - ! kmodts = 1 eddington (joseph et al., 1976) - ! = 2 pifm (zdunkowski et al., 1980) - ! = 3 discrete ordinates (liou, 1973) - ! - ! - ! Modifications: - ! -------------- - ! Original: J-JMorcrette, ECMWF, Feb 2003 - ! Revised for F90 reformatting: MJIacono, AER, Jul 2006 - ! Revised to add exponential lookup table: MJIacono, AER, Aug 2007 - ! - ! ------------------------------------------------------------------ - ! ------- Declarations ------ - ! ------- Input ------- - INTEGER, intent(in) :: nlayers - INTEGER, intent(in) :: ncol - LOGICAL, intent(in) :: lrtchk(:,:) ! Logical flag for reflectivity and - ! and transmissivity calculation; - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: pgg(:,:) ! asymmetry parameter - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: ptau(:,:) ! optical depth - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: pw(:,:) ! single scattering albedo - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: prmuz(:) ! cosine of solar zenith angle - ! ------- Output ------- - REAL(KIND=r8), intent(inout) :: pref(:,:) ! direct beam reflectivity - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(inout) :: prefd(:,:) ! diffuse beam reflectivity - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(inout) :: ptra(:,:) ! direct beam transmissivity - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(inout) :: ptrad(:,:) ! diffuse beam transmissivity - ! Dimensions: (nlayers+1) - ! ------- Local ------- - INTEGER :: kmodts - INTEGER :: jk - INTEGER :: itind, icol - REAL(KIND=r8) :: tblind - REAL(KIND=r8) :: za - REAL(KIND=r8) :: za1 - REAL(KIND=r8) :: za2 - REAL(KIND=r8) :: zbeta - REAL(KIND=r8) :: zdenr - REAL(KIND=r8) :: zdent - REAL(KIND=r8) :: zdend - REAL(KIND=r8) :: ze1 - REAL(KIND=r8) :: ze2 - REAL(KIND=r8) :: zem1 - REAL(KIND=r8) :: zep1 - REAL(KIND=r8) :: zem2 - REAL(KIND=r8) :: zep2 - REAL(KIND=r8) :: zemm - REAL(KIND=r8) :: zg - REAL(KIND=r8) :: zg3 - REAL(KIND=r8) :: zgamma1 - REAL(KIND=r8) :: zgamma2 - REAL(KIND=r8) :: zgamma3 - REAL(KIND=r8) :: zgamma4 - REAL(KIND=r8) :: zgt - REAL(KIND=r8) :: zr1 - REAL(KIND=r8) :: zr2 - REAL(KIND=r8) :: zr3 - REAL(KIND=r8) :: zr4 - REAL(KIND=r8) :: zr5 - REAL(KIND=r8) :: zrk - REAL(KIND=r8) :: zrp - REAL(KIND=r8) :: zrp1 - REAL(KIND=r8) :: zrm1 - REAL(KIND=r8) :: zrk2 - REAL(KIND=r8) :: zrpp - REAL(KIND=r8) :: zrkg - REAL(KIND=r8) :: zsr3 - REAL(KIND=r8) :: zto1 - REAL(KIND=r8) :: zt1 - REAL(KIND=r8) :: zt2 - REAL(KIND=r8) :: zt3 - REAL(KIND=r8) :: zt4 - REAL(KIND=r8) :: zt5 - REAL(KIND=r8) :: zwcrit - REAL(KIND=r8) :: zw - REAL(KIND=r8) :: zwo - REAL(KIND=r8), parameter :: eps = 1.e-08_r8 - ! ------------------------------------------------------------------ - ! Initialize - hvrrft = '$Revision: 1.2 $' - do icol = 1,ncol - zsr3=sqrt(3._r8) - zwcrit=0.9999995_r8 - kmodts=2 - do jk=1, nlayers - if (.not.lrtchk(icol,jk)) then - pref(icol,jk) =0._r8 - ptra(icol,jk) =1._r8 - prefd(icol,jk)=0._r8 - ptrad(icol,jk)=1._r8 - else - zto1=ptau(icol,jk) - zw =pw(icol,jk) - zg =pgg(icol,jk) - ! General two-stream expressions - zg3= 3._r8 * zg - if (kmodts == 1) then - zgamma1= (7._r8 - zw * (4._r8 + zg3)) * 0.25_r8 - zgamma2=-(1._r8 - zw * (4._r8 - zg3)) * 0.25_r8 - zgamma3= (2._r8 - zg3 * prmuz(icol) ) * 0.25_r8 - else if (kmodts == 2) then - zgamma1= (8._r8 - zw * (5._r8 + zg3)) * 0.25_r8 - zgamma2= 3._r8 *(zw * (1._r8 - zg )) * 0.25_r8 - zgamma3= (2._r8 - zg3 * prmuz(icol) ) * 0.25_r8 - else if (kmodts == 3) then - zgamma1= zsr3 * (2._r8 - zw * (1._r8 + zg)) * 0.5_r8 - zgamma2= zsr3 * zw * (1._r8 - zg ) * 0.5_r8 - zgamma3= (1._r8 - zsr3 * zg * prmuz(icol) ) * 0.5_r8 - end if - zgamma4= 1._r8 - zgamma3 - ! Recompute original s.s.a. to test for conservative solution - zwo= zw / (1._r8 - (1._r8 - zw) * (zg / (1._r8 - zg))**2) - if (zwo >= zwcrit) then - ! Conservative scattering - za = zgamma1 * prmuz(icol) - za1 = za - zgamma3 - zgt = zgamma1 * zto1 - ! Homogeneous reflectance and transmittance, - ! collimated beam - ze1 = min ( zto1 / prmuz(icol) , 500._r8) - ! ze2 = exp( -ze1 ) - ! Use exponential lookup table for transmittance, or expansion of - ! exponential for low tau - if (ze1 .le. od_lo) then - ze2 = 1._r8 - ze1 + 0.5_r8 * ze1 * ze1 - else - tblind = ze1 / (bpade + ze1) - itind = tblint * tblind + 0.5_r8 - ze2 = exp_tbl(itind) - endif - ! - pref(icol,jk) = (zgt - za1 * (1._r8 - ze2)) / (1._r8 + zgt) - ptra(icol,jk) = 1._r8 - pref(icol,jk) - ! isotropic incidence - prefd(icol,jk) = zgt / (1._r8 + zgt) - ptrad(icol,jk) = 1._r8 - prefd(icol,jk) - ! This is applied for consistency between total (delta-scaled) and direct (unscaled) - ! calculations at very low optical depths (tau < 1.e-4) when the exponential lookup - ! table returns a transmittance of 1.0. - if (ze2 .eq. 1.0_r8) then - pref(icol,jk) = 0.0_r8 - ptra(icol,jk) = 1.0_r8 - prefd(icol,jk) = 0.0_r8 - ptrad(icol,jk) = 1.0_r8 - endif - else - ! Non-conservative scattering - za1 = zgamma1 * zgamma4 + zgamma2 * zgamma3 - za2 = zgamma1 * zgamma3 + zgamma2 * zgamma4 - zrk = sqrt ( zgamma1**2 - zgamma2**2) - zrp = zrk * prmuz(icol) - zrp1 = 1._r8 + zrp - zrm1 = 1._r8 - zrp - zrk2 = 2._r8 * zrk - zrpp = 1._r8 - zrp*zrp - zrkg = zrk + zgamma1 - zr1 = zrm1 * (za2 + zrk * zgamma3) - zr2 = zrp1 * (za2 - zrk * zgamma3) - zr3 = zrk2 * (zgamma3 - za2 * prmuz(icol) ) - zr4 = zrpp * zrkg - zr5 = zrpp * (zrk - zgamma1) - zt1 = zrp1 * (za1 + zrk * zgamma4) - zt2 = zrm1 * (za1 - zrk * zgamma4) - zt3 = zrk2 * (zgamma4 + za1 * prmuz(icol) ) - zt4 = zr4 - zt5 = zr5 - zbeta = (zgamma1 - zrk) / zrkg !- zr5 / zr4 !- zr5 / zr4 - ! Homogeneous reflectance and transmittance - ze1 = min ( zrk * zto1, 500._r8) - ze2 = min ( zto1 / prmuz(icol) , 500._r8) - ! - ! Original - ! zep1 = exp( ze1 ) - ! zem1 = exp(-ze1 ) - ! zep2 = exp( ze2 ) - ! zem2 = exp(-ze2 ) - ! - ! Revised original, to reduce exponentials - ! zep1 = exp( ze1 ) - ! zem1 = 1._r8 / zep1 - ! zep2 = exp( ze2 ) - ! zem2 = 1._r8 / zep2 - ! - ! Use exponential lookup table for transmittance, or expansion of - ! exponential for low tau - if (ze1 .le. od_lo) then - zem1 = 1._r8 - ze1 + 0.5_r8 * ze1 * ze1 - zep1 = 1._r8 / zem1 - else - tblind = ze1 / (bpade + ze1) - itind = tblint * tblind + 0.5_r8 - zem1 = exp_tbl(itind) - zep1 = 1._r8 / zem1 - endif - if (ze2 .le. od_lo) then - zem2 = 1._r8 - ze2 + 0.5_r8 * ze2 * ze2 - zep2 = 1._r8 / zem2 - else - tblind = ze2 / (bpade + ze2) - itind = tblint * tblind + 0.5_r8 - zem2 = exp_tbl(itind) - zep2 = 1._r8 / zem2 - endif - ! collimated beam - zdenr = zr4*zep1 + zr5*zem1 - zdent = zt4*zep1 + zt5*zem1 - if (zdenr .ge. -eps .and. zdenr .le. eps) then - pref(icol,jk) = eps - ptra(icol,jk) = zem2 - else - pref(icol,jk) = zw * (zr1*zep1 - zr2*zem1 - zr3*zem2) / zdenr - ptra(icol,jk) = zem2 - zem2 * zw * (zt1*zep1 - zt2*zem1 - zt3*zep2) / zdent - endif - ! diffuse beam - zemm = zem1*zem1 - zdend = 1._r8 / ( (1._r8 - zbeta*zemm ) * zrkg) - prefd(icol,jk) = zgamma2 * (1._r8 - zemm) * zdend - ptrad(icol,jk) = zrk2*zem1*zdend - endif - endif - enddo -end do - END SUBROUTINE reftra_sw - END MODULE rrtmg_sw_reftra diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_setcoef.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_setcoef.f90 deleted file mode 100644 index cc95436a47..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_setcoef.f90 +++ /dev/null @@ -1,302 +0,0 @@ -! path: $Source: /storm/rc1/cvsroot/rc/rrtmg_sw/src/rrtmg_sw_setcoef.f90,v $ -! author: $Author: mike $ -! revision: $Revision: 1.2 $ -! created: $Date: 2007/08/23 20:40:14 $ - - module rrtmg_sw_setcoef - -! -------------------------------------------------------------------------- -! | | -! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | -! | This software may be used, copied, or redistributed as long as it is | -! | not sold and this copyright notice is reproduced on each copy made. | -! | This model is provided as is without any express or implied warranties. | -! | (http://www.rtweb.aer.com/) | -! | | -! -------------------------------------------------------------------------- - -! ------- Modules ------- - - use shr_kind_mod, only: r8 => shr_kind_r8 - -! use parkind, only : jpim, jprb - use rrsw_ref, only : preflog, tref - - implicit none - - contains - -!---------------------------------------------------------------------------- - subroutine setcoef_sw(ncol, nlayers, vec_pavel, vec_tavel, vec_pz, vec_tz, & - vec_tbound, vec_coldry, vec_wkl, & - vec_laytrop, vec_layswtch, vec_laylow, vec_jp, vec_jt, vec_jt1, & - vec_co2mult, vec_colch4, vec_colco2, vec_colh2o, vec_colmol, vec_coln2o, & - vec_colo2, vec_colo3, vec_fac00, vec_fac01, vec_fac10, vec_fac11, & - vec_selffac, vec_selffrac, vec_indself, vec_forfac, vec_forfrac, vec_indfor) -!---------------------------------------------------------------------------- -! -! Purpose: For a given atmosphere, calculate the indices and -! fractions related to the pressure and temperature interpolations. - -! Modifications: -! Original: J. Delamere, AER, Inc. (version 2.5, 02/04/01) -! Revised: Rewritten and adapted to ECMWF F90, JJMorcrette 030224 -! Revised: For uniform rrtmg formatting, MJIacono, Jul 2006 - -! ------ Declarations ------- - -! ----- Input ----- - - integer, intent(in) :: ncol ! total number of columns - integer, intent(in) :: nlayers ! total number of layers - - real(kind=r8), intent(in) :: vec_pavel(:,:) ! layer pressures (mb) - ! Dimensions: (ncol,nlayers) - real(kind=r8), intent(in) :: vec_tavel(:,:) ! layer temperatures (K) - ! Dimensions: (ncol,nlayers) - real(kind=r8), intent(in) :: vec_pz(:,0:) ! level (interface) pressures (hPa, mb) - ! Dimensions: (ncol,0:nlayers) - real(kind=r8), intent(in) :: vec_tz(:,0:) ! level (interface) temperatures (K) - ! Dimensions: (ncol,0:nlayers) - real(kind=r8), intent(in) :: vec_tbound(:) ! surface temperature (K) - real(kind=r8), intent(in) :: vec_coldry(:,:) ! dry air column density (mol/cm2) - ! Dimensions: (ncol,nlayers) - real(kind=r8), intent(in) :: vec_wkl(:,:,:) ! molecular amounts (mol/cm-2) - ! Dimensions: (mxmol,ncol,nlayers) - -! ----- Output ----- - integer, intent(out) :: vec_laytrop(:) ! tropopause layer index - integer, intent(out) :: vec_layswtch(:) ! - integer, intent(out) :: vec_laylow(:) ! - - integer, intent(out) :: vec_jp(:,:) ! - ! Dimensions: (ncol,nlayers) - integer, intent(out) :: vec_jt(:,:) ! - ! Dimensions: (ncol,nlayers) - integer, intent(out) :: vec_jt1(:,:) ! - ! Dimensions: (ncol,nlayers) - - real(kind=r8), intent(out) :: vec_colh2o(:,:) ! column amount (h2o) - ! Dimensions: (ncol,nlayers) - real(kind=r8), intent(out) :: vec_colco2(:,:) ! column amount (co2) - ! Dimensions: (ncol,nlayers) - real(kind=r8), intent(out) :: vec_colo3(:,:) ! column amount (o3) - ! Dimensions: (ncol,nlayers) - real(kind=r8), intent(out) :: vec_coln2o(:,:) ! column amount (n2o) - ! Dimensions: (ncol,nlayers) - real(kind=r8), intent(out) :: vec_colch4(:,:) ! column amount (ch4) - ! Dimensions: (ncol,nlayers) - real(kind=r8), intent(out) :: vec_colo2(:,:) ! column amount (o2) - ! Dimensions: (ncol,nlayers) - real(kind=r8), intent(out) :: vec_colmol(:,:) ! - ! Dimensions: (ncol,nlayers) - real(kind=r8), intent(out) :: vec_co2mult(:,:) ! - ! Dimensions: (ncol,nlayers) - - integer, intent(out) :: vec_indself(:,:) - ! Dimensions: (ncol,nlayers) - integer, intent(out) :: vec_indfor(:,:) - ! Dimensions: (ncol,nlayers) - real(kind=r8), intent(out) :: vec_selffac(:,:) - ! Dimensions: (ncol,nlayers) - real(kind=r8), intent(out) :: vec_selffrac(:,:) - ! Dimensions: (ncol,nlayers) - real(kind=r8), intent(out) :: vec_forfac(:,:) - ! Dimensions: (ncol,nlayers) - real(kind=r8), intent(out) :: vec_forfrac(:,:) - ! Dimensions: (ncol,nlayers) - - real(kind=r8), intent(out) :: & ! - vec_fac00(:,:), vec_fac01(:,:), & ! Dimensions: (ncol,nlayers) - vec_fac10(:,:), vec_fac11(:,:) - -! ----- Local ----- - - integer :: indbound - integer :: indlev0 - integer :: lay - integer :: jp1 - integer :: iplon - - real(kind=r8) :: stpfac - real(kind=r8) :: tbndfrac - real(kind=r8) :: t0frac - real(kind=r8) :: plog - real(kind=r8) :: fp - real(kind=r8) :: ft - real(kind=r8) :: ft1 - real(kind=r8) :: water - real(kind=r8) :: scalefac - real(kind=r8) :: factor - real(kind=r8) :: co2reg - real(kind=r8) :: compfp - - -! Initializations - - stpfac = 296._r8/1013._r8 - -!Begin column loop - do iplon=1, ncol - - vec_laytrop(iplon) = 0 - vec_layswtch(iplon) = 0 - vec_laylow(iplon) = 0 - - indbound = vec_tbound(iplon) - 159._r8 - tbndfrac = vec_tbound(iplon) - int(vec_tbound(iplon)) - indlev0 = vec_tz(iplon,0) - 159._r8 - t0frac = vec_tz(iplon,0) - int(vec_tz(iplon,0)) -! Begin layer loop - do lay = 1, nlayers -! Find the two reference pressures on either side of the -! layer pressure. Store them in JP and JP1. Store in FP the -! fraction of the difference (in ln(pressure)) between these -! two values that the layer pressure lies. - - plog = log(vec_pavel(iplon,lay)) - vec_jp(iplon,lay) = int(36._r8 - 5*(plog+0.04_r8)) - if (vec_jp(iplon,lay) .lt. 1) then - vec_jp(iplon,lay) = 1 - elseif (vec_jp(iplon,lay) .gt. 58) then - vec_jp(iplon,lay) = 58 - endif - jp1 = vec_jp(iplon,lay) + 1 - fp = 5._r8 * (preflog(vec_jp(iplon,lay)) - plog) - -! Determine, for each reference pressure (JP and JP1), which -! reference temperature (these are different for each -! reference pressure) is nearest the layer temperature but does -! not exceed it. Store these indices in JT and JT1, resp. -! Store in FT (resp. FT1) the fraction of the way between JT -! (JT1) and the next highest reference temperature that the -! layer temperature falls. - - vec_jt(iplon,lay) = int(3._r8 + (vec_tavel(iplon,lay)-tref(vec_jp(iplon,lay)))/15._r8) - if (vec_jt(iplon,lay) .lt. 1) then - vec_jt(iplon,lay) = 1 - elseif (vec_jt(iplon,lay) .gt. 4) then - vec_jt(iplon,lay) = 4 - endif - ft = ((vec_tavel(iplon,lay)-tref(vec_jp(iplon,lay)))/15._r8) - float(vec_jt(iplon,lay)-3) - vec_jt1(iplon,lay) = int(3._r8 + (vec_tavel(iplon,lay)-tref(jp1))/15._r8) - if (vec_jt1(iplon,lay) .lt. 1) then - vec_jt1(iplon,lay) = 1 - elseif (vec_jt1(iplon,lay) .gt. 4) then - vec_jt1(iplon,lay) = 4 - endif - ft1 = ((vec_tavel(iplon,lay)-tref(jp1))/15._r8) - float(vec_jt1(iplon,lay)-3) - - water = vec_wkl(iplon,1,lay)/vec_coldry(iplon,lay) - scalefac = vec_pavel(iplon,lay) * stpfac / vec_tavel(iplon,lay) - -! If the pressure is less than ~100mb, perform a different -! set of species interpolations. - - if (plog .le. 4.56_r8) go to 5300 - vec_laytrop(iplon) = vec_laytrop(iplon) + 1 - if (plog .ge. 6.62_r8) vec_laylow(iplon) = vec_laylow(iplon) + 1 - -! Set up factors needed to separately include the water vapor -! foreign-continuum in the calculation of absorption coefficient. - - vec_forfac(iplon,lay) = scalefac / (1.+water) - factor = (332.0_r8-vec_tavel(iplon,lay))/36.0_r8 - vec_indfor(iplon,lay) = min(2, max(1, int(factor))) - vec_forfrac(iplon,lay) = factor - float(vec_indfor(iplon,lay)) - -! Set up factors needed to separately include the water vapor -! self-continuum in the calculation of absorption coefficient. - - vec_selffac(iplon,lay) = water * vec_forfac(iplon,lay) - factor = (vec_tavel(iplon,lay)-188.0_r8)/7.2_r8 - vec_indself(iplon,lay) = min(9, max(1, int(factor)-7)) - vec_selffrac(iplon,lay) = factor - float(vec_indself(iplon,lay) + 7) - -! Calculate needed column amounts. - - vec_colh2o(iplon,lay) = 1.e-20_r8 * vec_wkl(iplon,1,lay) - vec_colco2(iplon,lay) = 1.e-20_r8 * vec_wkl(iplon,2,lay) - vec_colo3(iplon,lay) = 1.e-20_r8 * vec_wkl(iplon,3,lay) -! colo3(lay) = 0._r8 -! colo3(lay) = colo3(lay)/1.16_r8 - vec_coln2o(iplon,lay) = 1.e-20_r8 * vec_wkl(iplon,4,lay) - vec_colch4(iplon,lay) = 1.e-20_r8 * vec_wkl(iplon,6,lay) - vec_colo2(iplon,lay) = 1.e-20_r8 * vec_wkl(iplon,7,lay) - vec_colmol(iplon,lay) = 1.e-20_r8 * vec_coldry(iplon,lay) + vec_colh2o(iplon,lay) -! vec_colco2(lay) = 0._r8 -! colo3(lay) = 0._r8 -! coln2o(lay) = 0._r8 -! colch4(lay) = 0._r8 -! colo2(lay) = 0._r8 -! colmol(lay) = 0._r8 - if (vec_colco2(iplon,lay) .eq. 0._r8) vec_colco2(iplon,lay) = 1.e-32_r8 * vec_coldry(iplon,lay) - if (vec_coln2o(iplon,lay) .eq. 0._r8) vec_coln2o(iplon,lay) = 1.e-32_r8 * vec_coldry(iplon,lay) - if (vec_colch4(iplon,lay) .eq. 0._r8) vec_colch4(iplon,lay) = 1.e-32_r8 * vec_coldry(iplon,lay) - if (vec_colo2(iplon,lay) .eq. 0._r8) vec_colo2(iplon,lay) = 1.e-32_r8 * vec_coldry(iplon,lay) -! Using E = 1334.2 cm-1. - co2reg = 3.55e-24_r8 * vec_coldry(iplon,lay) - vec_co2mult(iplon,lay)= (vec_colco2(iplon,lay) - co2reg) * & - 272.63_r8*exp(-1919.4_r8/vec_tavel(iplon,lay))/(8.7604e-4_r8*vec_tavel(iplon,lay)) - goto 5400 - -! Above vec_laytrop. - 5300 continue - -! Set up factors needed to separately include the water vapor -! foreign-continuum in the calculation of absorption coefficient. - - vec_forfac(iplon,lay) = scalefac / (1.+water) - factor = (vec_tavel(iplon,lay)-188.0_r8)/36.0_r8 - vec_indfor(iplon,lay) = 3 - vec_forfrac(iplon,lay) = factor - 1.0_r8 - -! Calculate needed column amounts. - - vec_colh2o(iplon,lay) = 1.e-20_r8 * vec_wkl(iplon,1,lay) - vec_colco2(iplon,lay) = 1.e-20_r8 * vec_wkl(iplon,2,lay) - vec_colo3(iplon,lay) = 1.e-20_r8 * vec_wkl(iplon,3,lay) - vec_coln2o(iplon,lay) = 1.e-20_r8 * vec_wkl(iplon,4,lay) - vec_colch4(iplon,lay) = 1.e-20_r8 * vec_wkl(iplon,6,lay) - vec_colo2(iplon,lay) = 1.e-20_r8 * vec_wkl(iplon,7,lay) - vec_colmol(iplon,lay) = 1.e-20_r8 * vec_coldry(iplon,lay) + vec_colh2o(iplon,lay) - if (vec_colco2(iplon,lay) .eq. 0._r8) vec_colco2(iplon,lay) = 1.e-32_r8 * vec_coldry(iplon,lay) - if (vec_coln2o(iplon,lay) .eq. 0._r8) vec_coln2o(iplon,lay) = 1.e-32_r8 * vec_coldry(iplon,lay) - if (vec_colch4(iplon,lay) .eq. 0._r8) vec_colch4(iplon,lay) = 1.e-32_r8 * vec_coldry(iplon,lay) - if (vec_colo2(iplon,lay) .eq. 0._r8) vec_colo2(iplon,lay) = 1.e-32_r8 * vec_coldry(iplon,lay) - co2reg = 3.55e-24_r8 * vec_coldry(iplon,lay) - vec_co2mult(iplon,lay)= (vec_colco2(iplon,lay) - co2reg) * & - 272.63_r8*exp(-1919.4_r8/vec_tavel(iplon,lay))/(8.7604e-4_r8*vec_tavel(iplon,lay)) - - vec_selffac(iplon,lay) = 0._r8 - vec_selffrac(iplon,lay)= 0._r8 - vec_indself(iplon,lay) = 0 - - 5400 continue - -! We have now isolated the layer ln pressure and temperature, -! between two reference pressures and two reference temperatures -! (for each reference pressure). We multiply the pressure -! fraction FP with the appropriate temperature fractions to get -! the factors that will be needed for the interpolation that yields -! the optical depths (performed in routines TAUGBn for band n). - - compfp = 1._r8 - fp - vec_fac10(iplon,lay) = compfp * ft - vec_fac00(iplon,lay) = compfp * (1._r8 - ft) - vec_fac11(iplon,lay) = fp * ft1 - vec_fac01(iplon,lay) = fp * (1._r8 - ft1) - - ! End layer loop - enddo - - !End column loop - enddo - - end subroutine setcoef_sw - -!*************************************************************************** - - end module rrtmg_sw_setcoef - - diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_spcvmc.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_spcvmc.f90 deleted file mode 100644 index a00aee15bf..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_spcvmc.f90 +++ /dev/null @@ -1,624 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_sw_spcvmc.f90 -! Generated at: 2015-07-07 00:48:25 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_sw_spcvmc - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! ------- Modules ------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE parrrsw, ONLY: ngptsw - USE rrsw_tbl, ONLY: od_lo - USE rrsw_tbl, ONLY: bpade - USE rrsw_tbl, ONLY: tblint - USE rrsw_tbl, ONLY: exp_tbl - USE rrsw_wvn, ONLY: ngc - USE rrsw_wvn, ONLY: ngs - USE rrtmg_sw_reftra, ONLY: reftra_sw - USE rrtmg_sw_taumol, ONLY: taumol_sw - USE rrtmg_sw_vrtqdr, ONLY: vrtqdr_sw - IMPLICIT NONE - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - ! --------------------------------------------------------------------------- - - SUBROUTINE spcvmc_sw(lchnk, ncol, nlayers, istart, iend, icpr, idelm, iout, pavel, tavel, pz, tz, tbound, palbd, palbp, & - pcldfmc, ptaucmc, pasycmc, pomgcmc, ptaormc, ptaua, pasya, pomga, prmu0, coldry, wkl, adjflux, laytrop, layswtch, laylow, & - jp, jt, jt1, co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3, fac00, fac01, fac10, fac11, selffac, selffrac,& - indself, forfac, forfrac, indfor, pbbfd, pbbfu, pbbcd, pbbcu, puvfd, puvcd, pnifd, pnicd, pnifu, pnicu, pbbfddir, & - pbbcddir, puvfddir, puvcddir, pnifddir, pnicddir, pbbfsu, pbbfsd) - ! --------------------------------------------------------------------------- - ! - ! Purpose: Contains spectral loop to compute the shortwave radiative fluxes, - ! using the two-stream method of H. Barker and McICA, the Monte-Carlo - ! Independent Column Approximation, for the representation of - ! sub-grid cloud variability (i.e. cloud overlap). - ! - ! Interface: *spcvmc_sw* is called from *rrtmg_sw.F90* or rrtmg_sw.1col.F90* - ! - ! Method: - ! Adapted from two-stream model of H. Barker; - ! Two-stream model options (selected with kmodts in rrtmg_sw_reftra.F90): - ! 1: Eddington, 2: PIFM, Zdunkowski et al., 3: discret ordinates - ! - ! Modifications: - ! - ! Original: H. Barker - ! Revision: Merge with RRTMG_SW: J.-J.Morcrette, ECMWF, Feb 2003 - ! Revision: Add adjustment for Earth/Sun distance : MJIacono, AER, Oct 2003 - ! Revision: Bug fix for use of PALBP and PALBD: MJIacono, AER, Nov 2003 - ! Revision: Bug fix to apply delta scaling to clear sky: AER, Dec 2004 - ! Revision: Code modified so that delta scaling is not done in cloudy profiles - ! if routine cldprop is used; delta scaling can be applied by swithcing - ! code below if cldprop is not used to get cloud properties. - ! AER, Jan 2005 - ! Revision: Modified to use McICA: MJIacono, AER, Nov 2005 - ! Revision: Uniform formatting for RRTMG: MJIacono, AER, Jul 2006 - ! Revision: Use exponential lookup table for transmittance: MJIacono, AER, - ! Aug 2007 - ! - ! ------------------------------------------------------------------ - ! ------- Declarations ------ - ! ------- Input ------- - INTEGER, intent(in) :: lchnk - INTEGER, intent(in) :: nlayers - INTEGER, intent(in) :: istart - INTEGER, intent(in) :: iend - INTEGER, intent(in) :: icpr - INTEGER, intent(in) :: idelm ! delta-m scaling flag - ! [0 = direct and diffuse fluxes are unscaled] - ! [1 = direct and diffuse fluxes are scaled] - INTEGER, intent(in) :: iout - INTEGER, intent(in) :: ncol ! column loop index - INTEGER, intent(in) :: laytrop(ncol) - INTEGER, intent(in) :: layswtch(ncol) - INTEGER, intent(in) :: laylow(ncol) - INTEGER, intent(in) :: indfor(:,:) - ! Dimensions: (ncol,nlayers) - INTEGER, intent(in) :: indself(:,:) - ! Dimensions: (ncol,nlayers) - INTEGER, intent(in) :: jp(:,:) - ! Dimensions: (ncol,nlayers) - INTEGER, intent(in) :: jt(:,:) - ! Dimensions: (ncol,nlayers) - INTEGER, intent(in) :: jt1(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: pavel(:,:) ! layer pressure (hPa, mb) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: tavel(:,:) ! layer temperature (K) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: pz(:,0:) ! level (interface) pressure (hPa, mb) - ! Dimensions: (ncol,0:nlayers) - REAL(KIND=r8), intent(in) :: tz(:,0:) ! level temperatures (hPa, mb) - ! Dimensions: (ncol,0:nlayers) - REAL(KIND=r8), intent(in) :: tbound(ncol) ! surface temperature (K) - REAL(KIND=r8), intent(in) :: wkl(:,:,:) ! molecular amounts (mol/cm2) - ! Dimensions: (ncol,mxmol,nlayers) - REAL(KIND=r8), intent(in) :: coldry(:,:) ! dry air column density (mol/cm2) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: colmol(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: adjflux(:,:) ! Earth/Sun distance adjustment - ! Dimensions: (ncol,jpband) - REAL(KIND=r8), intent(in) :: palbd(:,:) ! surface albedo (diffuse) - ! Dimensions: (ncol,nbndsw) - REAL(KIND=r8), intent(in) :: palbp(:,:) ! surface albedo (direct) - ! Dimensions: (ncol, nbndsw) - REAL(KIND=r8), intent(in) :: prmu0(ncol) ! cosine of solar zenith angle - REAL(KIND=r8), intent(in) :: pcldfmc(:,:,:) ! cloud fraction [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - REAL(KIND=r8), intent(in) :: ptaucmc(:,:,:) ! cloud optical depth [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - REAL(KIND=r8), intent(in) :: pasycmc(:,:,:) ! cloud asymmetry parameter [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - REAL(KIND=r8), intent(in) :: pomgcmc(:,:,:) ! cloud single scattering albedo [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - REAL(KIND=r8), intent(in) :: ptaormc(:,:,:) ! cloud optical depth, non-delta scaled [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - REAL(KIND=r8), intent(in) :: ptaua(:,:,:) ! aerosol optical depth - ! Dimensions: (ncol,nlayers,nbndsw) - REAL(KIND=r8), intent(in) :: pasya(:,:,:) ! aerosol asymmetry parameter - ! Dimensions: (ncol,nlayers,nbndsw) - REAL(KIND=r8), intent(in) :: pomga(:,:,:) ! aerosol single scattering albedo - ! Dimensions: (ncol,nlayers,nbndsw) - REAL(KIND=r8), intent(in) :: colh2o(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: colco2(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: colch4(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: co2mult(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: colo3(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: colo2(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: coln2o(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: forfac(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: forfrac(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: selffac(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: selffrac(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: fac00(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: fac01(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: fac10(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: fac11(:,:) - ! Dimensions: (ncol,nlayers) - ! ------- Output ------- - ! All Dimensions: (nlayers+1) - REAL(KIND=r8), intent(out) :: pbbcd(:,:) - REAL(KIND=r8), intent(out) :: pbbcu(:,:) - REAL(KIND=r8), intent(out) :: pbbfd(:,:) - REAL(KIND=r8), intent(out) :: pbbfu(:,:) - REAL(KIND=r8), intent(out) :: pbbfddir(:,:) - REAL(KIND=r8), intent(out) :: pbbcddir(:,:) - REAL(KIND=r8), intent(out) :: puvcd(:,:) - REAL(KIND=r8), intent(out) :: puvfd(:,:) - REAL(KIND=r8), intent(out) :: puvcddir(:,:) - REAL(KIND=r8), intent(out) :: puvfddir(:,:) - REAL(KIND=r8), intent(out) :: pnicd(:,:) - REAL(KIND=r8), intent(out) :: pnifd(:,:) - REAL(KIND=r8), intent(out) :: pnicddir(:,:) - REAL(KIND=r8), intent(out) :: pnifddir(:,:) - ! Added for net near-IR flux diagnostic - REAL(KIND=r8), intent(out) :: pnicu(:,:) - REAL(KIND=r8), intent(out) :: pnifu(:,:) - ! Output - inactive ! All Dimensions: (nlayers+1) - ! real(kind=r8), intent(out) :: puvcu(:) - ! real(kind=r8), intent(out) :: puvfu(:) - ! real(kind=r8), intent(out) :: pvscd(:) - ! real(kind=r8), intent(out) :: pvscu(:) - ! real(kind=r8), intent(out) :: pvsfd(:) - ! real(kind=r8), intent(out) :: pvsfu(:) - REAL(KIND=r8), intent(out) :: pbbfsu(:,:,:) ! shortwave spectral flux up (nswbands,nlayers+1) - REAL(KIND=r8), intent(out) :: pbbfsd(:,:,:) ! shortwave spectral flux down (nswbands,nlayers+1) - ! ------- Local ------- - LOGICAL :: lrtchkclr(ncol,nlayers) - LOGICAL :: lrtchkcld(ncol,nlayers) - INTEGER :: klev - INTEGER :: ib1 - INTEGER :: ib2 - INTEGER :: ibm - INTEGER :: igt - INTEGER :: ikl - INTEGER :: iw(ncol) - INTEGER :: jk - INTEGER :: jb - INTEGER :: jg, iplon - ! integer, parameter :: nuv = ?? - ! integer, parameter :: nvs = ?? - INTEGER :: itind(ncol) - REAL(KIND=r8) :: ze1(ncol) - REAL(KIND=r8) :: tblind(ncol) - REAL(KIND=r8) :: zclear(ncol) - REAL(KIND=r8) :: zcloud(ncol) - REAL(KIND=r8) :: zdbt(ncol,nlayers+1) - REAL(KIND=r8) :: zdbt_nodel(ncol,nlayers+1) - REAL(KIND=r8) :: zgcc(ncol,nlayers) - REAL(KIND=r8) :: zgco(ncol,nlayers) - REAL(KIND=r8) :: zomcc(ncol,nlayers) - REAL(KIND=r8) :: zomco(ncol,nlayers) - REAL(KIND=r8) :: zrdndc(ncol,nlayers+1) - REAL(KIND=r8) :: zrdnd(ncol,nlayers+1) - REAL(KIND=r8) :: zrefc(ncol,nlayers+1) - REAL(KIND=r8) :: zrefo(ncol,nlayers+1) - REAL(KIND=r8) :: zref( ncol,nlayers+1) - REAL(KIND=r8) :: zrefdc(ncol,nlayers+1) - REAL(KIND=r8) :: zrefdo(ncol,nlayers+1) - REAL(KIND=r8) :: zrefd(ncol,nlayers+1) - REAL(KIND=r8) :: zrup(ncol,nlayers+1) - REAL(KIND=r8) :: zrupd(ncol,nlayers+1) - REAL(KIND=r8) :: zrupc(ncol,nlayers+1) - REAL(KIND=r8) :: zrupdc(ncol,nlayers+1) - REAL(KIND=r8) :: ztauc(ncol,nlayers) - REAL(KIND=r8) :: ztauo(ncol,nlayers) - REAL(KIND=r8) :: ztdbt(ncol,nlayers+1) - REAL(KIND=r8) :: ztrac(ncol,nlayers+1) - REAL(KIND=r8) :: ztrao(ncol,nlayers+1) - REAL(KIND=r8) :: ztra(ncol,nlayers+1) - REAL(KIND=r8) :: ztradc(ncol,nlayers+1) - REAL(KIND=r8) :: ztrado(ncol,nlayers+1) - REAL(KIND=r8) :: ztrad(ncol,nlayers+1) - REAL(KIND=r8) :: ztdbtc(ncol,nlayers+1) - REAL(KIND=r8) :: zdbtc(ncol,nlayers+1) - REAL(KIND=r8) :: zincflx(ncol,ngptsw) - REAL(KIND=r8) :: zdbtc_nodel(ncol,nlayers+1) - REAL(KIND=r8) :: ztdbtc_nodel(ncol,nlayers+1) - REAL(KIND=r8) :: ztdbt_nodel(ncol,nlayers+1) - REAL(KIND=r8) :: zdbtmc(ncol) - REAL(KIND=r8) :: zdbtmo(ncol) - REAL(KIND=r8) :: zf - REAL(KIND=r8) :: repclc(ncol) - REAL(KIND=r8) :: tauorig(ncol) - REAL(KIND=r8) :: zwf - ! real(kind=r8) :: zincflux ! inactive - ! Arrays from rrtmg_sw_taumoln routines - ! real(kind=r8) :: ztaug(nlayers,16), ztaur(nlayers,16) - ! real(kind=r8) :: zsflxzen(16) - REAL(KIND=r8) :: ztaug(ncol,nlayers,ngptsw) - REAL(KIND=r8) :: ztaur(ncol,nlayers,ngptsw) - REAL(KIND=r8) :: zsflxzen(ncol,ngptsw) - ! Arrays from rrtmg_sw_vrtqdr routine - REAL(KIND=r8) :: zcd(ncol,nlayers+1,ngptsw) - REAL(KIND=r8) :: zcu(ncol,nlayers+1,ngptsw) - REAL(KIND=r8) :: zfd(ncol,nlayers+1,ngptsw) - REAL(KIND=r8) :: zfu(ncol,nlayers+1,ngptsw) - ! Inactive arrays - ! real(kind=r8) :: zbbcd(nlayers+1), zbbcu(nlayers+1) - ! real(kind=r8) :: zbbfd(nlayers+1), zbbfu(nlayers+1) - ! real(kind=r8) :: zbbfddir(nlayers+1), zbbcddir(nlayers+1) - ! ------------------------------------------------------------------ - ! Initializations - ib1 = istart - ib2 = iend - klev = nlayers - !djp repclc(iplon) = 1.e-12_r8 - repclc(:) = 1.e-12_r8 - ! zincflux = 0.0_r8 - do iplon=1,ncol - do jk=1,klev+1 - pbbcd(iplon,jk)=0._r8 - pbbcu(iplon,jk)=0._r8 - pbbfd(iplon,jk)=0._r8 - pbbfu(iplon,jk)=0._r8 - pbbcddir(iplon,jk)=0._r8 - pbbfddir(iplon,jk)=0._r8 - puvcd(iplon,jk)=0._r8 - puvfd(iplon,jk)=0._r8 - puvcddir(iplon,jk)=0._r8 - puvfddir(iplon,jk)=0._r8 - pnicd(iplon,jk)=0._r8 - pnifd(iplon,jk)=0._r8 - pnicddir(iplon,jk)=0._r8 - pnifddir(iplon,jk)=0._r8 - pnicu(iplon,jk)=0._r8 - pnifu(iplon,jk)=0._r8 - enddo - end do - call taumol_sw(ncol,klev, & - colh2o, colco2, colch4, colo2, colo3, colmol, & - laytrop, jp, jt, jt1, & - fac00, fac01, fac10, fac11, & - selffac, selffrac, indself, forfac, forfrac,indfor, & - zsflxzen, ztaug, ztaur) - - jb = ib1-1 ! ??? ! ??? - do iplon=1,ncol - iw(iplon) =0 - end do - do jb = ib1, ib2 - ibm = jb-15 - igt = ngc(ibm) - ! Reinitialize g-point counter for each band if output for each band is requested. - ! do jk=1,klev+1 - ! zbbcd(jk)=0.0_r8 - ! zbbcu(jk)=0.0_r8 - ! zbbfd(jk)=0.0_r8 - ! zbbfu(jk)=0.0_r8 - ! enddo - ! Top of g-point interval loop within each band (iw(iplon) is cumulative counter) - - DO IPLON=1,ncol - if (iout.gt.0.and.ibm.ge.2) iw(iplon)= ngs(ibm-1) - END do - do jg = 1,igt - do iplon=1,ncol - - iw(iplon) = iw(iplon)+1 - ! Apply adjustment for correct Earth/Sun distance and zenith angle to incoming solar flux - zincflx(iplon,iw(iplon)) = adjflux(iplon,jb) * zsflxzen(iplon,iw(iplon)) * prmu0(iplon) - ! zincflux = zincflux + adjflux(jb) * zsflxzen(iw(iplon)) * prmu0 ! inactive - ! Compute layer reflectances and transmittances for direct and diffuse sources, - ! first clear then cloudy - ! zrefc(iplon,jk) direct albedo for clear - ! zrefo(iplon,jk) direct albedo for cloud - ! zrefdc(iplon,jk) diffuse albedo for clear - ! zrefdo(iplon,jk) diffuse albedo for cloud - ! ztrac(iplon,jk) direct transmittance for clear - ! ztrao(iplon,jk) direct transmittance for cloudy - ! ztradc(iplon,jk) diffuse transmittance for clear - ! ztrado(iplon,jk) diffuse transmittance for cloudy - ! - ! zref(iplon,jk) direct reflectance - ! zrefd(iplon,jk) diffuse reflectance - ! ztra(iplon,jk) direct transmittance - ! ztrad(iplon,jk) diffuse transmittance - ! - ! zdbtc(iplon,jk) clear direct beam transmittance - ! zdbto(jk) cloudy direct beam transmittance - ! zdbt(iplon,jk) layer mean direct beam transmittance - ! ztdbt(iplon,jk) total direct beam transmittance at levels - ! Clear-sky - ! TOA direct beam - ztdbtc(iplon,1)=1.0_r8 - ztdbtc_nodel(iplon,1)=1.0_r8 - ! Surface values - zdbtc(iplon,klev+1) =0.0_r8 - ztrac(iplon,klev+1) =0.0_r8 - ztradc(iplon,klev+1)=0.0_r8 - zrefc(iplon,klev+1) =palbp(iplon,ibm) - zrefdc(iplon,klev+1)=palbd(iplon,ibm) - zrupc(iplon,klev+1) =palbp(iplon,ibm) - zrupdc(iplon,klev+1)=palbd(iplon,ibm) - ! Cloudy-sky - ! Surface values - ztrao(iplon,klev+1) =0.0_r8 - ztrado(iplon,klev+1)=0.0_r8 - zrefo(iplon,klev+1) =palbp(iplon,ibm) - zrefdo(iplon,klev+1)=palbd(iplon,ibm) - ! Total sky - ! TOA direct beam - ztdbt(iplon,1)=1.0_r8 - ztdbt_nodel(iplon,1)=1.0_r8 - ! Surface values - zdbt(iplon,klev+1) =0.0_r8 - ztra(iplon,klev+1) =0.0_r8 - ztrad(iplon,klev+1)=0.0_r8 - zref(iplon,klev+1) =palbp(iplon,ibm) - zrefd(iplon,klev+1)=palbd(iplon,ibm) - zrup(iplon,klev+1) =palbp(iplon,ibm) - zrupd(iplon,klev+1)=palbd(iplon,ibm) - ! Top of layer loop - do jk=1,klev - ! Note: two-stream calculations proceed from top to bottom; - ! RRTMG_SW quantities are given bottom to top and are reversed here - ikl=klev+1-jk - ! Set logical flag to do REFTRA calculation - ! Do REFTRA for all clear layers - lrtchkclr(iplon,jk)=.true. - ! Do REFTRA only for cloudy layers in profile, since already done for clear layers - lrtchkcld(iplon,jk)=.false. - lrtchkcld(iplon,jk)=(pcldfmc(iplon,ikl,iw(iplon)) > repclc(iplon)) - ! Clear-sky optical parameters - this section inactive - ! Original - ! ztauc(iplon,jk) = ztaur(ikl,iw(iplon)) + ztaug(ikl,iw(iplon)) - ! zomcc(iplon,jk) = ztaur(ikl,iw(iplon)) / ztauc(iplon,jk) - ! zgcc(iplon,jk) = 0.0001_r8 - ! Total sky optical parameters - ! ztauo(iplon,jk) = ztaur(ikl,iw(iplon)) + ztaug(ikl,iw(iplon)) + ptaucmc(ikl,iw(iplon)) - ! zomco(iplon,jk) = ptaucmc(ikl,iw(iplon)) * pomgcmc(ikl,iw(iplon)) + ztaur(ikl,iw(iplon)) - ! zgco (jk) = (ptaucmc(ikl,iw(iplon)) * pomgcmc(ikl,iw(iplon)) * pasycmc(ikl,iw(iplon)) + & - ! ztaur(ikl,iw(iplon)) * 0.0001_r8) / zomco(iplon,jk) - ! zomco(iplon,jk) = zomco(iplon,jk) / ztauo(iplon,jk) - ! Clear-sky optical parameters including aerosols - ztauc(iplon,jk) = ztaur(iplon,ikl,iw(iplon)) + ztaug(iplon,ikl,iw(iplon)) + ptaua(iplon,ikl,ibm) - zomcc(iplon,jk) = ztaur(iplon,ikl,iw(iplon)) * 1.0_r8 + ptaua(iplon,ikl,ibm) * pomga(iplon,ikl,ibm) - zgcc(iplon,jk) = pasya(iplon,ikl,ibm) * pomga(iplon,ikl,ibm) * ptaua(iplon,ikl,ibm) / zomcc(iplon,jk) - zomcc(iplon,jk) = zomcc(iplon,jk) / ztauc(iplon,jk) - ! Pre-delta-scaling clear and cloudy direct beam transmittance (must use 'orig', unscaled cloud OD) - ! \/\/\/ This block of code is only needed for unscaled direct beam calculation - if (idelm .eq. 0) then - ! - zclear(iplon) = 1.0_r8 - pcldfmc(iplon,ikl,iw(iplon)) - zcloud(iplon) = pcldfmc(iplon,ikl,iw(iplon)) - ! Clear - ! zdbtmc(iplon) = exp(-ztauc(iplon,jk) / prmu0) - ! Use exponential lookup table for transmittance, or expansion of exponential for low tau - ze1(iplon) = ztauc(iplon,jk) / prmu0(iplon) - if (ze1(iplon) .le. od_lo) then - zdbtmc(iplon) = 1._r8 - ze1(iplon) + 0.5_r8 * ze1(iplon) * ze1(iplon) - else - tblind(iplon) = ze1(iplon) / (bpade + ze1(iplon)) - itind(iplon) = tblint * tblind(iplon) + 0.5_r8 - zdbtmc(iplon) = exp_tbl(itind(iplon)) - endif - zdbtc_nodel(iplon,jk) = zdbtmc(iplon) - ztdbtc_nodel(iplon,jk+1) = zdbtc_nodel(iplon,jk) * ztdbtc_nodel(iplon,jk) - ! Clear + Cloud - tauorig(iplon) = ztauc(iplon,jk) + ptaormc(iplon,ikl,iw(iplon)) - ! zdbtmo(iplon) = exp(-tauorig(iplon) / prmu0) - ! Use exponential lookup table for transmittance, or expansion of exponential for low tau - ze1(iplon) = tauorig(iplon) / prmu0(iplon) - if (ze1(iplon) .le. od_lo) then - zdbtmo(iplon) = 1._r8 - ze1(iplon) + 0.5_r8 * ze1(iplon) * ze1(iplon) - else - tblind(iplon) = ze1(iplon) / (bpade + ze1(iplon)) - itind(iplon) = tblint * tblind(iplon) + 0.5_r8 - zdbtmo(iplon) = exp_tbl(itind(iplon)) - endif - zdbt_nodel(iplon,jk) = zclear(iplon)*zdbtmc(iplon) + zcloud(iplon)*zdbtmo(iplon) - ztdbt_nodel(iplon,jk+1) = zdbt_nodel(iplon,jk) * ztdbt_nodel(iplon,jk) - endif - ! /\/\/\ Above code only needed for unscaled direct beam calculation - ! Delta scaling - clear - zf = zgcc(iplon,jk) * zgcc(iplon,jk) - zwf = zomcc(iplon,jk) * zf - ztauc(iplon,jk) = (1.0_r8 - zwf) * ztauc(iplon,jk) - zomcc(iplon,jk) = (zomcc(iplon,jk) - zwf) / (1.0_r8 - zwf) - zgcc (iplon,jk) = (zgcc(iplon,jk) - zf) / (1.0_r8 - zf) - ! Total sky optical parameters (cloud properties already delta-scaled) - ! Use this code if cloud properties are derived in rrtmg_sw_cldprop - if (icpr .ge. 1) then - ztauo(iplon,jk) = ztauc(iplon,jk) + ptaucmc(iplon,ikl,iw(iplon)) - zomco(iplon,jk) = ztauc(iplon,jk) * zomcc(iplon,jk) + ptaucmc(iplon,ikl,iw(iplon)) * pomgcmc(iplon,ikl,iw(iplon)) - zgco (iplon,jk) = (ptaucmc(iplon,ikl,iw(iplon)) * pomgcmc(iplon,ikl,iw(iplon)) * pasycmc(iplon,ikl,iw(iplon)) + & - ztauc(iplon,jk) * zomcc(iplon,jk) * zgcc(iplon,jk)) / zomco(iplon,jk) - zomco(iplon,jk) = zomco(iplon,jk) / ztauo(iplon,jk) - ! Total sky optical parameters (if cloud properties not delta scaled) - ! Use this code if cloud properties are not derived in rrtmg_sw_cldprop - elseif (icpr .eq. 0) then - ztauo(iplon,jk) = ztaur(iplon,ikl,iw(iplon)) + ztaug(iplon,ikl,iw(iplon)) + ptaua(iplon,ikl,ibm) + ptaucmc(iplon,ikl,iw(iplon)) - zomco(iplon,jk) = ptaua(iplon,ikl,ibm) * pomga(iplon,ikl,ibm) + ptaucmc(iplon,ikl,iw(iplon)) * pomgcmc(iplon,ikl,iw(iplon)) + & - ztaur(iplon,ikl,iw(iplon)) * 1.0_r8 - zgco (iplon,jk) = (ptaucmc(iplon,ikl,iw(iplon)) * pomgcmc(iplon,ikl,iw(iplon)) * pasycmc(iplon,ikl,iw(iplon)) + & - ptaua(iplon,ikl,ibm)*pomga(iplon,ikl,ibm)*pasya(iplon,ikl,ibm)) / zomco(iplon,jk) - zomco(iplon,jk) = zomco(iplon,jk) / ztauo(iplon,jk) - ! Delta scaling - clouds - ! Use only if subroutine rrtmg_sw_cldprop is not used to get cloud properties and to apply delta scaling - zf = zgco(iplon,jk) * zgco(iplon,jk) - zwf = zomco(iplon,jk) * zf - ztauo(iplon,jk) = (1._r8 - zwf) * ztauo(iplon,jk) - zomco(iplon,jk) = (zomco(iplon,jk) - zwf) / (1.0_r8 - zwf) - zgco (iplon,jk) = (zgco(iplon,jk) - zf) / (1.0_r8 - zf) - endif - ! End of layer loop - enddo - END DO - DO iplon=1,ncol - - ! Clear sky reflectivities - call reftra_sw (klev,ncol, & -lrtchkclr, zgcc, prmu0, ztauc, zomcc, & -zrefc, zrefdc, ztrac, ztradc) - ! Total sky reflectivities - call reftra_sw (klev, ncol, & -lrtchkcld, zgco, prmu0, ztauo, zomco, & -zrefo, zrefdo, ztrao, ztrado) - END DO - DO iplon=1,ncol - do jk=1,klev - ! Combine clear and cloudy contributions for total sky - ikl = klev+1-jk - zclear(iplon) = 1.0_r8 - pcldfmc(iplon,ikl,iw(iplon)) - zcloud(iplon) = pcldfmc(iplon,ikl,iw(iplon)) - zref(iplon,jk) = zclear(iplon)*zrefc(iplon,jk) + zcloud(iplon)*zrefo(iplon,jk) - zrefd(iplon,jk)= zclear(iplon)*zrefdc(iplon,jk) + zcloud(iplon)*zrefdo(iplon,jk) - ztra(iplon,jk) = zclear(iplon)*ztrac(iplon,jk) + zcloud(iplon)*ztrao(iplon,jk) - ztrad(iplon,jk)= zclear(iplon)*ztradc(iplon,jk) + zcloud(iplon)*ztrado(iplon,jk) - ! Direct beam transmittance - ! Clear - ! zdbtmc(iplon) = exp(-ztauc(iplon,jk) / prmu0) - ! Use exponential lookup table for transmittance, or expansion of - ! exponential for low tau - ze1(iplon) = ztauc(iplon,jk) / prmu0(iplon) - if (ze1(iplon) .le. od_lo) then - zdbtmc(iplon) = 1._r8 - ze1(iplon) + 0.5_r8 * ze1(iplon) * ze1(iplon) - else - tblind(iplon) = ze1(iplon) / (bpade + ze1(iplon)) - itind(iplon) = tblint * tblind(iplon) + 0.5_r8 - zdbtmc(iplon) = exp_tbl(itind(iplon)) - endif - zdbtc(iplon,jk) = zdbtmc(iplon) - ztdbtc(iplon,jk+1) = zdbtc(iplon,jk)*ztdbtc(iplon,jk) - ! Clear + Cloud - ! zdbtmo(iplon) = exp(-ztauo(iplon,jk) / prmu0) - ! Use exponential lookup table for transmittance, or expansion of - ! exponential for low tau - ze1(iplon) = ztauo(iplon,jk) / prmu0(iplon) - if (ze1(iplon) .le. od_lo) then - zdbtmo(iplon) = 1._r8 - ze1(iplon) + 0.5_r8 * ze1(iplon) * ze1(iplon) - else - tblind(iplon) = ze1(iplon) / (bpade + ze1(iplon)) - itind(iplon) = tblint * tblind(iplon) + 0.5_r8 - zdbtmo(iplon) = exp_tbl(itind(iplon)) - endif - zdbt(iplon,jk) = zclear(iplon)*zdbtmc(iplon) + zcloud(iplon)*zdbtmo(iplon) - ztdbt(iplon,jk+1) = zdbt(iplon,jk)*ztdbt(iplon,jk) - enddo - ! Vertical quadrature for clear-sky fluxes - END DO -! DO iplon=1,ncol - call vrtqdr_sw(ncol,klev, iw, & -zrefc, zrefdc, ztrac, ztradc, & -zdbtc, zrdndc, zrupc, zrupdc, ztdbtc, & -zcd, zcu) - ! Vertical quadrature for cloudy fluxes - call vrtqdr_sw(ncol,klev, iw, & -zref, zrefd, ztra, ztrad, & -zdbt, zrdnd, zrup, zrupd, ztdbt, & -zfd, zfu) -! END DO - DO iplon=1,ncol - ! Upwelling and downwelling fluxes at levels - ! Two-stream calculations go from top to bottom; - ! layer indexing is reversed to go bottom to top for output arrays - do jk=1,klev+1 - ikl=klev+2-jk - ! Accumulate spectral fluxes over bands - inactive - ! zbbfu(ikl) = zbbfu(ikl) + zincflx(iplon,iw(iplon))*zfu(iplon,jk,iw(iplon)) - ! zbbfd(ikl) = zbbfd(ikl) + zincflx(iplon,iw(iplon))*zfd(iplon,jk,iw(iplon)) - ! zbbcu(ikl) = zbbcu(ikl) + zincflx(iplon,iw(iplon))*zcu(iplon,jk,iw(iplon)) - ! zbbcd(ikl) = zbbcd(ikl) + zincflx(iplon,iw(iplon))*zcd(iplon,jk,iw(iplon)) - ! zbbfddir(ikl) = zbbfddir(ikl) + zincflx(iplon,iw(iplon))*ztdbt_nodel(iplon,jk) - ! zbbcddir(ikl) = zbbcddir(ikl) + zincflx(iplon,iw(iplon))*ztdbtc_nodel(iplon,jk) - pbbfsu(iplon,ibm,ikl) = pbbfsu(iplon,ibm,ikl) + zincflx(iplon,iw(iplon))*zfu(iplon,jk,iw(iplon)) - pbbfsd(iplon,ibm,ikl) = pbbfsd(iplon,ibm,ikl) + zincflx(iplon,iw(iplon))*zfd(iplon,jk,iw(iplon)) - ! Accumulate spectral fluxes over whole spectrum - pbbfu(iplon,ikl) = pbbfu(iplon,ikl) + zincflx(iplon,iw(iplon))*zfu(iplon,jk,iw(iplon)) - pbbfd(iplon,ikl) = pbbfd(iplon,ikl) +zincflx(iplon,iw(iplon))*zfd(iplon,jk,iw(iplon)) - pbbcu(iplon,ikl) = pbbcu(iplon,ikl) + zincflx(iplon,iw(iplon))*zcu(iplon,jk,iw(iplon)) - pbbcd(iplon,ikl) = pbbcd(iplon,ikl) + zincflx(iplon,iw(iplon))*zcd(iplon,jk,iw(iplon)) - if (idelm .eq. 0) then - pbbfddir(iplon,ikl) = pbbfddir(iplon,ikl) + zincflx(iplon,iw(iplon))*ztdbt_nodel(iplon,jk) - pbbcddir(iplon,ikl) = pbbcddir(iplon,ikl) + zincflx(iplon,iw(iplon))*ztdbtc_nodel(iplon,jk) - elseif (idelm .eq. 1) then - pbbfddir(iplon,ikl) = pbbfddir(iplon,ikl) + zincflx(iplon,iw(iplon))*ztdbt(iplon,jk) - pbbcddir(iplon,ikl) = pbbcddir(iplon,ikl) + zincflx(iplon,iw(iplon))*ztdbtc(iplon,jk) - endif - ! Accumulate direct fluxes for UV/visible bands - if (ibm >= 10 .and. ibm <= 13) then - puvcd(iplon,ikl) = puvcd(iplon,ikl) + zincflx(iplon,iw(iplon))*zcd(iplon,jk,iw(iplon)) - puvfd(iplon,ikl) = puvfd(iplon,ikl) + zincflx(iplon,iw(iplon))*zfd(iplon,jk,iw(iplon)) - if (idelm .eq. 0) then - puvfddir(iplon,ikl) = puvfddir(iplon,ikl) + zincflx(iplon,iw(iplon))*ztdbt_nodel(iplon,jk) - puvcddir(iplon,ikl) = puvcddir(iplon,ikl) + zincflx(iplon,iw(iplon))*ztdbtc_nodel(iplon,jk) - elseif (idelm .eq. 1) then - puvfddir(iplon,ikl) = puvfddir(iplon,ikl) + zincflx(iplon,iw(iplon))*ztdbt(iplon,jk) - puvcddir(iplon,ikl) = puvcddir(iplon,ikl) + zincflx(iplon,iw(iplon))*ztdbtc(iplon,jk) - endif - ! band 9 is half-NearIR and half-Visible - else if (ibm == 9) then - puvcd(iplon,ikl) = puvcd(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*zcd(iplon,jk,iw(iplon)) - puvfd(iplon,ikl) = puvfd(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*zfd(iplon,jk,iw(iplon)) - pnicd(iplon,ikl) = pnicd(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*zcd(iplon,jk,iw(iplon)) - pnifd(iplon,ikl) = pnifd(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*zfd(iplon,jk,iw(iplon)) - if (idelm .eq. 0) then - puvfddir(iplon,ikl) = puvfddir(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*ztdbt_nodel(iplon,jk) - puvcddir(iplon,ikl) = puvcddir(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*ztdbtc_nodel(iplon,jk) - pnifddir(iplon,ikl) = pnifddir(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*ztdbt_nodel(iplon,jk) - pnicddir(iplon,ikl) = pnicddir(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*ztdbtc_nodel(iplon,jk) - elseif (idelm .eq. 1) then - puvfddir(iplon,ikl) = puvfddir(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*ztdbt(iplon,jk) - puvcddir(iplon,ikl) = puvcddir(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*ztdbtc(iplon,jk) - pnifddir(iplon,ikl) = pnifddir(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*ztdbt(iplon,jk) - pnicddir(iplon,ikl) = pnicddir(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*ztdbtc(iplon,jk) - endif - pnicu(iplon,ikl) = pnicu(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*zcu(iplon,jk,iw(iplon)) - pnifu(iplon,ikl) = pnifu(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*zfu(iplon,jk,iw(iplon)) - ! Accumulate direct fluxes for near-IR bands - else if (ibm == 14 .or. ibm <= 8) then - pnicd(iplon,ikl) = pnicd(iplon,ikl) + zincflx(iplon,iw(iplon))*zcd(iplon,jk,iw(iplon)) - pnifd(iplon,ikl) = pnifd(iplon,ikl) + zincflx(iplon,iw(iplon))*zfd(iplon,jk,iw(iplon)) - if (idelm .eq. 0) then - pnifddir(iplon,ikl) = pnifddir(iplon,ikl) + zincflx(iplon,iw(iplon))*ztdbt_nodel(iplon,jk) - pnicddir(iplon,ikl) = pnicddir(iplon,ikl) + zincflx(iplon,iw(iplon))*ztdbtc_nodel(iplon,jk) - elseif (idelm .eq. 1) then - pnifddir(iplon,ikl) = pnifddir(iplon,ikl) + zincflx(iplon,iw(iplon))*ztdbt(iplon,jk) - pnicddir(iplon,ikl) = pnicddir(iplon,ikl) + zincflx(iplon,iw(iplon))*ztdbtc(iplon,jk) - endif - ! Added for net near-IR flux diagnostic - pnicu(iplon,ikl) = pnicu(iplon,ikl) + zincflx(iplon,iw(iplon))*zcu(iplon,jk,iw(iplon)) - pnifu(iplon,ikl) = pnifu(iplon,ikl) + zincflx(iplon,iw(iplon))*zfu(iplon,jk,iw(iplon)) - endif - enddo - ! End loop on jg, g-point interval - enddo - ! End loop on jb, spectral band - enddo - end do - END SUBROUTINE spcvmc_sw - END MODULE rrtmg_sw_spcvmc diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_taumol.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_taumol.f90 deleted file mode 100644 index 03f72fec88..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_taumol.f90 +++ /dev/null @@ -1,1584 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_sw_taumol.f90 -! Generated at: 2015-07-07 00:48:24 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_sw_taumol - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! ------- Modules ------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - ! use parrrsw, only : mg, jpband, nbndsw, ngptsw - USE rrsw_con, ONLY: oneminus - USE rrsw_wvn, ONLY: nspa - USE rrsw_wvn, ONLY: nspb - USE rrsw_vsn, ONLY: hvrtau - USE parrrsw, ONLY: ngptsw - IMPLICIT NONE - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !---------------------------------------------------------------------------- - - SUBROUTINE taumol_sw(ncol,nlayers, colh2o, colco2, colch4, colo2, colo3, colmol, laytrop, jp, jt, jt1, fac00, fac01, fac10, & - fac11, selffac, selffrac, indself, forfac, forfrac, indfor, sfluxzen, taug, taur) - !---------------------------------------------------------------------------- - ! ****************************************************************************** - ! * * - ! * Optical depths developed for the * - ! * * - ! * RAPID RADIATIVE TRANSFER MODEL (RRTM) * - ! * * - ! * * - ! * ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC. * - ! * 131 HARTWELL AVENUE * - ! * LEXINGTON, MA 02421 * - ! * * - ! * * - ! * ELI J. MLAWER * - ! * JENNIFER DELAMERE * - ! * STEVEN J. TAUBMAN * - ! * SHEPARD A. CLOUGH * - ! * * - ! * * - ! * * - ! * * - ! * email: mlawer@aer.com * - ! * email: jdelamer@aer.com * - ! * * - ! * The authors wish to acknowledge the contributions of the * - ! * following people: Patrick D. Brown, Michael J. Iacono, * - ! * Ronald E. Farren, Luke Chen, Robert Bergstrom. * - ! * * - ! ****************************************************************************** - ! * TAUMOL * - ! * * - ! * This file contains the subroutines TAUGBn (where n goes from * - ! * 1 to 28). TAUGBn calculates the optical depths and Planck fractions * - ! * per g-value and layer for band n. * - ! * * - ! * Output: optical depths (unitless) * - ! * fractions needed to compute Planck functions at every layer * - ! * and g-value * - ! * * - ! * COMMON /TAUGCOM/ TAUG(MXLAY,MG) * - ! * COMMON /PLANKG/ FRACS(MXLAY,MG) * - ! * * - ! * Input * - ! * * - ! * PARAMETER (MG=16, MXLAY=203, NBANDS=14) * - ! * * - ! * COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS) * - ! * COMMON /PRECISE/ ONEMINUS * - ! * COMMON /PROFILE/ NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY), * - ! * & PZ(0:MXLAY),TZ(0:MXLAY),TBOUND * - ! * COMMON /PROFDATA/ LAYTROP,LAYSWTCH,LAYLOW, * - ! * & COLH2O(MXLAY),COLCO2(MXLAY), * - ! * & COLO3(MXLAY),COLN2O(MXLAY),COLCH4(MXLAY), * - ! * & COLO2(MXLAY),CO2MULT(MXLAY) * - ! * COMMON /INTFAC/ FAC00(MXLAY),FAC01(MXLAY), * - ! * & FAC10(MXLAY),FAC11(MXLAY) * - ! * COMMON /INTIND/ JP(MXLAY),JT(MXLAY),JT1(MXLAY) * - ! * COMMON /SELF/ SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(MXLAY) * - ! * * - ! * Description: * - ! * NG(IBAND) - number of g-values in band IBAND * - ! * NSPA(IBAND) - for the lower atmosphere, the number of reference * - ! * atmospheres that are stored for band IBAND per * - ! * pressure level and temperature. Each of these * - ! * atmospheres has different relative amounts of the * - ! * key species for the band (i.e. different binary * - ! * species parameters). * - ! * NSPB(IBAND) - same for upper atmosphere * - ! * ONEMINUS - since problems are caused in some cases by interpolation * - ! * parameters equal to or greater than 1, for these cases * - ! * these parameters are set to this value, slightly < 1. * - ! * PAVEL - layer pressures (mb) * - ! * TAVEL - layer temperatures (degrees K) * - ! * PZ - level pressures (mb) * - ! * TZ - level temperatures (degrees K) * - ! * LAYTROP - layer at which switch is made from one combination of * - ! * key species to another * - ! * COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water * - ! * vapor,carbon dioxide, ozone, nitrous ozide, methane, * - ! * respectively (molecules/cm**2) * - ! * CO2MULT - for bands in which carbon dioxide is implemented as a * - ! * trace species, this is the factor used to multiply the * - ! * band's average CO2 absorption coefficient to get the added * - ! * contribution to the optical depth relative to 355 ppm. * - ! * FACij(LAY) - for layer LAY, these are factors that are needed to * - ! * compute the interpolation factors that multiply the * - ! * appropriate reference k-values. A value of 0 (1) for * - ! * i,j indicates that the corresponding factor multiplies * - ! * reference k-value for the lower (higher) of the two * - ! * appropriate temperatures, and altitudes, respectively. * - ! * JP - the index of the lower (in altitude) of the two appropriate * - ! * reference pressure levels needed for interpolation * - ! * JT, JT1 - the indices of the lower of the two appropriate reference * - ! * temperatures needed for interpolation (for pressure * - ! * levels JP and JP+1, respectively) * - ! * SELFFAC - scale factor needed to water vapor self-continuum, equals * - ! * (water vapor density)/(atmospheric density at 296K and * - ! * 1013 mb) * - ! * SELFFRAC - factor needed for temperature interpolation of reference * - ! * water vapor self-continuum data * - ! * INDSELF - index of the lower of the two appropriate reference * - ! * temperatures needed for the self-continuum interpolation * - ! * * - ! * Data input * - ! * COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG) * - ! * (note: n is the band number) * - ! * * - ! * Description: * - ! * KA - k-values for low reference atmospheres (no water vapor * - ! * self-continuum) (units: cm**2/molecule) * - ! * KB - k-values for high reference atmospheres (all sources) * - ! * (units: cm**2/molecule) * - ! * SELFREF - k-values for water vapor self-continuum for reference * - ! * atmospheres (used below LAYTROP) * - ! * (units: cm**2/molecule) * - ! * * - ! * DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG) * - ! * EQUIVALENCE (KA,ABSA),(KB,ABSB) * - ! * * - ! ***************************************************************************** - ! - ! Modifications - ! - ! Revised: Adapted to F90 coding, J.-J.Morcrette, ECMWF, Feb 2003 - ! Revised: Modified for g-point reduction, MJIacono, AER, Dec 2003 - ! Revised: Reformatted for consistency with rrtmg_lw, MJIacono, AER, Jul 2006 - ! - ! ------- Declarations ------- - ! ----- Input ----- - INTEGER, intent(in) :: nlayers ! total number of layers - INTEGER, intent(in) :: ncol ! total number of layers - INTEGER, intent(in) :: laytrop(ncol) ! tropopause layer index - INTEGER, intent(in) :: jp(ncol,nlayers) ! - !INTEGER, intent(in) :: nlayers ! total number of layers - ! Dimensions: (nlayers) - INTEGER, intent(in) :: jt(ncol,nlayers) ! - ! Dimensions: (nlayers) - INTEGER, intent(in) :: jt1(ncol,nlayers) ! - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: colh2o(ncol,nlayers) ! column amount (h2o) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: colco2(ncol,nlayers) ! column amount (co2) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: colo3(ncol,nlayers) ! column amount (o3) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: colch4(ncol,nlayers) ! column amount (ch4) - ! Dimensions: (nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: colo2(ncol,nlayers) ! column amount (o2) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: colmol(ncol,nlayers) ! - ! Dimensions: (nlayers) - INTEGER, intent(in) :: indself(ncol,nlayers) - ! Dimensions: (nlayers) - INTEGER, intent(in) :: indfor(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: selffac(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: selffrac(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: forfac(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: forfrac(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: fac01(ncol,nlayers) - REAL(KIND=r8), intent(in) :: fac10(ncol,nlayers) - REAL(KIND=r8), intent(in) :: fac11(ncol,nlayers) - REAL(KIND=r8), intent(in) :: fac00(ncol,nlayers) ! - ! Dimensions: (nlayers) - ! ----- Output ----- - REAL(KIND=r8), intent(out) :: sfluxzen(ncol,ngptsw) ! solar source function - ! Dimensions: (ngptsw) - REAL(KIND=r8), intent(out) :: taug(ncol,nlayers,ngptsw) ! gaseous optical depth - ! Dimensions: (nlayers,ngptsw) - REAL(KIND=r8), intent(out) :: taur(ncol,nlayers,ngptsw) ! Rayleigh - INTEGER :: icol - ! Dimensions: (nlayers,ngptsw) - ! real(kind=r8), intent(out) :: ssa(:,:) ! single scattering albedo (inactive) - ! Dimensions: (nlayers,ngptsw) - do icol=1,ncol - hvrtau = '$Revision: 1.2 $' - !print*,"ncol :::",ncol - ! Calculate gaseous optical depth and planck fractions for each spectral band. - call taumol16() - !print *,'end of taumol 16' - call taumol17 - !print *,'end of taumol 17' - call taumol18 - !print *,'end of taumol 18' - call taumol19 - !print *,'end of taumol 19' - call taumol20 - !print *,'end of taumol 20' - call taumol21 - !print *,'end of taumol 21' - call taumol22 - !print *,'end of taumol 22' - call taumol23 - !print *,'end of taumol 23' - call taumol24 - !print *,'end of taumol 24' - call taumol25 - !print *,'end of taumol 25' - call taumol26 - !print *,'end of taumol 26' - call taumol27 - !print *,'end of taumol 27' - call taumol28 - !print *,'end of taumol 28' - call taumol29 - !print *,'end of taumol 29' - end do - !------------- - CONTAINS - !------------- - !---------------------------------------------------------------------------- - - SUBROUTINE taumol16() - !---------------------------------------------------------------------------- - ! - ! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng16 - USE rrsw_kg16, ONLY: strrat1 - USE rrsw_kg16, ONLY: rayl - USE rrsw_kg16, ONLY: forref - USE rrsw_kg16, ONLY: absa - USE rrsw_kg16, ONLY: selfref - USE rrsw_kg16, ONLY: layreffr - USE rrsw_kg16, ONLY: absb - USE rrsw_kg16, ONLY: sfluxref - ! ------- Declarations ------- - !INTEGER, intent(in) ::ncol ! total number of layers - ! Local - INTEGER :: lay - INTEGER :: js - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - INTEGER :: laysolfr - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - !print*,"taumol 16 :: before lay loop" - ! do icol=1,ncol - !print*,"icol ::",icol,ncol - !print*,"laytrop",laytrop - do lay = 1, laytrop(icol) - !print*,'inside lay loop' - speccomb = colh2o(icol,lay) + strrat1*colch4(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(16) + js - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(16) + js - inds = indself(icol,lay) - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng16 - taug(icol,lay,ig) = speccomb * & - (fac000 * absa(ind0 ,ig) + & - fac100 * absa(ind0 +1,ig) + & - fac010 * absa(ind0 +9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac001 * absa(ind1 ,ig) + & - fac101 * absa(ind1 +1,ig) + & - fac011 * absa(ind1 +9,ig) + & - fac111 * absa(ind1+10,ig)) + & - colh2o(icol,lay) * & - (selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) - ! ssa(lay,ig) = tauray/taug(lay,ig) - taur(icol,lay,ig) = tauray - enddo - enddo - laysolfr = nlayers - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - if (jp(icol,(lay-1)) .lt. layreffr .and. jp(icol,lay) .ge. layreffr) & - laysolfr = lay - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(16) + 1 - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(16) + 1 - tauray = colmol(icol,lay) * rayl - do ig = 1, ng16 - taug(icol,lay,ig) = colch4(icol,lay) * & - (fac00(icol,lay) * absb(ind0 ,ig) + & - fac10(icol,lay) * absb(ind0+1,ig) + & - fac01(icol,lay) * absb(ind1 ,ig) + & - fac11(icol,lay) * absb(ind1+1,ig)) - ! ssa(lay,ig) = tauray/taug(lay,ig) - if (lay .eq. laysolfr) sfluxzen(icol,ig) = sfluxref(ig) - taur(icol,lay,ig) = tauray - enddo - enddo -!end do - END SUBROUTINE taumol16 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol17() - !---------------------------------------------------------------------------- - ! - ! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng17 - USE parrrsw, ONLY: ngs16 - USE rrsw_kg17, ONLY: strrat - USE rrsw_kg17, ONLY: rayl - USE rrsw_kg17, ONLY: absa - USE rrsw_kg17, ONLY: selfref - USE rrsw_kg17, ONLY: forref - USE rrsw_kg17, ONLY: layreffr - USE rrsw_kg17, ONLY: absb - USE rrsw_kg17, ONLY: sfluxref - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: js - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - INTEGER :: laysolfr - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - speccomb = colh2o(icol,lay) + strrat*colco2(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(17) + js - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(17) + js - inds = indself(icol,lay) - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng17 - taug(icol,lay,ngs16+ig) = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) + & - colh2o(icol,lay) * & - (selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) - ! ssa(lay,ngs16+ig) = tauray/taug(lay,ngs16+ig) - taur(icol,lay,ngs16+ig) = tauray - enddo - enddo - laysolfr = nlayers - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - if (jp(icol,lay-1) .lt. layreffr .and. jp(icol,lay) .ge. layreffr) & - laysolfr = lay - speccomb = colh2o(icol,lay) + strrat*colco2(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 4._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(17) + js - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(17) + js - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng17 - taug(icol,lay,ngs16+ig) = speccomb * & - (fac000 * absb(ind0,ig) + & - fac100 * absb(ind0+1,ig) + & - fac010 * absb(ind0+5,ig) + & - fac110 * absb(ind0+6,ig) + & - fac001 * absb(ind1,ig) + & - fac101 * absb(ind1+1,ig) + & - fac011 * absb(ind1+5,ig) + & - fac111 * absb(ind1+6,ig)) + & - colh2o(icol,lay) * & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig))) - ! ssa(lay,ngs16+ig) = tauray/taug(lay,ngs16+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs16+ig) = sfluxref(ig,js) & - + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) - taur(icol,lay,ngs16+ig) = tauray - enddo - enddo - END SUBROUTINE taumol17 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol18() - !---------------------------------------------------------------------------- - ! - ! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng18 - USE parrrsw, ONLY: ngs17 - USE rrsw_kg18, ONLY: layreffr - USE rrsw_kg18, ONLY: strrat - USE rrsw_kg18, ONLY: rayl - USE rrsw_kg18, ONLY: forref - USE rrsw_kg18, ONLY: absa - USE rrsw_kg18, ONLY: selfref - USE rrsw_kg18, ONLY: sfluxref - USE rrsw_kg18, ONLY: absb - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: js - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & - laysolfr = min(lay+1,laytrop(icol)) - speccomb = colh2o(icol,lay) + strrat*colch4(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(18) + js - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(18) + js - inds = indself(icol,lay) - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng18 - taug(icol,lay,ngs17+ig) = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) + & - colh2o(icol,lay) * & - (selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) - ! ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs17+ig) = sfluxref(ig,js) & - + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) - taur(icol,lay,ngs17+ig) = tauray - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(18) + 1 - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(18) + 1 - tauray = colmol(icol,lay) * rayl - do ig = 1, ng18 - taug(icol,lay,ngs17+ig) = colch4(icol,lay) * & - (fac00(icol,lay) * absb(ind0,ig) + & - fac10(icol,lay) * absb(ind0+1,ig) + & - fac01(icol,lay) * absb(ind1,ig) + & - fac11(icol,lay) * absb(ind1+1,ig)) - ! ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig) - taur(icol,lay,ngs17+ig) = tauray - enddo - enddo - END SUBROUTINE taumol18 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol19() - !---------------------------------------------------------------------------- - ! - ! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng19 - USE parrrsw, ONLY: ngs18 - USE rrsw_kg19, ONLY: layreffr - USE rrsw_kg19, ONLY: strrat - USE rrsw_kg19, ONLY: rayl - USE rrsw_kg19, ONLY: selfref - USE rrsw_kg19, ONLY: absa - USE rrsw_kg19, ONLY: forref - USE rrsw_kg19, ONLY: sfluxref - USE rrsw_kg19, ONLY: absb - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: js - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & - laysolfr = min(lay+1,laytrop(icol)) - speccomb = colh2o(icol,lay) + strrat*colco2(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(19) + js - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(19) + js - inds = indself(icol,lay) - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1 , ng19 - taug(icol,lay,ngs18+ig) = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) + & - colh2o(icol,lay) * & - (selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) - ! ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs18+ig) = sfluxref(ig,js) & - + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) - taur(icol,lay,ngs18+ig) = tauray - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(19) + 1 - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(19) + 1 - tauray = colmol(icol,lay) * rayl - do ig = 1 , ng19 - taug(icol,lay,ngs18+ig) = colco2(icol,lay) * & - (fac00(icol,lay) * absb(ind0,ig) + & - fac10(icol,lay) * absb(ind0+1,ig) + & - fac01(icol,lay) * absb(ind1,ig) + & - fac11(icol,lay) * absb(ind1+1,ig)) - ! ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig) - taur(icol,lay,ngs18+ig) = tauray - enddo - enddo - END SUBROUTINE taumol19 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol20() - !---------------------------------------------------------------------------- - ! - ! band 20: 5150-6150 cm-1 (low - h2o; high - h2o) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng20 - USE parrrsw, ONLY: ngs19 - USE rrsw_kg20, ONLY: layreffr - USE rrsw_kg20, ONLY: rayl - USE rrsw_kg20, ONLY: absch4 - USE rrsw_kg20, ONLY: forref - USE rrsw_kg20, ONLY: absa - USE rrsw_kg20, ONLY: selfref - USE rrsw_kg20, ONLY: sfluxref - USE rrsw_kg20, ONLY: absb - IMPLICIT NONE - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & - laysolfr = min(lay+1,laytrop(icol)) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(20) + 1 - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(20) + 1 - inds = indself(icol,lay) - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng20 - taug(icol,lay,ngs19+ig) = colh2o(icol,lay) * & - ((fac00(icol,lay) * absa(ind0,ig) + & - fac10(icol,lay) * absa(ind0+1,ig) + & - fac01(icol,lay) * absa(ind1,ig) + & - fac11(icol,lay) * absa(ind1+1,ig)) + & - selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) & - + colch4(icol,lay) * absch4(ig) - ! ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig) - taur(icol,lay,ngs19+ig) = tauray - if (lay .eq. laysolfr) sfluxzen(icol,ngs19+ig) = sfluxref(ig) - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(20) + 1 - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(20) + 1 - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng20 - taug(icol,lay,ngs19+ig) = colh2o(icol,lay) * & - (fac00(icol,lay) * absb(ind0,ig) + & - fac10(icol,lay) * absb(ind0+1,ig) + & - fac01(icol,lay) * absb(ind1,ig) + & - fac11(icol,lay) * absb(ind1+1,ig) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) + & - colch4(icol,lay) * absch4(ig) - ! ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig) - taur(icol,lay,ngs19+ig) = tauray - enddo - enddo - END SUBROUTINE taumol20 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol21() - !---------------------------------------------------------------------------- - ! - ! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng21 - USE parrrsw, ONLY: ngs20 - USE rrsw_kg21, ONLY: layreffr - USE rrsw_kg21, ONLY: strrat - USE rrsw_kg21, ONLY: rayl - USE rrsw_kg21, ONLY: forref - USE rrsw_kg21, ONLY: absa - USE rrsw_kg21, ONLY: selfref - USE rrsw_kg21, ONLY: sfluxref - USE rrsw_kg21, ONLY: absb - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: js - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & - laysolfr = min(lay+1,laytrop(icol)) - speccomb = colh2o(icol,lay) + strrat*colco2(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(21) + js - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(21) + js - inds = indself(icol,lay) - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng21 - taug(icol,lay,ngs20+ig) = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) + & - colh2o(icol,lay) * & - (selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) - ! ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs20+ig) = sfluxref(ig,js) & - + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) - taur(icol,lay,ngs20+ig) = tauray - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - speccomb = colh2o(icol,lay) + strrat*colco2(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 4._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(21) + js - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(21) + js - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng21 - taug(icol,lay,ngs20+ig) = speccomb * & - (fac000 * absb(ind0,ig) + & - fac100 * absb(ind0+1,ig) + & - fac010 * absb(ind0+5,ig) + & - fac110 * absb(ind0+6,ig) + & - fac001 * absb(ind1,ig) + & - fac101 * absb(ind1+1,ig) + & - fac011 * absb(ind1+5,ig) + & - fac111 * absb(ind1+6,ig)) + & - colh2o(icol,lay) * & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig))) - ! ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig) - taur(icol,lay,ngs20+ig) = tauray - enddo - enddo - END SUBROUTINE taumol21 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol22() - !---------------------------------------------------------------------------- - ! - ! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng22 - USE parrrsw, ONLY: ngs21 - USE rrsw_kg22, ONLY: layreffr - USE rrsw_kg22, ONLY: strrat - USE rrsw_kg22, ONLY: rayl - USE rrsw_kg22, ONLY: forref - USE rrsw_kg22, ONLY: absa - USE rrsw_kg22, ONLY: selfref - USE rrsw_kg22, ONLY: sfluxref - USE rrsw_kg22, ONLY: absb - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: js - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - REAL(KIND=r8) :: o2adj - REAL(KIND=r8) :: o2cont - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: tauray - ! The following factor is the ratio of total O2 band intensity (lines - ! and Mate continuum) to O2 band intensity (line only). It is needed - ! to adjust the optical depths since the k's include only lines. - o2adj = 1.6_r8 - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & - laysolfr = min(lay+1,laytrop(icol)) - o2cont = 4.35e-4_r8*colo2(icol,lay)/(350.0_r8*2.0_r8) - speccomb = colh2o(icol,lay) + o2adj*strrat*colo2(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - ! odadj = specparm + o2adj * (1._r8 - specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(22) + js - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(22) + js - inds = indself(icol,lay) - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng22 - taug(icol,lay,ngs21+ig) = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) + & - colh2o(icol,lay) * & - (selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) & - + o2cont - ! ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs21+ig) = sfluxref(ig,js) & - + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) - taur(icol,lay,ngs21+ig) = tauray - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - o2cont = 4.35e-4_r8*colo2(icol,lay)/(350.0_r8*2.0_r8) - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(22) + 1 - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(22) + 1 - tauray = colmol(icol,lay) * rayl - do ig = 1, ng22 - taug(icol,lay,ngs21+ig) = colo2(icol,lay) * o2adj * & - (fac00(icol,lay) * absb(ind0,ig) + & - fac10(icol,lay) * absb(ind0+1,ig) + & - fac01(icol,lay) * absb(ind1,ig) + & - fac11(icol,lay) * absb(ind1+1,ig)) + & - o2cont - ! ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig) - taur(icol,lay,ngs21+ig) = tauray - enddo - enddo - END SUBROUTINE taumol22 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol23() - !---------------------------------------------------------------------------- - ! - ! band 23: 8050-12850 cm-1 (low - h2o; high - nothing) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng23 - USE parrrsw, ONLY: ngs22 - USE rrsw_kg23, ONLY: layreffr - USE rrsw_kg23, ONLY: rayl - USE rrsw_kg23, ONLY: absa - USE rrsw_kg23, ONLY: givfac - USE rrsw_kg23, ONLY: forref - USE rrsw_kg23, ONLY: selfref - USE rrsw_kg23, ONLY: sfluxref - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & - laysolfr = min(lay+1,laytrop(icol)) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(23) + 1 - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(23) + 1 - inds = indself(icol,lay) - indf = indfor(icol,lay) - do ig = 1, ng23 - tauray = colmol(icol,lay) * rayl(ig) - taug(icol,lay,ngs22+ig) = colh2o(icol,lay) * & - (givfac * (fac00(icol,lay) * absa(ind0,ig) + & - fac10(icol,lay) * absa(ind0+1,ig) + & - fac01(icol,lay) * absa(ind1,ig) + & - fac11(icol,lay) * absa(ind1+1,ig)) + & - selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) - ! ssa(lay,ngs22+ig) = tauray/taug(lay,ngs22+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs22+ig) = sfluxref(ig) - taur(icol,lay,ngs22+ig) = tauray - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - do ig = 1, ng23 - ! taug(lay,ngs22+ig) = colmol(icol,lay) * rayl(ig) - ! ssa(lay,ngs22+ig) = 1.0_r8 - taug(icol,lay,ngs22+ig) = 0._r8 - taur(icol,lay,ngs22+ig) = colmol(icol,lay) * rayl(ig) - enddo - enddo - END SUBROUTINE taumol23 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol24() - !---------------------------------------------------------------------------- - ! - ! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng24 - USE parrrsw, ONLY: ngs23 - USE rrsw_kg24, ONLY: layreffr - USE rrsw_kg24, ONLY: strrat - USE rrsw_kg24, ONLY: rayla - USE rrsw_kg24, ONLY: absa - USE rrsw_kg24, ONLY: forref - USE rrsw_kg24, ONLY: selfref - USE rrsw_kg24, ONLY: abso3a - USE rrsw_kg24, ONLY: sfluxref - USE rrsw_kg24, ONLY: raylb - USE rrsw_kg24, ONLY: absb - USE rrsw_kg24, ONLY: abso3b - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: js - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & - laysolfr = min(lay+1,laytrop(icol)) - speccomb = colh2o(icol,lay) + strrat*colo2(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(24) + js - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(24) + js - inds = indself(icol,lay) - indf = indfor(icol,lay) - do ig = 1, ng24 - tauray = colmol(icol,lay) * (rayla(ig,js) + & - fs * (rayla(ig,js+1) - rayla(ig,js))) - taug(icol,lay,ngs23+ig) = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) + & - colo3(icol,lay) * abso3a(ig) + & - colh2o(icol,lay) * & - (selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) - ! ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs23+ig) = sfluxref(ig,js) & - + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) - taur(icol,lay,ngs23+ig) = tauray - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(24) + 1 - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(24) + 1 - do ig = 1, ng24 - tauray = colmol(icol,lay) * raylb(ig) - taug(icol,lay,ngs23+ig) = colo2(icol,lay) * & - (fac00(icol,lay) * absb(ind0,ig) + & - fac10(icol,lay) * absb(ind0+1,ig) + & - fac01(icol,lay) * absb(ind1,ig) + & - fac11(icol,lay) * absb(ind1+1,ig)) + & - colo3(icol,lay) * abso3b(ig) - ! ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig) - taur(icol,lay,ngs23+ig) = tauray - enddo - enddo - END SUBROUTINE taumol24 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol25() - !---------------------------------------------------------------------------- - ! - ! band 25: 16000-22650 cm-1 (low - h2o; high - nothing) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng25 - USE parrrsw, ONLY: ngs24 - USE rrsw_kg25, ONLY: layreffr - USE rrsw_kg25, ONLY: rayl - USE rrsw_kg25, ONLY: abso3a - USE rrsw_kg25, ONLY: absa - USE rrsw_kg25, ONLY: sfluxref - USE rrsw_kg25, ONLY: abso3b - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: ig - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & - laysolfr = min(lay+1,laytrop(icol)) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(25) + 1 - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(25) + 1 - do ig = 1, ng25 - tauray = colmol(icol,lay) * rayl(ig) - taug(icol,lay,ngs24+ig) = colh2o(icol,lay) * & - (fac00(icol,lay) * absa(ind0,ig) + & - fac10(icol,lay) * absa(ind0+1,ig) + & - fac01(icol,lay) * absa(ind1,ig) + & - fac11(icol,lay) * absa(ind1+1,ig)) + & - colo3(icol,lay) * abso3a(ig) - ! ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs24+ig) = sfluxref(ig) - taur(icol,lay,ngs24+ig) = tauray - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - do ig = 1, ng25 - tauray = colmol(icol,lay) * rayl(ig) - taug(icol,lay,ngs24+ig) = colo3(icol,lay) * abso3b(ig) - ! ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig) - taur(icol,lay,ngs24+ig) = tauray - enddo - enddo - END SUBROUTINE taumol25 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol26() - !---------------------------------------------------------------------------- - ! - ! band 26: 22650-29000 cm-1 (low - nothing; high - nothing) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng26 - USE parrrsw, ONLY: ngs25 - USE rrsw_kg26, ONLY: sfluxref - USE rrsw_kg26, ONLY: rayl - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: ig - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - do ig = 1, ng26 - ! taug(lay,ngs25+ig) = colmol(icol,lay) * rayl(ig) - ! ssa(lay,ngs25+ig) = 1.0_r8 - if (lay .eq. laysolfr) sfluxzen(icol,ngs25+ig) = sfluxref(ig) - taug(icol,lay,ngs25+ig) = 0._r8 - taur(icol,lay,ngs25+ig) = colmol(icol,lay) * rayl(ig) - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - do ig = 1, ng26 - ! taug(lay,ngs25+ig) = colmol(icol,lay) * rayl(ig) - ! ssa(lay,ngs25+ig) = 1.0_r8 - taug(icol,lay,ngs25+ig) = 0._r8 - taur(icol,lay,ngs25+ig) = colmol(icol,lay) * rayl(ig) - enddo - enddo - END SUBROUTINE taumol26 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol27() - !---------------------------------------------------------------------------- - ! - ! band 27: 29000-38000 cm-1 (low - o3; high - o3) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng27 - USE parrrsw, ONLY: ngs26 - USE rrsw_kg27, ONLY: rayl - USE rrsw_kg27, ONLY: absa - USE rrsw_kg27, ONLY: layreffr - USE rrsw_kg27, ONLY: absb - USE rrsw_kg27, ONLY: scalekur - USE rrsw_kg27, ONLY: sfluxref - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: ig - INTEGER :: laysolfr - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(27) + 1 - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(27) + 1 - do ig = 1, ng27 - tauray = colmol(icol,lay) * rayl(ig) - taug(icol,lay,ngs26+ig) = colo3(icol,lay) * & - (fac00(icol,lay) * absa(ind0,ig) + & - fac10(icol,lay) * absa(ind0+1,ig) + & - fac01(icol,lay) * absa(ind1,ig) + & - fac11(icol,lay) * absa(ind1+1,ig)) - ! ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig) - taur(icol,lay,ngs26+ig) = tauray - enddo - enddo - laysolfr = nlayers - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - if (jp(icol,lay-1) .lt. layreffr .and. jp(icol,lay) .ge. layreffr) & - laysolfr = lay - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(27) + 1 - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(27) + 1 - do ig = 1, ng27 - tauray = colmol(icol,lay) * rayl(ig) - taug(icol,lay,ngs26+ig) = colo3(icol,lay) * & - (fac00(icol,lay) * absb(ind0,ig) + & - fac10(icol,lay) * absb(ind0+1,ig) + & - fac01(icol,lay) * absb(ind1,ig) + & - fac11(icol,lay) * absb(ind1+1,ig)) - ! ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig) - if (lay.eq.laysolfr) sfluxzen(icol,ngs26+ig) = scalekur * sfluxref(ig) - taur(icol,lay,ngs26+ig) = tauray - enddo - enddo - END SUBROUTINE taumol27 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol28() - !---------------------------------------------------------------------------- - ! - ! band 28: 38000-50000 cm-1 (low - o3,o2; high - o3,o2) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng28 - USE parrrsw, ONLY: ngs27 - USE rrsw_kg28, ONLY: strrat - USE rrsw_kg28, ONLY: rayl - USE rrsw_kg28, ONLY: absa - USE rrsw_kg28, ONLY: layreffr - USE rrsw_kg28, ONLY: absb - USE rrsw_kg28, ONLY: sfluxref - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: js - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: ig - INTEGER :: laysolfr - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - speccomb = colo3(icol,lay) + strrat*colo2(icol,lay) - specparm = colo3(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(28) + js - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(28) + js - tauray = colmol(icol,lay) * rayl - do ig = 1, ng28 - taug(icol,lay,ngs27+ig) = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - ! ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig) - taur(icol,lay,ngs27+ig) = tauray - enddo - enddo - laysolfr = nlayers - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - if (jp(icol,lay-1) .lt. layreffr .and. jp(icol,lay) .ge. layreffr) & - laysolfr = lay - speccomb = colo3(icol,lay) + strrat*colo2(icol,lay) - specparm = colo3(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 4._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(28) + js - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(28) + js - tauray = colmol(icol,lay) * rayl - do ig = 1, ng28 - taug(icol,lay,ngs27+ig) = speccomb * & - (fac000 * absb(ind0,ig) + & - fac100 * absb(ind0+1,ig) + & - fac010 * absb(ind0+5,ig) + & - fac110 * absb(ind0+6,ig) + & - fac001 * absb(ind1,ig) + & - fac101 * absb(ind1+1,ig) + & - fac011 * absb(ind1+5,ig) + & - fac111 * absb(ind1+6,ig)) - ! ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs27+ig) = sfluxref(ig,js) & - + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) - taur(icol,lay,ngs27+ig) = tauray - enddo - enddo - END SUBROUTINE taumol28 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol29() - !---------------------------------------------------------------------------- - ! - ! band 29: 820-2600 cm-1 (low - h2o; high - co2) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng29 - USE parrrsw, ONLY: ngs28 - USE rrsw_kg29, ONLY: rayl - USE rrsw_kg29, ONLY: forref - USE rrsw_kg29, ONLY: absa - USE rrsw_kg29, ONLY: absco2 - USE rrsw_kg29, ONLY: selfref - USE rrsw_kg29, ONLY: layreffr - USE rrsw_kg29, ONLY: absh2o - USE rrsw_kg29, ONLY: absb - USE rrsw_kg29, ONLY: sfluxref - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - INTEGER :: laysolfr - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(29) + 1 - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(29) + 1 - inds = indself(icol,lay) - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng29 - taug(icol,lay,ngs28+ig) = colh2o(icol,lay) * & - ((fac00(icol,lay) * absa(ind0,ig) + & - fac10(icol,lay) * absa(ind0+1,ig) + & - fac01(icol,lay) * absa(ind1,ig) + & - fac11(icol,lay) * absa(ind1+1,ig)) + & - selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) & - + colco2(icol,lay) * absco2(ig) - ! ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig) - taur(icol,lay,ngs28+ig) = tauray - enddo - enddo - laysolfr = nlayers - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - if (jp(icol,lay-1) .lt. layreffr .and. jp(icol,lay) .ge. layreffr) & - laysolfr = lay - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(29) + 1 - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(29) + 1 - tauray = colmol(icol,lay) * rayl - do ig = 1, ng29 - taug(icol,lay,ngs28+ig) = colco2(icol,lay) * & - (fac00(icol,lay) * absb(ind0,ig) + & - fac10(icol,lay) * absb(ind0+1,ig) + & - fac01(icol,lay) * absb(ind1,ig) + & - fac11(icol,lay) * absb(ind1+1,ig)) & - + colh2o(icol,lay) * absh2o(ig) - ! ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs28+ig) = sfluxref(ig) - taur(icol,lay,ngs28+ig) = tauray - enddo - enddo - END SUBROUTINE taumol29 - END SUBROUTINE taumol_sw - END MODULE rrtmg_sw_taumol diff --git a/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_vrtqdr.f90 b/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_vrtqdr.f90 deleted file mode 100644 index 3786981c49..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_vrtqdr.f90 +++ /dev/null @@ -1,137 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_sw_vrtqdr.f90 -! Generated at: 2015-07-07 00:48:25 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_sw_vrtqdr - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! ------- Modules ------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only: jpim, jprb - ! use parrrsw, only: ngptsw - IMPLICIT NONE - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - ! -------------------------------------------------------------------------- - - SUBROUTINE vrtqdr_sw(ncol,klev, kw, pref, prefd, ptra, ptrad, pdbt, prdnd, prup, prupd, ptdbt, pfd, pfu) - ! -------------------------------------------------------------------------- - ! Purpose: This routine performs the vertical quadrature integration - ! - ! Interface: *vrtqdr_sw* is called from *spcvrt_sw* and *spcvmc_sw* - ! - ! Modifications. - ! - ! Original: H. Barker - ! Revision: Integrated with rrtmg_sw, J.-J. Morcrette, ECMWF, Oct 2002 - ! Revision: Reformatted for consistency with rrtmg_lw: MJIacono, AER, Jul 2006 - ! - !----------------------------------------------------------------------- - ! ------- Declarations ------- - ! Input - INTEGER, intent (in) :: ncol - INTEGER, intent (in) :: klev ! number of model layers - INTEGER, intent (in) :: kw(ncol) ! g-point index - REAL(KIND=r8), intent(in) :: pref(:,:) ! direct beam reflectivity - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(in) :: prefd(:,:) ! diffuse beam reflectivity - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(in) :: ptra(:,:) ! direct beam transmissivity - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(in) :: ptrad(:,:) ! diffuse beam transmissivity - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(in) :: pdbt(:,:) - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(in) :: ptdbt(:,:) - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(inout) :: prdnd(:,:) - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(inout) :: prup(:,:) - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(inout) :: prupd(:,:) - ! Dimensions: (nlayers+1) - ! Output - REAL(KIND=r8), intent(out) :: pfd(:,:,:) ! downwelling flux (W/m2) - ! Dimensions: (nlayers+1,ngptsw) - ! unadjusted for earth/sun distance or zenith angle - REAL(KIND=r8), intent(out) :: pfu(:,:,:) ! upwelling flux (W/m2) - ! Dimensions: (nlayers+1,ngptsw) - ! unadjusted for earth/sun distance or zenith angle - ! Local - INTEGER :: jk - INTEGER :: ikp - INTEGER :: ikx,icol - REAL(KIND=r8) :: zreflect - REAL(KIND=r8) :: ztdn(klev+1) - ! Definitions - ! - ! pref(icol,jk) direct reflectance - ! prefd(icol,jk) diffuse reflectance - ! ptra(icol,jk) direct transmittance - ! ptrad(icol,jk) diffuse transmittance - ! - ! pdbt(icol,jk) layer mean direct beam transmittance - ! ptdbt(icol,jk) total direct beam transmittance at levels - ! - !----------------------------------------------------------------------------- - ! Link lowest layer with surface - do icol=1,ncol - zreflect = 1._r8 / (1._r8 - prefd(icol,klev+1) * prefd(icol,klev)) - prup(icol,klev) = pref(icol,klev) + (ptrad(icol,klev) * & - ((ptra(icol,klev) - pdbt(icol,klev)) * prefd(icol,klev+1) + & - pdbt(icol,klev) * pref(icol,klev+1))) * zreflect - prupd(icol,klev) = prefd(icol,klev) + ptrad(icol,klev) * ptrad(icol,klev) * & - prefd(icol,klev+1) * zreflect - ! Pass from bottom to top - do jk = 1,klev-1 - ikp = klev+1-jk - ikx = ikp-1 - zreflect = 1._r8 / (1._r8 -prupd(icol,ikp) * prefd(icol,ikx)) - prup(icol,ikx) = pref(icol,ikx) + (ptrad(icol,ikx) * & - ((ptra(icol,ikx) - pdbt(icol,ikx)) * prupd(icol,ikp) + & - pdbt(icol,ikx) * prup(icol,ikp))) * zreflect - prupd(icol,ikx) = prefd(icol,ikx) + ptrad(icol,ikx) * ptrad(icol,ikx) * & - prupd(icol,ikp) * zreflect - enddo - ! Upper boundary conditions - ztdn(1) = 1._r8 - prdnd(icol,1) = 0._r8 - ztdn(2) = ptra(icol,1) - prdnd(icol,2) = prefd(icol,1) - ! Pass from top to bottom - do jk = 2,klev - ikp = jk+1 - zreflect = 1._r8 / (1._r8 - prefd(icol,jk) * prdnd(icol,jk)) - ztdn(ikp) = ptdbt(icol,jk) * ptra(icol,jk) + & - (ptrad(icol,jk) * ((ztdn(jk) - ptdbt(icol,jk)) + & - ptdbt(icol,jk) * pref(icol,jk) * prdnd(icol,jk))) * zreflect - prdnd(icol,ikp) = prefd(icol,jk) + ptrad(icol,jk) * ptrad(icol,jk) * & - prdnd(icol,jk) * zreflect - enddo - ! Up and down-welling fluxes at levels - do jk = 1,klev+1 - zreflect = 1._r8 / (1._r8 - prdnd(icol,jk) * prupd(icol,jk)) - pfu(icol,jk,kw(icol)) = (ptdbt(icol,jk) * prup(icol,jk) + & - (ztdn(jk) - ptdbt(icol,jk)) * prupd(icol,jk)) * zreflect - pfd(icol,jk,kw(icol)) = ptdbt(icol,jk) + (ztdn(jk) - ptdbt(icol,jk)+ & - ptdbt(icol,jk) * prup(icol,jk) * prdnd(icol,jk)) * zreflect - enddo - end do - END SUBROUTINE vrtqdr_sw - END MODULE rrtmg_sw_vrtqdr diff --git a/test/ncar_kernels/PORT_sw_rad/src/scamMod.F90 b/test/ncar_kernels/PORT_sw_rad/src/scamMod.F90 deleted file mode 100644 index f89c4c8cae..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/scamMod.F90 +++ /dev/null @@ -1,170 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : scamMod.F90 -! Generated at: 2015-07-07 00:48:24 -! KGEN version: 0.4.13 - - - - MODULE scammod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !----------------------------------------------------------------------- - !BOP - ! - ! !MODULE: scamMod - ! - ! !DESCRIPTION: - ! scam specific routines and data - ! - ! !USES: - ! - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! - IMPLICIT NONE - PRIVATE ! By default all data is public to this module - ! - ! !PUBLIC INTERFACES: - ! - ! SCAM default run-time options for CLM - ! SCAM default run-time options - ! SCAM run-time options - ! - ! !PUBLIC MODULE DATA: - ! - ! input namelist latitude for scam - ! input namelist longitude for scam - LOGICAL, public :: single_column ! Using IOP file or not - ! Using IOP file or not - ! perturb initial values - ! perturb forcing - ! If using diurnal averaging or not - LOGICAL, public :: scm_crm_mode ! column radiation mode - ! If this is a restart step or not - ! Logical flag settings from GUI - ! If true, update u/v after TPHYS - ! If true, T, U & V will be passed to SLT - ! use flux divergence terms for T and q? - ! use flux divergence terms for constituents? - ! do we want available diagnostics? - ! Error code from netCDF reads - ! 3D q advection - ! 3D T advection - ! vertical q advection - ! vertical T advection - ! surface pressure tendency - ! model minus observed humidity - ! actual W.V. Mixing ratio - ! actual W.V. Mixing ratio - ! actual W.V. Mixing ratio - ! actual - ! actual - ! observed precipitation - ! observed surface latent heat flux - ! observed surface sensible heat flux - ! observed apparent heat source - ! observed apparent heat sink - ! model minus observed temp - ! ground temperature - ! actual temperature - ! air temperature at the surface - ! model minus observed uwind - ! actual u wind - ! model minus observed vwind - ! actual v wind - ! observed cld - ! observed clwp - REAL(KIND=r8), public :: aldirobs(1) ! observed aldir - REAL(KIND=r8), public :: aldifobs(1) ! observed aldif - REAL(KIND=r8), public :: asdirobs(1) ! observed asdir - REAL(KIND=r8), public :: asdifobs(1) ! observed asdif - ! Vertical motion (slt) - ! Vertical motion (slt) - ! Divergence of moisture - ! Divergence of temperature - ! Horiz Divergence of E/W - ! Horiz Divergence of N/S - ! mo_drydep algorithm - ! - ! index into iop dataset - ! Length of time-step - ! Date in (yyyymmdd) of start time - ! Time of day of start time (sec) - ! do we need to read next iop timepoint - ! dataset contains divq - ! dataset contains divt - ! dataset contains divq3d - ! dataset contains vertdivt - ! dataset contains vertdivq - ! dataset contains divt3d - ! dataset contains divu - ! dataset contains divv - ! dataset contains omega - ! dataset contains phis - ! dataset contains ptend - ! dataset contains ps - ! dataset contains q - ! dataset contains Q1 - ! dataset contains Q2 - ! dataset contains prec - ! dataset contains lhflx - ! dataset contains shflx - ! dataset contains t - ! dataset contains tg - ! dataset contains tsair - ! dataset contains u - ! dataset contains v - ! dataset contains cld - ! dataset contains cldliq - ! dataset contains cldice - ! dataset contains numliq - ! dataset contains numice - ! dataset contains clwp - LOGICAL*4, public :: have_aldir ! dataset contains aldir - LOGICAL*4, public :: have_aldif ! dataset contains aldif - LOGICAL*4, public :: have_asdir ! dataset contains asdir - LOGICAL*4, public :: have_asdif ! dataset contains asdif - ! use the specified surface properties - ! use relaxation - ! use cam generated forcing - ! use 3d forcing - ! IOP name for CLUBB - !======================================================================= - PUBLIC kgen_read_externs_scammod - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_scammod(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) single_column - READ(UNIT=kgen_unit) scm_crm_mode - READ(UNIT=kgen_unit) aldirobs - READ(UNIT=kgen_unit) aldifobs - READ(UNIT=kgen_unit) asdirobs - READ(UNIT=kgen_unit) asdifobs - READ(UNIT=kgen_unit) have_aldir - READ(UNIT=kgen_unit) have_aldif - READ(UNIT=kgen_unit) have_asdir - READ(UNIT=kgen_unit) have_asdif - END SUBROUTINE kgen_read_externs_scammod - - !======================================================================= - ! - !----------------------------------------------------------------------- - ! - - - ! - !----------------------------------------------------------------------- - ! - - ! - !----------------------------------------------------------------------- - ! - ! - !----------------------------------------------------------------------- - ! - END MODULE scammod diff --git a/test/ncar_kernels/PORT_sw_rad/src/shr_const_mod.F90 b/test/ncar_kernels/PORT_sw_rad/src/shr_const_mod.F90 deleted file mode 100644 index ea2349f2a2..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/shr_const_mod.F90 +++ /dev/null @@ -1,60 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : shr_const_mod.F90 -! Generated at: 2015-07-07 00:48:24 -! KGEN version: 0.4.13 - - - - MODULE shr_const_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, only : shr_kind_in - USE shr_kind_mod, only : shr_kind_r8 - INTEGER(KIND=shr_kind_in), parameter, private :: r8 = shr_kind_r8 ! rename for local readability only - !---------------------------------------------------------------------------- - ! physical constants (all data public) - !---------------------------------------------------------------------------- - PUBLIC - ! pi - ! sec in calendar day ~ sec - ! sec in siderial day ~ sec - ! earth rot ~ rad/sec - ! radius of earth ~ m - ! acceleration of gravity ~ m/s^2 - ! Stefan-Boltzmann constant ~ W/m^2/K^4 - ! Boltzmann's constant ~ J/K/molecule - ! Avogadro's number ~ molecules/kmole - ! Universal gas constant ~ J/K/kmole - ! molecular weight dry air ~ kg/kmole - ! molecular weight water vapor - ! Dry air gas constant ~ J/K/kg - ! Water vapor gas constant ~ J/K/kg - ! RWV/RDAIR - 1.0 - ! Von Karman constant - ! standard pressure ~ pascals - ! ratio of 13C/12C in Pee Dee Belemnite (C isotope standard) - ! triple point of fresh water ~ K - ! freezing T of fresh water ~ K - ! freezing T of salt water ~ K - ! density of dry air at STP ~ kg/m^3 - ! density of fresh water ~ kg/m^3 - ! density of sea water ~ kg/m^3 - ! density of ice ~ kg/m^3 - REAL(KIND=r8), parameter :: shr_const_cpdair = 1.00464e3_r8 ! specific heat of dry air ~ J/kg/K - ! specific heat of water vap ~ J/kg/K - ! CPWV/CPDAIR - 1.0 - ! specific heat of fresh h2o ~ J/kg/K - ! specific heat of sea h2o ~ J/kg/K - ! specific heat of fresh ice ~ J/kg/K - ! latent heat of fusion ~ J/kg - ! latent heat of evaporation ~ J/kg - ! latent heat of sublimation ~ J/kg - ! ocn ref salinity (psu) - ! ice ref salinity (psu) - ! special missing value - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE shr_const_mod diff --git a/test/ncar_kernels/PORT_sw_rad/src/shr_kind_mod.f90 b/test/ncar_kernels/PORT_sw_rad/src/shr_kind_mod.f90 deleted file mode 100644 index 9792d511d2..0000000000 --- a/test/ncar_kernels/PORT_sw_rad/src/shr_kind_mod.f90 +++ /dev/null @@ -1,26 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : shr_kind_mod.f90 -! Generated at: 2015-07-07 00:48:24 -! KGEN version: 0.4.13 - - - - MODULE shr_kind_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - PUBLIC - INTEGER, parameter :: shr_kind_r8 = selected_real_kind(12) ! 8 byte real - ! 4 byte real - ! native real - INTEGER, parameter :: shr_kind_i8 = selected_int_kind (13) ! 8 byte integer - ! 4 byte integer - INTEGER, parameter :: shr_kind_in = kind(1) ! native integer - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE shr_kind_mod diff --git a/test/ncar_kernels/PORT_sw_reftra/CESM_license.txt b/test/ncar_kernels/PORT_sw_reftra/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/PORT_sw_reftra/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/PORT_sw_reftra/data/reftra_sw.1.1 b/test/ncar_kernels/PORT_sw_reftra/data/reftra_sw.1.1 deleted file mode 100644 index 1c0988402b..0000000000 Binary files a/test/ncar_kernels/PORT_sw_reftra/data/reftra_sw.1.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_reftra/data/reftra_sw.1.4 b/test/ncar_kernels/PORT_sw_reftra/data/reftra_sw.1.4 deleted file mode 100644 index 56190d64aa..0000000000 Binary files a/test/ncar_kernels/PORT_sw_reftra/data/reftra_sw.1.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_reftra/data/reftra_sw.1.8 b/test/ncar_kernels/PORT_sw_reftra/data/reftra_sw.1.8 deleted file mode 100644 index c31ab8a9da..0000000000 Binary files a/test/ncar_kernels/PORT_sw_reftra/data/reftra_sw.1.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_reftra/data/reftra_sw.5.1 b/test/ncar_kernels/PORT_sw_reftra/data/reftra_sw.5.1 deleted file mode 100644 index 13c160415c..0000000000 Binary files a/test/ncar_kernels/PORT_sw_reftra/data/reftra_sw.5.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_reftra/data/reftra_sw.5.4 b/test/ncar_kernels/PORT_sw_reftra/data/reftra_sw.5.4 deleted file mode 100644 index 12f83ca1cb..0000000000 Binary files a/test/ncar_kernels/PORT_sw_reftra/data/reftra_sw.5.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_reftra/data/reftra_sw.5.8 b/test/ncar_kernels/PORT_sw_reftra/data/reftra_sw.5.8 deleted file mode 100644 index 0cf57fd127..0000000000 Binary files a/test/ncar_kernels/PORT_sw_reftra/data/reftra_sw.5.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_reftra/inc/t1.mk b/test/ncar_kernels/PORT_sw_reftra/inc/t1.mk deleted file mode 100644 index d03a9fe024..0000000000 --- a/test/ncar_kernels/PORT_sw_reftra/inc/t1.mk +++ /dev/null @@ -1,76 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# Intel default flags -# FC_FLAGS_SNB := -O2 -fp-model source -convert big_endian -assume byterecl -ftz -traceback -assume realloc_lhs -xHost -vec-threshold0 -qopt-report=5 -align array256byte -# FC_FLAGS_HSW := -O2 -fp-model source -convert big_endian -assume byterecl -ftz -traceback -assume realloc_lhs -vec-threshold0 -xCORE-AVX2 -qopt-report=5 -align array256byte -# FC_FLAGS_PHI := -mmic -O2 -fp-model source -convert big_endian -assume byterecl -ftz -traceback -assume realloc_lhs -vec-threshold0 -qopt-report=5 -align array256byte -# -# -FC_FLAGS := $(OPT) -FC_FLAGS += -Mnofma - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - -# Makefile for KGEN-generated kernel - - -ALL_OBJS := kernel_driver.o rrtmg_sw_spcvmc.o kgen_utils.o rrsw_vsn.o rrtmg_sw_reftra.o shr_kind_mod.o rrsw_tbl.o - -verify: - @(grep "verification.FAIL" $(TEST).rslt && echo "FAILED") || (grep "verification.PASS" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt - -runphi: build - ssh `hostname`-mic0 "cd ${PWD}; ./kernel.exe" | tee phi.out - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 rrtmg_sw_spcvmc.o kgen_utils.o rrsw_vsn.o rrtmg_sw_reftra.o shr_kind_mod.o rrsw_tbl.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_sw_spcvmc.o: $(SRC_DIR)/rrtmg_sw_spcvmc.f90 kgen_utils.o rrtmg_sw_reftra.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_vsn.o: $(SRC_DIR)/rrsw_vsn.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_sw_reftra.o: $(SRC_DIR)/rrtmg_sw_reftra.f90 kgen_utils.o shr_kind_mod.o rrsw_vsn.o rrsw_tbl.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_kind_mod.o: $(SRC_DIR)/shr_kind_mod.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_tbl.o: $(SRC_DIR)/rrsw_tbl.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -kgen_utils.o: $(SRC_DIR)/kgen_utils.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.optrpt phi.out *.rslt diff --git a/test/ncar_kernels/PORT_sw_reftra/lit/runmake b/test/ncar_kernels/PORT_sw_reftra/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/PORT_sw_reftra/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/PORT_sw_reftra/lit/t1.sh b/test/ncar_kernels/PORT_sw_reftra/lit/t1.sh deleted file mode 100644 index 33c953a156..0000000000 --- a/test/ncar_kernels/PORT_sw_reftra/lit/t1.sh +++ /dev/null @@ -1,9 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -# Shared lit script for each tests. Run bash commands that run tests with make. - -# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t -# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/PORT_sw_reftra/makefile b/test/ncar_kernels/PORT_sw_reftra/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/PORT_sw_reftra/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/PORT_sw_reftra/src/kernel_driver.f90 b/test/ncar_kernels/PORT_sw_reftra/src/kernel_driver.f90 deleted file mode 100644 index 8a7d74a68b..0000000000 --- a/test/ncar_kernels/PORT_sw_reftra/src/kernel_driver.f90 +++ /dev/null @@ -1,106 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-07-31 20:52:25 -! KGEN version: 0.4.13 - - -PROGRAM kernel_driver - USE rrtmg_sw_spcvmc, ONLY : spcvmc_sw - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - USE rrsw_tbl, ONLY : kgen_read_externs_rrsw_tbl - USE rrsw_vsn, ONLY : kgen_read_externs_rrsw_vsn - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - - IMPLICIT NONE - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_mpi_rank_at = (/ 1, 4, 8 /) - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(2), PARAMETER :: kgen_counter_at = (/ 1, 5 /) - CHARACTER(LEN=1024) :: kgen_filepath - INTEGER :: nlayers - INTEGER :: ncol - REAL(KIND=r8), allocatable :: prmu0(:) - - DO kgen_repeat_counter = 0, 5 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 2)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - kgen_filepath = "../data/reftra_sw." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "** Verification against '" // trim(adjustl(kgen_filepath)) // "' **" - - CALL kgen_read_externs_rrsw_tbl(kgen_unit) - CALL kgen_read_externs_rrsw_vsn(kgen_unit) - - ! driver variables - READ(UNIT=kgen_unit) nlayers - READ(UNIT=kgen_unit) ncol - CALL kgen_read_real_r8_dim1(prmu0, kgen_unit) - - call spcvmc_sw(nlayers, ncol, prmu0, kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_r8_dim1(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim1 - - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/PORT_sw_reftra/src/kgen_utils.f90 b/test/ncar_kernels/PORT_sw_reftra/src/kgen_utils.f90 deleted file mode 100644 index cfa8d114e0..0000000000 --- a/test/ncar_kernels/PORT_sw_reftra/src/kgen_utils.f90 +++ /dev/null @@ -1,61 +0,0 @@ -module kgen_utils_mod - -INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - -type check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - real(kind=kgen_dp) :: minvalue -end type check_t - -public kgen_dp, check_t, kgen_init_check, kgen_print_check - -contains - -subroutine kgen_init_check(check, tolerance, minvalue) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - real(kind=kgen_dp), intent(in), optional :: minvalue - - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.0D-15 - endif - if(present(minvalue)) then - check%minvalue = minvalue - else - check%minvalue = 1.0D-15 - endif -end subroutine kgen_init_check - -subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif -end subroutine kgen_print_check - -end module diff --git a/test/ncar_kernels/PORT_sw_reftra/src/rrsw_tbl.f90 b/test/ncar_kernels/PORT_sw_reftra/src/rrsw_tbl.f90 deleted file mode 100644 index 366c0a12c7..0000000000 --- a/test/ncar_kernels/PORT_sw_reftra/src/rrsw_tbl.f90 +++ /dev/null @@ -1,49 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_tbl.f90 -! Generated at: 2015-07-31 20:52:25 -! KGEN version: 0.4.13 - - - - MODULE rrsw_tbl - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw lookup table arrays - ! Initial version: MJIacono, AER, may2007 - ! Revised: MJIacono, AER, aug2007 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! ntbl : integer: Lookup table dimension - ! tblint : real : Lookup table conversion factor - ! tau_tbl: real : Clear-sky optical depth - ! exp_tbl: real : Exponential lookup table for transmittance - ! od_lo : real : Value of tau below which expansion is used - ! : in place of lookup table - ! pade : real : Pade approximation constant - ! bpade : real : Inverse of Pade constant - !------------------------------------------------------------------ - INTEGER, parameter :: ntbl = 10000 - REAL(KIND=r8), parameter :: tblint = 10000.0 - REAL(KIND=r8), parameter :: od_lo = 0.06 - REAL(KIND=r8), dimension(0:ntbl) :: exp_tbl - REAL(KIND=r8) :: bpade - PUBLIC kgen_read_externs_rrsw_tbl - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_tbl(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) exp_tbl - READ(UNIT=kgen_unit) bpade - END SUBROUTINE kgen_read_externs_rrsw_tbl - - END MODULE rrsw_tbl diff --git a/test/ncar_kernels/PORT_sw_reftra/src/rrsw_vsn.f90 b/test/ncar_kernels/PORT_sw_reftra/src/rrsw_vsn.f90 deleted file mode 100644 index e0bbad739d..0000000000 --- a/test/ncar_kernels/PORT_sw_reftra/src/rrsw_vsn.f90 +++ /dev/null @@ -1,65 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_vsn.f90 -! Generated at: 2015-07-31 20:52:25 -! KGEN version: 0.4.13 - - - - MODULE rrsw_vsn - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw version information - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jul2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - !hnamrtm :character: - !hnamini :character: - !hnamcld :character: - !hnamclc :character: - !hnamrft :character: - !hnamspv :character: - !hnamspc :character: - !hnamset :character: - !hnamtau :character: - !hnamvqd :character: - !hnamatm :character: - !hnamutl :character: - !hnamext :character: - !hnamkg :character: - ! - ! hvrrtm :character: - ! hvrini :character: - ! hvrcld :character: - ! hvrclc :character: - ! hvrrft :character: - ! hvrspv :character: - ! hvrspc :character: - ! hvrset :character: - ! hvrtau :character: - ! hvrvqd :character: - ! hvratm :character: - ! hvrutl :character: - ! hvrext :character: - ! hvrkg :character: - !------------------------------------------------------------------ - CHARACTER(LEN=18) :: hvrrft - PUBLIC kgen_read_externs_rrsw_vsn - CONTAINS - - ! write subroutines - ! No subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_vsn(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) hvrrft - END SUBROUTINE kgen_read_externs_rrsw_vsn - - END MODULE rrsw_vsn diff --git a/test/ncar_kernels/PORT_sw_reftra/src/rrtmg_sw_reftra.f90 b/test/ncar_kernels/PORT_sw_reftra/src/rrtmg_sw_reftra.f90 deleted file mode 100644 index 3342f558ce..0000000000 --- a/test/ncar_kernels/PORT_sw_reftra/src/rrtmg_sw_reftra.f90 +++ /dev/null @@ -1,313 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_sw_reftra.f90 -! Generated at: 2015-07-31 20:52:25 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_sw_reftra - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! ------- Modules ------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE rrsw_tbl, ONLY: od_lo - USE rrsw_tbl, ONLY: bpade - USE rrsw_tbl, ONLY: tblint - USE rrsw_tbl, ONLY: exp_tbl - USE rrsw_vsn, ONLY: hvrrft - IMPLICIT NONE - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - ! -------------------------------------------------------------------- - - SUBROUTINE reftra_sw(nlayers, ncol, lrtchk, pgg, prmuz, ptau, pw, pref, prefd, ptra, ptrad) - ! -------------------------------------------------------------------- - ! Purpose: computes the reflectivity and transmissivity of a clear or - ! cloudy layer using a choice of various approximations. - ! - ! Interface: *rrtmg_sw_reftra* is called by *rrtmg_sw_spcvrt* - ! - ! Description: - ! explicit arguments : - ! -------------------- - ! inputs - ! ------ - ! lrtchk = .t. for all layers in clear profile - ! lrtchk = .t. for cloudy layers in cloud profile - ! = .f. for clear layers in cloud profile - ! pgg = assymetry factor - ! prmuz = cosine solar zenith angle - ! ptau = optical thickness - ! pw = single scattering albedo - ! - ! outputs - ! ------- - ! pref : collimated beam reflectivity - ! prefd : diffuse beam reflectivity - ! ptra : collimated beam transmissivity - ! ptrad : diffuse beam transmissivity - ! - ! - ! Method: - ! ------- - ! standard delta-eddington, p.i.f.m., or d.o.m. layer calculations. - ! kmodts = 1 eddington (joseph et al., 1976) - ! = 2 pifm (zdunkowski et al., 1980) - ! = 3 discrete ordinates (liou, 1973) - ! - ! - ! Modifications: - ! -------------- - ! Original: J-JMorcrette, ECMWF, Feb 2003 - ! Revised for F90 reformatting: MJIacono, AER, Jul 2006 - ! Revised to add exponential lookup table: MJIacono, AER, Aug 2007 - ! - ! ------------------------------------------------------------------ - ! ------- Declarations ------ - ! ------- Input ------- - INTEGER, intent(in) :: nlayers - INTEGER, intent(in) :: ncol - - - LOGICAL, intent(in) :: lrtchk(:,:) ! Logical flag for reflectivity and - ! and transmissivity calculation; - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: pgg(:,:) ! asymmetry parameter - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: ptau(:,:) ! optical depth - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: pw(:,:) ! single scattering albedo - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: prmuz(:) ! cosine of solar zenith angle - ! ------- Output ------- - REAL(KIND=r8), intent(inout) :: pref(:,:) ! direct beam reflectivity - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(inout) :: prefd(:,:) ! diffuse beam reflectivity - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(inout) :: ptra(:,:) ! direct beam transmissivity - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(inout) :: ptrad(:,:) ! diffuse beam transmissivity - ! Dimensions: (nlayers+1) - ! ------- Local ------- - INTEGER :: kmodts - INTEGER :: jk - INTEGER :: icol - INTEGER :: itind - REAL(KIND=r8) :: tblind - REAL(KIND=r8) :: za - REAL(KIND=r8) :: za1 - REAL(KIND=r8) :: za2 - REAL(KIND=r8) :: zbeta - REAL(KIND=r8) :: zdenr - REAL(KIND=r8) :: zdent - REAL(KIND=r8) :: zdend - REAL(KIND=r8) :: ze1 - REAL(KIND=r8) :: ze2 - REAL(KIND=r8) :: zem1 - REAL(KIND=r8) :: zep1 - REAL(KIND=r8) :: zem2 - REAL(KIND=r8) :: zep2 - REAL(KIND=r8) :: zemm - REAL(KIND=r8) :: zg - REAL(KIND=r8) :: zg3 - REAL(KIND=r8) :: zgamma1 - REAL(KIND=r8) :: zgamma2 - REAL(KIND=r8) :: zgamma3 - REAL(KIND=r8) :: zgamma4 - REAL(KIND=r8) :: zgt - REAL(KIND=r8) :: zr1 - REAL(KIND=r8) :: zr2 - REAL(KIND=r8) :: zr3 - REAL(KIND=r8) :: zr4 - REAL(KIND=r8) :: zr5 - REAL(KIND=r8) :: zrk - REAL(KIND=r8) :: zrp - REAL(KIND=r8) :: zrp1 - REAL(KIND=r8) :: zrm1 - REAL(KIND=r8) :: zrk2 - REAL(KIND=r8) :: zrpp - REAL(KIND=r8) :: zrkg - REAL(KIND=r8) :: zsr3 - REAL(KIND=r8) :: zto1 - REAL(KIND=r8) :: zt1 - REAL(KIND=r8) :: zt2 - REAL(KIND=r8) :: zt3 - REAL(KIND=r8) :: zt4 - REAL(KIND=r8) :: zt5 - REAL(KIND=r8) :: zwcrit - REAL(KIND=r8) :: zw - REAL(KIND=r8) :: zwo - REAL(KIND=r8) :: temp1, temp2 - REAL(KIND=r8), parameter :: eps = 1.e-08_r8 - ! ------------------------------------------------------------------ - ! Initialize - -!DIR$ ASSUME_ALIGNED lrtchk:256, pgg:256, ptau:256, pw:256, prmuz:256, pref:256, prefd:256, ptra:256, ptrad:256 - - hvrrft = '$Revision: 1.2 $' - zsr3=sqrt(3._r8) - zwcrit=0.9999995_r8 - kmodts=2 - do icol = 1,ncol -!DIR$ VECTOR ALWAYS ALIGNED - do jk=1, nlayers - if (.not.lrtchk(icol,jk)) then - pref(icol,jk) =0._r8 - ptra(icol,jk) =1._r8 - prefd(icol,jk)=0._r8 - ptrad(icol,jk)=1._r8 - else - zto1=ptau(icol,jk) - zw =pw(icol,jk) - zg =pgg(icol,jk) - ! General two-stream expressions - zg3= 3._r8 * zg - if (kmodts == 1) then - zgamma1= (7._r8 - zw * (4._r8 + zg3)) * 0.25_r8 - zgamma2=-(1._r8 - zw * (4._r8 - zg3)) * 0.25_r8 - zgamma3= (2._r8 - zg3 * prmuz(icol) ) * 0.25_r8 - else if (kmodts == 2) then - zgamma1= (8._r8 - zw * (5._r8 + zg3)) * 0.25_r8 - zgamma2= 3._r8 *(zw * (1._r8 - zg )) * 0.25_r8 - zgamma3= (2._r8 - zg3 * prmuz(icol) ) * 0.25_r8 - else if (kmodts == 3) then - zgamma1= zsr3 * (2._r8 - zw * (1._r8 + zg)) * 0.5_r8 - zgamma2= zsr3 * zw * (1._r8 - zg ) * 0.5_r8 - zgamma3= (1._r8 - zsr3 * zg * prmuz(icol) ) * 0.5_r8 - end if - zgamma4= 1._r8 - zgamma3 - ! Recompute original s.s.a. to test for conservative solution - !zwo= zw / (1._r8 - (1._r8 - zw) * (zg / (1._r8 - zg))**2) - temp1 = 1._r8 - 2._r8 * zg - zwo= zw * (temp1 + zg**2)/(temp1 + zg**2 * zw) - if (zwo >= zwcrit) then - ! Conservative scattering - za = zgamma1 * prmuz(icol) - za1 = za - zgamma3 - zgt = zgamma1 * zto1 - ! Homogeneous reflectance and transmittance, - ! collimated beam - ze1 = min ( zto1 / prmuz(icol) , 500._r8) - ! ze2 = exp( -ze1 ) - ! Use exponential lookup table for transmittance, or expansion of - ! exponential for low tau - if (ze1 .le. od_lo) then - ze2 = 1._r8 - ze1 + 0.5_r8 * ze1 * ze1 - else - tblind = ze1 / (bpade + ze1) - itind = tblint * tblind + 0.5_r8 - ze2 = exp_tbl(itind) - endif - ! - pref(icol,jk) = (zgt - za1 * (1._r8 - ze2)) / (1._r8 + zgt) - ptra(icol,jk) = 1._r8 - pref(icol,jk) - ! isotropic incidence - prefd(icol,jk) = zgt / (1._r8 + zgt) - ptrad(icol,jk) = 1._r8 - prefd(icol,jk) - ! This is applied for consistency between total (delta-scaled) and direct (unscaled) - ! calculations at very low optical depths (tau < 1.e-4) when the exponential lookup - ! table returns a transmittance of 1.0. - if (ze2 .eq. 1.0_r8) then - pref(icol,jk) = 0.0_r8 - ptra(icol,jk) = 1.0_r8 - prefd(icol,jk) = 0.0_r8 - ptrad(icol,jk) = 1.0_r8 - endif - else - ! Non-conservative scattering - za1 = zgamma1 * zgamma4 + zgamma2 * zgamma3 - za2 = zgamma1 * zgamma3 + zgamma2 * zgamma4 - zrk = sqrt ( zgamma1**2 - zgamma2**2) - !zrk = sqrt ( (zgamma1 - zgamma2) * (zgamma1 + zgamma2) ) - zrp = zrk * prmuz(icol) - zrp1 = 1._r8 + zrp - zrm1 = 1._r8 - zrp - zrk2 = 2._r8 * zrk - zrpp = 1._r8 - zrp*zrp - zrkg = zrk + zgamma1 - zr1 = zrm1 * (za2 + zrk * zgamma3) - zr2 = zrp1 * (za2 - zrk * zgamma3) - zr3 = zrk2 * (zgamma3 - za2 * prmuz(icol) ) - zr4 = zrpp * zrkg - zr5 = zrpp * (zrk - zgamma1) - zt1 = zrp1 * (za1 + zrk * zgamma4) - zt2 = zrm1 * (za1 - zrk * zgamma4) - zt3 = zrk2 * (zgamma4 + za1 * prmuz(icol) ) - zt4 = zr4 - zt5 = zr5 - zbeta = (zgamma1 - zrk) / zrkg !- zr5 / zr4 !- zr5 / zr4 !- zr5 / zr4 !- zr5 / zr4 - ! Homogeneous reflectance and transmittance - ze1 = min ( zrk * zto1, 500._r8) - ze2 = min ( zto1 / prmuz(icol) , 500._r8) - ! - ! Original - ! zep1 = exp( ze1 ) - ! zem1 = exp(-ze1 ) - ! zep2 = exp( ze2 ) - ! zem2 = exp(-ze2 ) - ! - ! Revised original, to reduce exponentials - ! zep1 = exp( ze1 ) - ! zem1 = 1._r8 / zep1 - ! zep2 = exp( ze2 ) - ! zem2 = 1._r8 / zep2 - ! - ! Use exponential lookup table for transmittance, or expansion of - ! exponential for low tau - if (ze1 .le. od_lo) then - zem1 = 1._r8 - ze1 + 0.5_r8 * ze1 * ze1 - zep1 = 1._r8 / zem1 - else - tblind = ze1 / (bpade + ze1) - itind = tblint * tblind + 0.5_r8 - zem1 = exp_tbl(itind) - zep1 = 1._r8 / zem1 - endif - if (ze2 .le. od_lo) then - zem2 = 1._r8 - ze2 + 0.5_r8 * ze2 * ze2 - zep2 = 1._r8 / zem2 - else - tblind = ze2 / (bpade + ze2) - itind = tblint * tblind + 0.5_r8 - zem2 = exp_tbl(itind) - zep2 = 1._r8 / zem2 - endif - ! collimated beam - zdenr = zr4*zep1 + zr5*zem1 - temp2 = 1._r8 / zdenr - !zdent = zt4*zep1 + zt5*zem1 - !temp2 = zem1 / (zr4 + zr5 * zem1**2) - if (zdenr .ge. -eps .and. zdenr .le. eps) then - pref(icol,jk) = eps - ptra(icol,jk) = zem2 - else - !pref(icol,jk) = zw * (zr1*zep1 - zr2*zem1 - zr3*zem2) / zdenr - pref(icol,jk) = zw * (zr1*zep1 - zr2*zem1 - zr3*zem2) * temp2 - !ptra(icol,jk) = zem2 - zem2 * zw * (zt1*zep1 - zt2*zem1 - zt3*zep2) / zdent - ptra(icol,jk) = zem2 - zem2 * zw * (zt1*zep1 - zt2*zem1 - zt3*zep2) * temp2 - endif - ! diffuse beam - zemm = zem1*zem1 - zdend = 1._r8 / ( (1._r8 - zbeta*zemm ) * zrkg) - prefd(icol,jk) = zgamma2 * (1._r8 - zemm) * zdend - ptrad(icol,jk) = zrk2*zem1*zdend - endif - endif - enddo -end do - END SUBROUTINE reftra_sw - END MODULE rrtmg_sw_reftra diff --git a/test/ncar_kernels/PORT_sw_reftra/src/rrtmg_sw_spcvmc.f90 b/test/ncar_kernels/PORT_sw_reftra/src/rrtmg_sw_spcvmc.f90 deleted file mode 100644 index 7d0855113b..0000000000 --- a/test/ncar_kernels/PORT_sw_reftra/src/rrtmg_sw_spcvmc.f90 +++ /dev/null @@ -1,302 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_sw_spcvmc.f90 -! Generated at: 2015-07-31 20:52:24 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_sw_spcvmc - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! ------- Modules ------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE rrtmg_sw_reftra, ONLY: reftra_sw - IMPLICIT NONE - PUBLIC spcvmc_sw - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - ! --------------------------------------------------------------------------- - - SUBROUTINE spcvmc_sw(nlayers, ncol, prmu0, kgen_unit) - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! --------------------------------------------------------------------------- - ! - ! Purpose: Contains spectral loop to compute the shortwave radiative fluxes, - ! using the two-stream method of H. Barker and McICA, the Monte-Carlo - ! Independent Column Approximation, for the representation of - ! sub-grid cloud variability (i.e. cloud overlap). - ! - ! Interface: *spcvmc_sw* is called from *rrtmg_sw.F90* or rrtmg_sw.1col.F90* - ! - ! Method: - ! Adapted from two-stream model of H. Barker; - ! Two-stream model options (selected with kmodts in rrtmg_sw_reftra.F90): - ! 1: Eddington, 2: PIFM, Zdunkowski et al., 3: discret ordinates - ! - ! Modifications: - ! - ! Original: H. Barker - ! Revision: Merge with RRTMG_SW: J.-J.Morcrette, ECMWF, Feb 2003 - ! Revision: Add adjustment for Earth/Sun distance : MJIacono, AER, Oct 2003 - ! Revision: Bug fix for use of PALBP and PALBD: MJIacono, AER, Nov 2003 - ! Revision: Bug fix to apply delta scaling to clear sky: AER, Dec 2004 - ! Revision: Code modified so that delta scaling is not done in cloudy profiles - ! if routine cldprop is used; delta scaling can be applied by swithcing - ! code below if cldprop is not used to get cloud properties. - ! AER, Jan 2005 - ! Revision: Modified to use McICA: MJIacono, AER, Nov 2005 - ! Revision: Uniform formatting for RRTMG: MJIacono, AER, Jul 2006 - ! Revision: Use exponential lookup table for transmittance: MJIacono, AER, - ! Aug 2007 - ! - ! ------------------------------------------------------------------ - ! ------- Declarations ------ - ! ------- Input ------- - integer, intent(in) :: kgen_unit - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - INTEGER, intent(in) :: nlayers - ! delta-m scaling flag - ! [0 = direct and diffuse fluxes are unscaled] - ! [1 = direct and diffuse fluxes are scaled] - INTEGER, intent(in) :: ncol ! column loop index - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! layer pressure (hPa, mb) - ! Dimensions: (ncol,nlayers) - ! layer temperature (K) - ! Dimensions: (ncol,nlayers) - ! level (interface) pressure (hPa, mb) - ! Dimensions: (ncol,0:nlayers) - ! level temperatures (hPa, mb) - ! Dimensions: (ncol,0:nlayers) - ! surface temperature (K) - ! molecular amounts (mol/cm2) - ! Dimensions: (ncol,mxmol,nlayers) - ! dry air column density (mol/cm2) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Earth/Sun distance adjustment - ! Dimensions: (ncol,jpband) - ! surface albedo (diffuse) - ! Dimensions: (ncol,nbndsw) - ! surface albedo (direct) - ! Dimensions: (ncol, nbndsw) - REAL(KIND=r8), intent(in) :: prmu0(ncol) ! cosine of solar zenith angle - ! cloud fraction [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - ! cloud optical depth [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - ! cloud asymmetry parameter [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - ! cloud single scattering albedo [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - ! cloud optical depth, non-delta scaled [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - ! aerosol optical depth - ! Dimensions: (ncol,nlayers,nbndsw) - ! aerosol asymmetry parameter - ! Dimensions: (ncol,nlayers,nbndsw) - ! aerosol single scattering albedo - ! Dimensions: (ncol,nlayers,nbndsw) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! ------- Output ------- - ! All Dimensions: (nlayers+1) - ! Added for net near-IR flux diagnostic - ! Output - inactive ! All Dimensions: (nlayers+1) - ! real(kind=r8), intent(out) :: puvcu(:) - ! real(kind=r8), intent(out) :: puvfu(:) - ! real(kind=r8), intent(out) :: pvscd(:) - ! real(kind=r8), intent(out) :: pvscu(:) - ! real(kind=r8), intent(out) :: pvsfd(:) - ! real(kind=r8), intent(out) :: pvsfu(:) - ! shortwave spectral flux up (nswbands,nlayers+1) - ! shortwave spectral flux down (nswbands,nlayers+1) - ! ------- Local ------- - -!DIR$ ATTRIBUTES ALIGN : 256 :: lrtchkclr, zgcc, zomcc, zrefc, zrefdc, ztauc, ztrac, ztradc - - LOGICAL :: lrtchkclr(ncol,nlayers) - INTEGER :: klev - ! integer, parameter :: nuv = ?? - ! integer, parameter :: nvs = ?? - REAL(KIND=r8) :: zgcc(ncol,nlayers) - REAL(KIND=r8) :: zomcc(ncol,nlayers) - REAL(KIND=r8) :: zrefc(ncol,nlayers+1) - REAL(KIND=r8) :: ref_zrefc(ncol,nlayers+1) - REAL(KIND=r8) :: zrefdc(ncol,nlayers+1) - REAL(KIND=r8) :: ref_zrefdc(ncol,nlayers+1) - REAL(KIND=r8) :: ztauc(ncol,nlayers) - REAL(KIND=r8) :: ztrac(ncol,nlayers+1) - REAL(KIND=r8) :: ref_ztrac(ncol,nlayers+1) - REAL(KIND=r8) :: ztradc(ncol,nlayers+1) - REAL(KIND=r8) :: ref_ztradc(ncol,nlayers+1) - ! real(kind=r8) :: zincflux ! inactive - ! Arrays from rrtmg_sw_taumoln routines - ! real(kind=r8) :: ztaug(nlayers,16), ztaur(nlayers,16) - ! real(kind=r8) :: zsflxzen(16) - ! Arrays from rrtmg_sw_vrtqdr routine - ! Inactive arrays - ! real(kind=r8) :: zbbcd(nlayers+1), zbbcu(nlayers+1) - ! real(kind=r8) :: zbbfd(nlayers+1), zbbfu(nlayers+1) - ! real(kind=r8) :: zbbfddir(nlayers+1), zbbcddir(nlayers+1) - ! ------------------------------------------------------------------ - ! Initializations - ! zincflux = 0.0_r8 - ! ??? ! ??? - tolerance = 1.E-14 - CALL kgen_init_check(check_status, tolerance) - READ(UNIT=kgen_unit) lrtchkclr - READ(UNIT=kgen_unit) klev - READ(UNIT=kgen_unit) zgcc - READ(UNIT=kgen_unit) zomcc - READ(UNIT=kgen_unit) zrefc - READ(UNIT=kgen_unit) zrefdc - READ(UNIT=kgen_unit) ztauc - READ(UNIT=kgen_unit) ztrac - READ(UNIT=kgen_unit) ztradc - - READ(UNIT=kgen_unit) ref_zrefc - READ(UNIT=kgen_unit) ref_zrefdc - READ(UNIT=kgen_unit) ref_ztrac - READ(UNIT=kgen_unit) ref_ztradc - - - ! call to kernel - call reftra_sw (klev,ncol, & -lrtchkclr, zgcc, prmu0, ztauc, zomcc, & -zrefc, zrefdc, ztrac, ztradc) - ! kernel verification for output variables - CALL kgen_verify_real_r8_dim2( "zrefc", check_status, zrefc, ref_zrefc) - CALL kgen_verify_real_r8_dim2( "zrefdc", check_status, zrefdc, ref_zrefdc) - CALL kgen_verify_real_r8_dim2( "ztrac", check_status, ztrac, ref_ztrac) - CALL kgen_verify_real_r8_dim2( "ztradc", check_status, ztradc, ref_ztradc) - CALL kgen_print_check("reftra_sw", check_status) - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,3000 - CALL reftra_sw(klev, ncol, lrtchkclr, zgcc, prmu0, ztauc, zomcc, zrefc, zrefdc, ztrac, ztradc) - END DO - CALL system_clock(stop_clock, rate_clock) - WRITE(*,*) - PRINT *, "Elapsed time (sec): ", (stop_clock - start_clock)/REAL(rate_clock*3000) - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_r8_dim2(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim2 - - - ! verify subroutines - SUBROUTINE kgen_verify_real_r8_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim2 - - END SUBROUTINE spcvmc_sw - END MODULE rrtmg_sw_spcvmc diff --git a/test/ncar_kernels/PORT_sw_reftra/src/shr_kind_mod.f90 b/test/ncar_kernels/PORT_sw_reftra/src/shr_kind_mod.f90 deleted file mode 100644 index d3796d5ed7..0000000000 --- a/test/ncar_kernels/PORT_sw_reftra/src/shr_kind_mod.f90 +++ /dev/null @@ -1,26 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : shr_kind_mod.f90 -! Generated at: 2015-07-31 20:52:25 -! KGEN version: 0.4.13 - - - - MODULE shr_kind_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - PUBLIC - INTEGER, parameter :: shr_kind_r8 = selected_real_kind(12) ! 8 byte real - ! 4 byte real - ! native real - ! 8 byte integer - ! 4 byte integer - ! native integer - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE shr_kind_mod diff --git a/test/ncar_kernels/PORT_sw_setcoef/CESM_license.txt b/test/ncar_kernels/PORT_sw_setcoef/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/PORT_sw_setcoef/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.1.1 b/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.1.1 deleted file mode 100644 index 7f18c7481e..0000000000 Binary files a/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.1.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.1.4 b/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.1.4 deleted file mode 100644 index b29e58048e..0000000000 Binary files a/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.1.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.1.8 b/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.1.8 deleted file mode 100644 index 0e490a7494..0000000000 Binary files a/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.1.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.10.1 b/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.10.1 deleted file mode 100644 index 915940bcdd..0000000000 Binary files a/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.10.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.10.4 b/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.10.4 deleted file mode 100644 index 01584c7b6c..0000000000 Binary files a/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.10.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.10.8 b/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.10.8 deleted file mode 100644 index cc509d8239..0000000000 Binary files a/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.10.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.5.1 b/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.5.1 deleted file mode 100644 index ef0cb55e65..0000000000 Binary files a/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.5.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.5.4 b/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.5.4 deleted file mode 100644 index 29df3107db..0000000000 Binary files a/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.5.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.5.8 b/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.5.8 deleted file mode 100644 index d6ad075900..0000000000 Binary files a/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.5.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_setcoef/inc/t1.mk b/test/ncar_kernels/PORT_sw_setcoef/inc/t1.mk deleted file mode 100644 index b8b244b3cd..0000000000 --- a/test/ncar_kernels/PORT_sw_setcoef/inc/t1.mk +++ /dev/null @@ -1,71 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# Intel default flags -# -# FC_FLAGS := -O2 -fp-model source -convert big_endian -assume byterecl -# -ftz -traceback -assume realloc_lhs -xAVX -# -FC_FLAGS := $(OPT) -FC_FLAGS += -Mnofma -Kieee - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - -# Makefile for KGEN-generated kernel - -ALL_OBJS := kernel_driver.o rrtmg_sw_rad.o kgen_utils.o rrsw_ref.o rrtmg_sw_setcoef.o shr_kind_mod.o parrrsw.o - -verify: - @(grep "verification.FAIL" $(TEST).rslt && echo "FAILED") || (grep "verification.PASS" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 rrtmg_sw_rad.o kgen_utils.o rrsw_ref.o rrtmg_sw_setcoef.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_sw_rad.o: $(SRC_DIR)/rrtmg_sw_rad.f90 kgen_utils.o rrtmg_sw_setcoef.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_ref.o: $(SRC_DIR)/rrsw_ref.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_sw_setcoef.o: $(SRC_DIR)/rrtmg_sw_setcoef.f90 kgen_utils.o shr_kind_mod.o rrsw_ref.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_kind_mod.o: $(SRC_DIR)/shr_kind_mod.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -parrrsw.o: $(SRC_DIR)/parrrsw.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -kgen_utils.o: $(SRC_DIR)/kgen_utils.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.oo *.rslt diff --git a/test/ncar_kernels/PORT_sw_setcoef/lit/runmake b/test/ncar_kernels/PORT_sw_setcoef/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/PORT_sw_setcoef/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/PORT_sw_setcoef/lit/t1.sh b/test/ncar_kernels/PORT_sw_setcoef/lit/t1.sh deleted file mode 100644 index 33c953a156..0000000000 --- a/test/ncar_kernels/PORT_sw_setcoef/lit/t1.sh +++ /dev/null @@ -1,9 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -# Shared lit script for each tests. Run bash commands that run tests with make. - -# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t -# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/PORT_sw_setcoef/makefile b/test/ncar_kernels/PORT_sw_setcoef/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/PORT_sw_setcoef/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/PORT_sw_setcoef/src/kernel_driver.f90 b/test/ncar_kernels/PORT_sw_setcoef/src/kernel_driver.f90 deleted file mode 100644 index 00aa16cd31..0000000000 --- a/test/ncar_kernels/PORT_sw_setcoef/src/kernel_driver.f90 +++ /dev/null @@ -1,81 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-07-27 00:47:03 -! KGEN version: 0.4.13 - - -PROGRAM kernel_driver - USE rrtmg_sw_rad, ONLY : rrtmg_sw - USE rrsw_ref, ONLY : kgen_read_externs_rrsw_ref - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - - IMPLICIT NONE - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_mpi_rank_at = (/ 1, 4, 8 /) - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_counter_at = (/ 1, 10, 5 /) - CHARACTER(LEN=1024) :: kgen_filepath - INTEGER :: ncol - INTEGER :: nlay - - DO kgen_repeat_counter = 0, 8 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - kgen_filepath = "../data/setcoef_sw." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "** Verification against '" // trim(adjustl(kgen_filepath)) // "' **" - - CALL kgen_read_externs_rrsw_ref(kgen_unit) - - ! driver variables - READ(UNIT=kgen_unit) ncol - READ(UNIT=kgen_unit) nlay - - call rrtmg_sw(ncol, nlay, kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! write subroutines - ! No subroutines - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/PORT_sw_setcoef/src/kgen_utils.f90 b/test/ncar_kernels/PORT_sw_setcoef/src/kgen_utils.f90 deleted file mode 100644 index cfa8d114e0..0000000000 --- a/test/ncar_kernels/PORT_sw_setcoef/src/kgen_utils.f90 +++ /dev/null @@ -1,61 +0,0 @@ -module kgen_utils_mod - -INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - -type check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - real(kind=kgen_dp) :: minvalue -end type check_t - -public kgen_dp, check_t, kgen_init_check, kgen_print_check - -contains - -subroutine kgen_init_check(check, tolerance, minvalue) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - real(kind=kgen_dp), intent(in), optional :: minvalue - - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.0D-15 - endif - if(present(minvalue)) then - check%minvalue = minvalue - else - check%minvalue = 1.0D-15 - endif -end subroutine kgen_init_check - -subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif -end subroutine kgen_print_check - -end module diff --git a/test/ncar_kernels/PORT_sw_setcoef/src/parrrsw.f90 b/test/ncar_kernels/PORT_sw_setcoef/src/parrrsw.f90 deleted file mode 100644 index 318e201346..0000000000 --- a/test/ncar_kernels/PORT_sw_setcoef/src/parrrsw.f90 +++ /dev/null @@ -1,82 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : parrrsw.f90 -! Generated at: 2015-07-27 00:47:04 -! KGEN version: 0.4.13 - - - - MODULE parrrsw - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw main parameters - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! mxlay : integer: maximum number of layers - ! mg : integer: number of original g-intervals per spectral band - ! nbndsw : integer: number of spectral bands - ! naerec : integer: number of aerosols (iaer=6, ecmwf aerosol option) - ! ngptsw : integer: total number of reduced g-intervals for rrtmg_lw - ! ngNN : integer: number of reduced g-intervals per spectral band - ! ngsNN : integer: cumulative number of g-intervals per band - !------------------------------------------------------------------ - ! Settings for single column mode. - ! For GCM use, set nlon to number of longitudes, and - ! mxlay to number of model layers - !jplay, klev - !jpg - !jpsw, ksw - !jpaer - INTEGER, parameter :: mxmol = 38 - ! Use for 112 g-point model - !jpgpt - ! Use for 224 g-point model - ! integer, parameter :: ngptsw = 224 !jpgpt - ! may need to rename these - from v2.6 - !istart - !iend - ! ^ - ! Use for 112 g-point model - ! Use for 224 g-point model - ! integer, parameter :: ng16 = 16 - ! integer, parameter :: ng17 = 16 - ! integer, parameter :: ng18 = 16 - ! integer, parameter :: ng19 = 16 - ! integer, parameter :: ng20 = 16 - ! integer, parameter :: ng21 = 16 - ! integer, parameter :: ng22 = 16 - ! integer, parameter :: ng23 = 16 - ! integer, parameter :: ng24 = 16 - ! integer, parameter :: ng25 = 16 - ! integer, parameter :: ng26 = 16 - ! integer, parameter :: ng27 = 16 - ! integer, parameter :: ng28 = 16 - ! integer, parameter :: ng29 = 16 - ! integer, parameter :: ngs16 = 16 - ! integer, parameter :: ngs17 = 32 - ! integer, parameter :: ngs18 = 48 - ! integer, parameter :: ngs19 = 64 - ! integer, parameter :: ngs20 = 80 - ! integer, parameter :: ngs21 = 96 - ! integer, parameter :: ngs22 = 112 - ! integer, parameter :: ngs23 = 128 - ! integer, parameter :: ngs24 = 144 - ! integer, parameter :: ngs25 = 160 - ! integer, parameter :: ngs26 = 176 - ! integer, parameter :: ngs27 = 192 - ! integer, parameter :: ngs28 = 208 - ! integer, parameter :: ngs29 = 224 - ! Source function solar constant - ! W/m2 - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE parrrsw diff --git a/test/ncar_kernels/PORT_sw_setcoef/src/rrsw_ref.f90 b/test/ncar_kernels/PORT_sw_setcoef/src/rrsw_ref.f90 deleted file mode 100644 index 901cae4798..0000000000 --- a/test/ncar_kernels/PORT_sw_setcoef/src/rrsw_ref.f90 +++ /dev/null @@ -1,43 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_ref.f90 -! Generated at: 2015-07-27 00:47:03 -! KGEN version: 0.4.13 - - - - MODULE rrsw_ref - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw reference atmosphere - ! Based on standard mid-latitude summer profile - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! pref : real : Reference pressure levels - ! preflog: real : Reference pressure levels, ln(pref) - ! tref : real : Reference temperature levels for MLS profile - !------------------------------------------------------------------ - REAL(KIND=r8), dimension(59) :: preflog - REAL(KIND=r8), dimension(59) :: tref - PUBLIC kgen_read_externs_rrsw_ref - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_ref(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) preflog - READ(UNIT=kgen_unit) tref - END SUBROUTINE kgen_read_externs_rrsw_ref - - END MODULE rrsw_ref diff --git a/test/ncar_kernels/PORT_sw_setcoef/src/rrtmg_sw_rad.f90 b/test/ncar_kernels/PORT_sw_setcoef/src/rrtmg_sw_rad.f90 deleted file mode 100644 index ea2a9fbe4c..0000000000 --- a/test/ncar_kernels/PORT_sw_setcoef/src/rrtmg_sw_rad.f90 +++ /dev/null @@ -1,800 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_sw_rad.f90 -! Generated at: 2015-07-27 00:47:03 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_sw_rad - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! - ! **************************************************************************** - ! * * - ! * RRTMG_SW * - ! * * - ! * * - ! * * - ! * a rapid radiative transfer model * - ! * for the solar spectral region * - ! * for application to general circulation models * - ! * * - ! * * - ! * Atmospheric and Environmental Research, Inc. * - ! * 131 Hartwell Avenue * - ! * Lexington, MA 02421 * - ! * * - ! * * - ! * Eli J. Mlawer * - ! * Jennifer S. Delamere * - ! * Michael J. Iacono * - ! * Shepard A. Clough * - ! * * - ! * * - ! * * - ! * * - ! * * - ! * * - ! * email: miacono@aer.com * - ! * email: emlawer@aer.com * - ! * email: jdelamer@aer.com * - ! * * - ! * The authors wish to acknowledge the contributions of the * - ! * following people: Steven J. Taubman, Patrick D. Brown, * - ! * Ronald E. Farren, Luke Chen, Robert Bergstrom. * - ! * * - ! **************************************************************************** - ! --------- Modules --------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - ! Move call to rrtmg_sw_ini and following use association to - ! GCM initialization area - ! use rrtmg_sw_init, only: rrtmg_sw_ini - USE rrtmg_sw_setcoef, ONLY: setcoef_sw - IMPLICIT NONE - ! public interfaces/functions/subroutines - ! public :: rrtmg_sw, inatm_sw, earth_sun - PUBLIC rrtmg_sw - !------------------------------------------------------------------ - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !------------------------------------------------------------------ - !------------------------------------------------------------------ - ! Public subroutines - !------------------------------------------------------------------ - - SUBROUTINE rrtmg_sw(ncol, nlay, kgen_unit) - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! ------- Description ------- - ! This program is the driver for RRTMG_SW, the AER SW radiation model for - ! application to GCMs, that has been adapted from RRTM_SW for improved - ! efficiency and to provide fractional cloudiness and cloud overlap - ! capability using McICA. - ! - ! Note: The call to RRTMG_SW_INI should be moved to the GCM initialization - ! area, since this has to be called only once. - ! - ! This routine - ! b) calls INATM_SW to read in the atmospheric profile; - ! all layering in RRTMG is ordered from surface to toa. - ! c) calls CLDPRMC_SW to set cloud optical depth for McICA based - ! on input cloud properties - ! d) calls SETCOEF_SW to calculate various quantities needed for - ! the radiative transfer algorithm - ! e) calls SPCVMC to call the two-stream model that in turn - ! calls TAUMOL to calculate gaseous optical depths for each - ! of the 16 spectral bands and to perform the radiative transfer - ! using McICA, the Monte-Carlo Independent Column Approximation, - ! to represent sub-grid scale cloud variability - ! f) passes the calculated fluxes and cooling rates back to GCM - ! - ! Two modes of operation are possible: - ! The mode is chosen by using either rrtmg_sw.nomcica.f90 (to not use - ! McICA) or rrtmg_sw.f90 (to use McICA) to interface with a GCM. - ! - ! 1) Standard, single forward model calculation (imca = 0); this is - ! valid only for clear sky or fully overcast clouds - ! 2) Monte Carlo Independent Column Approximation (McICA, Pincus et al., - ! JC, 2003) method is applied to the forward model calculation (imca = 1) - ! This method is valid for clear sky or partial cloud conditions. - ! - ! This call to RRTMG_SW must be preceeded by a call to the module - ! mcica_subcol_gen_sw.f90 to run the McICA sub-column cloud generator, - ! which will provide the cloud physical or cloud optical properties - ! on the RRTMG quadrature point (ngptsw) dimension. - ! - ! Two methods of cloud property input are possible: - ! Cloud properties can be input in one of two ways (controlled by input - ! flags inflag, iceflag and liqflag; see text file rrtmg_sw_instructions - ! and subroutine rrtmg_sw_cldprop.f90 for further details): - ! - ! 1) Input cloud fraction, cloud optical depth, single scattering albedo - ! and asymmetry parameter directly (inflgsw = 0) - ! 2) Input cloud fraction and cloud physical properties: ice fracion, - ! ice and liquid particle sizes (inflgsw = 1 or 2); - ! cloud optical properties are calculated by cldprop or cldprmc based - ! on input settings of iceflgsw and liqflgsw - ! - ! Two methods of aerosol property input are possible: - ! Aerosol properties can be input in one of two ways (controlled by input - ! flag iaer, see text file rrtmg_sw_instructions for further details): - ! - ! 1) Input aerosol optical depth, single scattering albedo and asymmetry - ! parameter directly by layer and spectral band (iaer=10) - ! 2) Input aerosol optical depth and 0.55 micron directly by layer and use - ! one or more of six ECMWF aerosol types (iaer=6) - ! - ! - ! ------- Modifications ------- - ! - ! This version of RRTMG_SW has been modified from RRTM_SW to use a reduced - ! set of g-point intervals and a two-stream model for application to GCMs. - ! - !-- Original version (derived from RRTM_SW) - ! 2002: AER. Inc. - !-- Conversion to F90 formatting; addition of 2-stream radiative transfer - ! Feb 2003: J.-J. Morcrette, ECMWF - !-- Additional modifications for GCM application - ! Aug 2003: M. J. Iacono, AER Inc. - !-- Total number of g-points reduced from 224 to 112. Original - ! set of 224 can be restored by exchanging code in module parrrsw.f90 - ! and in file rrtmg_sw_init.f90. - ! Apr 2004: M. J. Iacono, AER, Inc. - !-- Modifications to include output for direct and diffuse - ! downward fluxes. There are output as "true" fluxes without - ! any delta scaling applied. Code can be commented to exclude - ! this calculation in source file rrtmg_sw_spcvrt.f90. - ! Jan 2005: E. J. Mlawer, M. J. Iacono, AER, Inc. - !-- Revised to add McICA capability. - ! Nov 2005: M. J. Iacono, AER, Inc. - !-- Reformatted for consistency with rrtmg_lw. - ! Feb 2007: M. J. Iacono, AER, Inc. - !-- Modifications to formatting to use assumed-shape arrays. - ! Aug 2007: M. J. Iacono, AER, Inc. - !-- Modified to output direct and diffuse fluxes either with or without - ! delta scaling based on setting of idelm flag - ! Dec 2008: M. J. Iacono, AER, Inc. - ! --------- Modules --------- - USE parrrsw, ONLY: mxmol - ! ------- Declarations - ! ----- Input ----- - integer, intent(in) :: kgen_unit - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - ! chunk identifier - INTEGER, intent(in) :: ncol ! Number of horizontal columns - INTEGER, intent(in) :: nlay ! Number of model layers - ! Cloud overlap method - ! 0: Clear only - ! 1: Random - ! 2: Maximum/random - ! 3: Maximum - ! Layer pressures (hPa, mb) - ! Dimensions: (ncol,nlay) - ! Interface pressures (hPa, mb) - ! Dimensions: (ncol,nlay+1) - ! Layer temperatures (K) - ! Dimensions: (ncol,nlay) - ! Interface temperatures (K) - ! Dimensions: (ncol,nlay+1) - ! Surface temperature (K) - ! Dimensions: (ncol) - ! H2O volume mixing ratio - ! Dimensions: (ncol,nlay) - ! O3 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! CO2 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! Methane volume mixing ratio - ! Dimensions: (ncol,nlay) - ! O2 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! Nitrous oxide volume mixing ratio - ! Dimensions: (ncol,nlay) - ! UV/vis surface albedo direct rad - ! Dimensions: (ncol) - ! Near-IR surface albedo direct rad - ! Dimensions: (ncol) - ! UV/vis surface albedo: diffuse rad - ! Dimensions: (ncol) - ! Near-IR surface albedo: diffuse rad - ! Dimensions: (ncol) - ! Day of the year (used to get Earth/Sun - ! distance if adjflx not provided) - ! Flux adjustment for Earth/Sun distance - ! Cosine of solar zenith angle - ! Dimensions: (ncol) - ! Solar constant (Wm-2) scaling per band - ! Flag for cloud optical properties - ! Flag for ice particle specification - ! Flag for liquid droplet specification - ! Cloud fraction - ! Dimensions: (ngptsw,ncol,nlay) - ! Cloud optical depth - ! Dimensions: (ngptsw,ncol,nlay) - ! Cloud single scattering albedo - ! Dimensions: (ngptsw,ncol,nlay) - ! Cloud asymmetry parameter - ! Dimensions: (ngptsw,ncol,nlay) - ! Cloud forward scattering parameter - ! Dimensions: (ngptsw,ncol,nlay) - ! Cloud ice water path (g/m2) - ! Dimensions: (ngptsw,ncol,nlay) - ! Cloud liquid water path (g/m2) - ! Dimensions: (ngptsw,ncol,nlay) - ! Cloud ice effective radius (microns) - ! Dimensions: (ncol,nlay) - ! Cloud water drop effective radius (microns) - ! Dimensions: (ncol,nlay) - ! Aerosol optical depth (iaer=10 only) - ! Dimensions: (ncol,nlay,nbndsw) - ! (non-delta scaled) - ! Aerosol single scattering albedo (iaer=10 only) - ! Dimensions: (ncol,nlay,nbndsw) - ! (non-delta scaled) - ! Aerosol asymmetry parameter (iaer=10 only) - ! Dimensions: (ncol,nlay,nbndsw) - ! (non-delta scaled) - ! real(kind=r8), intent(in) :: ecaer(:,:,:) ! Aerosol optical depth at 0.55 micron (iaer=6 only) - ! Dimensions: (ncol,nlay,naerec) - ! (non-delta scaled) - ! ----- Output ----- - ! Total sky shortwave upward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Total sky shortwave downward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Total sky shortwave radiative heating rate (K/d) - ! Dimensions: (ncol,nlay) - ! Clear sky shortwave upward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Clear sky shortwave downward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Clear sky shortwave radiative heating rate (K/d) - ! Dimensions: (ncol,nlay) - ! Direct downward shortwave flux, UV/vis - ! Diffuse downward shortwave flux, UV/vis - ! Direct downward shortwave flux, near-IR - ! Diffuse downward shortwave flux, near-IR - ! Net shortwave flux, near-IR - ! Net clear sky shortwave flux, near-IR - ! shortwave spectral flux up - ! shortwave spectral flux down - ! ----- Local ----- - ! Control - ! beginning band of calculation - ! ending band of calculation - ! cldprop/cldprmc use flag - ! output option flag (inactive) - ! aerosol option flag - ! delta-m scaling flag - ! [0 = direct and diffuse fluxes are unscaled] - ! [1 = direct and diffuse fluxes are scaled] - ! (total downward fluxes are always delta scaled) - ! instrumental cosine response flag (inactive) - ! column loop index - ! layer loop index ! jk - ! band loop index ! jsw - ! indices - ! layer loop index - ! value for changing mcica permute seed - ! flag for mcica [0=off, 1=on] - ! epsilon - ! flux to heating conversion ratio - ! Atmosphere - REAL(KIND=r8) :: pavel(ncol,nlay) ! layer pressures (mb) - REAL(KIND=r8) :: tavel(ncol,nlay) ! layer temperatures (K) - REAL(KIND=r8) :: pz(ncol,0:nlay) ! level (interface) pressures (hPa, mb) - REAL(KIND=r8) :: tz(ncol,0:nlay) ! level (interface) temperatures (K) - REAL(KIND=r8) :: tbound(ncol) ! surface temperature (K) - ! layer pressure thickness (hPa, mb) - REAL(KIND=r8) :: coldry(ncol,nlay) ! dry air column amount - REAL(KIND=r8) :: wkl(ncol,mxmol,nlay) ! molecular amounts (mol/cm-2) - ! real(kind=r8) :: earth_sun ! function for Earth/Sun distance factor - ! Cosine of solar zenith angle - ! adjustment for current Earth/Sun distance - ! real(kind=r8) :: solvar(jpband) ! solar constant scaling factor from rrtmg_sw - ! default value of 1368.22 Wm-2 at 1 AU - ! surface albedo, direct ! zalbp - ! surface albedo, diffuse ! zalbd - ! Aerosol optical depth - ! Aerosol single scattering albedo - ! Aerosol asymmetry parameter - ! Atmosphere - setcoef - INTEGER :: laytrop(ncol) - INTEGER :: ref_laytrop(ncol) ! tropopause layer index - INTEGER :: layswtch(ncol) - INTEGER :: ref_layswtch(ncol) ! - INTEGER :: laylow(ncol) - INTEGER :: ref_laylow(ncol) ! - INTEGER :: jp(ncol,nlay) - INTEGER :: ref_jp(ncol,nlay) ! - INTEGER :: jt(ncol,nlay) - INTEGER :: ref_jt(ncol,nlay) ! - INTEGER :: jt1(ncol,nlay) - INTEGER :: ref_jt1(ncol,nlay) ! - REAL(KIND=r8) :: colh2o(ncol,nlay) - REAL(KIND=r8) :: ref_colh2o(ncol,nlay) ! column amount (h2o) - REAL(KIND=r8) :: colco2(ncol,nlay) - REAL(KIND=r8) :: ref_colco2(ncol,nlay) ! column amount (co2) - REAL(KIND=r8) :: colo3(ncol,nlay) - REAL(KIND=r8) :: ref_colo3(ncol,nlay) ! column amount (o3) - REAL(KIND=r8) :: coln2o(ncol,nlay) - REAL(KIND=r8) :: ref_coln2o(ncol,nlay) ! column amount (n2o) - REAL(KIND=r8) :: colch4(ncol,nlay) - REAL(KIND=r8) :: ref_colch4(ncol,nlay) ! column amount (ch4) - REAL(KIND=r8) :: colo2(ncol,nlay) - REAL(KIND=r8) :: ref_colo2(ncol,nlay) ! column amount (o2) - REAL(KIND=r8) :: colmol(ncol,nlay) - REAL(KIND=r8) :: ref_colmol(ncol,nlay) ! column amount - REAL(KIND=r8) :: co2mult(ncol,nlay) - REAL(KIND=r8) :: ref_co2mult(ncol,nlay) ! column amount - INTEGER :: indself(ncol,nlay) - INTEGER :: ref_indself(ncol,nlay) - INTEGER :: indfor(ncol,nlay) - INTEGER :: ref_indfor(ncol,nlay) - REAL(KIND=r8) :: selffac(ncol,nlay) - REAL(KIND=r8) :: ref_selffac(ncol,nlay) - REAL(KIND=r8) :: selffrac(ncol,nlay) - REAL(KIND=r8) :: ref_selffrac(ncol,nlay) - REAL(KIND=r8) :: forfac(ncol,nlay) - REAL(KIND=r8) :: ref_forfac(ncol,nlay) - REAL(KIND=r8) :: forfrac(ncol,nlay) - REAL(KIND=r8) :: ref_forfrac(ncol,nlay) - REAL(KIND=r8) :: fac00(ncol,nlay) - REAL(KIND=r8) :: ref_fac00(ncol,nlay) - REAL(KIND=r8) :: fac01(ncol,nlay) - REAL(KIND=r8) :: ref_fac01(ncol,nlay) - REAL(KIND=r8) :: fac11(ncol,nlay) - REAL(KIND=r8) :: ref_fac11(ncol,nlay) - REAL(KIND=r8) :: fac10(ncol,nlay) - REAL(KIND=r8) :: ref_fac10(ncol,nlay) ! - ! Atmosphere/clouds - cldprop - ! number of cloud spectral bands - ! flag for cloud property method - ! flag for ice cloud properties - ! flag for liquid cloud properties - ! real(kind=r8) :: cldfrac(nlay) ! layer cloud fraction - ! real(kind=r8) :: tauc(nlay) ! cloud optical depth (non-delta scaled) - ! real(kind=r8) :: ssac(nlay) ! cloud single scattering albedo (non-delta scaled) - ! real(kind=r8) :: asmc(nlay) ! cloud asymmetry parameter (non-delta scaled) - ! real(kind=r8) :: ciwp(nlay) ! cloud ice water path - ! real(kind=r8) :: clwp(nlay) ! cloud liquid water path - ! real(kind=r8) :: rei(nlay) ! cloud ice particle size - ! real(kind=r8) :: rel(nlay) ! cloud liquid particle size - ! real(kind=r8) :: taucloud(nlay,jpband) ! cloud optical depth - ! real(kind=r8) :: taucldorig(nlay,jpband) ! cloud optical depth (non-delta scaled) - ! real(kind=r8) :: ssacloud(nlay,jpband) ! cloud single scattering albedo - ! real(kind=r8) :: asmcloud(nlay,jpband) ! cloud asymmetry parameter - ! Atmosphere/clouds - cldprmc [mcica] - ! cloud fraction [mcica] - ! cloud ice water path [mcica] - ! cloud liquid water path [mcica] - ! liquid particle size (microns) - ! ice particle effective radius (microns) - ! ice particle generalized effective size (microns) - ! cloud optical depth [mcica] - ! unscaled cloud optical depth [mcica] - ! cloud single scattering albedo [mcica] - ! cloud asymmetry parameter [mcica] - ! cloud forward scattering fraction [mcica] - ! Atmosphere/clouds/aerosol - spcvrt,spcvmc - ! cloud optical depth - ! unscaled cloud optical depth - ! cloud asymmetry parameter - ! (first moment of phase function) - ! cloud single scattering albedo - ! total aerosol optical depth - ! total aerosol asymmetry parameter - ! total aerosol single scattering albedo - ! cloud fraction [mcica] - ! cloud optical depth [mcica] - ! unscaled cloud optical depth [mcica] - ! cloud asymmetry parameter [mcica] - ! cloud single scattering albedo [mcica] - ! temporary upward shortwave flux (w/m2) - ! temporary downward shortwave flux (w/m2) - ! temporary clear sky upward shortwave flux (w/m2) - ! temporary clear sky downward shortwave flux (w/m2) - ! temporary downward direct shortwave flux (w/m2) - ! temporary clear sky downward direct shortwave flux (w/m2) - ! temporary UV downward shortwave flux (w/m2) - ! temporary clear sky UV downward shortwave flux (w/m2) - ! temporary UV downward direct shortwave flux (w/m2) - ! temporary clear sky UV downward direct shortwave flux (w/m2) - ! temporary near-IR downward shortwave flux (w/m2) - ! temporary clear sky near-IR downward shortwave flux (w/m2) - ! temporary near-IR downward direct shortwave flux (w/m2) - ! temporary clear sky near-IR downward direct shortwave flux (w/m2) - ! Added for near-IR flux diagnostic - ! temporary near-IR downward shortwave flux (w/m2) - ! temporary clear sky near-IR downward shortwave flux (w/m2) - ! Optional output fields - ! Total sky shortwave net flux (W/m2) - ! Clear sky shortwave net flux (W/m2) - ! Direct downward shortwave surface flux - ! Diffuse downward shortwave surface flux - ! Total sky downward shortwave flux, UV/vis - ! Total sky downward shortwave flux, near-IR - ! temporary upward shortwave flux spectral (w/m2) - ! temporary downward shortwave flux spectral (w/m2) - ! Output - inactive - ! real(kind=r8) :: zuvfu(nlay+2) ! temporary upward UV shortwave flux (w/m2) - ! real(kind=r8) :: zuvfd(nlay+2) ! temporary downward UV shortwave flux (w/m2) - ! real(kind=r8) :: zuvcu(nlay+2) ! temporary clear sky upward UV shortwave flux (w/m2) - ! real(kind=r8) :: zuvcd(nlay+2) ! temporary clear sky downward UV shortwave flux (w/m2) - ! real(kind=r8) :: zvsfu(nlay+2) ! temporary upward visible shortwave flux (w/m2) - ! real(kind=r8) :: zvsfd(nlay+2) ! temporary downward visible shortwave flux (w/m2) - ! real(kind=r8) :: zvscu(nlay+2) ! temporary clear sky upward visible shortwave flux (w/m2) - ! real(kind=r8) :: zvscd(nlay+2) ! temporary clear sky downward visible shortwave flux (w/m2) - ! real(kind=r8) :: znifu(nlay+2) ! temporary upward near-IR shortwave flux (w/m2) - ! real(kind=r8) :: znifd(nlay+2) ! temporary downward near-IR shortwave flux (w/m2) - ! real(kind=r8) :: znicu(nlay+2) ! temporary clear sky upward near-IR shortwave flux (w/m2) - ! real(kind=r8) :: znicd(nlay+2) ! temporary clear sky downward near-IR shortwave flux (w/m2) - ! Initializations - ! In a GCM with or without McICA, set nlon to the longitude dimension - ! - ! Set imca to select calculation type: - ! imca = 0, use standard forward model calculation (clear and overcast only) - ! imca = 1, use McICA for Monte Carlo treatment of sub-grid cloud variability - ! (clear, overcast or partial cloud conditions) - ! *** This version uses McICA (imca = 1) *** - ! Set icld to select of clear or cloud calculation and cloud - ! overlap method (read by subroutine readprof from input file INPUT_RRTM): - ! icld = 0, clear only - ! icld = 1, with clouds using random cloud overlap (McICA only) - ! icld = 2, with clouds using maximum/random cloud overlap (McICA only) - ! icld = 3, with clouds using maximum cloud overlap (McICA only) - ! Set iaer to select aerosol option - ! iaer = 0, no aerosols - ! iaer = 6, use six ECMWF aerosol types - ! input aerosol optical depth at 0.55 microns for each aerosol type (ecaer) - ! iaer = 10, input total aerosol optical depth, single scattering albedo - ! and asymmetry parameter (tauaer, ssaaer, asmaer) directly - ! Set idelm to select between delta-M scaled or unscaled output direct and diffuse fluxes - ! NOTE: total downward fluxes are always delta scaled - ! idelm = 0, output direct and diffuse flux components are not delta scaled - ! (direct flux does not include forward scattering peak) - ! idelm = 1, output direct and diffuse flux components are delta scaled (default) - ! (direct flux includes part or most of forward scattering peak) - ! Call model and data initialization, compute lookup tables, perform - ! reduction of g-points from 224 to 112 for input absorption - ! coefficient data and other arrays. - ! - ! In a GCM this call should be placed in the model initialization - ! area, since this has to be called only once. - ! call rrtmg_sw_ini - ! This is the main longitude/column loop in RRTMG. - ! Modify to loop over all columns (nlon) or over daylight columns - !JMD #define OLD_INATM_SW 1 - ! For cloudy atmosphere, use cldprop to set cloud optical properties based on - ! input cloud physical properties. Select method based on choices described - ! in cldprop. Cloud fraction, water path, liquid droplet and ice particle - ! effective radius must be passed in cldprop. Cloud fraction and cloud - ! optical properties are transferred to rrtmg_sw arrays in cldprop. - ! Calculate coefficients for the temperature and pressure dependence of the - ! molecular absorption coefficients by interpolating data from stored - tolerance = 1.E-14 - CALL kgen_init_check(check_status, tolerance) - READ(UNIT=kgen_unit) pavel - READ(UNIT=kgen_unit) tavel - READ(UNIT=kgen_unit) pz - READ(UNIT=kgen_unit) tz - READ(UNIT=kgen_unit) tbound - READ(UNIT=kgen_unit) coldry - READ(UNIT=kgen_unit) wkl - READ(UNIT=kgen_unit) laytrop - READ(UNIT=kgen_unit) layswtch - READ(UNIT=kgen_unit) laylow - READ(UNIT=kgen_unit) jp - READ(UNIT=kgen_unit) jt - READ(UNIT=kgen_unit) jt1 - READ(UNIT=kgen_unit) colh2o - READ(UNIT=kgen_unit) colco2 - READ(UNIT=kgen_unit) colo3 - READ(UNIT=kgen_unit) coln2o - READ(UNIT=kgen_unit) colch4 - READ(UNIT=kgen_unit) colo2 - READ(UNIT=kgen_unit) colmol - READ(UNIT=kgen_unit) co2mult - READ(UNIT=kgen_unit) indself - READ(UNIT=kgen_unit) indfor - READ(UNIT=kgen_unit) selffac - READ(UNIT=kgen_unit) selffrac - READ(UNIT=kgen_unit) forfac - READ(UNIT=kgen_unit) forfrac - READ(UNIT=kgen_unit) fac00 - READ(UNIT=kgen_unit) fac01 - READ(UNIT=kgen_unit) fac11 - READ(UNIT=kgen_unit) fac10 - - READ(UNIT=kgen_unit) ref_laytrop - READ(UNIT=kgen_unit) ref_layswtch - READ(UNIT=kgen_unit) ref_laylow - READ(UNIT=kgen_unit) ref_jp - READ(UNIT=kgen_unit) ref_jt - READ(UNIT=kgen_unit) ref_jt1 - READ(UNIT=kgen_unit) ref_colh2o - READ(UNIT=kgen_unit) ref_colco2 - READ(UNIT=kgen_unit) ref_colo3 - READ(UNIT=kgen_unit) ref_coln2o - READ(UNIT=kgen_unit) ref_colch4 - READ(UNIT=kgen_unit) ref_colo2 - READ(UNIT=kgen_unit) ref_colmol - READ(UNIT=kgen_unit) ref_co2mult - READ(UNIT=kgen_unit) ref_indself - READ(UNIT=kgen_unit) ref_indfor - READ(UNIT=kgen_unit) ref_selffac - READ(UNIT=kgen_unit) ref_selffrac - READ(UNIT=kgen_unit) ref_forfac - READ(UNIT=kgen_unit) ref_forfrac - READ(UNIT=kgen_unit) ref_fac00 - READ(UNIT=kgen_unit) ref_fac01 - READ(UNIT=kgen_unit) ref_fac11 - READ(UNIT=kgen_unit) ref_fac10 - - - ! call to kernel - call setcoef_sw(ncol,nlay, pavel, tavel, pz, tz, tbound, coldry, wkl, & - laytrop, layswtch, laylow, jp, jt, jt1, & - co2mult, colch4, colco2, colh2o, colmol, coln2o, & - colo2, colo3, fac00, fac01, fac10, fac11, & - selffac, selffrac, indself, forfac, forfrac, indfor) - ! kernel verification for output variables - CALL kgen_verify_integer_4_dim1( "laytrop", check_status, laytrop, ref_laytrop) - CALL kgen_verify_integer_4_dim1( "layswtch", check_status, layswtch, ref_layswtch) - CALL kgen_verify_integer_4_dim1( "laylow", check_status, laylow, ref_laylow) - CALL kgen_verify_integer_4_dim2( "jp", check_status, jp, ref_jp) - CALL kgen_verify_integer_4_dim2( "jt", check_status, jt, ref_jt) - CALL kgen_verify_integer_4_dim2( "jt1", check_status, jt1, ref_jt1) - CALL kgen_verify_real_r8_dim2( "colh2o", check_status, colh2o, ref_colh2o) - CALL kgen_verify_real_r8_dim2( "colco2", check_status, colco2, ref_colco2) - CALL kgen_verify_real_r8_dim2( "colo3", check_status, colo3, ref_colo3) - CALL kgen_verify_real_r8_dim2( "coln2o", check_status, coln2o, ref_coln2o) - CALL kgen_verify_real_r8_dim2( "colch4", check_status, colch4, ref_colch4) - CALL kgen_verify_real_r8_dim2( "colo2", check_status, colo2, ref_colo2) - CALL kgen_verify_real_r8_dim2( "colmol", check_status, colmol, ref_colmol) - CALL kgen_verify_real_r8_dim2( "co2mult", check_status, co2mult, ref_co2mult) - CALL kgen_verify_integer_4_dim2( "indself", check_status, indself, ref_indself) - CALL kgen_verify_integer_4_dim2( "indfor", check_status, indfor, ref_indfor) - CALL kgen_verify_real_r8_dim2( "selffac", check_status, selffac, ref_selffac) - CALL kgen_verify_real_r8_dim2( "selffrac", check_status, selffrac, ref_selffrac) - CALL kgen_verify_real_r8_dim2( "forfac", check_status, forfac, ref_forfac) - CALL kgen_verify_real_r8_dim2( "forfrac", check_status, forfrac, ref_forfrac) - CALL kgen_verify_real_r8_dim2( "fac00", check_status, fac00, ref_fac00) - CALL kgen_verify_real_r8_dim2( "fac01", check_status, fac01, ref_fac01) - CALL kgen_verify_real_r8_dim2( "fac11", check_status, fac11, ref_fac11) - CALL kgen_verify_real_r8_dim2( "fac10", check_status, fac10, ref_fac10) - CALL kgen_print_check("setcoef_sw", check_status) - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,10 - CALL setcoef_sw(ncol, nlay, pavel, tavel, pz, tz, tbound, coldry, wkl, laytrop, layswtch, laylow, & -jp, jt, jt1, co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3, fac00, fac01, fac10, fac11, selffac, & -selffrac, indself, forfac, forfrac, indfor) - END DO - CALL system_clock(stop_clock, rate_clock) - WRITE(*,*) - PRINT *, "Elapsed time (sec): ", (stop_clock - start_clock)/REAL(rate_clock*10) - !do iplon = 1, ncol ! reference atmospheres. - ! call setcoef_sw(nlay, pavel(iplon,:), tavel(iplon,:), pz(iplon,:), tz(iplon,:), tbound(iplon), coldry(iplon,:), wkl( - ! iplon,:,:), & - ! laytrop(iplon), layswtch(iplon), laylow(iplon), jp(iplon,:), jt(iplon,:), jt1(iplon,:), & - ! co2mult(iplon,:), colch4(iplon,:), colco2(iplon,:), colh2o(iplon,:), colmol(iplon,:), coln2o(iplon,:) - ! , & - ! colo2(iplon,:), colo3(iplon,:), fac00(iplon,:), fac01(iplon,:), fac10(iplon,:), fac11(iplon,:), & - ! selffac(iplon,:), selffrac(iplon,:), indself(iplon,:), forfac(iplon,:), forfrac(iplon,:), indfor( - ! iplon,:)) - !end do - ! Cosine of the solar zenith angle - ! Prevent using value of zero; ideally, SW model is not called from host model when sun - ! is below horizon - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_integer_4_dim1(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - integer(KIND=4), INTENT(OUT), ALLOCATABLE, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_integer_4_dim1 - - SUBROUTINE kgen_read_integer_4_dim2(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - integer(KIND=4), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_integer_4_dim2 - - SUBROUTINE kgen_read_real_r8_dim2(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim2 - - - ! verify subroutines - SUBROUTINE kgen_verify_integer_4_dim1( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in), DIMENSION(:) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - end if - - check_status%numFatal = check_status%numFatal+1 - END IF - END SUBROUTINE kgen_verify_integer_4_dim1 - - SUBROUTINE kgen_verify_integer_4_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in), DIMENSION(:,:) :: var, ref_var - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - end if - - check_status%numFatal = check_status%numFatal+1 - END IF - END SUBROUTINE kgen_verify_integer_4_dim2 - - SUBROUTINE kgen_verify_real_r8_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim2 - - END SUBROUTINE rrtmg_sw - !************************************************************************* - - !*************************************************************************** - - END MODULE rrtmg_sw_rad diff --git a/test/ncar_kernels/PORT_sw_setcoef/src/rrtmg_sw_setcoef.f90 b/test/ncar_kernels/PORT_sw_setcoef/src/rrtmg_sw_setcoef.f90 deleted file mode 100644 index 6b4d3e5cc2..0000000000 --- a/test/ncar_kernels/PORT_sw_setcoef/src/rrtmg_sw_setcoef.f90 +++ /dev/null @@ -1,260 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_sw_setcoef.f90 -! Generated at: 2015-07-27 00:47:03 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_sw_setcoef - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! ------- Modules ------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE rrsw_ref, ONLY: preflog - USE rrsw_ref, ONLY: tref - IMPLICIT NONE - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !---------------------------------------------------------------------------- - - SUBROUTINE setcoef_sw(ncol, nlayers, vec_pavel, vec_tavel, vec_pz, vec_tz, vec_tbound, vec_coldry, vec_wkl, vec_laytrop, & - vec_layswtch, vec_laylow, vec_jp, vec_jt, vec_jt1, vec_co2mult, vec_colch4, vec_colco2, vec_colh2o, vec_colmol, & - vec_coln2o, vec_colo2, vec_colo3, vec_fac00, vec_fac01, vec_fac10, vec_fac11, vec_selffac, vec_selffrac, vec_indself, & - vec_forfac, vec_forfrac, vec_indfor) - !---------------------------------------------------------------------------- - ! - ! Purpose: For a given atmosphere, calculate the indices and - ! fractions related to the pressure and temperature interpolations. - ! Modifications: - ! Original: J. Delamere, AER, Inc. (version 2.5, 02/04/01) - ! Revised: Rewritten and adapted to ECMWF F90, JJMorcrette 030224 - ! Revised: For uniform rrtmg formatting, MJIacono, Jul 2006 - ! ------ Declarations ------- - ! ----- Input ----- - INTEGER, intent(in) :: ncol ! total number of columns - INTEGER, intent(in) :: nlayers ! total number of layers - REAL(KIND=r8), intent(in) :: vec_pavel(:,:) ! layer pressures (mb) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: vec_tavel(:,:) ! layer temperatures (K) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: vec_pz(:,0:) ! level (interface) pressures (hPa, mb) - ! Dimensions: (ncol,0:nlayers) - REAL(KIND=r8), intent(in) :: vec_tz(:,0:) ! level (interface) temperatures (K) - ! Dimensions: (ncol,0:nlayers) - REAL(KIND=r8), intent(in) :: vec_tbound(:) ! surface temperature (K) - REAL(KIND=r8), intent(in) :: vec_coldry(:,:) ! dry air column density (mol/cm2) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: vec_wkl(:,:,:) ! molecular amounts (mol/cm-2) - ! Dimensions: (mxmol,ncol,nlayers) - ! ----- Output ----- - INTEGER, intent(out) :: vec_laytrop(:) ! tropopause layer index - INTEGER, intent(out) :: vec_layswtch(:) ! - INTEGER, intent(out) :: vec_laylow(:) ! - INTEGER, intent(out) :: vec_jp(:,:) ! - ! Dimensions: (ncol,nlayers) - INTEGER, intent(out) :: vec_jt(:,:) ! - ! Dimensions: (ncol,nlayers) - INTEGER, intent(out) :: vec_jt1(:,:) ! - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(out) :: vec_colh2o(:,:) ! column amount (h2o) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(out) :: vec_colco2(:,:) ! column amount (co2) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(out) :: vec_colo3(:,:) ! column amount (o3) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(out) :: vec_coln2o(:,:) ! column amount (n2o) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(out) :: vec_colch4(:,:) ! column amount (ch4) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(out) :: vec_colo2(:,:) ! column amount (o2) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(out) :: vec_colmol(:,:) ! - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(out) :: vec_co2mult(:,:) ! - ! Dimensions: (ncol,nlayers) - INTEGER, intent(out) :: vec_indself(:,:) - ! Dimensions: (ncol,nlayers) - INTEGER, intent(out) :: vec_indfor(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(out) :: vec_selffac(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(out) :: vec_selffrac(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(out) :: vec_forfac(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(out) :: vec_forfrac(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(out) :: vec_fac11(:,:) - REAL(KIND=r8), intent(out) :: vec_fac10(:,:) - REAL(KIND=r8), intent(out) :: vec_fac00(:,:) - REAL(KIND=r8), intent(out) :: vec_fac01(:,:) ! - ! Dimensions: (ncol,nlayers) - ! ----- Local ----- - INTEGER :: indbound - INTEGER :: indlev0 - INTEGER :: lay - INTEGER :: jp1 - INTEGER :: iplon - REAL(KIND=r8) :: stpfac - REAL(KIND=r8) :: tbndfrac - REAL(KIND=r8) :: t0frac - REAL(KIND=r8) :: plog - REAL(KIND=r8) :: fp - REAL(KIND=r8) :: ft - REAL(KIND=r8) :: ft1 - REAL(KIND=r8) :: water - REAL(KIND=r8) :: scalefac - REAL(KIND=r8) :: factor - REAL(KIND=r8) :: co2reg - REAL(KIND=r8) :: compfp - ! Initializations - stpfac = 296._r8/1013._r8 - !Begin column loop - do iplon=1, ncol - vec_laytrop(iplon) = 0 - vec_layswtch(iplon) = 0 - vec_laylow(iplon) = 0 - indbound = vec_tbound(iplon) - 159._r8 - tbndfrac = vec_tbound(iplon) - int(vec_tbound(iplon)) - indlev0 = vec_tz(iplon,0) - 159._r8 - t0frac = vec_tz(iplon,0) - int(vec_tz(iplon,0)) - ! Begin layer loop - do lay = 1, nlayers - ! Find the two reference pressures on either side of the - ! layer pressure. Store them in JP and JP1. Store in FP the - ! fraction of the difference (in ln(pressure)) between these - ! two values that the layer pressure lies. - plog = log(vec_pavel(iplon,lay)) - vec_jp(iplon,lay) = int(36._r8 - 5*(plog+0.04_r8)) - if (vec_jp(iplon,lay) .lt. 1) then - vec_jp(iplon,lay) = 1 - elseif (vec_jp(iplon,lay) .gt. 58) then - vec_jp(iplon,lay) = 58 - endif - jp1 = vec_jp(iplon,lay) + 1 - fp = 5._r8 * (preflog(vec_jp(iplon,lay)) - plog) - ! Determine, for each reference pressure (JP and JP1), which - ! reference temperature (these are different for each - ! reference pressure) is nearest the layer temperature but does - ! not exceed it. Store these indices in JT and JT1, resp. - ! Store in FT (resp. FT1) the fraction of the way between JT - ! (JT1) and the next highest reference temperature that the - ! layer temperature falls. - vec_jt(iplon,lay) = int(3._r8 + (vec_tavel(iplon,lay)-tref(vec_jp(iplon,lay)))/15._r8) - if (vec_jt(iplon,lay) .lt. 1) then - vec_jt(iplon,lay) = 1 - elseif (vec_jt(iplon,lay) .gt. 4) then - vec_jt(iplon,lay) = 4 - endif - ft = ((vec_tavel(iplon,lay)-tref(vec_jp(iplon,lay)))/15._r8) - float(vec_jt(iplon,lay)-3) - vec_jt1(iplon,lay) = int(3._r8 + (vec_tavel(iplon,lay)-tref(jp1))/15._r8) - if (vec_jt1(iplon,lay) .lt. 1) then - vec_jt1(iplon,lay) = 1 - elseif (vec_jt1(iplon,lay) .gt. 4) then - vec_jt1(iplon,lay) = 4 - endif - ft1 = ((vec_tavel(iplon,lay)-tref(jp1))/15._r8) - float(vec_jt1(iplon,lay)-3) - water = vec_wkl(iplon,1,lay)/vec_coldry(iplon,lay) - scalefac = vec_pavel(iplon,lay) * stpfac / vec_tavel(iplon,lay) - ! If the pressure is less than ~100mb, perform a different - ! set of species interpolations. - if (plog .le. 4.56_r8) go to 5300 - vec_laytrop(iplon) = vec_laytrop(iplon) + 1 - if (plog .ge. 6.62_r8) vec_laylow(iplon) = vec_laylow(iplon) + 1 - ! Set up factors needed to separately include the water vapor - ! foreign-continuum in the calculation of absorption coefficient. - vec_forfac(iplon,lay) = scalefac / (1.+water) - factor = (332.0_r8-vec_tavel(iplon,lay))/36.0_r8 - vec_indfor(iplon,lay) = min(2, max(1, int(factor))) - vec_forfrac(iplon,lay) = factor - float(vec_indfor(iplon,lay)) - ! Set up factors needed to separately include the water vapor - ! self-continuum in the calculation of absorption coefficient. - vec_selffac(iplon,lay) = water * vec_forfac(iplon,lay) - factor = (vec_tavel(iplon,lay)-188.0_r8)/7.2_r8 - vec_indself(iplon,lay) = min(9, max(1, int(factor)-7)) - vec_selffrac(iplon,lay) = factor - float(vec_indself(iplon,lay) + 7) - ! Calculate needed column amounts. - vec_colh2o(iplon,lay) = 1.e-20_r8 * vec_wkl(iplon,1,lay) - vec_colco2(iplon,lay) = 1.e-20_r8 * vec_wkl(iplon,2,lay) - vec_colo3(iplon,lay) = 1.e-20_r8 * vec_wkl(iplon,3,lay) - ! colo3(lay) = 0._r8 - ! colo3(lay) = colo3(lay)/1.16_r8 - vec_coln2o(iplon,lay) = 1.e-20_r8 * vec_wkl(iplon,4,lay) - vec_colch4(iplon,lay) = 1.e-20_r8 * vec_wkl(iplon,6,lay) - vec_colo2(iplon,lay) = 1.e-20_r8 * vec_wkl(iplon,7,lay) - vec_colmol(iplon,lay) = 1.e-20_r8 * vec_coldry(iplon,lay) + vec_colh2o(iplon,lay) - ! vec_colco2(lay) = 0._r8 - ! colo3(lay) = 0._r8 - ! coln2o(lay) = 0._r8 - ! colch4(lay) = 0._r8 - ! colo2(lay) = 0._r8 - ! colmol(lay) = 0._r8 - if (vec_colco2(iplon,lay) .eq. 0._r8) vec_colco2(iplon,lay) = 1.e-32_r8 * vec_coldry(iplon,lay) - if (vec_coln2o(iplon,lay) .eq. 0._r8) vec_coln2o(iplon,lay) = 1.e-32_r8 * vec_coldry(iplon,lay) - if (vec_colch4(iplon,lay) .eq. 0._r8) vec_colch4(iplon,lay) = 1.e-32_r8 * vec_coldry(iplon,lay) - if (vec_colo2(iplon,lay) .eq. 0._r8) vec_colo2(iplon,lay) = 1.e-32_r8 * vec_coldry(iplon,lay) - ! Using E = 1334.2 cm-1. - co2reg = 3.55e-24_r8 * vec_coldry(iplon,lay) - vec_co2mult(iplon,lay)= (vec_colco2(iplon,lay) - co2reg) * & - 272.63_r8*exp(-1919.4_r8/vec_tavel(iplon,lay))/(8.7604e-4_r8*vec_tavel(iplon,lay)) - goto 5400 - ! Above vec_laytrop. - 5300 continue - ! Set up factors needed to separately include the water vapor - ! foreign-continuum in the calculation of absorption coefficient. - vec_forfac(iplon,lay) = scalefac / (1.+water) - factor = (vec_tavel(iplon,lay)-188.0_r8)/36.0_r8 - vec_indfor(iplon,lay) = 3 - vec_forfrac(iplon,lay) = factor - 1.0_r8 - ! Calculate needed column amounts. - vec_colh2o(iplon,lay) = 1.e-20_r8 * vec_wkl(iplon,1,lay) - vec_colco2(iplon,lay) = 1.e-20_r8 * vec_wkl(iplon,2,lay) - vec_colo3(iplon,lay) = 1.e-20_r8 * vec_wkl(iplon,3,lay) - vec_coln2o(iplon,lay) = 1.e-20_r8 * vec_wkl(iplon,4,lay) - vec_colch4(iplon,lay) = 1.e-20_r8 * vec_wkl(iplon,6,lay) - vec_colo2(iplon,lay) = 1.e-20_r8 * vec_wkl(iplon,7,lay) - vec_colmol(iplon,lay) = 1.e-20_r8 * vec_coldry(iplon,lay) + vec_colh2o(iplon,lay) - if (vec_colco2(iplon,lay) .eq. 0._r8) vec_colco2(iplon,lay) = 1.e-32_r8 * vec_coldry(iplon,lay) - if (vec_coln2o(iplon,lay) .eq. 0._r8) vec_coln2o(iplon,lay) = 1.e-32_r8 * vec_coldry(iplon,lay) - if (vec_colch4(iplon,lay) .eq. 0._r8) vec_colch4(iplon,lay) = 1.e-32_r8 * vec_coldry(iplon,lay) - if (vec_colo2(iplon,lay) .eq. 0._r8) vec_colo2(iplon,lay) = 1.e-32_r8 * vec_coldry(iplon,lay) - co2reg = 3.55e-24_r8 * vec_coldry(iplon,lay) - vec_co2mult(iplon,lay)= (vec_colco2(iplon,lay) - co2reg) * & - 272.63_r8*exp(-1919.4_r8/vec_tavel(iplon,lay))/(8.7604e-4_r8*vec_tavel(iplon,lay)) - vec_selffac(iplon,lay) = 0._r8 - vec_selffrac(iplon,lay)= 0._r8 - vec_indself(iplon,lay) = 0 - 5400 continue - ! We have now isolated the layer ln pressure and temperature, - ! between two reference pressures and two reference temperatures - ! (for each reference pressure). We multiply the pressure - ! fraction FP with the appropriate temperature fractions to get - ! the factors that will be needed for the interpolation that yields - ! the optical depths (performed in routines TAUGBn for band n). - compfp = 1._r8 - fp - vec_fac10(iplon,lay) = compfp * ft - vec_fac00(iplon,lay) = compfp * (1._r8 - ft) - vec_fac11(iplon,lay) = fp * ft1 - vec_fac01(iplon,lay) = fp * (1._r8 - ft1) - ! End layer loop - enddo - !End column loop - enddo - END SUBROUTINE setcoef_sw - !*************************************************************************** - - END MODULE rrtmg_sw_setcoef diff --git a/test/ncar_kernels/PORT_sw_setcoef/src/shr_kind_mod.f90 b/test/ncar_kernels/PORT_sw_setcoef/src/shr_kind_mod.f90 deleted file mode 100644 index 88858357d0..0000000000 --- a/test/ncar_kernels/PORT_sw_setcoef/src/shr_kind_mod.f90 +++ /dev/null @@ -1,26 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : shr_kind_mod.f90 -! Generated at: 2015-07-27 00:47:04 -! KGEN version: 0.4.13 - - - - MODULE shr_kind_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - PUBLIC - INTEGER, parameter :: shr_kind_r8 = selected_real_kind(12) ! 8 byte real - ! 4 byte real - ! native real - ! 8 byte integer - ! 4 byte integer - ! native integer - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE shr_kind_mod diff --git a/test/ncar_kernels/PORT_sw_spcvmc/CESM_license.txt b/test/ncar_kernels/PORT_sw_spcvmc/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.1.1 b/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.1.1 deleted file mode 100644 index a434555ef5..0000000000 Binary files a/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.1.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.1.4 b/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.1.4 deleted file mode 100644 index 89ea2684ef..0000000000 Binary files a/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.1.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.1.8 b/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.1.8 deleted file mode 100644 index e0c2b57c70..0000000000 Binary files a/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.1.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.10.1 b/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.10.1 deleted file mode 100644 index 85a3140501..0000000000 Binary files a/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.10.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.10.4 b/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.10.4 deleted file mode 100644 index 1498e9ec7a..0000000000 Binary files a/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.10.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.10.8 b/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.10.8 deleted file mode 100644 index 7e1b381109..0000000000 Binary files a/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.10.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.5.1 b/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.5.1 deleted file mode 100644 index c03404157a..0000000000 Binary files a/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.5.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.5.4 b/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.5.4 deleted file mode 100644 index 8331db256d..0000000000 Binary files a/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.5.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.5.8 b/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.5.8 deleted file mode 100644 index 91c1c7e21a..0000000000 Binary files a/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.5.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_spcvmc/inc/t1.mk b/test/ncar_kernels/PORT_sw_spcvmc/inc/t1.mk deleted file mode 100644 index 99f3bc37be..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/inc/t1.mk +++ /dev/null @@ -1,133 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# Intel default flags -# -# FC_FLAGS := -O2 -fp-model source -convert big_endian -assume byterecl -# -ftz -traceback -assume realloc_lhs -xAVX -# -FC_FLAGS := $(OPT) -FC_FLAGS += -Mnofma - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - -# Makefile for KGEN-generated kernel - -# Makefile for KGEN-generated kernel - -ALL_OBJS := kernel_driver.o rrtmg_sw_rad.o kgen_utils.o rrtmg_sw_reftra.o rrsw_kg28.o rrsw_kg25.o rrsw_kg19.o parrrsw.o rrsw_tbl.o rrsw_kg21.o rrsw_kg23.o rrsw_con.o rrsw_wvn.o rrsw_kg27.o rrsw_kg24.o rrsw_kg16.o rrsw_vsn.o shr_kind_mod.o rrsw_kg17.o rrsw_kg20.o rrsw_kg29.o rrsw_kg22.o rrtmg_sw_taumol.o rrtmg_sw_vrtqdr.o rrsw_kg26.o rrsw_kg18.o rrtmg_sw_spcvmc.o - -verify: - @(grep "verification.FAIL" $(TEST).rslt && echo "FAILED") || (grep "verification.PASS" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 rrtmg_sw_rad.o kgen_utils.o rrtmg_sw_reftra.o rrsw_kg28.o rrsw_kg25.o rrsw_kg19.o parrrsw.o rrsw_tbl.o rrsw_kg21.o rrsw_kg23.o rrsw_con.o rrsw_wvn.o rrsw_kg27.o rrsw_kg24.o rrsw_kg16.o rrsw_vsn.o shr_kind_mod.o rrsw_kg17.o rrsw_kg20.o rrsw_kg29.o rrsw_kg22.o rrtmg_sw_taumol.o rrtmg_sw_vrtqdr.o rrsw_kg26.o rrsw_kg18.o rrtmg_sw_spcvmc.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_sw_rad.o: $(SRC_DIR)/rrtmg_sw_rad.f90 kgen_utils.o rrtmg_sw_spcvmc.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_sw_reftra.o: $(SRC_DIR)/rrtmg_sw_reftra.f90 kgen_utils.o shr_kind_mod.o rrsw_vsn.o rrsw_tbl.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg28.o: $(SRC_DIR)/rrsw_kg28.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg25.o: $(SRC_DIR)/rrsw_kg25.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg19.o: $(SRC_DIR)/rrsw_kg19.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -parrrsw.o: $(SRC_DIR)/parrrsw.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_tbl.o: $(SRC_DIR)/rrsw_tbl.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg21.o: $(SRC_DIR)/rrsw_kg21.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg23.o: $(SRC_DIR)/rrsw_kg23.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_con.o: $(SRC_DIR)/rrsw_con.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_wvn.o: $(SRC_DIR)/rrsw_wvn.f90 kgen_utils.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg27.o: $(SRC_DIR)/rrsw_kg27.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg24.o: $(SRC_DIR)/rrsw_kg24.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg16.o: $(SRC_DIR)/rrsw_kg16.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_vsn.o: $(SRC_DIR)/rrsw_vsn.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_kind_mod.o: $(SRC_DIR)/shr_kind_mod.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg17.o: $(SRC_DIR)/rrsw_kg17.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg20.o: $(SRC_DIR)/rrsw_kg20.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg29.o: $(SRC_DIR)/rrsw_kg29.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg22.o: $(SRC_DIR)/rrsw_kg22.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_sw_taumol.o: $(SRC_DIR)/rrtmg_sw_taumol.f90 kgen_utils.o shr_kind_mod.o rrsw_vsn.o rrsw_kg16.o rrsw_con.o rrsw_wvn.o parrrsw.o rrsw_kg17.o rrsw_kg18.o rrsw_kg19.o rrsw_kg20.o rrsw_kg21.o rrsw_kg22.o rrsw_kg23.o rrsw_kg24.o rrsw_kg25.o rrsw_kg26.o rrsw_kg27.o rrsw_kg28.o rrsw_kg29.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_sw_vrtqdr.o: $(SRC_DIR)/rrtmg_sw_vrtqdr.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg26.o: $(SRC_DIR)/rrsw_kg26.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg18.o: $(SRC_DIR)/rrsw_kg18.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_sw_spcvmc.o: $(SRC_DIR)/rrtmg_sw_spcvmc.f90 kgen_utils.o shr_kind_mod.o parrrsw.o rrtmg_sw_taumol.o rrsw_wvn.o rrsw_tbl.o rrtmg_sw_reftra.o rrtmg_sw_vrtqdr.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -kgen_utils.o: $(SRC_DIR)/kgen_utils.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.oo *.rslt diff --git a/test/ncar_kernels/PORT_sw_spcvmc/lit/runmake b/test/ncar_kernels/PORT_sw_spcvmc/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/PORT_sw_spcvmc/lit/t1.sh b/test/ncar_kernels/PORT_sw_spcvmc/lit/t1.sh deleted file mode 100644 index 33c953a156..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/lit/t1.sh +++ /dev/null @@ -1,9 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -# Shared lit script for each tests. Run bash commands that run tests with make. - -# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t -# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/PORT_sw_spcvmc/makefile b/test/ncar_kernels/PORT_sw_spcvmc/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/kernel_driver.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/kernel_driver.f90 deleted file mode 100644 index 88c3b756cb..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/kernel_driver.f90 +++ /dev/null @@ -1,117 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-07-31 20:35:44 -! KGEN version: 0.4.13 - - -PROGRAM kernel_driver - USE rrtmg_sw_rad, ONLY : rrtmg_sw - USE rrsw_tbl, ONLY : kgen_read_externs_rrsw_tbl - USE rrsw_kg19, ONLY : kgen_read_externs_rrsw_kg19 - USE rrsw_kg18, ONLY : kgen_read_externs_rrsw_kg18 - USE rrsw_kg17, ONLY : kgen_read_externs_rrsw_kg17 - USE rrsw_kg16, ONLY : kgen_read_externs_rrsw_kg16 - USE rrsw_wvn, ONLY : kgen_read_externs_rrsw_wvn - USE rrsw_vsn, ONLY : kgen_read_externs_rrsw_vsn - USE rrsw_kg24, ONLY : kgen_read_externs_rrsw_kg24 - USE rrsw_kg25, ONLY : kgen_read_externs_rrsw_kg25 - USE rrsw_kg26, ONLY : kgen_read_externs_rrsw_kg26 - USE rrsw_kg27, ONLY : kgen_read_externs_rrsw_kg27 - USE rrsw_kg20, ONLY : kgen_read_externs_rrsw_kg20 - USE rrsw_kg21, ONLY : kgen_read_externs_rrsw_kg21 - USE rrsw_kg22, ONLY : kgen_read_externs_rrsw_kg22 - USE rrsw_kg23, ONLY : kgen_read_externs_rrsw_kg23 - USE rrsw_kg28, ONLY : kgen_read_externs_rrsw_kg28 - USE rrsw_kg29, ONLY : kgen_read_externs_rrsw_kg29 - USE rrsw_con, ONLY : kgen_read_externs_rrsw_con - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - - IMPLICIT NONE - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_mpi_rank_at = (/ 1, 4, 8 /) - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_counter_at = (/ 1, 10, 5 /) - CHARACTER(LEN=1024) :: kgen_filepath - INTEGER :: lchnk - INTEGER :: ncol - INTEGER :: nlay - - DO kgen_repeat_counter = 0, 8 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - kgen_filepath = "../data/spcvmc_sw." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "** Verification against '" // trim(adjustl(kgen_filepath)) // "' **" - - CALL kgen_read_externs_rrsw_tbl(kgen_unit) - CALL kgen_read_externs_rrsw_kg19(kgen_unit) - CALL kgen_read_externs_rrsw_kg18(kgen_unit) - CALL kgen_read_externs_rrsw_kg17(kgen_unit) - CALL kgen_read_externs_rrsw_kg16(kgen_unit) - CALL kgen_read_externs_rrsw_wvn(kgen_unit) - CALL kgen_read_externs_rrsw_vsn(kgen_unit) - CALL kgen_read_externs_rrsw_kg24(kgen_unit) - CALL kgen_read_externs_rrsw_kg25(kgen_unit) - CALL kgen_read_externs_rrsw_kg26(kgen_unit) - CALL kgen_read_externs_rrsw_kg27(kgen_unit) - CALL kgen_read_externs_rrsw_kg20(kgen_unit) - CALL kgen_read_externs_rrsw_kg21(kgen_unit) - CALL kgen_read_externs_rrsw_kg22(kgen_unit) - CALL kgen_read_externs_rrsw_kg23(kgen_unit) - CALL kgen_read_externs_rrsw_kg28(kgen_unit) - CALL kgen_read_externs_rrsw_kg29(kgen_unit) - CALL kgen_read_externs_rrsw_con(kgen_unit) - - ! driver variables - READ(UNIT=kgen_unit) lchnk - READ(UNIT=kgen_unit) ncol - READ(UNIT=kgen_unit) nlay - - call rrtmg_sw(lchnk, ncol, nlay, kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! write subroutines - ! No subroutines - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/kgen_utils.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/kgen_utils.f90 deleted file mode 100644 index cfa8d114e0..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/kgen_utils.f90 +++ /dev/null @@ -1,61 +0,0 @@ -module kgen_utils_mod - -INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - -type check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - real(kind=kgen_dp) :: minvalue -end type check_t - -public kgen_dp, check_t, kgen_init_check, kgen_print_check - -contains - -subroutine kgen_init_check(check, tolerance, minvalue) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - real(kind=kgen_dp), intent(in), optional :: minvalue - - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.0D-15 - endif - if(present(minvalue)) then - check%minvalue = minvalue - else - check%minvalue = 1.0D-15 - endif -end subroutine kgen_init_check - -subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif -end subroutine kgen_print_check - -end module diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/parrrsw.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/parrrsw.f90 deleted file mode 100644 index 54febe2868..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/parrrsw.f90 +++ /dev/null @@ -1,110 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : parrrsw.f90 -! Generated at: 2015-07-31 20:35:44 -! KGEN version: 0.4.13 - - - - MODULE parrrsw - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw main parameters - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! mxlay : integer: maximum number of layers - ! mg : integer: number of original g-intervals per spectral band - ! nbndsw : integer: number of spectral bands - ! naerec : integer: number of aerosols (iaer=6, ecmwf aerosol option) - ! ngptsw : integer: total number of reduced g-intervals for rrtmg_lw - ! ngNN : integer: number of reduced g-intervals per spectral band - ! ngsNN : integer: cumulative number of g-intervals per band - !------------------------------------------------------------------ - ! Settings for single column mode. - ! For GCM use, set nlon to number of longitudes, and - ! mxlay to number of model layers - !jplay, klev - !jpg - INTEGER, parameter :: nbndsw = 14 !jpsw, ksw - !jpaer - INTEGER, parameter :: mxmol = 38 - ! Use for 112 g-point model - INTEGER, parameter :: ngptsw = 112 !jpgpt - ! Use for 224 g-point model - ! integer, parameter :: ngptsw = 224 !jpgpt - ! may need to rename these - from v2.6 - INTEGER, parameter :: jpband = 29 - INTEGER, parameter :: jpb1 = 16 !istart - INTEGER, parameter :: jpb2 = 29 !iend - ! ^ - ! Use for 112 g-point model - INTEGER, parameter :: ng16 = 6 - INTEGER, parameter :: ng17 = 12 - INTEGER, parameter :: ng18 = 8 - INTEGER, parameter :: ng19 = 8 - INTEGER, parameter :: ng20 = 10 - INTEGER, parameter :: ng21 = 10 - INTEGER, parameter :: ng22 = 2 - INTEGER, parameter :: ng23 = 10 - INTEGER, parameter :: ng24 = 8 - INTEGER, parameter :: ng25 = 6 - INTEGER, parameter :: ng26 = 6 - INTEGER, parameter :: ng27 = 8 - INTEGER, parameter :: ng28 = 6 - INTEGER, parameter :: ng29 = 12 - INTEGER, parameter :: ngs16 = 6 - INTEGER, parameter :: ngs17 = 18 - INTEGER, parameter :: ngs18 = 26 - INTEGER, parameter :: ngs19 = 34 - INTEGER, parameter :: ngs20 = 44 - INTEGER, parameter :: ngs21 = 54 - INTEGER, parameter :: ngs22 = 56 - INTEGER, parameter :: ngs23 = 66 - INTEGER, parameter :: ngs24 = 74 - INTEGER, parameter :: ngs25 = 80 - INTEGER, parameter :: ngs26 = 86 - INTEGER, parameter :: ngs27 = 94 - INTEGER, parameter :: ngs28 = 100 - ! Use for 224 g-point model - ! integer, parameter :: ng16 = 16 - ! integer, parameter :: ng17 = 16 - ! integer, parameter :: ng18 = 16 - ! integer, parameter :: ng19 = 16 - ! integer, parameter :: ng20 = 16 - ! integer, parameter :: ng21 = 16 - ! integer, parameter :: ng22 = 16 - ! integer, parameter :: ng23 = 16 - ! integer, parameter :: ng24 = 16 - ! integer, parameter :: ng25 = 16 - ! integer, parameter :: ng26 = 16 - ! integer, parameter :: ng27 = 16 - ! integer, parameter :: ng28 = 16 - ! integer, parameter :: ng29 = 16 - ! integer, parameter :: ngs16 = 16 - ! integer, parameter :: ngs17 = 32 - ! integer, parameter :: ngs18 = 48 - ! integer, parameter :: ngs19 = 64 - ! integer, parameter :: ngs20 = 80 - ! integer, parameter :: ngs21 = 96 - ! integer, parameter :: ngs22 = 112 - ! integer, parameter :: ngs23 = 128 - ! integer, parameter :: ngs24 = 144 - ! integer, parameter :: ngs25 = 160 - ! integer, parameter :: ngs26 = 176 - ! integer, parameter :: ngs27 = 192 - ! integer, parameter :: ngs28 = 208 - ! integer, parameter :: ngs29 = 224 - ! Source function solar constant - ! W/m2 - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE parrrsw diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_con.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_con.f90 deleted file mode 100644 index 446b85c769..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_con.f90 +++ /dev/null @@ -1,49 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_con.f90 -! Generated at: 2015-07-31 20:35:44 -! KGEN version: 0.4.13 - - - - MODULE rrsw_con - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw constants - ! Initial version: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! fluxfac: real : radiance to flux conversion factor - ! heatfac: real : flux to heating rate conversion factor - !oneminus: real : 1.-1.e-6 - ! pi : real : pi - ! grav : real : acceleration of gravity (m/s2) - ! planck : real : planck constant - ! boltz : real : boltzman constant - ! clight : real : speed of light - ! avogad : real : avogadro's constant - ! alosmt : real : - ! gascon : real : gas constant - ! radcn1 : real : - ! radcn2 : real : - !------------------------------------------------------------------ - REAL(KIND=r8) :: oneminus - PUBLIC kgen_read_externs_rrsw_con - CONTAINS - - ! write subroutines - ! No subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_con(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) oneminus - END SUBROUTINE kgen_read_externs_rrsw_con - - END MODULE rrsw_con diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg16.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg16.f90 deleted file mode 100644 index 9f04bc2fa2..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg16.f90 +++ /dev/null @@ -1,77 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg16.f90 -! Generated at: 2015-07-31 20:35:44 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg16 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng16 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 16 - ! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: strrat1 - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 16 - ! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(585,ng16) - REAL(KIND=r8) :: absb(235,ng16) - REAL(KIND=r8) :: selfref(10,ng16) - REAL(KIND=r8) :: forref(3,ng16) - REAL(KIND=r8) :: sfluxref(ng16) - PUBLIC kgen_read_externs_rrsw_kg16 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg16(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) strrat1 - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) sfluxref - END SUBROUTINE kgen_read_externs_rrsw_kg16 - - END MODULE rrsw_kg16 diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg17.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg17.f90 deleted file mode 100644 index 02430604ad..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg17.f90 +++ /dev/null @@ -1,77 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg17.f90 -! Generated at: 2015-07-31 20:35:44 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg17 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng17 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 17 - ! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: strrat - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 17 - ! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(585,ng17) - REAL(KIND=r8) :: absb(1175,ng17) - REAL(KIND=r8) :: forref(4,ng17) - REAL(KIND=r8) :: selfref(10,ng17) - REAL(KIND=r8) :: sfluxref(ng17,5) - PUBLIC kgen_read_externs_rrsw_kg17 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg17(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) strrat - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) sfluxref - END SUBROUTINE kgen_read_externs_rrsw_kg17 - - END MODULE rrsw_kg17 diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg18.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg18.f90 deleted file mode 100644 index 1fd8773e24..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg18.f90 +++ /dev/null @@ -1,77 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg18.f90 -! Generated at: 2015-07-31 20:35:45 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg18 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng18 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 18 - ! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: strrat - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 18 - ! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(585,ng18) - REAL(KIND=r8) :: absb(235,ng18) - REAL(KIND=r8) :: selfref(10,ng18) - REAL(KIND=r8) :: forref(3,ng18) - REAL(KIND=r8) :: sfluxref(ng18,9) - PUBLIC kgen_read_externs_rrsw_kg18 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg18(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) strrat - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) sfluxref - END SUBROUTINE kgen_read_externs_rrsw_kg18 - - END MODULE rrsw_kg18 diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg19.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg19.f90 deleted file mode 100644 index 0e8da035ee..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg19.f90 +++ /dev/null @@ -1,77 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg19.f90 -! Generated at: 2015-07-31 20:35:44 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg19 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng19 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 19 - ! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: strrat - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 19 - ! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(585,ng19) - REAL(KIND=r8) :: absb(235,ng19) - REAL(KIND=r8) :: forref(3,ng19) - REAL(KIND=r8) :: selfref(10,ng19) - REAL(KIND=r8) :: sfluxref(ng19,9) - PUBLIC kgen_read_externs_rrsw_kg19 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg19(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) strrat - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) sfluxref - END SUBROUTINE kgen_read_externs_rrsw_kg19 - - END MODULE rrsw_kg19 diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg20.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg20.f90 deleted file mode 100644 index 2df520e2d9..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg20.f90 +++ /dev/null @@ -1,79 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg20.f90 -! Generated at: 2015-07-31 20:35:44 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg20 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng20 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 20 - ! band 20: 5150-6150 cm-1 (low - h2o; high - h2o) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - ! absch4o : real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 20 - ! band 20: 5150-6150 cm-1 (low - h2o; high - h2o) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - ! absch4 : real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(65,ng20) - REAL(KIND=r8) :: absb(235,ng20) - REAL(KIND=r8) :: forref(4,ng20) - REAL(KIND=r8) :: selfref(10,ng20) - REAL(KIND=r8) :: sfluxref(ng20) - REAL(KIND=r8) :: absch4(ng20) - PUBLIC kgen_read_externs_rrsw_kg20 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg20(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) sfluxref - READ(UNIT=kgen_unit) absch4 - END SUBROUTINE kgen_read_externs_rrsw_kg20 - - END MODULE rrsw_kg20 diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg21.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg21.f90 deleted file mode 100644 index 333d425b77..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg21.f90 +++ /dev/null @@ -1,77 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg21.f90 -! Generated at: 2015-07-31 20:35:44 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg21 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng21 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 21 - ! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: strrat - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 21 - ! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(585,ng21) - REAL(KIND=r8) :: absb(1175,ng21) - REAL(KIND=r8) :: selfref(10,ng21) - REAL(KIND=r8) :: forref(4,ng21) - REAL(KIND=r8) :: sfluxref(ng21,9) - PUBLIC kgen_read_externs_rrsw_kg21 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg21(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) strrat - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) sfluxref - END SUBROUTINE kgen_read_externs_rrsw_kg21 - - END MODULE rrsw_kg21 diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg22.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg22.f90 deleted file mode 100644 index 70e1847bd9..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg22.f90 +++ /dev/null @@ -1,77 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg22.f90 -! Generated at: 2015-07-31 20:35:44 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg22 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng22 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 22 - ! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: strrat - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 22 - ! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(585,ng22) - REAL(KIND=r8) :: absb(235,ng22) - REAL(KIND=r8) :: forref(3,ng22) - REAL(KIND=r8) :: selfref(10,ng22) - REAL(KIND=r8) :: sfluxref(ng22,9) - PUBLIC kgen_read_externs_rrsw_kg22 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg22(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) strrat - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) sfluxref - END SUBROUTINE kgen_read_externs_rrsw_kg22 - - END MODULE rrsw_kg22 diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg23.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg23.f90 deleted file mode 100644 index 98188f4b55..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg23.f90 +++ /dev/null @@ -1,75 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg23.f90 -! Generated at: 2015-07-31 20:35:44 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg23 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng23 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 23 - ! band 23: 8050-12850 cm-1 (low - h2o; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: givfac - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 23 - ! band 23: 8050-12850 cm-1 (low - h2o; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(65,ng23) - REAL(KIND=r8) :: forref(3,ng23) - REAL(KIND=r8) :: selfref(10,ng23) - REAL(KIND=r8) :: rayl(ng23) - REAL(KIND=r8) :: sfluxref(ng23) - PUBLIC kgen_read_externs_rrsw_kg23 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg23(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) givfac - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) sfluxref - END SUBROUTINE kgen_read_externs_rrsw_kg23 - - END MODULE rrsw_kg23 diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg24.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg24.f90 deleted file mode 100644 index b73ddd3055..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg24.f90 +++ /dev/null @@ -1,91 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg24.f90 -! Generated at: 2015-07-31 20:35:44 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg24 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng24 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 24 - ! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - ! abso3ao : real - ! abso3bo : real - ! raylao : real - ! raylbo : real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: strrat - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 24 - ! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - ! abso3a : real - ! abso3b : real - ! rayla : real - ! raylb : real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(585,ng24) - REAL(KIND=r8) :: absb(235,ng24) - REAL(KIND=r8) :: forref(3,ng24) - REAL(KIND=r8) :: selfref(10,ng24) - REAL(KIND=r8) :: sfluxref(ng24,9) - REAL(KIND=r8) :: abso3a(ng24) - REAL(KIND=r8) :: abso3b(ng24) - REAL(KIND=r8) :: rayla(ng24,9) - REAL(KIND=r8) :: raylb(ng24) - PUBLIC kgen_read_externs_rrsw_kg24 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg24(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) strrat - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) sfluxref - READ(UNIT=kgen_unit) abso3a - READ(UNIT=kgen_unit) abso3b - READ(UNIT=kgen_unit) rayla - READ(UNIT=kgen_unit) raylb - END SUBROUTINE kgen_read_externs_rrsw_kg24 - - END MODULE rrsw_kg24 diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg25.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg25.f90 deleted file mode 100644 index f2a00cd87e..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg25.f90 +++ /dev/null @@ -1,72 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg25.f90 -! Generated at: 2015-07-31 20:35:44 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg25 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng25 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 25 - ! band 25: 16000-22650 cm-1 (low - h2o; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - !sfluxrefo: real - ! abso3ao : real - ! abso3bo : real - ! raylo : real - !----------------------------------------------------------------- - INTEGER :: layreffr - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 25 - ! band 25: 16000-22650 cm-1 (low - h2o; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! absa : real - ! sfluxref: real - ! abso3a : real - ! abso3b : real - ! rayl : real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(65,ng25) - REAL(KIND=r8) :: sfluxref(ng25) - REAL(KIND=r8) :: abso3a(ng25) - REAL(KIND=r8) :: abso3b(ng25) - REAL(KIND=r8) :: rayl(ng25) - PUBLIC kgen_read_externs_rrsw_kg25 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg25(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) sfluxref - READ(UNIT=kgen_unit) abso3a - READ(UNIT=kgen_unit) abso3b - READ(UNIT=kgen_unit) rayl - END SUBROUTINE kgen_read_externs_rrsw_kg25 - - END MODULE rrsw_kg25 diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg26.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg26.f90 deleted file mode 100644 index d7898d6544..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg26.f90 +++ /dev/null @@ -1,57 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg26.f90 -! Generated at: 2015-07-31 20:35:45 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg26 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng26 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 26 - ! band 26: 22650-29000 cm-1 (low - nothing; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !sfluxrefo: real - ! raylo : real - !----------------------------------------------------------------- - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 26 - ! band 26: 22650-29000 cm-1 (low - nothing; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! sfluxref: real - ! rayl : real - !----------------------------------------------------------------- - REAL(KIND=r8) :: sfluxref(ng26) - REAL(KIND=r8) :: rayl(ng26) - PUBLIC kgen_read_externs_rrsw_kg26 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg26(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) sfluxref - READ(UNIT=kgen_unit) rayl - END SUBROUTINE kgen_read_externs_rrsw_kg26 - - END MODULE rrsw_kg26 diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg27.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg27.f90 deleted file mode 100644 index 6a787e8320..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg27.f90 +++ /dev/null @@ -1,71 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg27.f90 -! Generated at: 2015-07-31 20:35:44 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg27 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng27 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 27 - ! band 27: 29000-38000 cm-1 (low - o3; high - o3) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - !sfluxrefo: real - ! raylo : real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: scalekur - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 27 - ! band 27: 29000-38000 cm-1 (low - o3; high - o3) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! sfluxref: real - ! rayl : real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(65,ng27) - REAL(KIND=r8) :: absb(235,ng27) - REAL(KIND=r8) :: sfluxref(ng27) - REAL(KIND=r8) :: rayl(ng27) - PUBLIC kgen_read_externs_rrsw_kg27 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg27(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) scalekur - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) sfluxref - READ(UNIT=kgen_unit) rayl - END SUBROUTINE kgen_read_externs_rrsw_kg27 - - END MODULE rrsw_kg27 diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg28.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg28.f90 deleted file mode 100644 index 46659ed911..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg28.f90 +++ /dev/null @@ -1,67 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg28.f90 -! Generated at: 2015-07-31 20:35:44 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg28 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng28 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 28 - ! band 28: 38000-50000 cm-1 (low - o3, o2; high - o3, o2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - !sfluxrefo: real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: strrat - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 28 - ! band 28: 38000-50000 cm-1 (low - o3, o2; high - o3, o2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! sfluxref: real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(585,ng28) - REAL(KIND=r8) :: absb(1175,ng28) - REAL(KIND=r8) :: sfluxref(ng28,5) - PUBLIC kgen_read_externs_rrsw_kg28 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg28(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) strrat - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) sfluxref - END SUBROUTINE kgen_read_externs_rrsw_kg28 - - END MODULE rrsw_kg28 diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg29.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg29.f90 deleted file mode 100644 index 71a1496622..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg29.f90 +++ /dev/null @@ -1,81 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg29.f90 -! Generated at: 2015-07-31 20:35:44 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg29 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng29 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 29 - ! band 29: 820-2600 cm-1 (low - h2o; high - co2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - ! absh2oo : real - ! absco2o : real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 29 - ! band 29: 820-2600 cm-1 (low - h2o; high - co2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! selfref : real - ! forref : real - ! sfluxref: real - ! absh2o : real - ! absco2 : real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(65,ng29) - REAL(KIND=r8) :: absb(235,ng29) - REAL(KIND=r8) :: forref(4,ng29) - REAL(KIND=r8) :: selfref(10,ng29) - REAL(KIND=r8) :: sfluxref(ng29) - REAL(KIND=r8) :: absco2(ng29) - REAL(KIND=r8) :: absh2o(ng29) - PUBLIC kgen_read_externs_rrsw_kg29 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg29(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) sfluxref - READ(UNIT=kgen_unit) absco2 - READ(UNIT=kgen_unit) absh2o - END SUBROUTINE kgen_read_externs_rrsw_kg29 - - END MODULE rrsw_kg29 diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_tbl.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_tbl.f90 deleted file mode 100644 index 262875124e..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_tbl.f90 +++ /dev/null @@ -1,49 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_tbl.f90 -! Generated at: 2015-07-31 20:35:44 -! KGEN version: 0.4.13 - - - - MODULE rrsw_tbl - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw lookup table arrays - ! Initial version: MJIacono, AER, may2007 - ! Revised: MJIacono, AER, aug2007 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! ntbl : integer: Lookup table dimension - ! tblint : real : Lookup table conversion factor - ! tau_tbl: real : Clear-sky optical depth - ! exp_tbl: real : Exponential lookup table for transmittance - ! od_lo : real : Value of tau below which expansion is used - ! : in place of lookup table - ! pade : real : Pade approximation constant - ! bpade : real : Inverse of Pade constant - !------------------------------------------------------------------ - INTEGER, parameter :: ntbl = 10000 - REAL(KIND=r8), parameter :: tblint = 10000.0 - REAL(KIND=r8), parameter :: od_lo = 0.06 - REAL(KIND=r8), dimension(0:ntbl) :: exp_tbl - REAL(KIND=r8) :: bpade - PUBLIC kgen_read_externs_rrsw_tbl - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_tbl(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) exp_tbl - READ(UNIT=kgen_unit) bpade - END SUBROUTINE kgen_read_externs_rrsw_tbl - - END MODULE rrsw_tbl diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_vsn.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_vsn.f90 deleted file mode 100644 index 4dc058bbc3..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_vsn.f90 +++ /dev/null @@ -1,67 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_vsn.f90 -! Generated at: 2015-07-31 20:35:44 -! KGEN version: 0.4.13 - - - - MODULE rrsw_vsn - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw version information - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jul2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - !hnamrtm :character: - !hnamini :character: - !hnamcld :character: - !hnamclc :character: - !hnamrft :character: - !hnamspv :character: - !hnamspc :character: - !hnamset :character: - !hnamtau :character: - !hnamvqd :character: - !hnamatm :character: - !hnamutl :character: - !hnamext :character: - !hnamkg :character: - ! - ! hvrrtm :character: - ! hvrini :character: - ! hvrcld :character: - ! hvrclc :character: - ! hvrrft :character: - ! hvrspv :character: - ! hvrspc :character: - ! hvrset :character: - ! hvrtau :character: - ! hvrvqd :character: - ! hvratm :character: - ! hvrutl :character: - ! hvrext :character: - ! hvrkg :character: - !------------------------------------------------------------------ - CHARACTER(LEN=18) :: hvrtau - CHARACTER(LEN=18) :: hvrrft - PUBLIC kgen_read_externs_rrsw_vsn - CONTAINS - - ! write subroutines - ! No subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_vsn(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) hvrtau - READ(UNIT=kgen_unit) hvrrft - END SUBROUTINE kgen_read_externs_rrsw_vsn - - END MODULE rrsw_vsn diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_wvn.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_wvn.f90 deleted file mode 100644 index b12f3002db..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_wvn.f90 +++ /dev/null @@ -1,62 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_wvn.f90 -! Generated at: 2015-07-31 20:35:44 -! KGEN version: 0.4.13 - - - - MODULE rrsw_wvn - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind, only : jpim, jprb - USE parrrsw, ONLY: jpb1 - USE parrrsw, ONLY: jpb2 - USE parrrsw, ONLY: nbndsw - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw spectral information - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jul2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! ng : integer: Number of original g-intervals in each spectral band - ! nspa : integer: - ! nspb : integer: - !wavenum1: real : Spectral band lower boundary in wavenumbers - !wavenum2: real : Spectral band upper boundary in wavenumbers - ! delwave: real : Spectral band width in wavenumbers - ! - ! ngc : integer: The number of new g-intervals in each band - ! ngs : integer: The cumulative sum of new g-intervals for each band - ! ngm : integer: The index of each new g-interval relative to the - ! original 16 g-intervals in each band - ! ngn : integer: The number of original g-intervals that are - ! combined to make each new g-intervals in each band - ! ngb : integer: The band index for each new g-interval - ! wt : real : RRTM weights for the original 16 g-intervals - ! rwgt : real : Weights for combining original 16 g-intervals - ! (224 total) into reduced set of g-intervals - ! (112 total) - !------------------------------------------------------------------ - INTEGER :: nspa(jpb1:jpb2) - INTEGER :: nspb(jpb1:jpb2) - INTEGER :: ngc(nbndsw) - INTEGER :: ngs(nbndsw) - PUBLIC kgen_read_externs_rrsw_wvn - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_wvn(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) nspa - READ(UNIT=kgen_unit) nspb - READ(UNIT=kgen_unit) ngc - READ(UNIT=kgen_unit) ngs - END SUBROUTINE kgen_read_externs_rrsw_wvn - - END MODULE rrsw_wvn diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/rrtmg_sw_rad.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/rrtmg_sw_rad.f90 deleted file mode 100644 index b59acae0fb..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/rrtmg_sw_rad.f90 +++ /dev/null @@ -1,819 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_sw_rad.f90 -! Generated at: 2015-07-31 20:35:44 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_sw_rad - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! - ! **************************************************************************** - ! * * - ! * RRTMG_SW * - ! * * - ! * * - ! * * - ! * a rapid radiative transfer model * - ! * for the solar spectral region * - ! * for application to general circulation models * - ! * * - ! * * - ! * Atmospheric and Environmental Research, Inc. * - ! * 131 Hartwell Avenue * - ! * Lexington, MA 02421 * - ! * * - ! * * - ! * Eli J. Mlawer * - ! * Jennifer S. Delamere * - ! * Michael J. Iacono * - ! * Shepard A. Clough * - ! * * - ! * * - ! * * - ! * * - ! * * - ! * * - ! * email: miacono@aer.com * - ! * email: emlawer@aer.com * - ! * email: jdelamer@aer.com * - ! * * - ! * The authors wish to acknowledge the contributions of the * - ! * following people: Steven J. Taubman, Patrick D. Brown, * - ! * Ronald E. Farren, Luke Chen, Robert Bergstrom. * - ! * * - ! **************************************************************************** - ! --------- Modules --------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - ! Move call to rrtmg_sw_ini and following use association to - ! GCM initialization area - ! use rrtmg_sw_init, only: rrtmg_sw_ini - USE rrtmg_sw_spcvmc, ONLY: spcvmc_sw - IMPLICIT NONE - ! public interfaces/functions/subroutines - ! public :: rrtmg_sw, inatm_sw, earth_sun - PUBLIC rrtmg_sw - !------------------------------------------------------------------ - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !------------------------------------------------------------------ - !------------------------------------------------------------------ - ! Public subroutines - !------------------------------------------------------------------ - - SUBROUTINE rrtmg_sw(lchnk, ncol, nlay, kgen_unit) - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! ------- Description ------- - ! This program is the driver for RRTMG_SW, the AER SW radiation model for - ! application to GCMs, that has been adapted from RRTM_SW for improved - ! efficiency and to provide fractional cloudiness and cloud overlap - ! capability using McICA. - ! - ! Note: The call to RRTMG_SW_INI should be moved to the GCM initialization - ! area, since this has to be called only once. - ! - ! This routine - ! b) calls INATM_SW to read in the atmospheric profile; - ! all layering in RRTMG is ordered from surface to toa. - ! c) calls CLDPRMC_SW to set cloud optical depth for McICA based - ! on input cloud properties - ! d) calls SETCOEF_SW to calculate various quantities needed for - ! the radiative transfer algorithm - ! e) calls SPCVMC to call the two-stream model that in turn - ! calls TAUMOL to calculate gaseous optical depths for each - ! of the 16 spectral bands and to perform the radiative transfer - ! using McICA, the Monte-Carlo Independent Column Approximation, - ! to represent sub-grid scale cloud variability - ! f) passes the calculated fluxes and cooling rates back to GCM - ! - ! Two modes of operation are possible: - ! The mode is chosen by using either rrtmg_sw.nomcica.f90 (to not use - ! McICA) or rrtmg_sw.f90 (to use McICA) to interface with a GCM. - ! - ! 1) Standard, single forward model calculation (imca = 0); this is - ! valid only for clear sky or fully overcast clouds - ! 2) Monte Carlo Independent Column Approximation (McICA, Pincus et al., - ! JC, 2003) method is applied to the forward model calculation (imca = 1) - ! This method is valid for clear sky or partial cloud conditions. - ! - ! This call to RRTMG_SW must be preceeded by a call to the module - ! mcica_subcol_gen_sw.f90 to run the McICA sub-column cloud generator, - ! which will provide the cloud physical or cloud optical properties - ! on the RRTMG quadrature point (ngptsw) dimension. - ! - ! Two methods of cloud property input are possible: - ! Cloud properties can be input in one of two ways (controlled by input - ! flags inflag, iceflag and liqflag; see text file rrtmg_sw_instructions - ! and subroutine rrtmg_sw_cldprop.f90 for further details): - ! - ! 1) Input cloud fraction, cloud optical depth, single scattering albedo - ! and asymmetry parameter directly (inflgsw = 0) - ! 2) Input cloud fraction and cloud physical properties: ice fracion, - ! ice and liquid particle sizes (inflgsw = 1 or 2); - ! cloud optical properties are calculated by cldprop or cldprmc based - ! on input settings of iceflgsw and liqflgsw - ! - ! Two methods of aerosol property input are possible: - ! Aerosol properties can be input in one of two ways (controlled by input - ! flag iaer, see text file rrtmg_sw_instructions for further details): - ! - ! 1) Input aerosol optical depth, single scattering albedo and asymmetry - ! parameter directly by layer and spectral band (iaer=10) - ! 2) Input aerosol optical depth and 0.55 micron directly by layer and use - ! one or more of six ECMWF aerosol types (iaer=6) - ! - ! - ! ------- Modifications ------- - ! - ! This version of RRTMG_SW has been modified from RRTM_SW to use a reduced - ! set of g-point intervals and a two-stream model for application to GCMs. - ! - !-- Original version (derived from RRTM_SW) - ! 2002: AER. Inc. - !-- Conversion to F90 formatting; addition of 2-stream radiative transfer - ! Feb 2003: J.-J. Morcrette, ECMWF - !-- Additional modifications for GCM application - ! Aug 2003: M. J. Iacono, AER Inc. - !-- Total number of g-points reduced from 224 to 112. Original - ! set of 224 can be restored by exchanging code in module parrrsw.f90 - ! and in file rrtmg_sw_init.f90. - ! Apr 2004: M. J. Iacono, AER, Inc. - !-- Modifications to include output for direct and diffuse - ! downward fluxes. There are output as "true" fluxes without - ! any delta scaling applied. Code can be commented to exclude - ! this calculation in source file rrtmg_sw_spcvrt.f90. - ! Jan 2005: E. J. Mlawer, M. J. Iacono, AER, Inc. - !-- Revised to add McICA capability. - ! Nov 2005: M. J. Iacono, AER, Inc. - !-- Reformatted for consistency with rrtmg_lw. - ! Feb 2007: M. J. Iacono, AER, Inc. - !-- Modifications to formatting to use assumed-shape arrays. - ! Aug 2007: M. J. Iacono, AER, Inc. - !-- Modified to output direct and diffuse fluxes either with or without - ! delta scaling based on setting of idelm flag - ! Dec 2008: M. J. Iacono, AER, Inc. - ! --------- Modules --------- - USE parrrsw, ONLY: mxmol - USE parrrsw, ONLY: ngptsw - USE parrrsw, ONLY: nbndsw - USE parrrsw, ONLY: jpband - ! ------- Declarations - ! ----- Input ----- - integer, intent(in) :: kgen_unit - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - INTEGER, intent(in) :: lchnk ! chunk identifier - INTEGER, intent(in) :: ncol ! Number of horizontal columns - INTEGER, intent(in) :: nlay ! Number of model layers - ! Cloud overlap method - ! 0: Clear only - ! 1: Random - ! 2: Maximum/random - ! 3: Maximum - ! Layer pressures (hPa, mb) - ! Dimensions: (ncol,nlay) - ! Interface pressures (hPa, mb) - ! Dimensions: (ncol,nlay+1) - ! Layer temperatures (K) - ! Dimensions: (ncol,nlay) - ! Interface temperatures (K) - ! Dimensions: (ncol,nlay+1) - ! Surface temperature (K) - ! Dimensions: (ncol) - ! H2O volume mixing ratio - ! Dimensions: (ncol,nlay) - ! O3 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! CO2 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! Methane volume mixing ratio - ! Dimensions: (ncol,nlay) - ! O2 volume mixing ratio - ! Dimensions: (ncol,nlay) - ! Nitrous oxide volume mixing ratio - ! Dimensions: (ncol,nlay) - ! UV/vis surface albedo direct rad - ! Dimensions: (ncol) - ! Near-IR surface albedo direct rad - ! Dimensions: (ncol) - ! UV/vis surface albedo: diffuse rad - ! Dimensions: (ncol) - ! Near-IR surface albedo: diffuse rad - ! Dimensions: (ncol) - ! Day of the year (used to get Earth/Sun - ! distance if adjflx not provided) - ! Flux adjustment for Earth/Sun distance - ! Cosine of solar zenith angle - ! Dimensions: (ncol) - ! Solar constant (Wm-2) scaling per band - ! Flag for cloud optical properties - ! Flag for ice particle specification - ! Flag for liquid droplet specification - ! Cloud fraction - ! Dimensions: (ngptsw,ncol,nlay) - ! Cloud optical depth - ! Dimensions: (ngptsw,ncol,nlay) - ! Cloud single scattering albedo - ! Dimensions: (ngptsw,ncol,nlay) - ! Cloud asymmetry parameter - ! Dimensions: (ngptsw,ncol,nlay) - ! Cloud forward scattering parameter - ! Dimensions: (ngptsw,ncol,nlay) - ! Cloud ice water path (g/m2) - ! Dimensions: (ngptsw,ncol,nlay) - ! Cloud liquid water path (g/m2) - ! Dimensions: (ngptsw,ncol,nlay) - ! Cloud ice effective radius (microns) - ! Dimensions: (ncol,nlay) - ! Cloud water drop effective radius (microns) - ! Dimensions: (ncol,nlay) - ! Aerosol optical depth (iaer=10 only) - ! Dimensions: (ncol,nlay,nbndsw) - ! (non-delta scaled) - ! Aerosol single scattering albedo (iaer=10 only) - ! Dimensions: (ncol,nlay,nbndsw) - ! (non-delta scaled) - ! Aerosol asymmetry parameter (iaer=10 only) - ! Dimensions: (ncol,nlay,nbndsw) - ! (non-delta scaled) - ! real(kind=r8), intent(in) :: ecaer(:,:,:) ! Aerosol optical depth at 0.55 micron (iaer=6 only) - ! Dimensions: (ncol,nlay,naerec) - ! (non-delta scaled) - ! ----- Output ----- - ! Total sky shortwave upward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Total sky shortwave downward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Total sky shortwave radiative heating rate (K/d) - ! Dimensions: (ncol,nlay) - ! Clear sky shortwave upward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Clear sky shortwave downward flux (W/m2) - ! Dimensions: (ncol,nlay+1) - ! Clear sky shortwave radiative heating rate (K/d) - ! Dimensions: (ncol,nlay) - ! Direct downward shortwave flux, UV/vis - ! Diffuse downward shortwave flux, UV/vis - ! Direct downward shortwave flux, near-IR - ! Diffuse downward shortwave flux, near-IR - ! Net shortwave flux, near-IR - ! Net clear sky shortwave flux, near-IR - ! shortwave spectral flux up - ! shortwave spectral flux down - ! ----- Local ----- - ! Control - INTEGER :: istart ! beginning band of calculation - INTEGER :: iend ! ending band of calculation - INTEGER :: icpr ! cldprop/cldprmc use flag - INTEGER :: iout = 0 ! output option flag (inactive) - ! aerosol option flag - INTEGER :: idelm ! delta-m scaling flag - ! [0 = direct and diffuse fluxes are unscaled] - ! [1 = direct and diffuse fluxes are scaled] - ! (total downward fluxes are always delta scaled) - ! instrumental cosine response flag (inactive) - ! column loop index - ! layer loop index ! jk - ! band loop index ! jsw - ! indices - ! layer loop index - ! value for changing mcica permute seed - ! flag for mcica [0=off, 1=on] - ! epsilon - ! flux to heating conversion ratio - ! Atmosphere - REAL(KIND=r8) :: pavel(ncol,nlay) ! layer pressures (mb) - REAL(KIND=r8) :: tavel(ncol,nlay) ! layer temperatures (K) - REAL(KIND=r8) :: pz(ncol,0:nlay) ! level (interface) pressures (hPa, mb) - REAL(KIND=r8) :: tz(ncol,0:nlay) ! level (interface) temperatures (K) - REAL(KIND=r8) :: tbound(ncol) ! surface temperature (K) - ! layer pressure thickness (hPa, mb) - REAL(KIND=r8) :: coldry(ncol,nlay) ! dry air column amount - REAL(KIND=r8) :: wkl(ncol,mxmol,nlay) ! molecular amounts (mol/cm-2) - ! real(kind=r8) :: earth_sun ! function for Earth/Sun distance factor - REAL(KIND=r8) :: cossza(ncol) ! Cosine of solar zenith angle - REAL(KIND=r8) :: adjflux(ncol,jpband) ! adjustment for current Earth/Sun distance - ! real(kind=r8) :: solvar(jpband) ! solar constant scaling factor from rrtmg_sw - ! default value of 1368.22 Wm-2 at 1 AU - REAL(KIND=r8) :: albdir(ncol,nbndsw) ! surface albedo, direct ! zalbp - REAL(KIND=r8) :: albdif(ncol,nbndsw) ! surface albedo, diffuse ! zalbd - ! Aerosol optical depth - ! Aerosol single scattering albedo - ! Aerosol asymmetry parameter - ! Atmosphere - setcoef - INTEGER :: laytrop(ncol) ! tropopause layer index - INTEGER :: layswtch(ncol) ! - INTEGER :: laylow(ncol) ! - INTEGER :: jp(ncol,nlay) ! - INTEGER :: jt(ncol,nlay) ! - INTEGER :: jt1(ncol,nlay) ! - REAL(KIND=r8) :: colh2o(ncol,nlay) ! column amount (h2o) - REAL(KIND=r8) :: colco2(ncol,nlay) ! column amount (co2) - REAL(KIND=r8) :: colo3(ncol,nlay) ! column amount (o3) - REAL(KIND=r8) :: coln2o(ncol,nlay) ! column amount (n2o) - REAL(KIND=r8) :: colch4(ncol,nlay) ! column amount (ch4) - REAL(KIND=r8) :: colo2(ncol,nlay) ! column amount (o2) - REAL(KIND=r8) :: colmol(ncol,nlay) ! column amount - REAL(KIND=r8) :: co2mult(ncol,nlay) ! column amount - INTEGER :: indself(ncol,nlay) - INTEGER :: indfor(ncol,nlay) - REAL(KIND=r8) :: selffac(ncol,nlay) - REAL(KIND=r8) :: selffrac(ncol,nlay) - REAL(KIND=r8) :: forfac(ncol,nlay) - REAL(KIND=r8) :: forfrac(ncol,nlay) - REAL(KIND=r8) :: fac00(ncol,nlay) - REAL(KIND=r8) :: fac01(ncol,nlay) - REAL(KIND=r8) :: fac11(ncol,nlay) - REAL(KIND=r8) :: fac10(ncol,nlay) ! - ! Atmosphere/clouds - cldprop - ! number of cloud spectral bands - ! flag for cloud property method - ! flag for ice cloud properties - ! flag for liquid cloud properties - ! real(kind=r8) :: cldfrac(nlay) ! layer cloud fraction - ! real(kind=r8) :: tauc(nlay) ! cloud optical depth (non-delta scaled) - ! real(kind=r8) :: ssac(nlay) ! cloud single scattering albedo (non-delta scaled) - ! real(kind=r8) :: asmc(nlay) ! cloud asymmetry parameter (non-delta scaled) - ! real(kind=r8) :: ciwp(nlay) ! cloud ice water path - ! real(kind=r8) :: clwp(nlay) ! cloud liquid water path - ! real(kind=r8) :: rei(nlay) ! cloud ice particle size - ! real(kind=r8) :: rel(nlay) ! cloud liquid particle size - ! real(kind=r8) :: taucloud(nlay,jpband) ! cloud optical depth - ! real(kind=r8) :: taucldorig(nlay,jpband) ! cloud optical depth (non-delta scaled) - ! real(kind=r8) :: ssacloud(nlay,jpband) ! cloud single scattering albedo - ! real(kind=r8) :: asmcloud(nlay,jpband) ! cloud asymmetry parameter - ! Atmosphere/clouds - cldprmc [mcica] - ! cloud fraction [mcica] - ! cloud ice water path [mcica] - ! cloud liquid water path [mcica] - ! liquid particle size (microns) - ! ice particle effective radius (microns) - ! ice particle generalized effective size (microns) - ! cloud optical depth [mcica] - ! unscaled cloud optical depth [mcica] - ! cloud single scattering albedo [mcica] - ! cloud asymmetry parameter [mcica] - ! cloud forward scattering fraction [mcica] - ! Atmosphere/clouds/aerosol - spcvrt,spcvmc - ! cloud optical depth - ! unscaled cloud optical depth - ! cloud asymmetry parameter - ! (first moment of phase function) - ! cloud single scattering albedo - REAL(KIND=r8) :: ztaua(ncol,nlay,nbndsw) ! total aerosol optical depth - REAL(KIND=r8) :: zasya(ncol,nlay,nbndsw) ! total aerosol asymmetry parameter - REAL(KIND=r8) :: zomga(ncol,nlay,nbndsw) ! total aerosol single scattering albedo - REAL(KIND=r8) :: zcldfmc(ncol,nlay,ngptsw) ! cloud fraction [mcica] - REAL(KIND=r8) :: ztaucmc(ncol,nlay,ngptsw) ! cloud optical depth [mcica] - REAL(KIND=r8) :: ztaormc(ncol,nlay,ngptsw) ! unscaled cloud optical depth [mcica] - REAL(KIND=r8) :: zasycmc(ncol,nlay,ngptsw) ! cloud asymmetry parameter [mcica] - REAL(KIND=r8) :: zomgcmc(ncol,nlay,ngptsw) ! cloud single scattering albedo [mcica] - REAL(KIND=r8) :: zbbfu(ncol,nlay+2) - REAL(KIND=r8) :: ref_zbbfu(ncol,nlay+2) ! temporary upward shortwave flux (w/m2) - REAL(KIND=r8) :: zbbfd(ncol,nlay+2) - REAL(KIND=r8) :: ref_zbbfd(ncol,nlay+2) ! temporary downward shortwave flux (w/m2) - REAL(KIND=r8) :: zbbcu(ncol,nlay+2) - REAL(KIND=r8) :: ref_zbbcu(ncol,nlay+2) ! temporary clear sky upward shortwave flux (w/m2) - REAL(KIND=r8) :: zbbcd(ncol,nlay+2) - REAL(KIND=r8) :: ref_zbbcd(ncol,nlay+2) ! temporary clear sky downward shortwave flux (w/m2) - REAL(KIND=r8) :: zbbfddir(ncol,nlay+2) - REAL(KIND=r8) :: ref_zbbfddir(ncol,nlay+2) ! temporary downward direct shortwave flux (w/m2) - REAL(KIND=r8) :: zbbcddir(ncol,nlay+2) - REAL(KIND=r8) :: ref_zbbcddir(ncol,nlay+2) ! temporary clear sky downward direct shortwave flux (w/m2) - REAL(KIND=r8) :: zuvfd(ncol,nlay+2) - REAL(KIND=r8) :: ref_zuvfd(ncol,nlay+2) ! temporary UV downward shortwave flux (w/m2) - REAL(KIND=r8) :: zuvcd(ncol,nlay+2) - REAL(KIND=r8) :: ref_zuvcd(ncol,nlay+2) ! temporary clear sky UV downward shortwave flux (w/m2) - REAL(KIND=r8) :: zuvfddir(ncol,nlay+2) - REAL(KIND=r8) :: ref_zuvfddir(ncol,nlay+2) ! temporary UV downward direct shortwave flux (w/m2) - REAL(KIND=r8) :: zuvcddir(ncol,nlay+2) - REAL(KIND=r8) :: ref_zuvcddir(ncol,nlay+2) ! temporary clear sky UV downward direct shortwave flux (w/m2) - REAL(KIND=r8) :: znifd(ncol,nlay+2) - REAL(KIND=r8) :: ref_znifd(ncol,nlay+2) ! temporary near-IR downward shortwave flux (w/m2) - REAL(KIND=r8) :: znicd(ncol,nlay+2) - REAL(KIND=r8) :: ref_znicd(ncol,nlay+2) ! temporary clear sky near-IR downward shortwave flux (w/m2) - REAL(KIND=r8) :: znifddir(ncol,nlay+2) - REAL(KIND=r8) :: ref_znifddir(ncol,nlay+2) ! temporary near-IR downward direct shortwave flux (w/m2) - REAL(KIND=r8) :: znicddir(ncol,nlay+2) - REAL(KIND=r8) :: ref_znicddir(ncol,nlay+2) ! temporary clear sky near-IR downward direct shortwave flux (w/m2) - ! Added for near-IR flux diagnostic - REAL(KIND=r8) :: znifu(ncol,nlay+2) - REAL(KIND=r8) :: ref_znifu(ncol,nlay+2) ! temporary near-IR downward shortwave flux (w/m2) - REAL(KIND=r8) :: znicu(ncol,nlay+2) - REAL(KIND=r8) :: ref_znicu(ncol,nlay+2) ! temporary clear sky near-IR downward shortwave flux (w/m2) - ! Optional output fields - ! Total sky shortwave net flux (W/m2) - ! Clear sky shortwave net flux (W/m2) - ! Direct downward shortwave surface flux - ! Diffuse downward shortwave surface flux - ! Total sky downward shortwave flux, UV/vis - ! Total sky downward shortwave flux, near-IR - REAL(KIND=r8) :: zbbfsu(ncol,nbndsw,nlay+2) - REAL(KIND=r8) :: ref_zbbfsu(ncol,nbndsw,nlay+2) ! temporary upward shortwave flux spectral (w/m2) - REAL(KIND=r8) :: zbbfsd(ncol,nbndsw,nlay+2) - REAL(KIND=r8) :: ref_zbbfsd(ncol,nbndsw,nlay+2) ! temporary downward shortwave flux spectral (w/m2) - ! Output - inactive - ! real(kind=r8) :: zuvfu(nlay+2) ! temporary upward UV shortwave flux (w/m2) - ! real(kind=r8) :: zuvfd(nlay+2) ! temporary downward UV shortwave flux (w/m2) - ! real(kind=r8) :: zuvcu(nlay+2) ! temporary clear sky upward UV shortwave flux (w/m2) - ! real(kind=r8) :: zuvcd(nlay+2) ! temporary clear sky downward UV shortwave flux (w/m2) - ! real(kind=r8) :: zvsfu(nlay+2) ! temporary upward visible shortwave flux (w/m2) - ! real(kind=r8) :: zvsfd(nlay+2) ! temporary downward visible shortwave flux (w/m2) - ! real(kind=r8) :: zvscu(nlay+2) ! temporary clear sky upward visible shortwave flux (w/m2) - ! real(kind=r8) :: zvscd(nlay+2) ! temporary clear sky downward visible shortwave flux (w/m2) - ! real(kind=r8) :: znifu(nlay+2) ! temporary upward near-IR shortwave flux (w/m2) - ! real(kind=r8) :: znifd(nlay+2) ! temporary downward near-IR shortwave flux (w/m2) - ! real(kind=r8) :: znicu(nlay+2) ! temporary clear sky upward near-IR shortwave flux (w/m2) - ! real(kind=r8) :: znicd(nlay+2) ! temporary clear sky downward near-IR shortwave flux (w/m2) - ! Initializations - ! In a GCM with or without McICA, set nlon to the longitude dimension - ! - ! Set imca to select calculation type: - ! imca = 0, use standard forward model calculation (clear and overcast only) - ! imca = 1, use McICA for Monte Carlo treatment of sub-grid cloud variability - ! (clear, overcast or partial cloud conditions) - ! *** This version uses McICA (imca = 1) *** - ! Set icld to select of clear or cloud calculation and cloud - ! overlap method (read by subroutine readprof from input file INPUT_RRTM): - ! icld = 0, clear only - ! icld = 1, with clouds using random cloud overlap (McICA only) - ! icld = 2, with clouds using maximum/random cloud overlap (McICA only) - ! icld = 3, with clouds using maximum cloud overlap (McICA only) - ! Set iaer to select aerosol option - ! iaer = 0, no aerosols - ! iaer = 6, use six ECMWF aerosol types - ! input aerosol optical depth at 0.55 microns for each aerosol type (ecaer) - ! iaer = 10, input total aerosol optical depth, single scattering albedo - ! and asymmetry parameter (tauaer, ssaaer, asmaer) directly - ! Set idelm to select between delta-M scaled or unscaled output direct and diffuse fluxes - ! NOTE: total downward fluxes are always delta scaled - ! idelm = 0, output direct and diffuse flux components are not delta scaled - ! (direct flux does not include forward scattering peak) - ! idelm = 1, output direct and diffuse flux components are delta scaled (default) - ! (direct flux includes part or most of forward scattering peak) - ! Call model and data initialization, compute lookup tables, perform - ! reduction of g-points from 224 to 112 for input absorption - ! coefficient data and other arrays. - ! - ! In a GCM this call should be placed in the model initialization - ! area, since this has to be called only once. - ! call rrtmg_sw_ini - ! This is the main longitude/column loop in RRTMG. - ! Modify to loop over all columns (nlon) or over daylight columns - ! For cloudy atmosphere, use cldprop to set cloud optical properties based on - ! input cloud physical properties. Select method based on choices described - ! in cldprop. Cloud fraction, water path, liquid droplet and ice particle - ! effective radius must be passed in cldprop. Cloud fraction and cloud - ! optical properties are transferred to rrtmg_sw arrays in cldprop. - ! Calculate coefficients for the temperature and pressure dependence of the - ! molecular absorption coefficients by interpolating data from stored - ! Cosine of the solar zenith angle - ! Prevent using value of zero; ideally, SW model is not called from host model when sun - ! is below horizon - !do iplon=1,ncol - ! call spcvmc_sw & - ! (lchnk, iplon, nlay, istart, iend, icpr, idelm, iout, & - ! pavel(iplon,:), tavel(iplon,:), pz(iplon,:), tz(iplon,:), tbound(iplon), albdif(iplon,:), albdir(iplon,:), & - ! zcldfmc(iplon,:,:), ztaucmc(iplon,:,:), zasycmc(iplon,:,:), zomgcmc(iplon,:,:), ztaormc(iplon,:,:), & - ! ztaua(iplon,:,:), zasya(iplon,:,:), zomga(iplon,:,:), cossza(iplon), coldry(iplon,:), wkl(iplon,:,:), - ! adjflux(iplon,:), & - ! laytrop(iplon), layswtch(iplon), laylow(iplon), jp(iplon,:), jt(iplon,:), jt1(iplon,:), & - ! co2mult(iplon,:), colch4(iplon,:), colco2(iplon,:), colh2o(iplon,:), colmol(iplon,:), coln2o(iplon,:), colo2( - ! iplon,:), colo3(iplon,:), & - ! fac00(iplon,:), fac01(iplon,:), fac10(iplon,:), fac11(iplon,:), & - ! selffac(iplon,:), selffrac(iplon,:), indself(iplon,:), forfac(iplon,:), forfrac(iplon,:), indfor(iplon,:), & - ! zbbfd(iplon,:), zbbfu(iplon,:), zbbcd(iplon,:), zbbcu(iplon,:), zuvfd(iplon,:), zuvcd(iplon,:), znifd(iplon, - ! :), znicd(iplon,:), znifu(iplon,:), znicu(iplon,:), & - ! zbbfddir(iplon,:), zbbcddir(iplon,:), zuvfddir(iplon,:), zuvcddir(iplon,:), znifddir(iplon,:), znicddir( - ! iplon,:), zbbfsu(iplon,:,:), zbbfsd(iplon,:,:)) - ! ! Transfer up and down, clear and total sky fluxes to output arrays. - ! ! Vertical indexing goes from bottom to top - !end do - tolerance = 1.E-14 - CALL kgen_init_check(check_status, tolerance) - READ(UNIT=kgen_unit) istart - READ(UNIT=kgen_unit) iend - READ(UNIT=kgen_unit) icpr - READ(UNIT=kgen_unit) iout - READ(UNIT=kgen_unit) idelm - READ(UNIT=kgen_unit) pavel - READ(UNIT=kgen_unit) tavel - READ(UNIT=kgen_unit) pz - READ(UNIT=kgen_unit) tz - READ(UNIT=kgen_unit) tbound - READ(UNIT=kgen_unit) coldry - READ(UNIT=kgen_unit) wkl - READ(UNIT=kgen_unit) cossza - READ(UNIT=kgen_unit) adjflux - READ(UNIT=kgen_unit) albdir - READ(UNIT=kgen_unit) albdif - READ(UNIT=kgen_unit) laytrop - READ(UNIT=kgen_unit) layswtch - READ(UNIT=kgen_unit) laylow - READ(UNIT=kgen_unit) jp - READ(UNIT=kgen_unit) jt - READ(UNIT=kgen_unit) jt1 - READ(UNIT=kgen_unit) colh2o - READ(UNIT=kgen_unit) colco2 - READ(UNIT=kgen_unit) colo3 - READ(UNIT=kgen_unit) coln2o - READ(UNIT=kgen_unit) colch4 - READ(UNIT=kgen_unit) colo2 - READ(UNIT=kgen_unit) colmol - READ(UNIT=kgen_unit) co2mult - READ(UNIT=kgen_unit) indself - READ(UNIT=kgen_unit) indfor - READ(UNIT=kgen_unit) selffac - READ(UNIT=kgen_unit) selffrac - READ(UNIT=kgen_unit) forfac - READ(UNIT=kgen_unit) forfrac - READ(UNIT=kgen_unit) fac00 - READ(UNIT=kgen_unit) fac01 - READ(UNIT=kgen_unit) fac11 - READ(UNIT=kgen_unit) fac10 - READ(UNIT=kgen_unit) ztaua - READ(UNIT=kgen_unit) zasya - READ(UNIT=kgen_unit) zomga - READ(UNIT=kgen_unit) zcldfmc - READ(UNIT=kgen_unit) ztaucmc - READ(UNIT=kgen_unit) ztaormc - READ(UNIT=kgen_unit) zasycmc - READ(UNIT=kgen_unit) zomgcmc - READ(UNIT=kgen_unit) zbbfu - READ(UNIT=kgen_unit) zbbfd - READ(UNIT=kgen_unit) zbbcu - READ(UNIT=kgen_unit) zbbcd - READ(UNIT=kgen_unit) zbbfddir - READ(UNIT=kgen_unit) zbbcddir - READ(UNIT=kgen_unit) zuvfd - READ(UNIT=kgen_unit) zuvcd - READ(UNIT=kgen_unit) zuvfddir - READ(UNIT=kgen_unit) zuvcddir - READ(UNIT=kgen_unit) znifd - READ(UNIT=kgen_unit) znicd - READ(UNIT=kgen_unit) znifddir - READ(UNIT=kgen_unit) znicddir - READ(UNIT=kgen_unit) znifu - READ(UNIT=kgen_unit) znicu - READ(UNIT=kgen_unit) zbbfsu - READ(UNIT=kgen_unit) zbbfsd - - READ(UNIT=kgen_unit) ref_zbbfu - READ(UNIT=kgen_unit) ref_zbbfd - READ(UNIT=kgen_unit) ref_zbbcu - READ(UNIT=kgen_unit) ref_zbbcd - READ(UNIT=kgen_unit) ref_zbbfddir - READ(UNIT=kgen_unit) ref_zbbcddir - READ(UNIT=kgen_unit) ref_zuvfd - READ(UNIT=kgen_unit) ref_zuvcd - READ(UNIT=kgen_unit) ref_zuvfddir - READ(UNIT=kgen_unit) ref_zuvcddir - READ(UNIT=kgen_unit) ref_znifd - READ(UNIT=kgen_unit) ref_znicd - READ(UNIT=kgen_unit) ref_znifddir - READ(UNIT=kgen_unit) ref_znicddir - READ(UNIT=kgen_unit) ref_znifu - READ(UNIT=kgen_unit) ref_znicu - READ(UNIT=kgen_unit) ref_zbbfsu - READ(UNIT=kgen_unit) ref_zbbfsd - - - ! call to kernel - call spcvmc_sw & - (lchnk, ncol, nlay, istart, iend, icpr, idelm, iout, & - pavel, tavel, pz, tz, tbound, albdif, albdir, & - zcldfmc, ztaucmc, zasycmc, zomgcmc, ztaormc, & - ztaua, zasya, zomga, cossza, coldry, wkl, adjflux, & - laytrop, layswtch, laylow, jp, jt, jt1, & - co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3, & - fac00, fac01, fac10, fac11, & - selffac, selffrac, indself, forfac, forfrac, indfor, & - zbbfd, zbbfu, zbbcd, zbbcu, zuvfd, zuvcd, znifd, znicd, znifu, znicu, & - zbbfddir, zbbcddir, zuvfddir, zuvcddir, znifddir, znicddir, zbbfsu, zbbfsd) - ! kernel verification for output variables - CALL kgen_verify_real_r8_dim2( "zbbfu", check_status, zbbfu, ref_zbbfu) - CALL kgen_verify_real_r8_dim2( "zbbfd", check_status, zbbfd, ref_zbbfd) - CALL kgen_verify_real_r8_dim2( "zbbcu", check_status, zbbcu, ref_zbbcu) - CALL kgen_verify_real_r8_dim2( "zbbcd", check_status, zbbcd, ref_zbbcd) - CALL kgen_verify_real_r8_dim2( "zbbfddir", check_status, zbbfddir, ref_zbbfddir) - CALL kgen_verify_real_r8_dim2( "zbbcddir", check_status, zbbcddir, ref_zbbcddir) - CALL kgen_verify_real_r8_dim2( "zuvfd", check_status, zuvfd, ref_zuvfd) - CALL kgen_verify_real_r8_dim2( "zuvcd", check_status, zuvcd, ref_zuvcd) - CALL kgen_verify_real_r8_dim2( "zuvfddir", check_status, zuvfddir, ref_zuvfddir) - CALL kgen_verify_real_r8_dim2( "zuvcddir", check_status, zuvcddir, ref_zuvcddir) - CALL kgen_verify_real_r8_dim2( "znifd", check_status, znifd, ref_znifd) - CALL kgen_verify_real_r8_dim2( "znicd", check_status, znicd, ref_znicd) - CALL kgen_verify_real_r8_dim2( "znifddir", check_status, znifddir, ref_znifddir) - CALL kgen_verify_real_r8_dim2( "znicddir", check_status, znicddir, ref_znicddir) - CALL kgen_verify_real_r8_dim2( "znifu", check_status, znifu, ref_znifu) - CALL kgen_verify_real_r8_dim2( "znicu", check_status, znicu, ref_znicu) - CALL kgen_verify_real_r8_dim3( "zbbfsu", check_status, zbbfsu, ref_zbbfsu) - CALL kgen_verify_real_r8_dim3( "zbbfsd", check_status, zbbfsd, ref_zbbfsd) - CALL kgen_print_check("spcvmc_sw", check_status) - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,10 - CALL spcvmc_sw(lchnk, ncol, nlay, istart, iend, icpr, idelm, iout, pavel, tavel, pz, tz, tbound, & -albdif, albdir, zcldfmc, ztaucmc, zasycmc, zomgcmc, ztaormc, ztaua, zasya, zomga, cossza, coldry, wkl, & -adjflux, laytrop, layswtch, laylow, jp, jt, jt1, co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, & -colo3, fac00, fac01, fac10, fac11, selffac, selffrac, indself, forfac, forfrac, indfor, zbbfd, zbbfu, zbbcd, & -zbbcu, zuvfd, zuvcd, znifd, znicd, znifu, znicu, zbbfddir, zbbcddir, zuvfddir, zuvcddir, znifddir, znicddir, & -zbbfsu, zbbfsd) - END DO - CALL system_clock(stop_clock, rate_clock) - WRITE(*,*) - PRINT *, "Elapsed time (sec): ", (stop_clock - start_clock)/REAL(rate_clock*10) - ! Transfer up and down, clear and total sky fluxes to output arrays. - ! Vertical indexing goes from bottom to top - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_r8_dim2(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim2 - - SUBROUTINE kgen_read_real_r8_dim3(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2,idx3 - INTEGER, DIMENSION(2,3) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim3 - - - ! verify subroutines - SUBROUTINE kgen_verify_real_r8_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim2 - - SUBROUTINE kgen_verify_real_r8_dim3( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim3 - - END SUBROUTINE rrtmg_sw - !************************************************************************* - - !*************************************************************************** - - END MODULE rrtmg_sw_rad diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/rrtmg_sw_reftra.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/rrtmg_sw_reftra.f90 deleted file mode 100644 index faac537fbe..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/rrtmg_sw_reftra.f90 +++ /dev/null @@ -1,299 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_sw_reftra.f90 -! Generated at: 2015-07-31 20:35:44 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_sw_reftra - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! ------- Modules ------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE rrsw_tbl, ONLY: od_lo - USE rrsw_tbl, ONLY: bpade - USE rrsw_tbl, ONLY: tblint - USE rrsw_tbl, ONLY: exp_tbl - USE rrsw_vsn, ONLY: hvrrft - IMPLICIT NONE - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - ! -------------------------------------------------------------------- - - SUBROUTINE reftra_sw(nlayers, ncol, lrtchk, pgg, prmuz, ptau, pw, pref, prefd, ptra, ptrad) - ! -------------------------------------------------------------------- - ! Purpose: computes the reflectivity and transmissivity of a clear or - ! cloudy layer using a choice of various approximations. - ! - ! Interface: *rrtmg_sw_reftra* is called by *rrtmg_sw_spcvrt* - ! - ! Description: - ! explicit arguments : - ! -------------------- - ! inputs - ! ------ - ! lrtchk = .t. for all layers in clear profile - ! lrtchk = .t. for cloudy layers in cloud profile - ! = .f. for clear layers in cloud profile - ! pgg = assymetry factor - ! prmuz = cosine solar zenith angle - ! ptau = optical thickness - ! pw = single scattering albedo - ! - ! outputs - ! ------- - ! pref : collimated beam reflectivity - ! prefd : diffuse beam reflectivity - ! ptra : collimated beam transmissivity - ! ptrad : diffuse beam transmissivity - ! - ! - ! Method: - ! ------- - ! standard delta-eddington, p.i.f.m., or d.o.m. layer calculations. - ! kmodts = 1 eddington (joseph et al., 1976) - ! = 2 pifm (zdunkowski et al., 1980) - ! = 3 discrete ordinates (liou, 1973) - ! - ! - ! Modifications: - ! -------------- - ! Original: J-JMorcrette, ECMWF, Feb 2003 - ! Revised for F90 reformatting: MJIacono, AER, Jul 2006 - ! Revised to add exponential lookup table: MJIacono, AER, Aug 2007 - ! - ! ------------------------------------------------------------------ - ! ------- Declarations ------ - ! ------- Input ------- - INTEGER, intent(in) :: nlayers - INTEGER, intent(in) :: ncol - LOGICAL, intent(in) :: lrtchk(:,:) ! Logical flag for reflectivity and - ! and transmissivity calculation; - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: pgg(:,:) ! asymmetry parameter - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: ptau(:,:) ! optical depth - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: pw(:,:) ! single scattering albedo - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: prmuz(:) ! cosine of solar zenith angle - ! ------- Output ------- - REAL(KIND=r8), intent(inout) :: pref(:,:) ! direct beam reflectivity - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(inout) :: prefd(:,:) ! diffuse beam reflectivity - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(inout) :: ptra(:,:) ! direct beam transmissivity - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(inout) :: ptrad(:,:) ! diffuse beam transmissivity - ! Dimensions: (nlayers+1) - ! ------- Local ------- - INTEGER :: kmodts - INTEGER :: jk - INTEGER :: icol - INTEGER :: itind - REAL(KIND=r8) :: tblind - REAL(KIND=r8) :: za - REAL(KIND=r8) :: za1 - REAL(KIND=r8) :: za2 - REAL(KIND=r8) :: zbeta - REAL(KIND=r8) :: zdenr - REAL(KIND=r8) :: zdent - REAL(KIND=r8) :: zdend - REAL(KIND=r8) :: ze1 - REAL(KIND=r8) :: ze2 - REAL(KIND=r8) :: zem1 - REAL(KIND=r8) :: zep1 - REAL(KIND=r8) :: zem2 - REAL(KIND=r8) :: zep2 - REAL(KIND=r8) :: zemm - REAL(KIND=r8) :: zg - REAL(KIND=r8) :: zg3 - REAL(KIND=r8) :: zgamma1 - REAL(KIND=r8) :: zgamma2 - REAL(KIND=r8) :: zgamma3 - REAL(KIND=r8) :: zgamma4 - REAL(KIND=r8) :: zgt - REAL(KIND=r8) :: zr1 - REAL(KIND=r8) :: zr2 - REAL(KIND=r8) :: zr3 - REAL(KIND=r8) :: zr4 - REAL(KIND=r8) :: zr5 - REAL(KIND=r8) :: zrk - REAL(KIND=r8) :: zrp - REAL(KIND=r8) :: zrp1 - REAL(KIND=r8) :: zrm1 - REAL(KIND=r8) :: zrk2 - REAL(KIND=r8) :: zrpp - REAL(KIND=r8) :: zrkg - REAL(KIND=r8) :: zsr3 - REAL(KIND=r8) :: zto1 - REAL(KIND=r8) :: zt1 - REAL(KIND=r8) :: zt2 - REAL(KIND=r8) :: zt3 - REAL(KIND=r8) :: zt4 - REAL(KIND=r8) :: zt5 - REAL(KIND=r8) :: zwcrit - REAL(KIND=r8) :: zw - REAL(KIND=r8) :: zwo - REAL(KIND=r8), parameter :: eps = 1.e-08_r8 - ! ------------------------------------------------------------------ - ! Initialize - hvrrft = '$Revision: 1.2 $' - do icol = 1,ncol - zsr3=sqrt(3._r8) - zwcrit=0.9999995_r8 - kmodts=2 - do jk=1, nlayers - if (.not.lrtchk(icol,jk)) then - pref(icol,jk) =0._r8 - ptra(icol,jk) =1._r8 - prefd(icol,jk)=0._r8 - ptrad(icol,jk)=1._r8 - else - zto1=ptau(icol,jk) - zw =pw(icol,jk) - zg =pgg(icol,jk) - ! General two-stream expressions - zg3= 3._r8 * zg - if (kmodts == 1) then - zgamma1= (7._r8 - zw * (4._r8 + zg3)) * 0.25_r8 - zgamma2=-(1._r8 - zw * (4._r8 - zg3)) * 0.25_r8 - zgamma3= (2._r8 - zg3 * prmuz(icol) ) * 0.25_r8 - else if (kmodts == 2) then - zgamma1= (8._r8 - zw * (5._r8 + zg3)) * 0.25_r8 - zgamma2= 3._r8 *(zw * (1._r8 - zg )) * 0.25_r8 - zgamma3= (2._r8 - zg3 * prmuz(icol) ) * 0.25_r8 - else if (kmodts == 3) then - zgamma1= zsr3 * (2._r8 - zw * (1._r8 + zg)) * 0.5_r8 - zgamma2= zsr3 * zw * (1._r8 - zg ) * 0.5_r8 - zgamma3= (1._r8 - zsr3 * zg * prmuz(icol) ) * 0.5_r8 - end if - zgamma4= 1._r8 - zgamma3 - ! Recompute original s.s.a. to test for conservative solution - zwo= zw / (1._r8 - (1._r8 - zw) * (zg / (1._r8 - zg))**2) - if (zwo >= zwcrit) then - ! Conservative scattering - za = zgamma1 * prmuz(icol) - za1 = za - zgamma3 - zgt = zgamma1 * zto1 - ! Homogeneous reflectance and transmittance, - ! collimated beam - ze1 = min ( zto1 / prmuz(icol) , 500._r8) - ! ze2 = exp( -ze1 ) - ! Use exponential lookup table for transmittance, or expansion of - ! exponential for low tau - if (ze1 .le. od_lo) then - ze2 = 1._r8 - ze1 + 0.5_r8 * ze1 * ze1 - else - tblind = ze1 / (bpade + ze1) - itind = tblint * tblind + 0.5_r8 - ze2 = exp_tbl(itind) - endif - ! - pref(icol,jk) = (zgt - za1 * (1._r8 - ze2)) / (1._r8 + zgt) - ptra(icol,jk) = 1._r8 - pref(icol,jk) - ! isotropic incidence - prefd(icol,jk) = zgt / (1._r8 + zgt) - ptrad(icol,jk) = 1._r8 - prefd(icol,jk) - ! This is applied for consistency between total (delta-scaled) and direct (unscaled) - ! calculations at very low optical depths (tau < 1.e-4) when the exponential lookup - ! table returns a transmittance of 1.0. - if (ze2 .eq. 1.0_r8) then - pref(icol,jk) = 0.0_r8 - ptra(icol,jk) = 1.0_r8 - prefd(icol,jk) = 0.0_r8 - ptrad(icol,jk) = 1.0_r8 - endif - else - ! Non-conservative scattering - za1 = zgamma1 * zgamma4 + zgamma2 * zgamma3 - za2 = zgamma1 * zgamma3 + zgamma2 * zgamma4 - zrk = sqrt ( zgamma1**2 - zgamma2**2) - zrp = zrk * prmuz(icol) - zrp1 = 1._r8 + zrp - zrm1 = 1._r8 - zrp - zrk2 = 2._r8 * zrk - zrpp = 1._r8 - zrp*zrp - zrkg = zrk + zgamma1 - zr1 = zrm1 * (za2 + zrk * zgamma3) - zr2 = zrp1 * (za2 - zrk * zgamma3) - zr3 = zrk2 * (zgamma3 - za2 * prmuz(icol) ) - zr4 = zrpp * zrkg - zr5 = zrpp * (zrk - zgamma1) - zt1 = zrp1 * (za1 + zrk * zgamma4) - zt2 = zrm1 * (za1 - zrk * zgamma4) - zt3 = zrk2 * (zgamma4 + za1 * prmuz(icol) ) - zt4 = zr4 - zt5 = zr5 - zbeta = (zgamma1 - zrk) / zrkg !- zr5 / zr4 !- zr5 / zr4 !- zr5 / zr4 !- zr5 / zr4 - ! Homogeneous reflectance and transmittance - ze1 = min ( zrk * zto1, 500._r8) - ze2 = min ( zto1 / prmuz(icol) , 500._r8) - ! - ! Original - ! zep1 = exp( ze1 ) - ! zem1 = exp(-ze1 ) - ! zep2 = exp( ze2 ) - ! zem2 = exp(-ze2 ) - ! - ! Revised original, to reduce exponentials - ! zep1 = exp( ze1 ) - ! zem1 = 1._r8 / zep1 - ! zep2 = exp( ze2 ) - ! zem2 = 1._r8 / zep2 - ! - ! Use exponential lookup table for transmittance, or expansion of - ! exponential for low tau - if (ze1 .le. od_lo) then - zem1 = 1._r8 - ze1 + 0.5_r8 * ze1 * ze1 - zep1 = 1._r8 / zem1 - else - tblind = ze1 / (bpade + ze1) - itind = tblint * tblind + 0.5_r8 - zem1 = exp_tbl(itind) - zep1 = 1._r8 / zem1 - endif - if (ze2 .le. od_lo) then - zem2 = 1._r8 - ze2 + 0.5_r8 * ze2 * ze2 - zep2 = 1._r8 / zem2 - else - tblind = ze2 / (bpade + ze2) - itind = tblint * tblind + 0.5_r8 - zem2 = exp_tbl(itind) - zep2 = 1._r8 / zem2 - endif - ! collimated beam - zdenr = zr4*zep1 + zr5*zem1 - zdent = zt4*zep1 + zt5*zem1 - if (zdenr .ge. -eps .and. zdenr .le. eps) then - pref(icol,jk) = eps - ptra(icol,jk) = zem2 - else - pref(icol,jk) = zw * (zr1*zep1 - zr2*zem1 - zr3*zem2) / zdenr - ptra(icol,jk) = zem2 - zem2 * zw * (zt1*zep1 - zt2*zem1 - zt3*zep2) / zdent - endif - ! diffuse beam - zemm = zem1*zem1 - zdend = 1._r8 / ( (1._r8 - zbeta*zemm ) * zrkg) - prefd(icol,jk) = zgamma2 * (1._r8 - zemm) * zdend - ptrad(icol,jk) = zrk2*zem1*zdend - endif - endif - enddo -end do - END SUBROUTINE reftra_sw - END MODULE rrtmg_sw_reftra diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/rrtmg_sw_spcvmc.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/rrtmg_sw_spcvmc.f90 deleted file mode 100644 index efca771aa8..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/rrtmg_sw_spcvmc.f90 +++ /dev/null @@ -1,624 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_sw_spcvmc.f90 -! Generated at: 2015-07-31 20:35:45 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_sw_spcvmc - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! ------- Modules ------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE parrrsw, ONLY: ngptsw - USE rrsw_tbl, ONLY: od_lo - USE rrsw_tbl, ONLY: bpade - USE rrsw_tbl, ONLY: tblint - USE rrsw_tbl, ONLY: exp_tbl - USE rrsw_wvn, ONLY: ngc - USE rrsw_wvn, ONLY: ngs - USE rrtmg_sw_reftra, ONLY: reftra_sw - USE rrtmg_sw_taumol, ONLY: taumol_sw - USE rrtmg_sw_vrtqdr, ONLY: vrtqdr_sw - IMPLICIT NONE - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - ! --------------------------------------------------------------------------- - - SUBROUTINE spcvmc_sw(lchnk, ncol, nlayers, istart, iend, icpr, idelm, iout, pavel, tavel, pz, tz, tbound, palbd, palbp, & - pcldfmc, ptaucmc, pasycmc, pomgcmc, ptaormc, ptaua, pasya, pomga, prmu0, coldry, wkl, adjflux, laytrop, layswtch, laylow, & - jp, jt, jt1, co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3, fac00, fac01, fac10, fac11, selffac, selffrac,& - indself, forfac, forfrac, indfor, pbbfd, pbbfu, pbbcd, pbbcu, puvfd, puvcd, pnifd, pnicd, pnifu, pnicu, pbbfddir, & - pbbcddir, puvfddir, puvcddir, pnifddir, pnicddir, pbbfsu, pbbfsd) - ! --------------------------------------------------------------------------- - ! - ! Purpose: Contains spectral loop to compute the shortwave radiative fluxes, - ! using the two-stream method of H. Barker and McICA, the Monte-Carlo - ! Independent Column Approximation, for the representation of - ! sub-grid cloud variability (i.e. cloud overlap). - ! - ! Interface: *spcvmc_sw* is called from *rrtmg_sw.F90* or rrtmg_sw.1col.F90* - ! - ! Method: - ! Adapted from two-stream model of H. Barker; - ! Two-stream model options (selected with kmodts in rrtmg_sw_reftra.F90): - ! 1: Eddington, 2: PIFM, Zdunkowski et al., 3: discret ordinates - ! - ! Modifications: - ! - ! Original: H. Barker - ! Revision: Merge with RRTMG_SW: J.-J.Morcrette, ECMWF, Feb 2003 - ! Revision: Add adjustment for Earth/Sun distance : MJIacono, AER, Oct 2003 - ! Revision: Bug fix for use of PALBP and PALBD: MJIacono, AER, Nov 2003 - ! Revision: Bug fix to apply delta scaling to clear sky: AER, Dec 2004 - ! Revision: Code modified so that delta scaling is not done in cloudy profiles - ! if routine cldprop is used; delta scaling can be applied by swithcing - ! code below if cldprop is not used to get cloud properties. - ! AER, Jan 2005 - ! Revision: Modified to use McICA: MJIacono, AER, Nov 2005 - ! Revision: Uniform formatting for RRTMG: MJIacono, AER, Jul 2006 - ! Revision: Use exponential lookup table for transmittance: MJIacono, AER, - ! Aug 2007 - ! - ! ------------------------------------------------------------------ - ! ------- Declarations ------ - ! ------- Input ------- - INTEGER, intent(in) :: lchnk - INTEGER, intent(in) :: nlayers - INTEGER, intent(in) :: istart - INTEGER, intent(in) :: iend - INTEGER, intent(in) :: icpr - INTEGER, intent(in) :: idelm ! delta-m scaling flag - ! [0 = direct and diffuse fluxes are unscaled] - ! [1 = direct and diffuse fluxes are scaled] - INTEGER, intent(in) :: iout - INTEGER, intent(in) :: ncol ! column loop index - INTEGER, intent(in) :: laytrop(ncol) - INTEGER, intent(in) :: layswtch(ncol) - INTEGER, intent(in) :: laylow(ncol) - INTEGER, intent(in) :: indfor(:,:) - ! Dimensions: (ncol,nlayers) - INTEGER, intent(in) :: indself(:,:) - ! Dimensions: (ncol,nlayers) - INTEGER, intent(in) :: jp(:,:) - ! Dimensions: (ncol,nlayers) - INTEGER, intent(in) :: jt(:,:) - ! Dimensions: (ncol,nlayers) - INTEGER, intent(in) :: jt1(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: pavel(:,:) ! layer pressure (hPa, mb) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: tavel(:,:) ! layer temperature (K) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: pz(:,0:) ! level (interface) pressure (hPa, mb) - ! Dimensions: (ncol,0:nlayers) - REAL(KIND=r8), intent(in) :: tz(:,0:) ! level temperatures (hPa, mb) - ! Dimensions: (ncol,0:nlayers) - REAL(KIND=r8), intent(in) :: tbound(ncol) ! surface temperature (K) - REAL(KIND=r8), intent(in) :: wkl(:,:,:) ! molecular amounts (mol/cm2) - ! Dimensions: (ncol,mxmol,nlayers) - REAL(KIND=r8), intent(in) :: coldry(:,:) ! dry air column density (mol/cm2) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: colmol(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: adjflux(:,:) ! Earth/Sun distance adjustment - ! Dimensions: (ncol,jpband) - REAL(KIND=r8), intent(in) :: palbd(:,:) ! surface albedo (diffuse) - ! Dimensions: (ncol,nbndsw) - REAL(KIND=r8), intent(in) :: palbp(:,:) ! surface albedo (direct) - ! Dimensions: (ncol, nbndsw) - REAL(KIND=r8), intent(in) :: prmu0(ncol) ! cosine of solar zenith angle - REAL(KIND=r8), intent(in) :: pcldfmc(:,:,:) ! cloud fraction [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - REAL(KIND=r8), intent(in) :: ptaucmc(:,:,:) ! cloud optical depth [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - REAL(KIND=r8), intent(in) :: pasycmc(:,:,:) ! cloud asymmetry parameter [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - REAL(KIND=r8), intent(in) :: pomgcmc(:,:,:) ! cloud single scattering albedo [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - REAL(KIND=r8), intent(in) :: ptaormc(:,:,:) ! cloud optical depth, non-delta scaled [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - REAL(KIND=r8), intent(in) :: ptaua(:,:,:) ! aerosol optical depth - ! Dimensions: (ncol,nlayers,nbndsw) - REAL(KIND=r8), intent(in) :: pasya(:,:,:) ! aerosol asymmetry parameter - ! Dimensions: (ncol,nlayers,nbndsw) - REAL(KIND=r8), intent(in) :: pomga(:,:,:) ! aerosol single scattering albedo - ! Dimensions: (ncol,nlayers,nbndsw) - REAL(KIND=r8), intent(in) :: colh2o(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: colco2(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: colch4(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: co2mult(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: colo3(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: colo2(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: coln2o(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: forfac(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: forfrac(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: selffac(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: selffrac(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: fac00(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: fac01(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: fac10(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: fac11(:,:) - ! Dimensions: (ncol,nlayers) - ! ------- Output ------- - ! All Dimensions: (nlayers+1) - REAL(KIND=r8), intent(out) :: pbbcd(:,:) - REAL(KIND=r8), intent(out) :: pbbcu(:,:) - REAL(KIND=r8), intent(out) :: pbbfd(:,:) - REAL(KIND=r8), intent(out) :: pbbfu(:,:) - REAL(KIND=r8), intent(out) :: pbbfddir(:,:) - REAL(KIND=r8), intent(out) :: pbbcddir(:,:) - REAL(KIND=r8), intent(out) :: puvcd(:,:) - REAL(KIND=r8), intent(out) :: puvfd(:,:) - REAL(KIND=r8), intent(out) :: puvcddir(:,:) - REAL(KIND=r8), intent(out) :: puvfddir(:,:) - REAL(KIND=r8), intent(out) :: pnicd(:,:) - REAL(KIND=r8), intent(out) :: pnifd(:,:) - REAL(KIND=r8), intent(out) :: pnicddir(:,:) - REAL(KIND=r8), intent(out) :: pnifddir(:,:) - ! Added for net near-IR flux diagnostic - REAL(KIND=r8), intent(out) :: pnicu(:,:) - REAL(KIND=r8), intent(out) :: pnifu(:,:) - ! Output - inactive ! All Dimensions: (nlayers+1) - ! real(kind=r8), intent(out) :: puvcu(:) - ! real(kind=r8), intent(out) :: puvfu(:) - ! real(kind=r8), intent(out) :: pvscd(:) - ! real(kind=r8), intent(out) :: pvscu(:) - ! real(kind=r8), intent(out) :: pvsfd(:) - ! real(kind=r8), intent(out) :: pvsfu(:) - REAL(KIND=r8), intent(out) :: pbbfsu(:,:,:) ! shortwave spectral flux up (nswbands,nlayers+1) - REAL(KIND=r8), intent(out) :: pbbfsd(:,:,:) ! shortwave spectral flux down (nswbands,nlayers+1) - ! ------- Local ------- - LOGICAL :: lrtchkclr(ncol,nlayers) - LOGICAL :: lrtchkcld(ncol,nlayers) - INTEGER :: klev - INTEGER :: ib1 - INTEGER :: ib2 - INTEGER :: ibm - INTEGER :: igt - INTEGER :: ikl - INTEGER :: iw(ncol) - INTEGER :: jk - INTEGER :: jb - INTEGER :: iplon - INTEGER :: jg - ! integer, parameter :: nuv = ?? - ! integer, parameter :: nvs = ?? - INTEGER :: itind(ncol) - REAL(KIND=r8) :: ze1(ncol) - REAL(KIND=r8) :: tblind(ncol) - REAL(KIND=r8) :: zclear(ncol) - REAL(KIND=r8) :: zcloud(ncol) - REAL(KIND=r8) :: zdbt(ncol,nlayers+1) - REAL(KIND=r8) :: zdbt_nodel(ncol,nlayers+1) - REAL(KIND=r8) :: zgcc(ncol,nlayers) - REAL(KIND=r8) :: zgco(ncol,nlayers) - REAL(KIND=r8) :: zomcc(ncol,nlayers) - REAL(KIND=r8) :: zomco(ncol,nlayers) - REAL(KIND=r8) :: zrdndc(ncol,nlayers+1) - REAL(KIND=r8) :: zrdnd(ncol,nlayers+1) - REAL(KIND=r8) :: zrefc(ncol,nlayers+1) - REAL(KIND=r8) :: zrefo(ncol,nlayers+1) - REAL(KIND=r8) :: zref(ncol,nlayers+1) - REAL(KIND=r8) :: zrefdc(ncol,nlayers+1) - REAL(KIND=r8) :: zrefdo(ncol,nlayers+1) - REAL(KIND=r8) :: zrefd(ncol,nlayers+1) - REAL(KIND=r8) :: zrup(ncol,nlayers+1) - REAL(KIND=r8) :: zrupd(ncol,nlayers+1) - REAL(KIND=r8) :: zrupc(ncol,nlayers+1) - REAL(KIND=r8) :: zrupdc(ncol,nlayers+1) - REAL(KIND=r8) :: ztauc(ncol,nlayers) - REAL(KIND=r8) :: ztauo(ncol,nlayers) - REAL(KIND=r8) :: ztdbt(ncol,nlayers+1) - REAL(KIND=r8) :: ztrac(ncol,nlayers+1) - REAL(KIND=r8) :: ztrao(ncol,nlayers+1) - REAL(KIND=r8) :: ztra(ncol,nlayers+1) - REAL(KIND=r8) :: ztradc(ncol,nlayers+1) - REAL(KIND=r8) :: ztrado(ncol,nlayers+1) - REAL(KIND=r8) :: ztrad(ncol,nlayers+1) - REAL(KIND=r8) :: ztdbtc(ncol,nlayers+1) - REAL(KIND=r8) :: zdbtc(ncol,nlayers+1) - REAL(KIND=r8) :: zincflx(ncol,ngptsw) - REAL(KIND=r8) :: zdbtc_nodel(ncol,nlayers+1) - REAL(KIND=r8) :: ztdbtc_nodel(ncol,nlayers+1) - REAL(KIND=r8) :: ztdbt_nodel(ncol,nlayers+1) - REAL(KIND=r8) :: zdbtmc(ncol) - REAL(KIND=r8) :: zdbtmo(ncol) - REAL(KIND=r8) :: zf - REAL(KIND=r8) :: repclc(ncol) - REAL(KIND=r8) :: tauorig(ncol) - REAL(KIND=r8) :: zwf - ! real(kind=r8) :: zincflux ! inactive - ! Arrays from rrtmg_sw_taumoln routines - ! real(kind=r8) :: ztaug(nlayers,16), ztaur(nlayers,16) - ! real(kind=r8) :: zsflxzen(16) - REAL(KIND=r8) :: ztaug(ncol,nlayers,ngptsw) - REAL(KIND=r8) :: ztaur(ncol,nlayers,ngptsw) - REAL(KIND=r8) :: zsflxzen(ncol,ngptsw) - ! Arrays from rrtmg_sw_vrtqdr routine - REAL(KIND=r8) :: zcd(ncol,nlayers+1,ngptsw) - REAL(KIND=r8) :: zcu(ncol,nlayers+1,ngptsw) - REAL(KIND=r8) :: zfd(ncol,nlayers+1,ngptsw) - REAL(KIND=r8) :: zfu(ncol,nlayers+1,ngptsw) - ! Inactive arrays - ! real(kind=r8) :: zbbcd(nlayers+1), zbbcu(nlayers+1) - ! real(kind=r8) :: zbbfd(nlayers+1), zbbfu(nlayers+1) - ! real(kind=r8) :: zbbfddir(nlayers+1), zbbcddir(nlayers+1) - ! ------------------------------------------------------------------ - ! Initializations - ib1 = istart - ib2 = iend - klev = nlayers - !djp repclc(iplon) = 1.e-12_r8 - repclc(:) = 1.e-12_r8 - ! zincflux = 0.0_r8 - do iplon=1,ncol - do jk=1,klev+1 - pbbcd(iplon,jk)=0._r8 - pbbcu(iplon,jk)=0._r8 - pbbfd(iplon,jk)=0._r8 - pbbfu(iplon,jk)=0._r8 - pbbcddir(iplon,jk)=0._r8 - pbbfddir(iplon,jk)=0._r8 - puvcd(iplon,jk)=0._r8 - puvfd(iplon,jk)=0._r8 - puvcddir(iplon,jk)=0._r8 - puvfddir(iplon,jk)=0._r8 - pnicd(iplon,jk)=0._r8 - pnifd(iplon,jk)=0._r8 - pnicddir(iplon,jk)=0._r8 - pnifddir(iplon,jk)=0._r8 - pnicu(iplon,jk)=0._r8 - pnifu(iplon,jk)=0._r8 - enddo - end do - call taumol_sw(ncol,klev, & - colh2o, colco2, colch4, colo2, colo3, colmol, & - laytrop, jp, jt, jt1, & - fac00, fac01, fac10, fac11, & - selffac, selffrac, indself, forfac, forfrac,indfor, & - zsflxzen, ztaug, ztaur) - jb = ib1-1 ! ??? ! ??? ! ??? ! ??? - do iplon=1,ncol - iw(iplon) =0 - end do - do jb = ib1, ib2 - ibm = jb-15 - igt = ngc(ibm) - ! Reinitialize g-point counter for each band if output for each band is requested. - ! do jk=1,klev+1 - ! zbbcd(jk)=0.0_r8 - ! zbbcu(jk)=0.0_r8 - ! zbbfd(jk)=0.0_r8 - ! zbbfu(jk)=0.0_r8 - ! enddo - ! Top of g-point interval loop within each band (iw(iplon) is cumulative counter) - DO IPLON=1,ncol - if (iout.gt.0.and.ibm.ge.2) iw(iplon)= ngs(ibm-1) - END do - do jg = 1,igt - do iplon=1,ncol - iw(iplon) = iw(iplon)+1 - ! Apply adjustment for correct Earth/Sun distance and zenith angle to incoming solar flux - zincflx(iplon,iw(iplon)) = adjflux(iplon,jb) * zsflxzen(iplon,iw(iplon)) * prmu0(iplon) - ! zincflux = zincflux + adjflux(jb) * zsflxzen(iw(iplon)) * prmu0 ! inactive - ! Compute layer reflectances and transmittances for direct and diffuse sources, - ! first clear then cloudy - ! zrefc(iplon,jk) direct albedo for clear - ! zrefo(iplon,jk) direct albedo for cloud - ! zrefdc(iplon,jk) diffuse albedo for clear - ! zrefdo(iplon,jk) diffuse albedo for cloud - ! ztrac(iplon,jk) direct transmittance for clear - ! ztrao(iplon,jk) direct transmittance for cloudy - ! ztradc(iplon,jk) diffuse transmittance for clear - ! ztrado(iplon,jk) diffuse transmittance for cloudy - ! - ! zref(iplon,jk) direct reflectance - ! zrefd(iplon,jk) diffuse reflectance - ! ztra(iplon,jk) direct transmittance - ! ztrad(iplon,jk) diffuse transmittance - ! - ! zdbtc(iplon,jk) clear direct beam transmittance - ! zdbto(jk) cloudy direct beam transmittance - ! zdbt(iplon,jk) layer mean direct beam transmittance - ! ztdbt(iplon,jk) total direct beam transmittance at levels - ! Clear-sky - ! TOA direct beam - ztdbtc(iplon,1)=1.0_r8 - ztdbtc_nodel(iplon,1)=1.0_r8 - ! Surface values - zdbtc(iplon,klev+1) =0.0_r8 - ztrac(iplon,klev+1) =0.0_r8 - ztradc(iplon,klev+1)=0.0_r8 - zrefc(iplon,klev+1) =palbp(iplon,ibm) - zrefdc(iplon,klev+1)=palbd(iplon,ibm) - zrupc(iplon,klev+1) =palbp(iplon,ibm) - zrupdc(iplon,klev+1)=palbd(iplon,ibm) - ! Cloudy-sky - ! Surface values - ztrao(iplon,klev+1) =0.0_r8 - ztrado(iplon,klev+1)=0.0_r8 - zrefo(iplon,klev+1) =palbp(iplon,ibm) - zrefdo(iplon,klev+1)=palbd(iplon,ibm) - ! Total sky - ! TOA direct beam - ztdbt(iplon,1)=1.0_r8 - ztdbt_nodel(iplon,1)=1.0_r8 - ! Surface values - zdbt(iplon,klev+1) =0.0_r8 - ztra(iplon,klev+1) =0.0_r8 - ztrad(iplon,klev+1)=0.0_r8 - zref(iplon,klev+1) =palbp(iplon,ibm) - zrefd(iplon,klev+1)=palbd(iplon,ibm) - zrup(iplon,klev+1) =palbp(iplon,ibm) - zrupd(iplon,klev+1)=palbd(iplon,ibm) - ! Top of layer loop - do jk=1,klev - ! Note: two-stream calculations proceed from top to bottom; - ! RRTMG_SW quantities are given bottom to top and are reversed here - ikl=klev+1-jk - ! Set logical flag to do REFTRA calculation - ! Do REFTRA for all clear layers - lrtchkclr(iplon,jk)=.true. - ! Do REFTRA only for cloudy layers in profile, since already done for clear layers - lrtchkcld(iplon,jk)=.false. - lrtchkcld(iplon,jk)=(pcldfmc(iplon,ikl,iw(iplon)) > repclc(iplon)) - ! Clear-sky optical parameters - this section inactive - ! Original - ! ztauc(iplon,jk) = ztaur(ikl,iw(iplon)) + ztaug(ikl,iw(iplon)) - ! zomcc(iplon,jk) = ztaur(ikl,iw(iplon)) / ztauc(iplon,jk) - ! zgcc(iplon,jk) = 0.0001_r8 - ! Total sky optical parameters - ! ztauo(iplon,jk) = ztaur(ikl,iw(iplon)) + ztaug(ikl,iw(iplon)) + ptaucmc(ikl,iw(iplon)) - ! zomco(iplon,jk) = ptaucmc(ikl,iw(iplon)) * pomgcmc(ikl,iw(iplon)) + ztaur(ikl,iw( - ! iplon)) - ! zgco (jk) = (ptaucmc(ikl,iw(iplon)) * pomgcmc(ikl,iw(iplon)) * pasycmc(ikl,iw(iplon)) - ! + & - ! ztaur(ikl,iw(iplon)) * 0.0001_r8) / zomco(iplon,jk) - ! zomco(iplon,jk) = zomco(iplon,jk) / ztauo(iplon,jk) - ! Clear-sky optical parameters including aerosols - ztauc(iplon,jk) = ztaur(iplon,ikl,iw(iplon)) + ztaug(iplon,ikl,iw(iplon)) + ptaua(iplon,ikl,ibm) - zomcc(iplon,jk) = ztaur(iplon,ikl,iw(iplon)) * 1.0_r8 + ptaua(iplon,ikl,ibm) * pomga(iplon,ikl,ibm) - zgcc(iplon,jk) = pasya(iplon,ikl,ibm) * pomga(iplon,ikl,ibm) * ptaua(iplon,ikl,ibm) / zomcc(iplon,jk) - zomcc(iplon,jk) = zomcc(iplon,jk) / ztauc(iplon,jk) - ! Pre-delta-scaling clear and cloudy direct beam transmittance (must use 'orig', unscaled cloud OD) - ! \/\/\/ This block of code is only needed for unscaled direct beam calculation - if (idelm .eq. 0) then - ! - zclear(iplon) = 1.0_r8 - pcldfmc(iplon,ikl,iw(iplon)) - zcloud(iplon) = pcldfmc(iplon,ikl,iw(iplon)) - ! Clear - ! zdbtmc(iplon) = exp(-ztauc(iplon,jk) / prmu0) - ! Use exponential lookup table for transmittance, or expansion of exponential for low tau - ze1(iplon) = ztauc(iplon,jk) / prmu0(iplon) - if (ze1(iplon) .le. od_lo) then - zdbtmc(iplon) = 1._r8 - ze1(iplon) + 0.5_r8 * ze1(iplon) * ze1(iplon) - else - tblind(iplon) = ze1(iplon) / (bpade + ze1(iplon)) - itind(iplon) = tblint * tblind(iplon) + 0.5_r8 - zdbtmc(iplon) = exp_tbl(itind(iplon)) - endif - zdbtc_nodel(iplon,jk) = zdbtmc(iplon) - ztdbtc_nodel(iplon,jk+1) = zdbtc_nodel(iplon,jk) * ztdbtc_nodel(iplon,jk) - ! Clear + Cloud - tauorig(iplon) = ztauc(iplon,jk) + ptaormc(iplon,ikl,iw(iplon)) - ! zdbtmo(iplon) = exp(-tauorig(iplon) / prmu0) - ! Use exponential lookup table for transmittance, or expansion of exponential for low tau - ze1(iplon) = tauorig(iplon) / prmu0(iplon) - if (ze1(iplon) .le. od_lo) then - zdbtmo(iplon) = 1._r8 - ze1(iplon) + 0.5_r8 * ze1(iplon) * ze1(iplon) - else - tblind(iplon) = ze1(iplon) / (bpade + ze1(iplon)) - itind(iplon) = tblint * tblind(iplon) + 0.5_r8 - zdbtmo(iplon) = exp_tbl(itind(iplon)) - endif - zdbt_nodel(iplon,jk) = zclear(iplon)*zdbtmc(iplon) + zcloud(iplon)*zdbtmo(iplon) - ztdbt_nodel(iplon,jk+1) = zdbt_nodel(iplon,jk) * ztdbt_nodel(iplon,jk) - endif - ! /\/\/\ Above code only needed for unscaled direct beam calculation - ! Delta scaling - clear - zf = zgcc(iplon,jk) * zgcc(iplon,jk) - zwf = zomcc(iplon,jk) * zf - ztauc(iplon,jk) = (1.0_r8 - zwf) * ztauc(iplon,jk) - zomcc(iplon,jk) = (zomcc(iplon,jk) - zwf) / (1.0_r8 - zwf) - zgcc (iplon,jk) = (zgcc(iplon,jk) - zf) / (1.0_r8 - zf) - ! Total sky optical parameters (cloud properties already delta-scaled) - ! Use this code if cloud properties are derived in rrtmg_sw_cldprop - if (icpr .ge. 1) then - ztauo(iplon,jk) = ztauc(iplon,jk) + ptaucmc(iplon,ikl,iw(iplon)) - zomco(iplon,jk) = ztauc(iplon,jk) * zomcc(iplon,jk) + ptaucmc(iplon,ikl,iw(iplon)) * pomgcmc(iplon,ikl,iw(iplon)) - zgco (iplon,jk) = (ptaucmc(iplon,ikl,iw(iplon)) * pomgcmc(iplon,ikl,iw(iplon)) * pasycmc(iplon,ikl,iw(iplon)) + & - ztauc(iplon,jk) * zomcc(iplon,jk) * zgcc(iplon,jk)) / zomco(iplon,jk) - zomco(iplon,jk) = zomco(iplon,jk) / ztauo(iplon,jk) - ! Total sky optical parameters (if cloud properties not delta scaled) - ! Use this code if cloud properties are not derived in rrtmg_sw_cldprop - elseif (icpr .eq. 0) then - ztauo(iplon,jk) = ztaur(iplon,ikl,iw(iplon)) + ztaug(iplon,ikl,iw(iplon)) + ptaua(iplon,ikl,ibm) + ptaucmc(iplon,ikl,iw(iplon)) - zomco(iplon,jk) = ptaua(iplon,ikl,ibm) * pomga(iplon,ikl,ibm) + ptaucmc(iplon,ikl,iw(iplon)) * pomgcmc(iplon,ikl,iw(iplon)) + & - ztaur(iplon,ikl,iw(iplon)) * 1.0_r8 - zgco (iplon,jk) = (ptaucmc(iplon,ikl,iw(iplon)) * pomgcmc(iplon,ikl,iw(iplon)) * pasycmc(iplon,ikl,iw(iplon)) + & - ptaua(iplon,ikl,ibm)*pomga(iplon,ikl,ibm)*pasya(iplon,ikl,ibm)) / zomco(iplon,jk) - zomco(iplon,jk) = zomco(iplon,jk) / ztauo(iplon,jk) - ! Delta scaling - clouds - ! Use only if subroutine rrtmg_sw_cldprop is not used to get cloud properties and to apply - ! delta scaling - zf = zgco(iplon,jk) * zgco(iplon,jk) - zwf = zomco(iplon,jk) * zf - ztauo(iplon,jk) = (1._r8 - zwf) * ztauo(iplon,jk) - zomco(iplon,jk) = (zomco(iplon,jk) - zwf) / (1.0_r8 - zwf) - zgco (iplon,jk) = (zgco(iplon,jk) - zf) / (1.0_r8 - zf) - endif - ! End of layer loop - enddo - END DO - DO iplon=1,ncol - ! Clear sky reflectivities - call reftra_sw (klev,ncol, & -lrtchkclr, zgcc, prmu0, ztauc, zomcc, & -zrefc, zrefdc, ztrac, ztradc) - ! Total sky reflectivities - call reftra_sw (klev, ncol, & -lrtchkcld, zgco, prmu0, ztauo, zomco, & -zrefo, zrefdo, ztrao, ztrado) - END DO - DO iplon=1,ncol - do jk=1,klev - ! Combine clear and cloudy contributions for total sky - ikl = klev+1-jk - zclear(iplon) = 1.0_r8 - pcldfmc(iplon,ikl,iw(iplon)) - zcloud(iplon) = pcldfmc(iplon,ikl,iw(iplon)) - zref(iplon,jk) = zclear(iplon)*zrefc(iplon,jk) + zcloud(iplon)*zrefo(iplon,jk) - zrefd(iplon,jk)= zclear(iplon)*zrefdc(iplon,jk) + zcloud(iplon)*zrefdo(iplon,jk) - ztra(iplon,jk) = zclear(iplon)*ztrac(iplon,jk) + zcloud(iplon)*ztrao(iplon,jk) - ztrad(iplon,jk)= zclear(iplon)*ztradc(iplon,jk) + zcloud(iplon)*ztrado(iplon,jk) - ! Direct beam transmittance - ! Clear - ! zdbtmc(iplon) = exp(-ztauc(iplon,jk) / prmu0) - ! Use exponential lookup table for transmittance, or expansion of - ! exponential for low tau - ze1(iplon) = ztauc(iplon,jk) / prmu0(iplon) - if (ze1(iplon) .le. od_lo) then - zdbtmc(iplon) = 1._r8 - ze1(iplon) + 0.5_r8 * ze1(iplon) * ze1(iplon) - else - tblind(iplon) = ze1(iplon) / (bpade + ze1(iplon)) - itind(iplon) = tblint * tblind(iplon) + 0.5_r8 - zdbtmc(iplon) = exp_tbl(itind(iplon)) - endif - zdbtc(iplon,jk) = zdbtmc(iplon) - ztdbtc(iplon,jk+1) = zdbtc(iplon,jk)*ztdbtc(iplon,jk) - ! Clear + Cloud - ! zdbtmo(iplon) = exp(-ztauo(iplon,jk) / prmu0) - ! Use exponential lookup table for transmittance, or expansion of - ! exponential for low tau - ze1(iplon) = ztauo(iplon,jk) / prmu0(iplon) - if (ze1(iplon) .le. od_lo) then - zdbtmo(iplon) = 1._r8 - ze1(iplon) + 0.5_r8 * ze1(iplon) * ze1(iplon) - else - tblind(iplon) = ze1(iplon) / (bpade + ze1(iplon)) - itind(iplon) = tblint * tblind(iplon) + 0.5_r8 - zdbtmo(iplon) = exp_tbl(itind(iplon)) - endif - zdbt(iplon,jk) = zclear(iplon)*zdbtmc(iplon) + zcloud(iplon)*zdbtmo(iplon) - ztdbt(iplon,jk+1) = zdbt(iplon,jk)*ztdbt(iplon,jk) - enddo - ! Vertical quadrature for clear-sky fluxes - END DO - ! DO iplon=1,ncol - call vrtqdr_sw(ncol,klev, iw, & -zrefc, zrefdc, ztrac, ztradc, & -zdbtc, zrdndc, zrupc, zrupdc, ztdbtc, & -zcd, zcu) - ! Vertical quadrature for cloudy fluxes - call vrtqdr_sw(ncol,klev, iw, & -zref, zrefd, ztra, ztrad, & -zdbt, zrdnd, zrup, zrupd, ztdbt, & -zfd, zfu) - ! END DO - DO iplon=1,ncol - ! Upwelling and downwelling fluxes at levels - ! Two-stream calculations go from top to bottom; - ! layer indexing is reversed to go bottom to top for output arrays - do jk=1,klev+1 - ikl=klev+2-jk - ! Accumulate spectral fluxes over bands - inactive - ! zbbfu(ikl) = zbbfu(ikl) + zincflx(iplon,iw(iplon))*zfu(iplon,jk,iw(iplon)) - ! zbbfd(ikl) = zbbfd(ikl) + zincflx(iplon,iw(iplon))*zfd(iplon,jk,iw(iplon)) - ! zbbcu(ikl) = zbbcu(ikl) + zincflx(iplon,iw(iplon))*zcu(iplon,jk,iw(iplon)) - ! zbbcd(ikl) = zbbcd(ikl) + zincflx(iplon,iw(iplon))*zcd(iplon,jk,iw(iplon)) - ! zbbfddir(ikl) = zbbfddir(ikl) + zincflx(iplon,iw(iplon))*ztdbt_nodel(iplon,jk) - ! zbbcddir(ikl) = zbbcddir(ikl) + zincflx(iplon,iw(iplon))*ztdbtc_nodel(iplon,jk) - pbbfsu(iplon,ibm,ikl) = pbbfsu(iplon,ibm,ikl) + zincflx(iplon,iw(iplon))*zfu(iplon,jk,iw(iplon)) - pbbfsd(iplon,ibm,ikl) = pbbfsd(iplon,ibm,ikl) + zincflx(iplon,iw(iplon))*zfd(iplon,jk,iw(iplon)) - ! Accumulate spectral fluxes over whole spectrum - pbbfu(iplon,ikl) = pbbfu(iplon,ikl) + zincflx(iplon,iw(iplon))*zfu(iplon,jk,iw(iplon)) - pbbfd(iplon,ikl) = pbbfd(iplon,ikl) +zincflx(iplon,iw(iplon))*zfd(iplon,jk,iw(iplon)) - pbbcu(iplon,ikl) = pbbcu(iplon,ikl) + zincflx(iplon,iw(iplon))*zcu(iplon,jk,iw(iplon)) - pbbcd(iplon,ikl) = pbbcd(iplon,ikl) + zincflx(iplon,iw(iplon))*zcd(iplon,jk,iw(iplon)) - if (idelm .eq. 0) then - pbbfddir(iplon,ikl) = pbbfddir(iplon,ikl) + zincflx(iplon,iw(iplon))*ztdbt_nodel(iplon,jk) - pbbcddir(iplon,ikl) = pbbcddir(iplon,ikl) + zincflx(iplon,iw(iplon))*ztdbtc_nodel(iplon,jk) - elseif (idelm .eq. 1) then - pbbfddir(iplon,ikl) = pbbfddir(iplon,ikl) + zincflx(iplon,iw(iplon))*ztdbt(iplon,jk) - pbbcddir(iplon,ikl) = pbbcddir(iplon,ikl) + zincflx(iplon,iw(iplon))*ztdbtc(iplon,jk) - endif - ! Accumulate direct fluxes for UV/visible bands - if (ibm >= 10 .and. ibm <= 13) then - puvcd(iplon,ikl) = puvcd(iplon,ikl) + zincflx(iplon,iw(iplon))*zcd(iplon,jk,iw(iplon)) - puvfd(iplon,ikl) = puvfd(iplon,ikl) + zincflx(iplon,iw(iplon))*zfd(iplon,jk,iw(iplon)) - if (idelm .eq. 0) then - puvfddir(iplon,ikl) = puvfddir(iplon,ikl) + zincflx(iplon,iw(iplon))*ztdbt_nodel(iplon,jk) - puvcddir(iplon,ikl) = puvcddir(iplon,ikl) + zincflx(iplon,iw(iplon))*ztdbtc_nodel(iplon,jk) - elseif (idelm .eq. 1) then - puvfddir(iplon,ikl) = puvfddir(iplon,ikl) + zincflx(iplon,iw(iplon))*ztdbt(iplon,jk) - puvcddir(iplon,ikl) = puvcddir(iplon,ikl) + zincflx(iplon,iw(iplon))*ztdbtc(iplon,jk) - endif - ! band 9 is half-NearIR and half-Visible - else if (ibm == 9) then - puvcd(iplon,ikl) = puvcd(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*zcd(iplon,jk,iw(iplon)) - puvfd(iplon,ikl) = puvfd(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*zfd(iplon,jk,iw(iplon)) - pnicd(iplon,ikl) = pnicd(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*zcd(iplon,jk,iw(iplon)) - pnifd(iplon,ikl) = pnifd(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*zfd(iplon,jk,iw(iplon)) - if (idelm .eq. 0) then - puvfddir(iplon,ikl) = puvfddir(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*ztdbt_nodel(iplon,jk) - puvcddir(iplon,ikl) = puvcddir(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*ztdbtc_nodel(iplon,jk) - pnifddir(iplon,ikl) = pnifddir(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*ztdbt_nodel(iplon,jk) - pnicddir(iplon,ikl) = pnicddir(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*ztdbtc_nodel(iplon,jk) - elseif (idelm .eq. 1) then - puvfddir(iplon,ikl) = puvfddir(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*ztdbt(iplon,jk) - puvcddir(iplon,ikl) = puvcddir(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*ztdbtc(iplon,jk) - pnifddir(iplon,ikl) = pnifddir(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*ztdbt(iplon,jk) - pnicddir(iplon,ikl) = pnicddir(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*ztdbtc(iplon,jk) - endif - pnicu(iplon,ikl) = pnicu(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*zcu(iplon,jk,iw(iplon)) - pnifu(iplon,ikl) = pnifu(iplon,ikl) + 0.5_r8*zincflx(iplon,iw(iplon))*zfu(iplon,jk,iw(iplon)) - ! Accumulate direct fluxes for near-IR bands - else if (ibm == 14 .or. ibm <= 8) then - pnicd(iplon,ikl) = pnicd(iplon,ikl) + zincflx(iplon,iw(iplon))*zcd(iplon,jk,iw(iplon)) - pnifd(iplon,ikl) = pnifd(iplon,ikl) + zincflx(iplon,iw(iplon))*zfd(iplon,jk,iw(iplon)) - if (idelm .eq. 0) then - pnifddir(iplon,ikl) = pnifddir(iplon,ikl) + zincflx(iplon,iw(iplon))*ztdbt_nodel(iplon,jk) - pnicddir(iplon,ikl) = pnicddir(iplon,ikl) + zincflx(iplon,iw(iplon))*ztdbtc_nodel(iplon,jk) - elseif (idelm .eq. 1) then - pnifddir(iplon,ikl) = pnifddir(iplon,ikl) + zincflx(iplon,iw(iplon))*ztdbt(iplon,jk) - pnicddir(iplon,ikl) = pnicddir(iplon,ikl) + zincflx(iplon,iw(iplon))*ztdbtc(iplon,jk) - endif - ! Added for net near-IR flux diagnostic - pnicu(iplon,ikl) = pnicu(iplon,ikl) + zincflx(iplon,iw(iplon))*zcu(iplon,jk,iw(iplon)) - pnifu(iplon,ikl) = pnifu(iplon,ikl) + zincflx(iplon,iw(iplon))*zfu(iplon,jk,iw(iplon)) - endif - enddo - ! End loop on jg, g-point interval - enddo - ! End loop on jb, spectral band - enddo - end do - END SUBROUTINE spcvmc_sw - END MODULE rrtmg_sw_spcvmc diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/rrtmg_sw_taumol.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/rrtmg_sw_taumol.f90 deleted file mode 100644 index ea3cf37a94..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/rrtmg_sw_taumol.f90 +++ /dev/null @@ -1,1583 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_sw_taumol.f90 -! Generated at: 2015-07-31 20:35:44 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_sw_taumol - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! ------- Modules ------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - ! use parrrsw, only : mg, jpband, nbndsw, ngptsw - USE rrsw_con, ONLY: oneminus - USE rrsw_wvn, ONLY: nspa - USE rrsw_wvn, ONLY: nspb - USE rrsw_vsn, ONLY: hvrtau - IMPLICIT NONE - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !---------------------------------------------------------------------------- - - SUBROUTINE taumol_sw(ncol, nlayers, colh2o, colco2, colch4, colo2, colo3, colmol, laytrop, jp, jt, jt1, fac00, fac01, & - fac10, fac11, selffac, selffrac, indself, forfac, forfrac, indfor, sfluxzen, taug, taur) - !---------------------------------------------------------------------------- - ! ****************************************************************************** - ! * * - ! * Optical depths developed for the * - ! * * - ! * RAPID RADIATIVE TRANSFER MODEL (RRTM) * - ! * * - ! * * - ! * ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC. * - ! * 131 HARTWELL AVENUE * - ! * LEXINGTON, MA 02421 * - ! * * - ! * * - ! * ELI J. MLAWER * - ! * JENNIFER DELAMERE * - ! * STEVEN J. TAUBMAN * - ! * SHEPARD A. CLOUGH * - ! * * - ! * * - ! * * - ! * * - ! * email: mlawer@aer.com * - ! * email: jdelamer@aer.com * - ! * * - ! * The authors wish to acknowledge the contributions of the * - ! * following people: Patrick D. Brown, Michael J. Iacono, * - ! * Ronald E. Farren, Luke Chen, Robert Bergstrom. * - ! * * - ! ****************************************************************************** - ! * TAUMOL * - ! * * - ! * This file contains the subroutines TAUGBn (where n goes from * - ! * 1 to 28). TAUGBn calculates the optical depths and Planck fractions * - ! * per g-value and layer for band n. * - ! * * - ! * Output: optical depths (unitless) * - ! * fractions needed to compute Planck functions at every layer * - ! * and g-value * - ! * * - ! * COMMON /TAUGCOM/ TAUG(MXLAY,MG) * - ! * COMMON /PLANKG/ FRACS(MXLAY,MG) * - ! * * - ! * Input * - ! * * - ! * PARAMETER (MG=16, MXLAY=203, NBANDS=14) * - ! * * - ! * COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS) * - ! * COMMON /PRECISE/ ONEMINUS * - ! * COMMON /PROFILE/ NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY), * - ! * & PZ(0:MXLAY),TZ(0:MXLAY),TBOUND * - ! * COMMON /PROFDATA/ LAYTROP,LAYSWTCH,LAYLOW, * - ! * & COLH2O(MXLAY),COLCO2(MXLAY), * - ! * & COLO3(MXLAY),COLN2O(MXLAY),COLCH4(MXLAY), * - ! * & COLO2(MXLAY),CO2MULT(MXLAY) * - ! * COMMON /INTFAC/ FAC00(MXLAY),FAC01(MXLAY), * - ! * & FAC10(MXLAY),FAC11(MXLAY) * - ! * COMMON /INTIND/ JP(MXLAY),JT(MXLAY),JT1(MXLAY) * - ! * COMMON /SELF/ SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(MXLAY) * - ! * * - ! * Description: * - ! * NG(IBAND) - number of g-values in band IBAND * - ! * NSPA(IBAND) - for the lower atmosphere, the number of reference * - ! * atmospheres that are stored for band IBAND per * - ! * pressure level and temperature. Each of these * - ! * atmospheres has different relative amounts of the * - ! * key species for the band (i.e. different binary * - ! * species parameters). * - ! * NSPB(IBAND) - same for upper atmosphere * - ! * ONEMINUS - since problems are caused in some cases by interpolation * - ! * parameters equal to or greater than 1, for these cases * - ! * these parameters are set to this value, slightly < 1. * - ! * PAVEL - layer pressures (mb) * - ! * TAVEL - layer temperatures (degrees K) * - ! * PZ - level pressures (mb) * - ! * TZ - level temperatures (degrees K) * - ! * LAYTROP - layer at which switch is made from one combination of * - ! * key species to another * - ! * COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water * - ! * vapor,carbon dioxide, ozone, nitrous ozide, methane, * - ! * respectively (molecules/cm**2) * - ! * CO2MULT - for bands in which carbon dioxide is implemented as a * - ! * trace species, this is the factor used to multiply the * - ! * band's average CO2 absorption coefficient to get the added * - ! * contribution to the optical depth relative to 355 ppm. * - ! * FACij(LAY) - for layer LAY, these are factors that are needed to * - ! * compute the interpolation factors that multiply the * - ! * appropriate reference k-values. A value of 0 (1) for * - ! * i,j indicates that the corresponding factor multiplies * - ! * reference k-value for the lower (higher) of the two * - ! * appropriate temperatures, and altitudes, respectively. * - ! * JP - the index of the lower (in altitude) of the two appropriate * - ! * reference pressure levels needed for interpolation * - ! * JT, JT1 - the indices of the lower of the two appropriate reference * - ! * temperatures needed for interpolation (for pressure * - ! * levels JP and JP+1, respectively) * - ! * SELFFAC - scale factor needed to water vapor self-continuum, equals * - ! * (water vapor density)/(atmospheric density at 296K and * - ! * 1013 mb) * - ! * SELFFRAC - factor needed for temperature interpolation of reference * - ! * water vapor self-continuum data * - ! * INDSELF - index of the lower of the two appropriate reference * - ! * temperatures needed for the self-continuum interpolation * - ! * * - ! * Data input * - ! * COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG) * - ! * (note: n is the band number) * - ! * * - ! * Description: * - ! * KA - k-values for low reference atmospheres (no water vapor * - ! * self-continuum) (units: cm**2/molecule) * - ! * KB - k-values for high reference atmospheres (all sources) * - ! * (units: cm**2/molecule) * - ! * SELFREF - k-values for water vapor self-continuum for reference * - ! * atmospheres (used below LAYTROP) * - ! * (units: cm**2/molecule) * - ! * * - ! * DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG) * - ! * EQUIVALENCE (KA,ABSA),(KB,ABSB) * - ! * * - ! ***************************************************************************** - ! - ! Modifications - ! - ! Revised: Adapted to F90 coding, J.-J.Morcrette, ECMWF, Feb 2003 - ! Revised: Modified for g-point reduction, MJIacono, AER, Dec 2003 - ! Revised: Reformatted for consistency with rrtmg_lw, MJIacono, AER, Jul 2006 - ! - ! ------- Declarations ------- - ! ----- Input ----- - INTEGER, intent(in) :: nlayers ! total number of layers - INTEGER, intent(in) :: ncol ! total number of layers - INTEGER, intent(in) :: laytrop(ncol) ! tropopause layer index - INTEGER, intent(in) :: jp(ncol,nlayers) ! - !INTEGER, intent(in) :: nlayers ! total number of layers - ! Dimensions: (nlayers) - INTEGER, intent(in) :: jt(ncol,nlayers) ! - ! Dimensions: (nlayers) - INTEGER, intent(in) :: jt1(ncol,nlayers) ! - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: colh2o(ncol,nlayers) ! column amount (h2o) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: colco2(ncol,nlayers) ! column amount (co2) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: colo3(ncol,nlayers) ! column amount (o3) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: colch4(ncol,nlayers) ! column amount (ch4) - ! Dimensions: (nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: colo2(ncol,nlayers) ! column amount (o2) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: colmol(ncol,nlayers) ! - ! Dimensions: (nlayers) - INTEGER, intent(in) :: indself(ncol,nlayers) - ! Dimensions: (nlayers) - INTEGER, intent(in) :: indfor(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: selffac(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: selffrac(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: forfac(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: forfrac(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: fac01(ncol,nlayers) - REAL(KIND=r8), intent(in) :: fac10(ncol,nlayers) - REAL(KIND=r8), intent(in) :: fac11(ncol,nlayers) - REAL(KIND=r8), intent(in) :: fac00(ncol,nlayers) ! - ! Dimensions: (nlayers) - ! ----- Output ----- - REAL(KIND=r8), intent(out) :: sfluxzen(:,:) ! solar source function - ! Dimensions: (ngptsw) - REAL(KIND=r8), intent(out) :: taug(:,:,:) ! gaseous optical depth - ! Dimensions: (nlayers,ngptsw) - REAL(KIND=r8), intent(out) :: taur(:,:,:) ! Rayleigh - INTEGER :: icol - ! Dimensions: (nlayers,ngptsw) - ! real(kind=r8), intent(out) :: ssa(:,:) ! single scattering albedo (inactive) - ! Dimensions: (nlayers,ngptsw) - do icol=1,ncol - hvrtau = '$Revision: 1.2 $' - !print*,"ncol :::",ncol - ! Calculate gaseous optical depth and planck fractions for each spectral band. - call taumol16() - !print *,'end of taumol 16' - call taumol17 - !print *,'end of taumol 17' - call taumol18 - !print *,'end of taumol 18' - call taumol19 - !print *,'end of taumol 19' - call taumol20 - !print *,'end of taumol 20' - call taumol21 - !print *,'end of taumol 21' - call taumol22 - !print *,'end of taumol 22' - call taumol23 - !print *,'end of taumol 23' - call taumol24 - !print *,'end of taumol 24' - call taumol25 - !print *,'end of taumol 25' - call taumol26 - !print *,'end of taumol 26' - call taumol27 - !print *,'end of taumol 27' - call taumol28 - !print *,'end of taumol 28' - call taumol29 - !print *,'end of taumol 29' - end do - !------------- - CONTAINS - !------------- - !---------------------------------------------------------------------------- - - SUBROUTINE taumol16() - !---------------------------------------------------------------------------- - ! - ! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng16 - USE rrsw_kg16, ONLY: strrat1 - USE rrsw_kg16, ONLY: rayl - USE rrsw_kg16, ONLY: forref - USE rrsw_kg16, ONLY: absa - USE rrsw_kg16, ONLY: selfref - USE rrsw_kg16, ONLY: layreffr - USE rrsw_kg16, ONLY: absb - USE rrsw_kg16, ONLY: sfluxref - ! ------- Declarations ------- - !INTEGER, intent(in) ::ncol ! total number of layers - ! Local - INTEGER :: lay - INTEGER :: js - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - INTEGER :: laysolfr - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - !print*,"taumol 16 :: before lay loop" - ! do icol=1,ncol - !print*,"icol ::",icol,ncol - !print*,"laytrop",laytrop - do lay = 1, laytrop(icol) - !print*,'inside lay loop' - speccomb = colh2o(icol,lay) + strrat1*colch4(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(16) + js - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(16) + js - inds = indself(icol,lay) - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng16 - taug(icol,lay,ig) = speccomb * & - (fac000 * absa(ind0 ,ig) + & - fac100 * absa(ind0 +1,ig) + & - fac010 * absa(ind0 +9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac001 * absa(ind1 ,ig) + & - fac101 * absa(ind1 +1,ig) + & - fac011 * absa(ind1 +9,ig) + & - fac111 * absa(ind1+10,ig)) + & - colh2o(icol,lay) * & - (selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) - ! ssa(lay,ig) = tauray/taug(lay,ig) - taur(icol,lay,ig) = tauray - enddo - enddo - laysolfr = nlayers - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - if (jp(icol,(lay-1)) .lt. layreffr .and. jp(icol,lay) .ge. layreffr) & - laysolfr = lay - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(16) + 1 - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(16) + 1 - tauray = colmol(icol,lay) * rayl - do ig = 1, ng16 - taug(icol,lay,ig) = colch4(icol,lay) * & - (fac00(icol,lay) * absb(ind0 ,ig) + & - fac10(icol,lay) * absb(ind0+1,ig) + & - fac01(icol,lay) * absb(ind1 ,ig) + & - fac11(icol,lay) * absb(ind1+1,ig)) - ! ssa(lay,ig) = tauray/taug(lay,ig) - if (lay .eq. laysolfr) sfluxzen(icol,ig) = sfluxref(ig) - taur(icol,lay,ig) = tauray - enddo - enddo - !end do - END SUBROUTINE taumol16 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol17() - !---------------------------------------------------------------------------- - ! - ! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng17 - USE parrrsw, ONLY: ngs16 - USE rrsw_kg17, ONLY: strrat - USE rrsw_kg17, ONLY: rayl - USE rrsw_kg17, ONLY: absa - USE rrsw_kg17, ONLY: selfref - USE rrsw_kg17, ONLY: forref - USE rrsw_kg17, ONLY: layreffr - USE rrsw_kg17, ONLY: absb - USE rrsw_kg17, ONLY: sfluxref - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: js - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - INTEGER :: laysolfr - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - speccomb = colh2o(icol,lay) + strrat*colco2(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(17) + js - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(17) + js - inds = indself(icol,lay) - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng17 - taug(icol,lay,ngs16+ig) = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) + & - colh2o(icol,lay) * & - (selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) - ! ssa(lay,ngs16+ig) = tauray/taug(lay,ngs16+ig) - taur(icol,lay,ngs16+ig) = tauray - enddo - enddo - laysolfr = nlayers - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - if (jp(icol,lay-1) .lt. layreffr .and. jp(icol,lay) .ge. layreffr) & - laysolfr = lay - speccomb = colh2o(icol,lay) + strrat*colco2(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 4._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(17) + js - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(17) + js - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng17 - taug(icol,lay,ngs16+ig) = speccomb * & - (fac000 * absb(ind0,ig) + & - fac100 * absb(ind0+1,ig) + & - fac010 * absb(ind0+5,ig) + & - fac110 * absb(ind0+6,ig) + & - fac001 * absb(ind1,ig) + & - fac101 * absb(ind1+1,ig) + & - fac011 * absb(ind1+5,ig) + & - fac111 * absb(ind1+6,ig)) + & - colh2o(icol,lay) * & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig))) - ! ssa(lay,ngs16+ig) = tauray/taug(lay,ngs16+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs16+ig) = sfluxref(ig,js) & - + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) - taur(icol,lay,ngs16+ig) = tauray - enddo - enddo - END SUBROUTINE taumol17 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol18() - !---------------------------------------------------------------------------- - ! - ! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng18 - USE parrrsw, ONLY: ngs17 - USE rrsw_kg18, ONLY: layreffr - USE rrsw_kg18, ONLY: strrat - USE rrsw_kg18, ONLY: rayl - USE rrsw_kg18, ONLY: forref - USE rrsw_kg18, ONLY: absa - USE rrsw_kg18, ONLY: selfref - USE rrsw_kg18, ONLY: sfluxref - USE rrsw_kg18, ONLY: absb - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: js - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & - laysolfr = min(lay+1,laytrop(icol)) - speccomb = colh2o(icol,lay) + strrat*colch4(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(18) + js - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(18) + js - inds = indself(icol,lay) - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng18 - taug(icol,lay,ngs17+ig) = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) + & - colh2o(icol,lay) * & - (selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) - ! ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs17+ig) = sfluxref(ig,js) & - + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) - taur(icol,lay,ngs17+ig) = tauray - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(18) + 1 - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(18) + 1 - tauray = colmol(icol,lay) * rayl - do ig = 1, ng18 - taug(icol,lay,ngs17+ig) = colch4(icol,lay) * & - (fac00(icol,lay) * absb(ind0,ig) + & - fac10(icol,lay) * absb(ind0+1,ig) + & - fac01(icol,lay) * absb(ind1,ig) + & - fac11(icol,lay) * absb(ind1+1,ig)) - ! ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig) - taur(icol,lay,ngs17+ig) = tauray - enddo - enddo - END SUBROUTINE taumol18 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol19() - !---------------------------------------------------------------------------- - ! - ! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng19 - USE parrrsw, ONLY: ngs18 - USE rrsw_kg19, ONLY: layreffr - USE rrsw_kg19, ONLY: strrat - USE rrsw_kg19, ONLY: rayl - USE rrsw_kg19, ONLY: selfref - USE rrsw_kg19, ONLY: absa - USE rrsw_kg19, ONLY: forref - USE rrsw_kg19, ONLY: sfluxref - USE rrsw_kg19, ONLY: absb - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: js - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & - laysolfr = min(lay+1,laytrop(icol)) - speccomb = colh2o(icol,lay) + strrat*colco2(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(19) + js - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(19) + js - inds = indself(icol,lay) - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1 , ng19 - taug(icol,lay,ngs18+ig) = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) + & - colh2o(icol,lay) * & - (selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) - ! ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs18+ig) = sfluxref(ig,js) & - + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) - taur(icol,lay,ngs18+ig) = tauray - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(19) + 1 - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(19) + 1 - tauray = colmol(icol,lay) * rayl - do ig = 1 , ng19 - taug(icol,lay,ngs18+ig) = colco2(icol,lay) * & - (fac00(icol,lay) * absb(ind0,ig) + & - fac10(icol,lay) * absb(ind0+1,ig) + & - fac01(icol,lay) * absb(ind1,ig) + & - fac11(icol,lay) * absb(ind1+1,ig)) - ! ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig) - taur(icol,lay,ngs18+ig) = tauray - enddo - enddo - END SUBROUTINE taumol19 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol20() - !---------------------------------------------------------------------------- - ! - ! band 20: 5150-6150 cm-1 (low - h2o; high - h2o) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng20 - USE parrrsw, ONLY: ngs19 - USE rrsw_kg20, ONLY: layreffr - USE rrsw_kg20, ONLY: rayl - USE rrsw_kg20, ONLY: absch4 - USE rrsw_kg20, ONLY: forref - USE rrsw_kg20, ONLY: absa - USE rrsw_kg20, ONLY: selfref - USE rrsw_kg20, ONLY: sfluxref - USE rrsw_kg20, ONLY: absb - IMPLICIT NONE - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & - laysolfr = min(lay+1,laytrop(icol)) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(20) + 1 - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(20) + 1 - inds = indself(icol,lay) - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng20 - taug(icol,lay,ngs19+ig) = colh2o(icol,lay) * & - ((fac00(icol,lay) * absa(ind0,ig) + & - fac10(icol,lay) * absa(ind0+1,ig) + & - fac01(icol,lay) * absa(ind1,ig) + & - fac11(icol,lay) * absa(ind1+1,ig)) + & - selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) & - + colch4(icol,lay) * absch4(ig) - ! ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig) - taur(icol,lay,ngs19+ig) = tauray - if (lay .eq. laysolfr) sfluxzen(icol,ngs19+ig) = sfluxref(ig) - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(20) + 1 - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(20) + 1 - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng20 - taug(icol,lay,ngs19+ig) = colh2o(icol,lay) * & - (fac00(icol,lay) * absb(ind0,ig) + & - fac10(icol,lay) * absb(ind0+1,ig) + & - fac01(icol,lay) * absb(ind1,ig) + & - fac11(icol,lay) * absb(ind1+1,ig) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) + & - colch4(icol,lay) * absch4(ig) - ! ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig) - taur(icol,lay,ngs19+ig) = tauray - enddo - enddo - END SUBROUTINE taumol20 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol21() - !---------------------------------------------------------------------------- - ! - ! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng21 - USE parrrsw, ONLY: ngs20 - USE rrsw_kg21, ONLY: layreffr - USE rrsw_kg21, ONLY: strrat - USE rrsw_kg21, ONLY: rayl - USE rrsw_kg21, ONLY: forref - USE rrsw_kg21, ONLY: absa - USE rrsw_kg21, ONLY: selfref - USE rrsw_kg21, ONLY: sfluxref - USE rrsw_kg21, ONLY: absb - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: js - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & - laysolfr = min(lay+1,laytrop(icol)) - speccomb = colh2o(icol,lay) + strrat*colco2(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(21) + js - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(21) + js - inds = indself(icol,lay) - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng21 - taug(icol,lay,ngs20+ig) = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) + & - colh2o(icol,lay) * & - (selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) - ! ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs20+ig) = sfluxref(ig,js) & - + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) - taur(icol,lay,ngs20+ig) = tauray - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - speccomb = colh2o(icol,lay) + strrat*colco2(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 4._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(21) + js - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(21) + js - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng21 - taug(icol,lay,ngs20+ig) = speccomb * & - (fac000 * absb(ind0,ig) + & - fac100 * absb(ind0+1,ig) + & - fac010 * absb(ind0+5,ig) + & - fac110 * absb(ind0+6,ig) + & - fac001 * absb(ind1,ig) + & - fac101 * absb(ind1+1,ig) + & - fac011 * absb(ind1+5,ig) + & - fac111 * absb(ind1+6,ig)) + & - colh2o(icol,lay) * & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig))) - ! ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig) - taur(icol,lay,ngs20+ig) = tauray - enddo - enddo - END SUBROUTINE taumol21 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol22() - !---------------------------------------------------------------------------- - ! - ! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng22 - USE parrrsw, ONLY: ngs21 - USE rrsw_kg22, ONLY: layreffr - USE rrsw_kg22, ONLY: strrat - USE rrsw_kg22, ONLY: rayl - USE rrsw_kg22, ONLY: forref - USE rrsw_kg22, ONLY: absa - USE rrsw_kg22, ONLY: selfref - USE rrsw_kg22, ONLY: sfluxref - USE rrsw_kg22, ONLY: absb - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: js - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - REAL(KIND=r8) :: o2adj - REAL(KIND=r8) :: o2cont - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: tauray - ! The following factor is the ratio of total O2 band intensity (lines - ! and Mate continuum) to O2 band intensity (line only). It is needed - ! to adjust the optical depths since the k's include only lines. - o2adj = 1.6_r8 - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & - laysolfr = min(lay+1,laytrop(icol)) - o2cont = 4.35e-4_r8*colo2(icol,lay)/(350.0_r8*2.0_r8) - speccomb = colh2o(icol,lay) + o2adj*strrat*colo2(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - ! odadj = specparm + o2adj * (1._r8 - specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(22) + js - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(22) + js - inds = indself(icol,lay) - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng22 - taug(icol,lay,ngs21+ig) = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) + & - colh2o(icol,lay) * & - (selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) & - + o2cont - ! ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs21+ig) = sfluxref(ig,js) & - + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) - taur(icol,lay,ngs21+ig) = tauray - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - o2cont = 4.35e-4_r8*colo2(icol,lay)/(350.0_r8*2.0_r8) - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(22) + 1 - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(22) + 1 - tauray = colmol(icol,lay) * rayl - do ig = 1, ng22 - taug(icol,lay,ngs21+ig) = colo2(icol,lay) * o2adj * & - (fac00(icol,lay) * absb(ind0,ig) + & - fac10(icol,lay) * absb(ind0+1,ig) + & - fac01(icol,lay) * absb(ind1,ig) + & - fac11(icol,lay) * absb(ind1+1,ig)) + & - o2cont - ! ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig) - taur(icol,lay,ngs21+ig) = tauray - enddo - enddo - END SUBROUTINE taumol22 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol23() - !---------------------------------------------------------------------------- - ! - ! band 23: 8050-12850 cm-1 (low - h2o; high - nothing) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng23 - USE parrrsw, ONLY: ngs22 - USE rrsw_kg23, ONLY: layreffr - USE rrsw_kg23, ONLY: rayl - USE rrsw_kg23, ONLY: absa - USE rrsw_kg23, ONLY: givfac - USE rrsw_kg23, ONLY: forref - USE rrsw_kg23, ONLY: selfref - USE rrsw_kg23, ONLY: sfluxref - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & - laysolfr = min(lay+1,laytrop(icol)) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(23) + 1 - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(23) + 1 - inds = indself(icol,lay) - indf = indfor(icol,lay) - do ig = 1, ng23 - tauray = colmol(icol,lay) * rayl(ig) - taug(icol,lay,ngs22+ig) = colh2o(icol,lay) * & - (givfac * (fac00(icol,lay) * absa(ind0,ig) + & - fac10(icol,lay) * absa(ind0+1,ig) + & - fac01(icol,lay) * absa(ind1,ig) + & - fac11(icol,lay) * absa(ind1+1,ig)) + & - selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) - ! ssa(lay,ngs22+ig) = tauray/taug(lay,ngs22+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs22+ig) = sfluxref(ig) - taur(icol,lay,ngs22+ig) = tauray - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - do ig = 1, ng23 - ! taug(lay,ngs22+ig) = colmol(icol,lay) * rayl(ig) - ! ssa(lay,ngs22+ig) = 1.0_r8 - taug(icol,lay,ngs22+ig) = 0._r8 - taur(icol,lay,ngs22+ig) = colmol(icol,lay) * rayl(ig) - enddo - enddo - END SUBROUTINE taumol23 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol24() - !---------------------------------------------------------------------------- - ! - ! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng24 - USE parrrsw, ONLY: ngs23 - USE rrsw_kg24, ONLY: layreffr - USE rrsw_kg24, ONLY: strrat - USE rrsw_kg24, ONLY: rayla - USE rrsw_kg24, ONLY: absa - USE rrsw_kg24, ONLY: forref - USE rrsw_kg24, ONLY: selfref - USE rrsw_kg24, ONLY: abso3a - USE rrsw_kg24, ONLY: sfluxref - USE rrsw_kg24, ONLY: raylb - USE rrsw_kg24, ONLY: absb - USE rrsw_kg24, ONLY: abso3b - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: js - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & - laysolfr = min(lay+1,laytrop(icol)) - speccomb = colh2o(icol,lay) + strrat*colo2(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(24) + js - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(24) + js - inds = indself(icol,lay) - indf = indfor(icol,lay) - do ig = 1, ng24 - tauray = colmol(icol,lay) * (rayla(ig,js) + & - fs * (rayla(ig,js+1) - rayla(ig,js))) - taug(icol,lay,ngs23+ig) = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) + & - colo3(icol,lay) * abso3a(ig) + & - colh2o(icol,lay) * & - (selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) - ! ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs23+ig) = sfluxref(ig,js) & - + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) - taur(icol,lay,ngs23+ig) = tauray - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(24) + 1 - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(24) + 1 - do ig = 1, ng24 - tauray = colmol(icol,lay) * raylb(ig) - taug(icol,lay,ngs23+ig) = colo2(icol,lay) * & - (fac00(icol,lay) * absb(ind0,ig) + & - fac10(icol,lay) * absb(ind0+1,ig) + & - fac01(icol,lay) * absb(ind1,ig) + & - fac11(icol,lay) * absb(ind1+1,ig)) + & - colo3(icol,lay) * abso3b(ig) - ! ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig) - taur(icol,lay,ngs23+ig) = tauray - enddo - enddo - END SUBROUTINE taumol24 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol25() - !---------------------------------------------------------------------------- - ! - ! band 25: 16000-22650 cm-1 (low - h2o; high - nothing) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng25 - USE parrrsw, ONLY: ngs24 - USE rrsw_kg25, ONLY: layreffr - USE rrsw_kg25, ONLY: rayl - USE rrsw_kg25, ONLY: abso3a - USE rrsw_kg25, ONLY: absa - USE rrsw_kg25, ONLY: sfluxref - USE rrsw_kg25, ONLY: abso3b - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: ig - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & - laysolfr = min(lay+1,laytrop(icol)) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(25) + 1 - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(25) + 1 - do ig = 1, ng25 - tauray = colmol(icol,lay) * rayl(ig) - taug(icol,lay,ngs24+ig) = colh2o(icol,lay) * & - (fac00(icol,lay) * absa(ind0,ig) + & - fac10(icol,lay) * absa(ind0+1,ig) + & - fac01(icol,lay) * absa(ind1,ig) + & - fac11(icol,lay) * absa(ind1+1,ig)) + & - colo3(icol,lay) * abso3a(ig) - ! ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs24+ig) = sfluxref(ig) - taur(icol,lay,ngs24+ig) = tauray - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - do ig = 1, ng25 - tauray = colmol(icol,lay) * rayl(ig) - taug(icol,lay,ngs24+ig) = colo3(icol,lay) * abso3b(ig) - ! ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig) - taur(icol,lay,ngs24+ig) = tauray - enddo - enddo - END SUBROUTINE taumol25 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol26() - !---------------------------------------------------------------------------- - ! - ! band 26: 22650-29000 cm-1 (low - nothing; high - nothing) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng26 - USE parrrsw, ONLY: ngs25 - USE rrsw_kg26, ONLY: sfluxref - USE rrsw_kg26, ONLY: rayl - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: ig - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - do ig = 1, ng26 - ! taug(lay,ngs25+ig) = colmol(icol,lay) * rayl(ig) - ! ssa(lay,ngs25+ig) = 1.0_r8 - if (lay .eq. laysolfr) sfluxzen(icol,ngs25+ig) = sfluxref(ig) - taug(icol,lay,ngs25+ig) = 0._r8 - taur(icol,lay,ngs25+ig) = colmol(icol,lay) * rayl(ig) - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - do ig = 1, ng26 - ! taug(lay,ngs25+ig) = colmol(icol,lay) * rayl(ig) - ! ssa(lay,ngs25+ig) = 1.0_r8 - taug(icol,lay,ngs25+ig) = 0._r8 - taur(icol,lay,ngs25+ig) = colmol(icol,lay) * rayl(ig) - enddo - enddo - END SUBROUTINE taumol26 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol27() - !---------------------------------------------------------------------------- - ! - ! band 27: 29000-38000 cm-1 (low - o3; high - o3) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng27 - USE parrrsw, ONLY: ngs26 - USE rrsw_kg27, ONLY: rayl - USE rrsw_kg27, ONLY: absa - USE rrsw_kg27, ONLY: layreffr - USE rrsw_kg27, ONLY: absb - USE rrsw_kg27, ONLY: scalekur - USE rrsw_kg27, ONLY: sfluxref - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: ig - INTEGER :: laysolfr - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(27) + 1 - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(27) + 1 - do ig = 1, ng27 - tauray = colmol(icol,lay) * rayl(ig) - taug(icol,lay,ngs26+ig) = colo3(icol,lay) * & - (fac00(icol,lay) * absa(ind0,ig) + & - fac10(icol,lay) * absa(ind0+1,ig) + & - fac01(icol,lay) * absa(ind1,ig) + & - fac11(icol,lay) * absa(ind1+1,ig)) - ! ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig) - taur(icol,lay,ngs26+ig) = tauray - enddo - enddo - laysolfr = nlayers - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - if (jp(icol,lay-1) .lt. layreffr .and. jp(icol,lay) .ge. layreffr) & - laysolfr = lay - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(27) + 1 - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(27) + 1 - do ig = 1, ng27 - tauray = colmol(icol,lay) * rayl(ig) - taug(icol,lay,ngs26+ig) = colo3(icol,lay) * & - (fac00(icol,lay) * absb(ind0,ig) + & - fac10(icol,lay) * absb(ind0+1,ig) + & - fac01(icol,lay) * absb(ind1,ig) + & - fac11(icol,lay) * absb(ind1+1,ig)) - ! ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig) - if (lay.eq.laysolfr) sfluxzen(icol,ngs26+ig) = scalekur * sfluxref(ig) - taur(icol,lay,ngs26+ig) = tauray - enddo - enddo - END SUBROUTINE taumol27 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol28() - !---------------------------------------------------------------------------- - ! - ! band 28: 38000-50000 cm-1 (low - o3,o2; high - o3,o2) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng28 - USE parrrsw, ONLY: ngs27 - USE rrsw_kg28, ONLY: strrat - USE rrsw_kg28, ONLY: rayl - USE rrsw_kg28, ONLY: absa - USE rrsw_kg28, ONLY: layreffr - USE rrsw_kg28, ONLY: absb - USE rrsw_kg28, ONLY: sfluxref - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: js - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: ig - INTEGER :: laysolfr - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - speccomb = colo3(icol,lay) + strrat*colo2(icol,lay) - specparm = colo3(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(28) + js - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(28) + js - tauray = colmol(icol,lay) * rayl - do ig = 1, ng28 - taug(icol,lay,ngs27+ig) = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - ! ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig) - taur(icol,lay,ngs27+ig) = tauray - enddo - enddo - laysolfr = nlayers - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - if (jp(icol,lay-1) .lt. layreffr .and. jp(icol,lay) .ge. layreffr) & - laysolfr = lay - speccomb = colo3(icol,lay) + strrat*colo2(icol,lay) - specparm = colo3(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 4._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(28) + js - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(28) + js - tauray = colmol(icol,lay) * rayl - do ig = 1, ng28 - taug(icol,lay,ngs27+ig) = speccomb * & - (fac000 * absb(ind0,ig) + & - fac100 * absb(ind0+1,ig) + & - fac010 * absb(ind0+5,ig) + & - fac110 * absb(ind0+6,ig) + & - fac001 * absb(ind1,ig) + & - fac101 * absb(ind1+1,ig) + & - fac011 * absb(ind1+5,ig) + & - fac111 * absb(ind1+6,ig)) - ! ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs27+ig) = sfluxref(ig,js) & - + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) - taur(icol,lay,ngs27+ig) = tauray - enddo - enddo - END SUBROUTINE taumol28 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol29() - !---------------------------------------------------------------------------- - ! - ! band 29: 820-2600 cm-1 (low - h2o; high - co2) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng29 - USE parrrsw, ONLY: ngs28 - USE rrsw_kg29, ONLY: rayl - USE rrsw_kg29, ONLY: forref - USE rrsw_kg29, ONLY: absa - USE rrsw_kg29, ONLY: absco2 - USE rrsw_kg29, ONLY: selfref - USE rrsw_kg29, ONLY: layreffr - USE rrsw_kg29, ONLY: absh2o - USE rrsw_kg29, ONLY: absb - USE rrsw_kg29, ONLY: sfluxref - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - INTEGER :: laysolfr - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(29) + 1 - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(29) + 1 - inds = indself(icol,lay) - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng29 - taug(icol,lay,ngs28+ig) = colh2o(icol,lay) * & - ((fac00(icol,lay) * absa(ind0,ig) + & - fac10(icol,lay) * absa(ind0+1,ig) + & - fac01(icol,lay) * absa(ind1,ig) + & - fac11(icol,lay) * absa(ind1+1,ig)) + & - selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) & - + colco2(icol,lay) * absco2(ig) - ! ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig) - taur(icol,lay,ngs28+ig) = tauray - enddo - enddo - laysolfr = nlayers - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - if (jp(icol,lay-1) .lt. layreffr .and. jp(icol,lay) .ge. layreffr) & - laysolfr = lay - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(29) + 1 - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(29) + 1 - tauray = colmol(icol,lay) * rayl - do ig = 1, ng29 - taug(icol,lay,ngs28+ig) = colco2(icol,lay) * & - (fac00(icol,lay) * absb(ind0,ig) + & - fac10(icol,lay) * absb(ind0+1,ig) + & - fac01(icol,lay) * absb(ind1,ig) + & - fac11(icol,lay) * absb(ind1+1,ig)) & - + colh2o(icol,lay) * absh2o(ig) - ! ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs28+ig) = sfluxref(ig) - taur(icol,lay,ngs28+ig) = tauray - enddo - enddo - END SUBROUTINE taumol29 - END SUBROUTINE taumol_sw - END MODULE rrtmg_sw_taumol diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/rrtmg_sw_vrtqdr.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/rrtmg_sw_vrtqdr.f90 deleted file mode 100644 index 45aabcd3dd..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/rrtmg_sw_vrtqdr.f90 +++ /dev/null @@ -1,138 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_sw_vrtqdr.f90 -! Generated at: 2015-07-31 20:35:45 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_sw_vrtqdr - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! ------- Modules ------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only: jpim, jprb - ! use parrrsw, only: ngptsw - IMPLICIT NONE - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - ! -------------------------------------------------------------------------- - - SUBROUTINE vrtqdr_sw(ncol, klev, kw, pref, prefd, ptra, ptrad, pdbt, prdnd, prup, prupd, ptdbt, pfd, pfu) - ! -------------------------------------------------------------------------- - ! Purpose: This routine performs the vertical quadrature integration - ! - ! Interface: *vrtqdr_sw* is called from *spcvrt_sw* and *spcvmc_sw* - ! - ! Modifications. - ! - ! Original: H. Barker - ! Revision: Integrated with rrtmg_sw, J.-J. Morcrette, ECMWF, Oct 2002 - ! Revision: Reformatted for consistency with rrtmg_lw: MJIacono, AER, Jul 2006 - ! - !----------------------------------------------------------------------- - ! ------- Declarations ------- - ! Input - INTEGER, intent (in) :: ncol - INTEGER, intent (in) :: klev ! number of model layers - INTEGER, intent (in) :: kw(ncol) ! g-point index - REAL(KIND=r8), intent(in) :: pref(:,:) ! direct beam reflectivity - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(in) :: prefd(:,:) ! diffuse beam reflectivity - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(in) :: ptra(:,:) ! direct beam transmissivity - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(in) :: ptrad(:,:) ! diffuse beam transmissivity - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(in) :: pdbt(:,:) - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(in) :: ptdbt(:,:) - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(inout) :: prdnd(:,:) - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(inout) :: prup(:,:) - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(inout) :: prupd(:,:) - ! Dimensions: (nlayers+1) - ! Output - REAL(KIND=r8), intent(out) :: pfd(:,:,:) ! downwelling flux (W/m2) - ! Dimensions: (nlayers+1,ngptsw) - ! unadjusted for earth/sun distance or zenith angle - REAL(KIND=r8), intent(out) :: pfu(:,:,:) ! upwelling flux (W/m2) - ! Dimensions: (nlayers+1,ngptsw) - ! unadjusted for earth/sun distance or zenith angle - ! Local - INTEGER :: jk - INTEGER :: ikp - INTEGER :: icol - INTEGER :: ikx - REAL(KIND=r8) :: zreflect - REAL(KIND=r8) :: ztdn(klev+1) - ! Definitions - ! - ! pref(icol,jk) direct reflectance - ! prefd(icol,jk) diffuse reflectance - ! ptra(icol,jk) direct transmittance - ! ptrad(icol,jk) diffuse transmittance - ! - ! pdbt(icol,jk) layer mean direct beam transmittance - ! ptdbt(icol,jk) total direct beam transmittance at levels - ! - !----------------------------------------------------------------------------- - ! Link lowest layer with surface - do icol=1,ncol - zreflect = 1._r8 / (1._r8 - prefd(icol,klev+1) * prefd(icol,klev)) - prup(icol,klev) = pref(icol,klev) + (ptrad(icol,klev) * & - ((ptra(icol,klev) - pdbt(icol,klev)) * prefd(icol,klev+1) + & - pdbt(icol,klev) * pref(icol,klev+1))) * zreflect - prupd(icol,klev) = prefd(icol,klev) + ptrad(icol,klev) * ptrad(icol,klev) * & - prefd(icol,klev+1) * zreflect - ! Pass from bottom to top - do jk = 1,klev-1 - ikp = klev+1-jk - ikx = ikp-1 - zreflect = 1._r8 / (1._r8 -prupd(icol,ikp) * prefd(icol,ikx)) - prup(icol,ikx) = pref(icol,ikx) + (ptrad(icol,ikx) * & - ((ptra(icol,ikx) - pdbt(icol,ikx)) * prupd(icol,ikp) + & - pdbt(icol,ikx) * prup(icol,ikp))) * zreflect - prupd(icol,ikx) = prefd(icol,ikx) + ptrad(icol,ikx) * ptrad(icol,ikx) * & - prupd(icol,ikp) * zreflect - enddo - ! Upper boundary conditions - ztdn(1) = 1._r8 - prdnd(icol,1) = 0._r8 - ztdn(2) = ptra(icol,1) - prdnd(icol,2) = prefd(icol,1) - ! Pass from top to bottom - do jk = 2,klev - ikp = jk+1 - zreflect = 1._r8 / (1._r8 - prefd(icol,jk) * prdnd(icol,jk)) - ztdn(ikp) = ptdbt(icol,jk) * ptra(icol,jk) + & - (ptrad(icol,jk) * ((ztdn(jk) - ptdbt(icol,jk)) + & - ptdbt(icol,jk) * pref(icol,jk) * prdnd(icol,jk))) * zreflect - prdnd(icol,ikp) = prefd(icol,jk) + ptrad(icol,jk) * ptrad(icol,jk) * & - prdnd(icol,jk) * zreflect - enddo - ! Up and down-welling fluxes at levels - do jk = 1,klev+1 - zreflect = 1._r8 / (1._r8 - prdnd(icol,jk) * prupd(icol,jk)) - pfu(icol,jk,kw(icol)) = (ptdbt(icol,jk) * prup(icol,jk) + & - (ztdn(jk) - ptdbt(icol,jk)) * prupd(icol,jk)) * zreflect - pfd(icol,jk,kw(icol)) = ptdbt(icol,jk) + (ztdn(jk) - ptdbt(icol,jk)+ & - ptdbt(icol,jk) * prup(icol,jk) * prdnd(icol,jk)) * zreflect - enddo - end do - END SUBROUTINE vrtqdr_sw - END MODULE rrtmg_sw_vrtqdr diff --git a/test/ncar_kernels/PORT_sw_spcvmc/src/shr_kind_mod.f90 b/test/ncar_kernels/PORT_sw_spcvmc/src/shr_kind_mod.f90 deleted file mode 100644 index e4e5e74e6d..0000000000 --- a/test/ncar_kernels/PORT_sw_spcvmc/src/shr_kind_mod.f90 +++ /dev/null @@ -1,26 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : shr_kind_mod.f90 -! Generated at: 2015-07-31 20:35:44 -! KGEN version: 0.4.13 - - - - MODULE shr_kind_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - PUBLIC - INTEGER, parameter :: shr_kind_r8 = selected_real_kind(12) ! 8 byte real - ! 4 byte real - ! native real - ! 8 byte integer - ! 4 byte integer - ! native integer - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE shr_kind_mod diff --git a/test/ncar_kernels/PORT_sw_taumols/CESM_license.txt b/test/ncar_kernels/PORT_sw_taumols/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.1.1 b/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.1.1 deleted file mode 100644 index 5be83bd98a..0000000000 Binary files a/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.1.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.1.4 b/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.1.4 deleted file mode 100644 index 785fd2eaa1..0000000000 Binary files a/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.1.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.1.8 b/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.1.8 deleted file mode 100644 index 4859694ff0..0000000000 Binary files a/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.1.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.10.1 b/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.10.1 deleted file mode 100644 index 5e4d435354..0000000000 Binary files a/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.10.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.10.4 b/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.10.4 deleted file mode 100644 index 7b3bbe3348..0000000000 Binary files a/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.10.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.10.8 b/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.10.8 deleted file mode 100644 index 0d313ffffa..0000000000 Binary files a/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.10.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.5.1 b/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.5.1 deleted file mode 100644 index a675f97d8e..0000000000 Binary files a/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.5.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.5.4 b/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.5.4 deleted file mode 100644 index 86ebe55480..0000000000 Binary files a/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.5.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.5.8 b/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.5.8 deleted file mode 100644 index 388618099e..0000000000 Binary files a/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.5.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_taumols/inc/t1.mk b/test/ncar_kernels/PORT_sw_taumols/inc/t1.mk deleted file mode 100644 index 2ed66fb60b..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/inc/t1.mk +++ /dev/null @@ -1,116 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# Intel default flags -# -# FC_FLAGS := -O2 -fp-model source -convert big_endian -assume byterecl -# -ftz -traceback -assume realloc_lhs -xAVX -# -FC_FLAGS := $(OPT) - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - -ALL_OBJS := kernel_driver.o rrtmg_sw_spcvmc.o kgen_utils.o rrsw_kg21.o rrsw_kg25.o rrsw_kg26.o shr_kind_mod.o rrsw_kg18.o rrsw_kg17.o rrsw_con.o rrsw_wvn.o rrsw_kg27.o rrsw_kg19.o rrsw_kg29.o rrsw_kg22.o rrsw_kg24.o rrsw_kg20.o rrsw_kg16.o parrrsw.o rrtmg_sw_taumol.o rrsw_kg23.o rrsw_vsn.o rrsw_kg28.o - -verify: - @(grep "verification.FAIL" $(TEST).rslt && echo "FAILED") || (grep "verification.PASS" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 rrtmg_sw_spcvmc.o kgen_utils.o rrsw_kg21.o rrsw_kg25.o rrsw_kg26.o shr_kind_mod.o rrsw_kg18.o rrsw_kg17.o rrsw_con.o rrsw_wvn.o rrsw_kg27.o rrsw_kg19.o rrsw_kg29.o rrsw_kg22.o rrsw_kg24.o rrsw_kg20.o rrsw_kg16.o parrrsw.o rrtmg_sw_taumol.o rrsw_kg23.o rrsw_vsn.o rrsw_kg28.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_sw_spcvmc.o: $(SRC_DIR)/rrtmg_sw_spcvmc.f90 kgen_utils.o rrtmg_sw_taumol.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg21.o: $(SRC_DIR)/rrsw_kg21.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg25.o: $(SRC_DIR)/rrsw_kg25.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg26.o: $(SRC_DIR)/rrsw_kg26.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_kind_mod.o: $(SRC_DIR)/shr_kind_mod.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg18.o: $(SRC_DIR)/rrsw_kg18.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg17.o: $(SRC_DIR)/rrsw_kg17.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_con.o: $(SRC_DIR)/rrsw_con.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_wvn.o: $(SRC_DIR)/rrsw_wvn.f90 kgen_utils.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg27.o: $(SRC_DIR)/rrsw_kg27.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg19.o: $(SRC_DIR)/rrsw_kg19.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg29.o: $(SRC_DIR)/rrsw_kg29.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg22.o: $(SRC_DIR)/rrsw_kg22.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg24.o: $(SRC_DIR)/rrsw_kg24.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg20.o: $(SRC_DIR)/rrsw_kg20.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg16.o: $(SRC_DIR)/rrsw_kg16.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -parrrsw.o: $(SRC_DIR)/parrrsw.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_sw_taumol.o: $(SRC_DIR)/rrtmg_sw_taumol.f90 kgen_utils.o shr_kind_mod.o rrsw_vsn.o rrsw_kg16.o rrsw_con.o rrsw_wvn.o parrrsw.o rrsw_kg17.o rrsw_kg18.o rrsw_kg19.o rrsw_kg20.o rrsw_kg21.o rrsw_kg22.o rrsw_kg23.o rrsw_kg24.o rrsw_kg25.o rrsw_kg26.o rrsw_kg27.o rrsw_kg28.o rrsw_kg29.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg23.o: $(SRC_DIR)/rrsw_kg23.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_vsn.o: $(SRC_DIR)/rrsw_vsn.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrsw_kg28.o: $(SRC_DIR)/rrsw_kg28.f90 kgen_utils.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -kgen_utils.o: $(SRC_DIR)/kgen_utils.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.rslt diff --git a/test/ncar_kernels/PORT_sw_taumols/lit/runmake b/test/ncar_kernels/PORT_sw_taumols/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/PORT_sw_taumols/lit/t1.sh b/test/ncar_kernels/PORT_sw_taumols/lit/t1.sh deleted file mode 100644 index 33c953a156..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/lit/t1.sh +++ /dev/null @@ -1,9 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -# Shared lit script for each tests. Run bash commands that run tests with make. - -# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t -# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/PORT_sw_taumols/makefile b/test/ncar_kernels/PORT_sw_taumols/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/PORT_sw_taumols/src/kernel_driver.f90 b/test/ncar_kernels/PORT_sw_taumols/src/kernel_driver.f90 deleted file mode 100644 index 3ca9c6aad2..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/src/kernel_driver.f90 +++ /dev/null @@ -1,220 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-07-31 20:45:42 -! KGEN version: 0.4.13 - - -PROGRAM kernel_driver - USE rrtmg_sw_spcvmc, ONLY : spcvmc_sw - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - USE rrsw_vsn, ONLY : kgen_read_externs_rrsw_vsn - USE rrsw_kg23, ONLY : kgen_read_externs_rrsw_kg23 - USE rrsw_kg28, ONLY : kgen_read_externs_rrsw_kg28 - USE rrsw_con, ONLY : kgen_read_externs_rrsw_con - USE rrsw_kg24, ONLY : kgen_read_externs_rrsw_kg24 - USE rrsw_kg25, ONLY : kgen_read_externs_rrsw_kg25 - USE rrsw_kg26, ONLY : kgen_read_externs_rrsw_kg26 - USE rrsw_kg27, ONLY : kgen_read_externs_rrsw_kg27 - USE rrsw_kg19, ONLY : kgen_read_externs_rrsw_kg19 - USE rrsw_kg18, ONLY : kgen_read_externs_rrsw_kg18 - USE rrsw_kg22, ONLY : kgen_read_externs_rrsw_kg22 - USE rrsw_wvn, ONLY : kgen_read_externs_rrsw_wvn - USE rrsw_kg17, ONLY : kgen_read_externs_rrsw_kg17 - USE rrsw_kg16, ONLY : kgen_read_externs_rrsw_kg16 - USE rrsw_kg20, ONLY : kgen_read_externs_rrsw_kg20 - USE rrsw_kg29, ONLY : kgen_read_externs_rrsw_kg29 - USE rrsw_kg21, ONLY : kgen_read_externs_rrsw_kg21 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - - IMPLICIT NONE - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_mpi_rank_at = (/ 1, 4, 8 /) - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_counter_at = (/ 1, 10, 5 /) - CHARACTER(LEN=1024) :: kgen_filepath - REAL(KIND=r8), allocatable :: selffac(:,:) - REAL(KIND=r8), allocatable :: selffrac(:,:) - INTEGER :: ncol - REAL(KIND=r8), allocatable :: forfac(:,:) - INTEGER :: nlayers - REAL(KIND=r8), allocatable :: forfrac(:,:) - INTEGER, allocatable :: indself(:,:) - REAL(KIND=r8), allocatable :: colh2o(:,:) - REAL(KIND=r8), allocatable :: colco2(:,:) - REAL(KIND=r8), allocatable :: colch4(:,:) - REAL(KIND=r8), allocatable :: colo3(:,:) - REAL(KIND=r8), allocatable :: colmol(:,:) - REAL(KIND=r8), allocatable :: colo2(:,:) - INTEGER, allocatable :: laytrop(:) - INTEGER, allocatable :: jp(:,:) - INTEGER, allocatable :: jt(:,:) - INTEGER, allocatable :: indfor(:,:) - INTEGER, allocatable :: jt1(:,:) - REAL(KIND=r8), allocatable :: fac00(:,:) - REAL(KIND=r8), allocatable :: fac01(:,:) - REAL(KIND=r8), allocatable :: fac10(:,:) - REAL(KIND=r8), allocatable :: fac11(:,:) - - DO kgen_repeat_counter = 0, 8 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - kgen_filepath = "../data/taumol_sw." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "** Verification against '" // trim(adjustl(kgen_filepath)) // "' **" - - CALL kgen_read_externs_rrsw_vsn(kgen_unit) - CALL kgen_read_externs_rrsw_kg23(kgen_unit) - CALL kgen_read_externs_rrsw_kg28(kgen_unit) - CALL kgen_read_externs_rrsw_con(kgen_unit) - CALL kgen_read_externs_rrsw_kg24(kgen_unit) - CALL kgen_read_externs_rrsw_kg25(kgen_unit) - CALL kgen_read_externs_rrsw_kg26(kgen_unit) - CALL kgen_read_externs_rrsw_kg27(kgen_unit) - CALL kgen_read_externs_rrsw_kg19(kgen_unit) - CALL kgen_read_externs_rrsw_kg18(kgen_unit) - CALL kgen_read_externs_rrsw_kg22(kgen_unit) - CALL kgen_read_externs_rrsw_wvn(kgen_unit) - CALL kgen_read_externs_rrsw_kg17(kgen_unit) - CALL kgen_read_externs_rrsw_kg16(kgen_unit) - CALL kgen_read_externs_rrsw_kg20(kgen_unit) - CALL kgen_read_externs_rrsw_kg29(kgen_unit) - CALL kgen_read_externs_rrsw_kg21(kgen_unit) - - ! driver variables - READ(UNIT=kgen_unit) nlayers - READ(UNIT=kgen_unit) ncol - CALL kgen_read_integer_4_dim1(laytrop, kgen_unit) - CALL kgen_read_integer_4_dim2(indfor, kgen_unit) - CALL kgen_read_integer_4_dim2(indself, kgen_unit) - CALL kgen_read_integer_4_dim2(jp, kgen_unit) - CALL kgen_read_integer_4_dim2(jt, kgen_unit) - CALL kgen_read_integer_4_dim2(jt1, kgen_unit) - CALL kgen_read_real_r8_dim2(colmol, kgen_unit) - CALL kgen_read_real_r8_dim2(colh2o, kgen_unit) - CALL kgen_read_real_r8_dim2(colco2, kgen_unit) - CALL kgen_read_real_r8_dim2(colch4, kgen_unit) - CALL kgen_read_real_r8_dim2(colo3, kgen_unit) - CALL kgen_read_real_r8_dim2(colo2, kgen_unit) - CALL kgen_read_real_r8_dim2(forfac, kgen_unit) - CALL kgen_read_real_r8_dim2(forfrac, kgen_unit) - CALL kgen_read_real_r8_dim2(selffac, kgen_unit) - CALL kgen_read_real_r8_dim2(selffrac, kgen_unit) - CALL kgen_read_real_r8_dim2(fac00, kgen_unit) - CALL kgen_read_real_r8_dim2(fac01, kgen_unit) - CALL kgen_read_real_r8_dim2(fac10, kgen_unit) - CALL kgen_read_real_r8_dim2(fac11, kgen_unit) - - call spcvmc_sw(nlayers, ncol, laytrop, indfor, indself, jp, jt, jt1, colmol, colh2o, colco2, colch4, colo3, colo2, forfac, forfrac, selffac, selffrac, fac00, fac01, fac10, fac11, kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_integer_4_dim1(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - integer(KIND=4), INTENT(OUT), ALLOCATABLE, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_integer_4_dim1 - - SUBROUTINE kgen_read_integer_4_dim2(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - integer(KIND=4), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_integer_4_dim2 - - SUBROUTINE kgen_read_real_r8_dim2(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim2 - - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/PORT_sw_taumols/src/kgen_utils.f90 b/test/ncar_kernels/PORT_sw_taumols/src/kgen_utils.f90 deleted file mode 100644 index cfa8d114e0..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/src/kgen_utils.f90 +++ /dev/null @@ -1,61 +0,0 @@ -module kgen_utils_mod - -INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - -type check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - real(kind=kgen_dp) :: minvalue -end type check_t - -public kgen_dp, check_t, kgen_init_check, kgen_print_check - -contains - -subroutine kgen_init_check(check, tolerance, minvalue) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - real(kind=kgen_dp), intent(in), optional :: minvalue - - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.0D-15 - endif - if(present(minvalue)) then - check%minvalue = minvalue - else - check%minvalue = 1.0D-15 - endif -end subroutine kgen_init_check - -subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif -end subroutine kgen_print_check - -end module diff --git a/test/ncar_kernels/PORT_sw_taumols/src/parrrsw.f90 b/test/ncar_kernels/PORT_sw_taumols/src/parrrsw.f90 deleted file mode 100644 index e9b49d3d17..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/src/parrrsw.f90 +++ /dev/null @@ -1,108 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : parrrsw.f90 -! Generated at: 2015-07-31 20:45:42 -! KGEN version: 0.4.13 - - - - MODULE parrrsw - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw main parameters - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! mxlay : integer: maximum number of layers - ! mg : integer: number of original g-intervals per spectral band - ! nbndsw : integer: number of spectral bands - ! naerec : integer: number of aerosols (iaer=6, ecmwf aerosol option) - ! ngptsw : integer: total number of reduced g-intervals for rrtmg_lw - ! ngNN : integer: number of reduced g-intervals per spectral band - ! ngsNN : integer: cumulative number of g-intervals per band - !------------------------------------------------------------------ - ! Settings for single column mode. - ! For GCM use, set nlon to number of longitudes, and - ! mxlay to number of model layers - !jplay, klev - !jpg - !jpsw, ksw - !jpaer - ! Use for 112 g-point model - INTEGER, parameter :: ngptsw = 112 !jpgpt - ! Use for 224 g-point model - ! integer, parameter :: ngptsw = 224 !jpgpt - ! may need to rename these - from v2.6 - INTEGER, parameter :: jpb1 = 16 !istart - INTEGER, parameter :: jpb2 = 29 !iend - ! ^ - ! Use for 112 g-point model - INTEGER, parameter :: ng16 = 6 - INTEGER, parameter :: ng17 = 12 - INTEGER, parameter :: ng18 = 8 - INTEGER, parameter :: ng19 = 8 - INTEGER, parameter :: ng20 = 10 - INTEGER, parameter :: ng21 = 10 - INTEGER, parameter :: ng22 = 2 - INTEGER, parameter :: ng23 = 10 - INTEGER, parameter :: ng24 = 8 - INTEGER, parameter :: ng25 = 6 - INTEGER, parameter :: ng26 = 6 - INTEGER, parameter :: ng27 = 8 - INTEGER, parameter :: ng28 = 6 - INTEGER, parameter :: ng29 = 12 - INTEGER, parameter :: ngs16 = 6 - INTEGER, parameter :: ngs17 = 18 - INTEGER, parameter :: ngs18 = 26 - INTEGER, parameter :: ngs19 = 34 - INTEGER, parameter :: ngs20 = 44 - INTEGER, parameter :: ngs21 = 54 - INTEGER, parameter :: ngs22 = 56 - INTEGER, parameter :: ngs23 = 66 - INTEGER, parameter :: ngs24 = 74 - INTEGER, parameter :: ngs25 = 80 - INTEGER, parameter :: ngs26 = 86 - INTEGER, parameter :: ngs27 = 94 - INTEGER, parameter :: ngs28 = 100 - ! Use for 224 g-point model - ! integer, parameter :: ng16 = 16 - ! integer, parameter :: ng17 = 16 - ! integer, parameter :: ng18 = 16 - ! integer, parameter :: ng19 = 16 - ! integer, parameter :: ng20 = 16 - ! integer, parameter :: ng21 = 16 - ! integer, parameter :: ng22 = 16 - ! integer, parameter :: ng23 = 16 - ! integer, parameter :: ng24 = 16 - ! integer, parameter :: ng25 = 16 - ! integer, parameter :: ng26 = 16 - ! integer, parameter :: ng27 = 16 - ! integer, parameter :: ng28 = 16 - ! integer, parameter :: ng29 = 16 - ! integer, parameter :: ngs16 = 16 - ! integer, parameter :: ngs17 = 32 - ! integer, parameter :: ngs18 = 48 - ! integer, parameter :: ngs19 = 64 - ! integer, parameter :: ngs20 = 80 - ! integer, parameter :: ngs21 = 96 - ! integer, parameter :: ngs22 = 112 - ! integer, parameter :: ngs23 = 128 - ! integer, parameter :: ngs24 = 144 - ! integer, parameter :: ngs25 = 160 - ! integer, parameter :: ngs26 = 176 - ! integer, parameter :: ngs27 = 192 - ! integer, parameter :: ngs28 = 208 - ! integer, parameter :: ngs29 = 224 - ! Source function solar constant - ! W/m2 - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE parrrsw diff --git a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_con.f90 b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_con.f90 deleted file mode 100644 index b9a6ee158b..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_con.f90 +++ /dev/null @@ -1,49 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_con.f90 -! Generated at: 2015-07-31 20:45:42 -! KGEN version: 0.4.13 - - - - MODULE rrsw_con - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw constants - ! Initial version: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! fluxfac: real : radiance to flux conversion factor - ! heatfac: real : flux to heating rate conversion factor - !oneminus: real : 1.-1.e-6 - ! pi : real : pi - ! grav : real : acceleration of gravity (m/s2) - ! planck : real : planck constant - ! boltz : real : boltzman constant - ! clight : real : speed of light - ! avogad : real : avogadro's constant - ! alosmt : real : - ! gascon : real : gas constant - ! radcn1 : real : - ! radcn2 : real : - !------------------------------------------------------------------ - REAL(KIND=r8) :: oneminus - PUBLIC kgen_read_externs_rrsw_con - CONTAINS - - ! write subroutines - ! No subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_con(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) oneminus - END SUBROUTINE kgen_read_externs_rrsw_con - - END MODULE rrsw_con diff --git a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg16.f90 b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg16.f90 deleted file mode 100644 index 11ca46b8c7..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg16.f90 +++ /dev/null @@ -1,77 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg16.f90 -! Generated at: 2015-07-31 20:45:42 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg16 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng16 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 16 - ! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: strrat1 - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 16 - ! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(585,ng16) - REAL(KIND=r8) :: absb(235,ng16) - REAL(KIND=r8) :: selfref(10,ng16) - REAL(KIND=r8) :: forref(3,ng16) - REAL(KIND=r8) :: sfluxref(ng16) - PUBLIC kgen_read_externs_rrsw_kg16 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg16(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) strrat1 - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) sfluxref - END SUBROUTINE kgen_read_externs_rrsw_kg16 - - END MODULE rrsw_kg16 diff --git a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg17.f90 b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg17.f90 deleted file mode 100644 index 889c6799ae..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg17.f90 +++ /dev/null @@ -1,77 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg17.f90 -! Generated at: 2015-07-31 20:45:42 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg17 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng17 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 17 - ! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: strrat - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 17 - ! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(585,ng17) - REAL(KIND=r8) :: absb(1175,ng17) - REAL(KIND=r8) :: selfref(10,ng17) - REAL(KIND=r8) :: forref(4,ng17) - REAL(KIND=r8) :: sfluxref(ng17,5) - PUBLIC kgen_read_externs_rrsw_kg17 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg17(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) strrat - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) sfluxref - END SUBROUTINE kgen_read_externs_rrsw_kg17 - - END MODULE rrsw_kg17 diff --git a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg18.f90 b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg18.f90 deleted file mode 100644 index e08968e73a..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg18.f90 +++ /dev/null @@ -1,77 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg18.f90 -! Generated at: 2015-07-31 20:45:42 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg18 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng18 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 18 - ! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: strrat - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 18 - ! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(585,ng18) - REAL(KIND=r8) :: absb(235,ng18) - REAL(KIND=r8) :: forref(3,ng18) - REAL(KIND=r8) :: selfref(10,ng18) - REAL(KIND=r8) :: sfluxref(ng18,9) - PUBLIC kgen_read_externs_rrsw_kg18 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg18(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) strrat - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) sfluxref - END SUBROUTINE kgen_read_externs_rrsw_kg18 - - END MODULE rrsw_kg18 diff --git a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg19.f90 b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg19.f90 deleted file mode 100644 index 583d8ef329..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg19.f90 +++ /dev/null @@ -1,77 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg19.f90 -! Generated at: 2015-07-31 20:45:42 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg19 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng19 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 19 - ! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: strrat - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 19 - ! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(585,ng19) - REAL(KIND=r8) :: absb(235,ng19) - REAL(KIND=r8) :: forref(3,ng19) - REAL(KIND=r8) :: selfref(10,ng19) - REAL(KIND=r8) :: sfluxref(ng19,9) - PUBLIC kgen_read_externs_rrsw_kg19 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg19(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) strrat - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) sfluxref - END SUBROUTINE kgen_read_externs_rrsw_kg19 - - END MODULE rrsw_kg19 diff --git a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg20.f90 b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg20.f90 deleted file mode 100644 index 3bb88b2214..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg20.f90 +++ /dev/null @@ -1,79 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg20.f90 -! Generated at: 2015-07-31 20:45:42 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg20 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng20 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 20 - ! band 20: 5150-6150 cm-1 (low - h2o; high - h2o) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - ! absch4o : real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 20 - ! band 20: 5150-6150 cm-1 (low - h2o; high - h2o) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - ! absch4 : real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(65,ng20) - REAL(KIND=r8) :: absb(235,ng20) - REAL(KIND=r8) :: forref(4,ng20) - REAL(KIND=r8) :: selfref(10,ng20) - REAL(KIND=r8) :: sfluxref(ng20) - REAL(KIND=r8) :: absch4(ng20) - PUBLIC kgen_read_externs_rrsw_kg20 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg20(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) sfluxref - READ(UNIT=kgen_unit) absch4 - END SUBROUTINE kgen_read_externs_rrsw_kg20 - - END MODULE rrsw_kg20 diff --git a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg21.f90 b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg21.f90 deleted file mode 100644 index a9a63dc4f9..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg21.f90 +++ /dev/null @@ -1,77 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg21.f90 -! Generated at: 2015-07-31 20:45:42 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg21 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng21 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 21 - ! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: strrat - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 21 - ! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(585,ng21) - REAL(KIND=r8) :: absb(1175,ng21) - REAL(KIND=r8) :: forref(4,ng21) - REAL(KIND=r8) :: selfref(10,ng21) - REAL(KIND=r8) :: sfluxref(ng21,9) - PUBLIC kgen_read_externs_rrsw_kg21 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg21(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) strrat - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) sfluxref - END SUBROUTINE kgen_read_externs_rrsw_kg21 - - END MODULE rrsw_kg21 diff --git a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg22.f90 b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg22.f90 deleted file mode 100644 index 22ad705814..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg22.f90 +++ /dev/null @@ -1,77 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg22.f90 -! Generated at: 2015-07-31 20:45:42 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg22 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng22 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 22 - ! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: strrat - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 22 - ! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(585,ng22) - REAL(KIND=r8) :: absb(235,ng22) - REAL(KIND=r8) :: selfref(10,ng22) - REAL(KIND=r8) :: forref(3,ng22) - REAL(KIND=r8) :: sfluxref(ng22,9) - PUBLIC kgen_read_externs_rrsw_kg22 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg22(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) strrat - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) sfluxref - END SUBROUTINE kgen_read_externs_rrsw_kg22 - - END MODULE rrsw_kg22 diff --git a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg23.f90 b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg23.f90 deleted file mode 100644 index 5adb9d291c..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg23.f90 +++ /dev/null @@ -1,75 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg23.f90 -! Generated at: 2015-07-31 20:45:43 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg23 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng23 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 23 - ! band 23: 8050-12850 cm-1 (low - h2o; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: givfac - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 23 - ! band 23: 8050-12850 cm-1 (low - h2o; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(65,ng23) - REAL(KIND=r8) :: selfref(10,ng23) - REAL(KIND=r8) :: forref(3,ng23) - REAL(KIND=r8) :: rayl(ng23) - REAL(KIND=r8) :: sfluxref(ng23) - PUBLIC kgen_read_externs_rrsw_kg23 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg23(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) givfac - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) sfluxref - END SUBROUTINE kgen_read_externs_rrsw_kg23 - - END MODULE rrsw_kg23 diff --git a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg24.f90 b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg24.f90 deleted file mode 100644 index d3f405ee4a..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg24.f90 +++ /dev/null @@ -1,91 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg24.f90 -! Generated at: 2015-07-31 20:45:42 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg24 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng24 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 24 - ! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - ! abso3ao : real - ! abso3bo : real - ! raylao : real - ! raylbo : real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: strrat - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 24 - ! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! selfref : real - ! forref : real - ! sfluxref: real - ! abso3a : real - ! abso3b : real - ! rayla : real - ! raylb : real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(585,ng24) - REAL(KIND=r8) :: absb(235,ng24) - REAL(KIND=r8) :: selfref(10,ng24) - REAL(KIND=r8) :: forref(3,ng24) - REAL(KIND=r8) :: sfluxref(ng24,9) - REAL(KIND=r8) :: abso3a(ng24) - REAL(KIND=r8) :: abso3b(ng24) - REAL(KIND=r8) :: rayla(ng24,9) - REAL(KIND=r8) :: raylb(ng24) - PUBLIC kgen_read_externs_rrsw_kg24 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg24(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) strrat - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) sfluxref - READ(UNIT=kgen_unit) abso3a - READ(UNIT=kgen_unit) abso3b - READ(UNIT=kgen_unit) rayla - READ(UNIT=kgen_unit) raylb - END SUBROUTINE kgen_read_externs_rrsw_kg24 - - END MODULE rrsw_kg24 diff --git a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg25.f90 b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg25.f90 deleted file mode 100644 index ea382a9930..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg25.f90 +++ /dev/null @@ -1,72 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg25.f90 -! Generated at: 2015-07-31 20:45:42 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg25 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng25 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 25 - ! band 25: 16000-22650 cm-1 (low - h2o; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - !sfluxrefo: real - ! abso3ao : real - ! abso3bo : real - ! raylo : real - !----------------------------------------------------------------- - INTEGER :: layreffr - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 25 - ! band 25: 16000-22650 cm-1 (low - h2o; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! absa : real - ! sfluxref: real - ! abso3a : real - ! abso3b : real - ! rayl : real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(65,ng25) - REAL(KIND=r8) :: sfluxref(ng25) - REAL(KIND=r8) :: abso3a(ng25) - REAL(KIND=r8) :: abso3b(ng25) - REAL(KIND=r8) :: rayl(ng25) - PUBLIC kgen_read_externs_rrsw_kg25 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg25(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) sfluxref - READ(UNIT=kgen_unit) abso3a - READ(UNIT=kgen_unit) abso3b - READ(UNIT=kgen_unit) rayl - END SUBROUTINE kgen_read_externs_rrsw_kg25 - - END MODULE rrsw_kg25 diff --git a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg26.f90 b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg26.f90 deleted file mode 100644 index 248f3d3368..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg26.f90 +++ /dev/null @@ -1,57 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg26.f90 -! Generated at: 2015-07-31 20:45:42 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg26 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng26 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 26 - ! band 26: 22650-29000 cm-1 (low - nothing; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - !sfluxrefo: real - ! raylo : real - !----------------------------------------------------------------- - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 26 - ! band 26: 22650-29000 cm-1 (low - nothing; high - nothing) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! sfluxref: real - ! rayl : real - !----------------------------------------------------------------- - REAL(KIND=r8) :: sfluxref(ng26) - REAL(KIND=r8) :: rayl(ng26) - PUBLIC kgen_read_externs_rrsw_kg26 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg26(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) sfluxref - READ(UNIT=kgen_unit) rayl - END SUBROUTINE kgen_read_externs_rrsw_kg26 - - END MODULE rrsw_kg26 diff --git a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg27.f90 b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg27.f90 deleted file mode 100644 index 4b99f4ee92..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg27.f90 +++ /dev/null @@ -1,71 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg27.f90 -! Generated at: 2015-07-31 20:45:42 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg27 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng27 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 27 - ! band 27: 29000-38000 cm-1 (low - o3; high - o3) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - !sfluxrefo: real - ! raylo : real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: scalekur - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 27 - ! band 27: 29000-38000 cm-1 (low - o3; high - o3) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! absa : real - ! absb : real - ! sfluxref: real - ! rayl : real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(65,ng27) - REAL(KIND=r8) :: absb(235,ng27) - REAL(KIND=r8) :: sfluxref(ng27) - REAL(KIND=r8) :: rayl(ng27) - PUBLIC kgen_read_externs_rrsw_kg27 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg27(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) scalekur - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) sfluxref - READ(UNIT=kgen_unit) rayl - END SUBROUTINE kgen_read_externs_rrsw_kg27 - - END MODULE rrsw_kg27 diff --git a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg28.f90 b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg28.f90 deleted file mode 100644 index 972b81285a..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg28.f90 +++ /dev/null @@ -1,67 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg28.f90 -! Generated at: 2015-07-31 20:45:43 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg28 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng28 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 28 - ! band 28: 38000-50000 cm-1 (low - o3, o2; high - o3, o2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - !sfluxrefo: real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: strrat - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 28 - ! band 28: 38000-50000 cm-1 (low - o3, o2; high - o3, o2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! sfluxref: real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(585,ng28) - REAL(KIND=r8) :: absb(1175,ng28) - REAL(KIND=r8) :: sfluxref(ng28,5) - PUBLIC kgen_read_externs_rrsw_kg28 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg28(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) strrat - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) sfluxref - END SUBROUTINE kgen_read_externs_rrsw_kg28 - - END MODULE rrsw_kg28 diff --git a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg29.f90 b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg29.f90 deleted file mode 100644 index be08b352e7..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg29.f90 +++ /dev/null @@ -1,81 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_kg29.f90 -! Generated at: 2015-07-31 20:45:42 -! KGEN version: 0.4.13 - - - - MODULE rrsw_kg29 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind ,only : jpim, jprb - USE parrrsw, ONLY: ng29 - IMPLICIT NONE - !----------------------------------------------------------------- - ! rrtmg_sw ORIGINAL abs. coefficients for interval 29 - ! band 29: 820-2600 cm-1 (low - h2o; high - co2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! kao : real - ! kbo : real - ! selfrefo: real - ! forrefo : real - !sfluxrefo: real - ! absh2oo : real - ! absco2o : real - !----------------------------------------------------------------- - INTEGER :: layreffr - REAL(KIND=r8) :: rayl - !----------------------------------------------------------------- - ! rrtmg_sw COMBINED abs. coefficients for interval 29 - ! band 29: 820-2600 cm-1 (low - h2o; high - co2) - ! - ! Initial version: JJMorcrette, ECMWF, oct1999 - ! Revised: MJIacono, AER, jul2006 - !----------------------------------------------------------------- - ! - ! name type purpose - ! ---- : ---- : --------------------------------------------- - ! ka : real - ! kb : real - ! selfref : real - ! forref : real - ! sfluxref: real - ! absh2o : real - ! absco2 : real - !----------------------------------------------------------------- - REAL(KIND=r8) :: absa(65,ng29) - REAL(KIND=r8) :: absb(235,ng29) - REAL(KIND=r8) :: selfref(10,ng29) - REAL(KIND=r8) :: forref(4,ng29) - REAL(KIND=r8) :: sfluxref(ng29) - REAL(KIND=r8) :: absco2(ng29) - REAL(KIND=r8) :: absh2o(ng29) - PUBLIC kgen_read_externs_rrsw_kg29 - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_kg29(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) layreffr - READ(UNIT=kgen_unit) rayl - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) sfluxref - READ(UNIT=kgen_unit) absco2 - READ(UNIT=kgen_unit) absh2o - END SUBROUTINE kgen_read_externs_rrsw_kg29 - - END MODULE rrsw_kg29 diff --git a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_vsn.f90 b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_vsn.f90 deleted file mode 100644 index 46c81e64c6..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_vsn.f90 +++ /dev/null @@ -1,65 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_vsn.f90 -! Generated at: 2015-07-31 20:45:43 -! KGEN version: 0.4.13 - - - - MODULE rrsw_vsn - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind, only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw version information - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jul2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - !hnamrtm :character: - !hnamini :character: - !hnamcld :character: - !hnamclc :character: - !hnamrft :character: - !hnamspv :character: - !hnamspc :character: - !hnamset :character: - !hnamtau :character: - !hnamvqd :character: - !hnamatm :character: - !hnamutl :character: - !hnamext :character: - !hnamkg :character: - ! - ! hvrrtm :character: - ! hvrini :character: - ! hvrcld :character: - ! hvrclc :character: - ! hvrrft :character: - ! hvrspv :character: - ! hvrspc :character: - ! hvrset :character: - ! hvrtau :character: - ! hvrvqd :character: - ! hvratm :character: - ! hvrutl :character: - ! hvrext :character: - ! hvrkg :character: - !------------------------------------------------------------------ - CHARACTER(LEN=18) :: hvrtau - PUBLIC kgen_read_externs_rrsw_vsn - CONTAINS - - ! write subroutines - ! No subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_vsn(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) hvrtau - END SUBROUTINE kgen_read_externs_rrsw_vsn - - END MODULE rrsw_vsn diff --git a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_wvn.f90 b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_wvn.f90 deleted file mode 100644 index f78fcf83f2..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/src/rrsw_wvn.f90 +++ /dev/null @@ -1,57 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrsw_wvn.f90 -! Generated at: 2015-07-31 20:45:42 -! KGEN version: 0.4.13 - - - - MODULE rrsw_wvn - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind, only : jpim, jprb - USE parrrsw, ONLY: jpb1 - USE parrrsw, ONLY: jpb2 - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw spectral information - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jul2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! ng : integer: Number of original g-intervals in each spectral band - ! nspa : integer: - ! nspb : integer: - !wavenum1: real : Spectral band lower boundary in wavenumbers - !wavenum2: real : Spectral band upper boundary in wavenumbers - ! delwave: real : Spectral band width in wavenumbers - ! - ! ngc : integer: The number of new g-intervals in each band - ! ngs : integer: The cumulative sum of new g-intervals for each band - ! ngm : integer: The index of each new g-interval relative to the - ! original 16 g-intervals in each band - ! ngn : integer: The number of original g-intervals that are - ! combined to make each new g-intervals in each band - ! ngb : integer: The band index for each new g-interval - ! wt : real : RRTM weights for the original 16 g-intervals - ! rwgt : real : Weights for combining original 16 g-intervals - ! (224 total) into reduced set of g-intervals - ! (112 total) - !------------------------------------------------------------------ - INTEGER :: nspa(jpb1:jpb2) - INTEGER :: nspb(jpb1:jpb2) - PUBLIC kgen_read_externs_rrsw_wvn - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_rrsw_wvn(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) nspa - READ(UNIT=kgen_unit) nspb - END SUBROUTINE kgen_read_externs_rrsw_wvn - - END MODULE rrsw_wvn diff --git a/test/ncar_kernels/PORT_sw_taumols/src/rrtmg_sw_spcvmc.f90 b/test/ncar_kernels/PORT_sw_taumols/src/rrtmg_sw_spcvmc.f90 deleted file mode 100644 index f3c1d51721..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/src/rrtmg_sw_spcvmc.f90 +++ /dev/null @@ -1,395 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_sw_spcvmc.f90 -! Generated at: 2015-07-31 20:45:42 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_sw_spcvmc - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! ------- Modules ------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE parrrsw, ONLY: ngptsw - USE rrtmg_sw_taumol, ONLY: taumol_sw - IMPLICIT NONE - PUBLIC spcvmc_sw - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - ! --------------------------------------------------------------------------- - - SUBROUTINE spcvmc_sw(nlayers, ncol, laytrop, indfor, indself, jp, jt, jt1, colmol, colh2o, colco2, colch4, colo3, colo2, & - forfac, forfrac, selffac, selffrac, fac00, fac01, fac10, fac11, kgen_unit) - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! --------------------------------------------------------------------------- - ! - ! Purpose: Contains spectral loop to compute the shortwave radiative fluxes, - ! using the two-stream method of H. Barker and McICA, the Monte-Carlo - ! Independent Column Approximation, for the representation of - ! sub-grid cloud variability (i.e. cloud overlap). - ! - ! Interface: *spcvmc_sw* is called from *rrtmg_sw.F90* or rrtmg_sw.1col.F90* - ! - ! Method: - ! Adapted from two-stream model of H. Barker; - ! Two-stream model options (selected with kmodts in rrtmg_sw_reftra.F90): - ! 1: Eddington, 2: PIFM, Zdunkowski et al., 3: discret ordinates - ! - ! Modifications: - ! - ! Original: H. Barker - ! Revision: Merge with RRTMG_SW: J.-J.Morcrette, ECMWF, Feb 2003 - ! Revision: Add adjustment for Earth/Sun distance : MJIacono, AER, Oct 2003 - ! Revision: Bug fix for use of PALBP and PALBD: MJIacono, AER, Nov 2003 - ! Revision: Bug fix to apply delta scaling to clear sky: AER, Dec 2004 - ! Revision: Code modified so that delta scaling is not done in cloudy profiles - ! if routine cldprop is used; delta scaling can be applied by swithcing - ! code below if cldprop is not used to get cloud properties. - ! AER, Jan 2005 - ! Revision: Modified to use McICA: MJIacono, AER, Nov 2005 - ! Revision: Uniform formatting for RRTMG: MJIacono, AER, Jul 2006 - ! Revision: Use exponential lookup table for transmittance: MJIacono, AER, - ! Aug 2007 - ! - ! ------------------------------------------------------------------ - ! ------- Declarations ------ - ! ------- Input ------- - integer, intent(in) :: kgen_unit - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - INTEGER, intent(in) :: nlayers - ! delta-m scaling flag - ! [0 = direct and diffuse fluxes are unscaled] - ! [1 = direct and diffuse fluxes are scaled] - INTEGER, intent(in) :: ncol ! column loop index - INTEGER, intent(in) :: laytrop(ncol) - INTEGER, intent(in) :: indfor(:,:) - ! Dimensions: (ncol,nlayers) - INTEGER, intent(in) :: indself(:,:) - ! Dimensions: (ncol,nlayers) - INTEGER, intent(in) :: jp(:,:) - ! Dimensions: (ncol,nlayers) - INTEGER, intent(in) :: jt(:,:) - ! Dimensions: (ncol,nlayers) - INTEGER, intent(in) :: jt1(:,:) - ! Dimensions: (ncol,nlayers) - ! layer pressure (hPa, mb) - ! Dimensions: (ncol,nlayers) - ! layer temperature (K) - ! Dimensions: (ncol,nlayers) - ! level (interface) pressure (hPa, mb) - ! Dimensions: (ncol,0:nlayers) - ! level temperatures (hPa, mb) - ! Dimensions: (ncol,0:nlayers) - ! surface temperature (K) - ! molecular amounts (mol/cm2) - ! Dimensions: (ncol,mxmol,nlayers) - ! dry air column density (mol/cm2) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: colmol(:,:) - ! Dimensions: (ncol,nlayers) - ! Earth/Sun distance adjustment - ! Dimensions: (ncol,jpband) - ! surface albedo (diffuse) - ! Dimensions: (ncol,nbndsw) - ! surface albedo (direct) - ! Dimensions: (ncol, nbndsw) - ! cosine of solar zenith angle - ! cloud fraction [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - ! cloud optical depth [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - ! cloud asymmetry parameter [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - ! cloud single scattering albedo [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - ! cloud optical depth, non-delta scaled [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - ! aerosol optical depth - ! Dimensions: (ncol,nlayers,nbndsw) - ! aerosol asymmetry parameter - ! Dimensions: (ncol,nlayers,nbndsw) - ! aerosol single scattering albedo - ! Dimensions: (ncol,nlayers,nbndsw) - REAL(KIND=r8), intent(in) :: colh2o(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: colco2(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: colch4(:,:) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: colo3(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: colo2(:,:) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: forfac(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: forfrac(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: selffac(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: selffrac(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: fac00(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: fac01(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: fac10(:,:) - ! Dimensions: (ncol,nlayers) - REAL(KIND=r8), intent(in) :: fac11(:,:) - ! Dimensions: (ncol,nlayers) - ! ------- Output ------- - ! All Dimensions: (nlayers+1) - ! Added for net near-IR flux diagnostic - ! Output - inactive ! All Dimensions: (nlayers+1) - ! real(kind=r8), intent(out) :: puvcu(:) - ! real(kind=r8), intent(out) :: puvfu(:) - ! real(kind=r8), intent(out) :: pvscd(:) - ! real(kind=r8), intent(out) :: pvscu(:) - ! real(kind=r8), intent(out) :: pvsfd(:) - ! real(kind=r8), intent(out) :: pvsfu(:) - ! shortwave spectral flux up (nswbands,nlayers+1) - ! shortwave spectral flux down (nswbands,nlayers+1) - ! ------- Local ------- - INTEGER :: klev,maxiter=100 - ! integer, parameter :: nuv = ?? - ! integer, parameter :: nvs = ?? - ! real(kind=r8) :: zincflux ! inactive - ! Arrays from rrtmg_sw_taumoln routines - ! real(kind=r8) :: ztaug(nlayers,16), ztaur(nlayers,16) - ! real(kind=r8) :: zsflxzen(16) - REAL(KIND=r8) :: ztaug(ncol,nlayers,ngptsw) - REAL(KIND=r8) :: ref_ztaug(ncol,nlayers,ngptsw) - REAL(KIND=r8) :: ztaur(ncol,nlayers,ngptsw) - REAL(KIND=r8) :: ref_ztaur(ncol,nlayers,ngptsw) - REAL(KIND=r8) :: zsflxzen(ncol,ngptsw) - REAL(KIND=r8) :: ref_zsflxzen(ncol,ngptsw) - ! Arrays from rrtmg_sw_vrtqdr routine - ! Inactive arrays - ! real(kind=r8) :: zbbcd(nlayers+1), zbbcu(nlayers+1) - ! real(kind=r8) :: zbbfd(nlayers+1), zbbfu(nlayers+1) - ! real(kind=r8) :: zbbfddir(nlayers+1), zbbcddir(nlayers+1) - ! ------------------------------------------------------------------ - ! Initializations - ! zincflux = 0.0_r8 - tolerance = 1.E-14 - CALL kgen_init_check(check_status, tolerance) - READ(UNIT=kgen_unit) klev - READ(UNIT=kgen_unit) ztaug - READ(UNIT=kgen_unit) ztaur - READ(UNIT=kgen_unit) zsflxzen - - READ(UNIT=kgen_unit) ref_ztaug - READ(UNIT=kgen_unit) ref_ztaur - READ(UNIT=kgen_unit) ref_zsflxzen - - - ! call to kernel - call taumol_sw(ncol,klev, & - colh2o, colco2, colch4, colo2, colo3, colmol, & - laytrop, jp, jt, jt1, & - fac00, fac01, fac10, fac11, & - selffac, selffrac, indself, forfac, forfrac,indfor, & - zsflxzen, ztaug, ztaur) - ! kernel verification for output variables - CALL kgen_verify_real_r8_dim3( "ztaug", check_status, ztaug, ref_ztaug) - CALL kgen_verify_real_r8_dim3( "ztaur", check_status, ztaur, ref_ztaur) - CALL kgen_verify_real_r8_dim2( "zsflxzen", check_status, zsflxzen, ref_zsflxzen) - CALL kgen_print_check("taumol_sw", check_status) - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,maxiter - CALL taumol_sw(ncol, klev, colh2o, colco2, colch4, colo2, colo3, colmol, laytrop, jp, jt, jt1, fac00, fac01, fac10, fac11, selffac, selffrac, indself, forfac, forfrac, indfor, zsflxzen, ztaug, ztaur) - END DO - CALL system_clock(stop_clock, rate_clock) - WRITE(*,*) - PRINT *, "Elapsed time (sec): ", (stop_clock - start_clock)/REAL(rate_clock*maxiter) - ! ??? ! ??? - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_r8_dim3(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2,idx3 - INTEGER, DIMENSION(2,3) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim3 - - SUBROUTINE kgen_read_real_r8_dim2(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim2 - - - ! verify subroutines - SUBROUTINE kgen_verify_real_r8_dim3( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim3 - - SUBROUTINE kgen_verify_real_r8_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim2 - - END SUBROUTINE spcvmc_sw - END MODULE rrtmg_sw_spcvmc diff --git a/test/ncar_kernels/PORT_sw_taumols/src/rrtmg_sw_taumol.f90 b/test/ncar_kernels/PORT_sw_taumols/src/rrtmg_sw_taumol.f90 deleted file mode 100644 index 4ba45029b5..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/src/rrtmg_sw_taumol.f90 +++ /dev/null @@ -1,1589 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_sw_taumol.f90 -! Generated at: 2015-07-31 20:45:42 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_sw_taumol - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! ------- Modules ------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - ! use parrrsw, only : mg, jpband, nbndsw, ngptsw - USE rrsw_con, ONLY: oneminus - USE rrsw_wvn, ONLY: nspa - USE rrsw_wvn, ONLY: nspb - USE rrsw_vsn, ONLY: hvrtau - IMPLICIT NONE - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - !---------------------------------------------------------------------------- - - SUBROUTINE taumol_sw(ncol, nlayers, colh2o, colco2, colch4, colo2, colo3, colmol, laytrop, jp, jt, jt1, fac00, fac01, & - fac10, fac11, selffac, selffrac, indself, forfac, forfrac, indfor, sfluxzen, taug, taur) - !---------------------------------------------------------------------------- - ! ****************************************************************************** - ! * * - ! * Optical depths developed for the * - ! * * - ! * RAPID RADIATIVE TRANSFER MODEL (RRTM) * - ! * * - ! * * - ! * ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC. * - ! * 131 HARTWELL AVENUE * - ! * LEXINGTON, MA 02421 * - ! * * - ! * * - ! * ELI J. MLAWER * - ! * JENNIFER DELAMERE * - ! * STEVEN J. TAUBMAN * - ! * SHEPARD A. CLOUGH * - ! * * - ! * * - ! * * - ! * * - ! * email: mlawer@aer.com * - ! * email: jdelamer@aer.com * - ! * * - ! * The authors wish to acknowledge the contributions of the * - ! * following people: Patrick D. Brown, Michael J. Iacono, * - ! * Ronald E. Farren, Luke Chen, Robert Bergstrom. * - ! * * - ! ****************************************************************************** - ! * TAUMOL * - ! * * - ! * This file contains the subroutines TAUGBn (where n goes from * - ! * 1 to 28). TAUGBn calculates the optical depths and Planck fractions * - ! * per g-value and layer for band n. * - ! * * - ! * Output: optical depths (unitless) * - ! * fractions needed to compute Planck functions at every layer * - ! * and g-value * - ! * * - ! * COMMON /TAUGCOM/ TAUG(MXLAY,MG) * - ! * COMMON /PLANKG/ FRACS(MXLAY,MG) * - ! * * - ! * Input * - ! * * - ! * PARAMETER (MG=16, MXLAY=203, NBANDS=14) * - ! * * - ! * COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS) * - ! * COMMON /PRECISE/ ONEMINUS * - ! * COMMON /PROFILE/ NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY), * - ! * & PZ(0:MXLAY),TZ(0:MXLAY),TBOUND * - ! * COMMON /PROFDATA/ LAYTROP,LAYSWTCH,LAYLOW, * - ! * & COLH2O(MXLAY),COLCO2(MXLAY), * - ! * & COLO3(MXLAY),COLN2O(MXLAY),COLCH4(MXLAY), * - ! * & COLO2(MXLAY),CO2MULT(MXLAY) * - ! * COMMON /INTFAC/ FAC00(MXLAY),FAC01(MXLAY), * - ! * & FAC10(MXLAY),FAC11(MXLAY) * - ! * COMMON /INTIND/ JP(MXLAY),JT(MXLAY),JT1(MXLAY) * - ! * COMMON /SELF/ SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(MXLAY) * - ! * * - ! * Description: * - ! * NG(IBAND) - number of g-values in band IBAND * - ! * NSPA(IBAND) - for the lower atmosphere, the number of reference * - ! * atmospheres that are stored for band IBAND per * - ! * pressure level and temperature. Each of these * - ! * atmospheres has different relative amounts of the * - ! * key species for the band (i.e. different binary * - ! * species parameters). * - ! * NSPB(IBAND) - same for upper atmosphere * - ! * ONEMINUS - since problems are caused in some cases by interpolation * - ! * parameters equal to or greater than 1, for these cases * - ! * these parameters are set to this value, slightly < 1. * - ! * PAVEL - layer pressures (mb) * - ! * TAVEL - layer temperatures (degrees K) * - ! * PZ - level pressures (mb) * - ! * TZ - level temperatures (degrees K) * - ! * LAYTROP - layer at which switch is made from one combination of * - ! * key species to another * - ! * COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water * - ! * vapor,carbon dioxide, ozone, nitrous ozide, methane, * - ! * respectively (molecules/cm**2) * - ! * CO2MULT - for bands in which carbon dioxide is implemented as a * - ! * trace species, this is the factor used to multiply the * - ! * band's average CO2 absorption coefficient to get the added * - ! * contribution to the optical depth relative to 355 ppm. * - ! * FACij(LAY) - for layer LAY, these are factors that are needed to * - ! * compute the interpolation factors that multiply the * - ! * appropriate reference k-values. A value of 0 (1) for * - ! * i,j indicates that the corresponding factor multiplies * - ! * reference k-value for the lower (higher) of the two * - ! * appropriate temperatures, and altitudes, respectively. * - ! * JP - the index of the lower (in altitude) of the two appropriate * - ! * reference pressure levels needed for interpolation * - ! * JT, JT1 - the indices of the lower of the two appropriate reference * - ! * temperatures needed for interpolation (for pressure * - ! * levels JP and JP+1, respectively) * - ! * SELFFAC - scale factor needed to water vapor self-continuum, equals * - ! * (water vapor density)/(atmospheric density at 296K and * - ! * 1013 mb) * - ! * SELFFRAC - factor needed for temperature interpolation of reference * - ! * water vapor self-continuum data * - ! * INDSELF - index of the lower of the two appropriate reference * - ! * temperatures needed for the self-continuum interpolation * - ! * * - ! * Data input * - ! * COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG) * - ! * (note: n is the band number) * - ! * * - ! * Description: * - ! * KA - k-values for low reference atmospheres (no water vapor * - ! * self-continuum) (units: cm**2/molecule) * - ! * KB - k-values for high reference atmospheres (all sources) * - ! * (units: cm**2/molecule) * - ! * SELFREF - k-values for water vapor self-continuum for reference * - ! * atmospheres (used below LAYTROP) * - ! * (units: cm**2/molecule) * - ! * * - ! * DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG) * - ! * EQUIVALENCE (KA,ABSA),(KB,ABSB) * - ! * * - ! ***************************************************************************** - ! - ! Modifications - ! - ! Revised: Adapted to F90 coding, J.-J.Morcrette, ECMWF, Feb 2003 - ! Revised: Modified for g-point reduction, MJIacono, AER, Dec 2003 - ! Revised: Reformatted for consistency with rrtmg_lw, MJIacono, AER, Jul 2006 - ! - ! ------- Declarations ------- - ! ----- Input ----- - INTEGER, intent(in) :: nlayers ! total number of layers - INTEGER, intent(in) :: ncol ! total number of layers - INTEGER, intent(in) :: laytrop(ncol) ! tropopause layer index - INTEGER, intent(in) :: jp(ncol,nlayers) ! - !INTEGER, intent(in) :: nlayers ! total number of layers - ! Dimensions: (nlayers) - INTEGER, intent(in) :: jt(ncol,nlayers) ! - ! Dimensions: (nlayers) - INTEGER, intent(in) :: jt1(ncol,nlayers) ! - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: colh2o(ncol,nlayers) ! column amount (h2o) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: colco2(ncol,nlayers) ! column amount (co2) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: colo3(ncol,nlayers) ! column amount (o3) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: colch4(ncol,nlayers) ! column amount (ch4) - ! Dimensions: (nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: colo2(ncol,nlayers) ! column amount (o2) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: colmol(ncol,nlayers) ! - ! Dimensions: (nlayers) - INTEGER, intent(in) :: indself(ncol,nlayers) - ! Dimensions: (nlayers) - INTEGER, intent(in) :: indfor(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: selffac(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: selffrac(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: forfac(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: forfrac(ncol,nlayers) - ! Dimensions: (nlayers) - REAL(KIND=r8), intent(in) :: fac01(ncol,nlayers) - REAL(KIND=r8), intent(in) :: fac10(ncol,nlayers) - REAL(KIND=r8), intent(in) :: fac11(ncol,nlayers) - REAL(KIND=r8), intent(in) :: fac00(ncol,nlayers) ! - ! Dimensions: (nlayers) - ! ----- Output ----- - REAL(KIND=r8), intent(out) :: sfluxzen(:,:) ! solar source function - ! Dimensions: (ngptsw) - REAL(KIND=r8), intent(out) :: taug(:,:,:) ! gaseous optical depth - ! Dimensions: (nlayers,ngptsw) - REAL(KIND=r8), intent(out) :: taur(:,:,:) ! Rayleigh - INTEGER :: icol - ! Dimensions: (nlayers,ngptsw) - ! real(kind=r8), intent(out) :: ssa(:,:) ! single scattering albedo (inactive) - ! Dimensions: (nlayers,ngptsw) - hvrtau = '$Revision: 1.2 $' - call taumol16() - call taumol17 - call taumol18 - call taumol19 - call taumol20 - call taumol21 - call taumol22 - call taumol23 - call taumol24 - call taumol25 - call taumol26 - call taumol27 - call taumol28 - call taumol29 - !------------- - CONTAINS - !------------- - !---------------------------------------------------------------------------- - - SUBROUTINE taumol16() - !---------------------------------------------------------------------------- - ! - ! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng16 - USE rrsw_kg16, ONLY: strrat1 - USE rrsw_kg16, ONLY: rayl - USE rrsw_kg16, ONLY: forref - USE rrsw_kg16, ONLY: absa - USE rrsw_kg16, ONLY: selfref - USE rrsw_kg16, ONLY: layreffr - USE rrsw_kg16, ONLY: absb - USE rrsw_kg16, ONLY: sfluxref - ! ------- Declarations ------- - !INTEGER, intent(in) ::ncol ! total number of layers - ! Local - INTEGER :: lay - INTEGER :: js - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - INTEGER :: laysolfr - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - !print*,"taumol 16 :: before lay loop" - do icol=1,ncol - do lay = 1, laytrop(icol) - !print*,'inside lay loop' - speccomb = colh2o(icol,lay) + strrat1*colch4(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(16) + js - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(16) + js - inds = indself(icol,lay) - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng16 - taug(icol,lay,ig) = speccomb * & - (fac000 * absa(ind0 ,ig) + & - fac100 * absa(ind0 +1,ig) + & - fac010 * absa(ind0 +9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac001 * absa(ind1 ,ig) + & - fac101 * absa(ind1 +1,ig) + & - fac011 * absa(ind1 +9,ig) + & - fac111 * absa(ind1+10,ig)) + & - colh2o(icol,lay) * & - (selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) - ! ssa(lay,ig) = tauray/taug(lay,ig) - taur(icol,lay,ig) = tauray - enddo - enddo - laysolfr = nlayers - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - if (jp(icol,(lay-1)) .lt. layreffr .and. jp(icol,lay) .ge. layreffr) & - laysolfr = lay - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(16) + 1 - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(16) + 1 - tauray = colmol(icol,lay) * rayl - do ig = 1, ng16 - taug(icol,lay,ig) = colch4(icol,lay) * & - (fac00(icol,lay) * absb(ind0 ,ig) + & - fac10(icol,lay) * absb(ind0+1,ig) + & - fac01(icol,lay) * absb(ind1 ,ig) + & - fac11(icol,lay) * absb(ind1+1,ig)) - ! ssa(lay,ig) = tauray/taug(lay,ig) - if (lay .eq. laysolfr) sfluxzen(icol,ig) = sfluxref(ig) - taur(icol,lay,ig) = tauray - enddo - enddo - end do - END SUBROUTINE taumol16 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol17() - !---------------------------------------------------------------------------- - ! - ! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng17 - USE parrrsw, ONLY: ngs16 - USE rrsw_kg17, ONLY: strrat - USE rrsw_kg17, ONLY: rayl - USE rrsw_kg17, ONLY: absa - USE rrsw_kg17, ONLY: selfref - USE rrsw_kg17, ONLY: forref - USE rrsw_kg17, ONLY: layreffr - USE rrsw_kg17, ONLY: absb - USE rrsw_kg17, ONLY: sfluxref - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: js - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - INTEGER :: laysolfr - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - do icol=1,ncol - do lay = 1, laytrop(icol) - speccomb = colh2o(icol,lay) + strrat*colco2(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(17) + js - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(17) + js - inds = indself(icol,lay) - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng17 - taug(icol,lay,ngs16+ig) = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) + & - colh2o(icol,lay) * & - (selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) - ! ssa(lay,ngs16+ig) = tauray/taug(lay,ngs16+ig) - taur(icol,lay,ngs16+ig) = tauray - enddo - enddo - laysolfr = nlayers - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - if (jp(icol,lay-1) .lt. layreffr .and. jp(icol,lay) .ge. layreffr) & - laysolfr = lay - speccomb = colh2o(icol,lay) + strrat*colco2(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 4._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(17) + js - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(17) + js - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng17 - taug(icol,lay,ngs16+ig) = speccomb * & - (fac000 * absb(ind0,ig) + & - fac100 * absb(ind0+1,ig) + & - fac010 * absb(ind0+5,ig) + & - fac110 * absb(ind0+6,ig) + & - fac001 * absb(ind1,ig) + & - fac101 * absb(ind1+1,ig) + & - fac011 * absb(ind1+5,ig) + & - fac111 * absb(ind1+6,ig)) + & - colh2o(icol,lay) * & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig))) - ! ssa(lay,ngs16+ig) = tauray/taug(lay,ngs16+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs16+ig) = sfluxref(ig,js) & - + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) - taur(icol,lay,ngs16+ig) = tauray - enddo - enddo - enddo - END SUBROUTINE taumol17 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol18() - !---------------------------------------------------------------------------- - ! - ! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng18 - USE parrrsw, ONLY: ngs17 - USE rrsw_kg18, ONLY: layreffr - USE rrsw_kg18, ONLY: strrat - USE rrsw_kg18, ONLY: rayl - USE rrsw_kg18, ONLY: forref - USE rrsw_kg18, ONLY: absa - USE rrsw_kg18, ONLY: selfref - USE rrsw_kg18, ONLY: sfluxref - USE rrsw_kg18, ONLY: absb - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: js - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - do icol=1,ncol - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & - laysolfr = min(lay+1,laytrop(icol)) - speccomb = colh2o(icol,lay) + strrat*colch4(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(18) + js - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(18) + js - inds = indself(icol,lay) - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng18 - taug(icol,lay,ngs17+ig) = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) + & - colh2o(icol,lay) * & - (selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) - ! ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs17+ig) = sfluxref(ig,js) & - + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) - taur(icol,lay,ngs17+ig) = tauray - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(18) + 1 - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(18) + 1 - tauray = colmol(icol,lay) * rayl - do ig = 1, ng18 - taug(icol,lay,ngs17+ig) = colch4(icol,lay) * & - (fac00(icol,lay) * absb(ind0,ig) + & - fac10(icol,lay) * absb(ind0+1,ig) + & - fac01(icol,lay) * absb(ind1,ig) + & - fac11(icol,lay) * absb(ind1+1,ig)) - ! ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig) - taur(icol,lay,ngs17+ig) = tauray - enddo - enddo - enddo - END SUBROUTINE taumol18 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol19() - !---------------------------------------------------------------------------- - ! - ! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng19 - USE parrrsw, ONLY: ngs18 - USE rrsw_kg19, ONLY: layreffr - USE rrsw_kg19, ONLY: strrat - USE rrsw_kg19, ONLY: rayl - USE rrsw_kg19, ONLY: selfref - USE rrsw_kg19, ONLY: absa - USE rrsw_kg19, ONLY: forref - USE rrsw_kg19, ONLY: sfluxref - USE rrsw_kg19, ONLY: absb - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: js - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - do icol=1,ncol - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & - laysolfr = min(lay+1,laytrop(icol)) - speccomb = colh2o(icol,lay) + strrat*colco2(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(19) + js - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(19) + js - inds = indself(icol,lay) - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1 , ng19 - taug(icol,lay,ngs18+ig) = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) + & - colh2o(icol,lay) * & - (selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) - ! ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs18+ig) = sfluxref(ig,js) & - + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) - taur(icol,lay,ngs18+ig) = tauray - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(19) + 1 - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(19) + 1 - tauray = colmol(icol,lay) * rayl - do ig = 1 , ng19 - taug(icol,lay,ngs18+ig) = colco2(icol,lay) * & - (fac00(icol,lay) * absb(ind0,ig) + & - fac10(icol,lay) * absb(ind0+1,ig) + & - fac01(icol,lay) * absb(ind1,ig) + & - fac11(icol,lay) * absb(ind1+1,ig)) - ! ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig) - taur(icol,lay,ngs18+ig) = tauray - enddo - enddo - enddo - END SUBROUTINE taumol19 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol20() - !---------------------------------------------------------------------------- - ! - ! band 20: 5150-6150 cm-1 (low - h2o; high - h2o) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng20 - USE parrrsw, ONLY: ngs19 - USE rrsw_kg20, ONLY: layreffr - USE rrsw_kg20, ONLY: rayl - USE rrsw_kg20, ONLY: absch4 - USE rrsw_kg20, ONLY: forref - USE rrsw_kg20, ONLY: absa - USE rrsw_kg20, ONLY: selfref - USE rrsw_kg20, ONLY: sfluxref - USE rrsw_kg20, ONLY: absb - IMPLICIT NONE - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - do icol=1,ncol - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & - laysolfr = min(lay+1,laytrop(icol)) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(20) + 1 - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(20) + 1 - inds = indself(icol,lay) - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng20 - taug(icol,lay,ngs19+ig) = colh2o(icol,lay) * & - ((fac00(icol,lay) * absa(ind0,ig) + & - fac10(icol,lay) * absa(ind0+1,ig) + & - fac01(icol,lay) * absa(ind1,ig) + & - fac11(icol,lay) * absa(ind1+1,ig)) + & - selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) & - + colch4(icol,lay) * absch4(ig) - ! ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig) - taur(icol,lay,ngs19+ig) = tauray - if (lay .eq. laysolfr) sfluxzen(icol,ngs19+ig) = sfluxref(ig) - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(20) + 1 - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(20) + 1 - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng20 - taug(icol,lay,ngs19+ig) = colh2o(icol,lay) * & - (fac00(icol,lay) * absb(ind0,ig) + & - fac10(icol,lay) * absb(ind0+1,ig) + & - fac01(icol,lay) * absb(ind1,ig) + & - fac11(icol,lay) * absb(ind1+1,ig) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) + & - colch4(icol,lay) * absch4(ig) - ! ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig) - taur(icol,lay,ngs19+ig) = tauray - enddo - enddo - enddo - END SUBROUTINE taumol20 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol21() - !---------------------------------------------------------------------------- - ! - ! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng21 - USE parrrsw, ONLY: ngs20 - USE rrsw_kg21, ONLY: layreffr - USE rrsw_kg21, ONLY: strrat - USE rrsw_kg21, ONLY: rayl - USE rrsw_kg21, ONLY: forref - USE rrsw_kg21, ONLY: absa - USE rrsw_kg21, ONLY: selfref - USE rrsw_kg21, ONLY: sfluxref - USE rrsw_kg21, ONLY: absb - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: js - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - do icol=1,ncol - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & - laysolfr = min(lay+1,laytrop(icol)) - speccomb = colh2o(icol,lay) + strrat*colco2(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(21) + js - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(21) + js - inds = indself(icol,lay) - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng21 - taug(icol,lay,ngs20+ig) = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) + & - colh2o(icol,lay) * & - (selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) - ! ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs20+ig) = sfluxref(ig,js) & - + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) - taur(icol,lay,ngs20+ig) = tauray - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - speccomb = colh2o(icol,lay) + strrat*colco2(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 4._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(21) + js - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(21) + js - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng21 - taug(icol,lay,ngs20+ig) = speccomb * & - (fac000 * absb(ind0,ig) + & - fac100 * absb(ind0+1,ig) + & - fac010 * absb(ind0+5,ig) + & - fac110 * absb(ind0+6,ig) + & - fac001 * absb(ind1,ig) + & - fac101 * absb(ind1+1,ig) + & - fac011 * absb(ind1+5,ig) + & - fac111 * absb(ind1+6,ig)) + & - colh2o(icol,lay) * & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig))) - ! ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig) - taur(icol,lay,ngs20+ig) = tauray - enddo - enddo - enddo - END SUBROUTINE taumol21 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol22() - !---------------------------------------------------------------------------- - ! - ! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng22 - USE parrrsw, ONLY: ngs21 - USE rrsw_kg22, ONLY: layreffr - USE rrsw_kg22, ONLY: strrat - USE rrsw_kg22, ONLY: rayl - USE rrsw_kg22, ONLY: forref - USE rrsw_kg22, ONLY: absa - USE rrsw_kg22, ONLY: selfref - USE rrsw_kg22, ONLY: sfluxref - USE rrsw_kg22, ONLY: absb - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: js - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - REAL(KIND=r8) :: o2adj - REAL(KIND=r8) :: o2cont - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: tauray - ! The following factor is the ratio of total O2 band intensity (lines - ! and Mate continuum) to O2 band intensity (line only). It is needed - ! to adjust the optical depths since the k's include only lines. - o2adj = 1.6_r8 - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - do icol=1,ncol - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & - laysolfr = min(lay+1,laytrop(icol)) - o2cont = 4.35e-4_r8*colo2(icol,lay)/(350.0_r8*2.0_r8) - speccomb = colh2o(icol,lay) + o2adj*strrat*colo2(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - ! odadj = specparm + o2adj * (1._r8 - specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(22) + js - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(22) + js - inds = indself(icol,lay) - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng22 - taug(icol,lay,ngs21+ig) = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) + & - colh2o(icol,lay) * & - (selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) & - + o2cont - ! ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs21+ig) = sfluxref(ig,js) & - + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) - taur(icol,lay,ngs21+ig) = tauray - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - o2cont = 4.35e-4_r8*colo2(icol,lay)/(350.0_r8*2.0_r8) - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(22) + 1 - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(22) + 1 - tauray = colmol(icol,lay) * rayl - do ig = 1, ng22 - taug(icol,lay,ngs21+ig) = colo2(icol,lay) * o2adj * & - (fac00(icol,lay) * absb(ind0,ig) + & - fac10(icol,lay) * absb(ind0+1,ig) + & - fac01(icol,lay) * absb(ind1,ig) + & - fac11(icol,lay) * absb(ind1+1,ig)) + & - o2cont - ! ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig) - taur(icol,lay,ngs21+ig) = tauray - enddo - enddo - enddo - END SUBROUTINE taumol22 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol23() - !---------------------------------------------------------------------------- - ! - ! band 23: 8050-12850 cm-1 (low - h2o; high - nothing) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng23 - USE parrrsw, ONLY: ngs22 - USE rrsw_kg23, ONLY: layreffr - USE rrsw_kg23, ONLY: rayl - USE rrsw_kg23, ONLY: absa - USE rrsw_kg23, ONLY: givfac - USE rrsw_kg23, ONLY: forref - USE rrsw_kg23, ONLY: selfref - USE rrsw_kg23, ONLY: sfluxref - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - do icol=1,ncol - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & - laysolfr = min(lay+1,laytrop(icol)) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(23) + 1 - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(23) + 1 - inds = indself(icol,lay) - indf = indfor(icol,lay) - do ig = 1, ng23 - tauray = colmol(icol,lay) * rayl(ig) - taug(icol,lay,ngs22+ig) = colh2o(icol,lay) * & - (givfac * (fac00(icol,lay) * absa(ind0,ig) + & - fac10(icol,lay) * absa(ind0+1,ig) + & - fac01(icol,lay) * absa(ind1,ig) + & - fac11(icol,lay) * absa(ind1+1,ig)) + & - selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) - ! ssa(lay,ngs22+ig) = tauray/taug(lay,ngs22+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs22+ig) = sfluxref(ig) - taur(icol,lay,ngs22+ig) = tauray - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - do ig = 1, ng23 - ! taug(lay,ngs22+ig) = colmol(icol,lay) * rayl(ig) - ! ssa(lay,ngs22+ig) = 1.0_r8 - taug(icol,lay,ngs22+ig) = 0._r8 - taur(icol,lay,ngs22+ig) = colmol(icol,lay) * rayl(ig) - enddo - enddo - enddo - END SUBROUTINE taumol23 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol24() - !---------------------------------------------------------------------------- - ! - ! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng24 - USE parrrsw, ONLY: ngs23 - USE rrsw_kg24, ONLY: layreffr - USE rrsw_kg24, ONLY: strrat - USE rrsw_kg24, ONLY: rayla - USE rrsw_kg24, ONLY: absa - USE rrsw_kg24, ONLY: forref - USE rrsw_kg24, ONLY: selfref - USE rrsw_kg24, ONLY: abso3a - USE rrsw_kg24, ONLY: sfluxref - USE rrsw_kg24, ONLY: raylb - USE rrsw_kg24, ONLY: absb - USE rrsw_kg24, ONLY: abso3b - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: js - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - do icol=1,ncol - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & - laysolfr = min(lay+1,laytrop(icol)) - speccomb = colh2o(icol,lay) + strrat*colo2(icol,lay) - specparm = colh2o(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(24) + js - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(24) + js - inds = indself(icol,lay) - indf = indfor(icol,lay) - do ig = 1, ng24 - tauray = colmol(icol,lay) * (rayla(ig,js) + & - fs * (rayla(ig,js+1) - rayla(ig,js))) - taug(icol,lay,ngs23+ig) = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) + & - colo3(icol,lay) * abso3a(ig) + & - colh2o(icol,lay) * & - (selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) - ! ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs23+ig) = sfluxref(ig,js) & - + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) - taur(icol,lay,ngs23+ig) = tauray - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(24) + 1 - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(24) + 1 - do ig = 1, ng24 - tauray = colmol(icol,lay) * raylb(ig) - taug(icol,lay,ngs23+ig) = colo2(icol,lay) * & - (fac00(icol,lay) * absb(ind0,ig) + & - fac10(icol,lay) * absb(ind0+1,ig) + & - fac01(icol,lay) * absb(ind1,ig) + & - fac11(icol,lay) * absb(ind1+1,ig)) + & - colo3(icol,lay) * abso3b(ig) - ! ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig) - taur(icol,lay,ngs23+ig) = tauray - enddo - enddo - enddo - END SUBROUTINE taumol24 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol25() - !---------------------------------------------------------------------------- - ! - ! band 25: 16000-22650 cm-1 (low - h2o; high - nothing) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng25 - USE parrrsw, ONLY: ngs24 - USE rrsw_kg25, ONLY: layreffr - USE rrsw_kg25, ONLY: rayl - USE rrsw_kg25, ONLY: abso3a - USE rrsw_kg25, ONLY: absa - USE rrsw_kg25, ONLY: sfluxref - USE rrsw_kg25, ONLY: abso3b - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: ig - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - do icol=1,ncol - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & - laysolfr = min(lay+1,laytrop(icol)) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(25) + 1 - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(25) + 1 - do ig = 1, ng25 - tauray = colmol(icol,lay) * rayl(ig) - taug(icol,lay,ngs24+ig) = colh2o(icol,lay) * & - (fac00(icol,lay) * absa(ind0,ig) + & - fac10(icol,lay) * absa(ind0+1,ig) + & - fac01(icol,lay) * absa(ind1,ig) + & - fac11(icol,lay) * absa(ind1+1,ig)) + & - colo3(icol,lay) * abso3a(ig) - ! ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs24+ig) = sfluxref(ig) - taur(icol,lay,ngs24+ig) = tauray - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - do ig = 1, ng25 - tauray = colmol(icol,lay) * rayl(ig) - taug(icol,lay,ngs24+ig) = colo3(icol,lay) * abso3b(ig) - ! ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig) - taur(icol,lay,ngs24+ig) = tauray - enddo - enddo - enddo - END SUBROUTINE taumol25 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol26() - !---------------------------------------------------------------------------- - ! - ! band 26: 22650-29000 cm-1 (low - nothing; high - nothing) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng26 - USE parrrsw, ONLY: ngs25 - USE rrsw_kg26, ONLY: sfluxref - USE rrsw_kg26, ONLY: rayl - ! ------- Declarations ------- - ! Local - INTEGER :: laysolfr - INTEGER :: lay - INTEGER :: ig - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - do icol=1,ncol - laysolfr = laytrop(icol) - ! Lower atmosphere loop - do lay = 1, laytrop(icol) - do ig = 1, ng26 - ! taug(lay,ngs25+ig) = colmol(icol,lay) * rayl(ig) - ! ssa(lay,ngs25+ig) = 1.0_r8 - if (lay .eq. laysolfr) sfluxzen(icol,ngs25+ig) = sfluxref(ig) - taug(icol,lay,ngs25+ig) = 0._r8 - taur(icol,lay,ngs25+ig) = colmol(icol,lay) * rayl(ig) - enddo - enddo - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - do ig = 1, ng26 - ! taug(lay,ngs25+ig) = colmol(icol,lay) * rayl(ig) - ! ssa(lay,ngs25+ig) = 1.0_r8 - taug(icol,lay,ngs25+ig) = 0._r8 - taur(icol,lay,ngs25+ig) = colmol(icol,lay) * rayl(ig) - enddo - enddo - enddo - END SUBROUTINE taumol26 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol27() - !---------------------------------------------------------------------------- - ! - ! band 27: 29000-38000 cm-1 (low - o3; high - o3) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng27 - USE parrrsw, ONLY: ngs26 - USE rrsw_kg27, ONLY: rayl - USE rrsw_kg27, ONLY: absa - USE rrsw_kg27, ONLY: layreffr - USE rrsw_kg27, ONLY: absb - USE rrsw_kg27, ONLY: scalekur - USE rrsw_kg27, ONLY: sfluxref - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: ig - INTEGER :: laysolfr - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - do icol=1,ncol - do lay = 1, laytrop(icol) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(27) + 1 - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(27) + 1 - do ig = 1, ng27 - tauray = colmol(icol,lay) * rayl(ig) - taug(icol,lay,ngs26+ig) = colo3(icol,lay) * & - (fac00(icol,lay) * absa(ind0,ig) + & - fac10(icol,lay) * absa(ind0+1,ig) + & - fac01(icol,lay) * absa(ind1,ig) + & - fac11(icol,lay) * absa(ind1+1,ig)) - ! ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig) - taur(icol,lay,ngs26+ig) = tauray - enddo - enddo - laysolfr = nlayers - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - if (jp(icol,lay-1) .lt. layreffr .and. jp(icol,lay) .ge. layreffr) & - laysolfr = lay - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(27) + 1 - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(27) + 1 - do ig = 1, ng27 - tauray = colmol(icol,lay) * rayl(ig) - taug(icol,lay,ngs26+ig) = colo3(icol,lay) * & - (fac00(icol,lay) * absb(ind0,ig) + & - fac10(icol,lay) * absb(ind0+1,ig) + & - fac01(icol,lay) * absb(ind1,ig) + & - fac11(icol,lay) * absb(ind1+1,ig)) - ! ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig) - if (lay.eq.laysolfr) sfluxzen(icol,ngs26+ig) = scalekur * sfluxref(ig) - taur(icol,lay,ngs26+ig) = tauray - enddo - enddo - enddo - END SUBROUTINE taumol27 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol28() - !---------------------------------------------------------------------------- - ! - ! band 28: 38000-50000 cm-1 (low - o3,o2; high - o3,o2) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng28 - USE parrrsw, ONLY: ngs27 - USE rrsw_kg28, ONLY: strrat - USE rrsw_kg28, ONLY: rayl - USE rrsw_kg28, ONLY: absa - USE rrsw_kg28, ONLY: layreffr - USE rrsw_kg28, ONLY: absb - USE rrsw_kg28, ONLY: sfluxref - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: js - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: ig - INTEGER :: laysolfr - REAL(KIND=r8) :: speccomb - REAL(KIND=r8) :: specparm - REAL(KIND=r8) :: specmult - REAL(KIND=r8) :: fs - REAL(KIND=r8) :: fac000 - REAL(KIND=r8) :: fac010 - REAL(KIND=r8) :: fac100 - REAL(KIND=r8) :: fac110 - REAL(KIND=r8) :: fac001 - REAL(KIND=r8) :: fac011 - REAL(KIND=r8) :: fac101 - REAL(KIND=r8) :: fac111 - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - do icol=1,ncol - do lay = 1, laytrop(icol) - speccomb = colo3(icol,lay) + strrat*colo2(icol,lay) - specparm = colo3(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 8._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(28) + js - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(28) + js - tauray = colmol(icol,lay) * rayl - do ig = 1, ng28 - taug(icol,lay,ngs27+ig) = speccomb * & - (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + & - fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig) + & - fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + & - fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - ! ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig) - taur(icol,lay,ngs27+ig) = tauray - enddo - enddo - laysolfr = nlayers - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - if (jp(icol,lay-1) .lt. layreffr .and. jp(icol,lay) .ge. layreffr) & - laysolfr = lay - speccomb = colo3(icol,lay) + strrat*colo2(icol,lay) - specparm = colo3(icol,lay)/speccomb - if (specparm .ge. oneminus) specparm = oneminus - specmult = 4._r8*(specparm) - js = 1 + int(specmult) - fs = mod(specmult, 1._r8 ) - fac000 = (1._r8 - fs) * fac00(icol,lay) - fac010 = (1._r8 - fs) * fac10(icol,lay) - fac100 = fs * fac00(icol,lay) - fac110 = fs * fac10(icol,lay) - fac001 = (1._r8 - fs) * fac01(icol,lay) - fac011 = (1._r8 - fs) * fac11(icol,lay) - fac101 = fs * fac01(icol,lay) - fac111 = fs * fac11(icol,lay) - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(28) + js - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(28) + js - tauray = colmol(icol,lay) * rayl - do ig = 1, ng28 - taug(icol,lay,ngs27+ig) = speccomb * & - (fac000 * absb(ind0,ig) + & - fac100 * absb(ind0+1,ig) + & - fac010 * absb(ind0+5,ig) + & - fac110 * absb(ind0+6,ig) + & - fac001 * absb(ind1,ig) + & - fac101 * absb(ind1+1,ig) + & - fac011 * absb(ind1+5,ig) + & - fac111 * absb(ind1+6,ig)) - ! ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs27+ig) = sfluxref(ig,js) & - + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) - taur(icol,lay,ngs27+ig) = tauray - enddo - enddo - enddo - END SUBROUTINE taumol28 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol29() - !---------------------------------------------------------------------------- - ! - ! band 29: 820-2600 cm-1 (low - h2o; high - co2) - ! - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE parrrsw, ONLY: ng29 - USE parrrsw, ONLY: ngs28 - USE rrsw_kg29, ONLY: rayl - USE rrsw_kg29, ONLY: forref - USE rrsw_kg29, ONLY: absa - USE rrsw_kg29, ONLY: absco2 - USE rrsw_kg29, ONLY: selfref - USE rrsw_kg29, ONLY: layreffr - USE rrsw_kg29, ONLY: absh2o - USE rrsw_kg29, ONLY: absb - USE rrsw_kg29, ONLY: sfluxref - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: ig - INTEGER :: laysolfr - REAL(KIND=r8) :: tauray - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below LAYTROP, the water - ! vapor self-continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - do icol=1,ncol - do lay = 1, laytrop(icol) - ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(29) + 1 - ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(29) + 1 - inds = indself(icol,lay) - indf = indfor(icol,lay) - tauray = colmol(icol,lay) * rayl - do ig = 1, ng29 - taug(icol,lay,ngs28+ig) = colh2o(icol,lay) * & - ((fac00(icol,lay) * absa(ind0,ig) + & - fac10(icol,lay) * absa(ind0+1,ig) + & - fac01(icol,lay) * absa(ind1,ig) + & - fac11(icol,lay) * absa(ind1+1,ig)) + & - selffac(icol,lay) * (selfref(inds,ig) + & - selffrac(icol,lay) * & - (selfref(inds+1,ig) - selfref(inds,ig))) + & - forfac(icol,lay) * (forref(indf,ig) + & - forfrac(icol,lay) * & - (forref(indf+1,ig) - forref(indf,ig)))) & - + colco2(icol,lay) * absco2(ig) - ! ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig) - taur(icol,lay,ngs28+ig) = tauray - enddo - enddo - laysolfr = nlayers - ! Upper atmosphere loop - do lay = laytrop(icol)+1, nlayers - if (jp(icol,lay-1) .lt. layreffr .and. jp(icol,lay) .ge. layreffr) & - laysolfr = lay - ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(29) + 1 - ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(29) + 1 - tauray = colmol(icol,lay) * rayl - do ig = 1, ng29 - taug(icol,lay,ngs28+ig) = colco2(icol,lay) * & - (fac00(icol,lay) * absb(ind0,ig) + & - fac10(icol,lay) * absb(ind0+1,ig) + & - fac01(icol,lay) * absb(ind1,ig) + & - fac11(icol,lay) * absb(ind1+1,ig)) & - + colh2o(icol,lay) * absh2o(ig) - ! ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig) - if (lay .eq. laysolfr) sfluxzen(icol,ngs28+ig) = sfluxref(ig) - taur(icol,lay,ngs28+ig) = tauray - enddo - enddo - enddo - END SUBROUTINE taumol29 - END SUBROUTINE taumol_sw - END MODULE rrtmg_sw_taumol diff --git a/test/ncar_kernels/PORT_sw_taumols/src/shr_kind_mod.f90 b/test/ncar_kernels/PORT_sw_taumols/src/shr_kind_mod.f90 deleted file mode 100644 index 15253abfcd..0000000000 --- a/test/ncar_kernels/PORT_sw_taumols/src/shr_kind_mod.f90 +++ /dev/null @@ -1,26 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : shr_kind_mod.f90 -! Generated at: 2015-07-31 20:45:42 -! KGEN version: 0.4.13 - - - - MODULE shr_kind_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - PUBLIC - INTEGER, parameter :: shr_kind_r8 = selected_real_kind(12) ! 8 byte real - ! 4 byte real - ! native real - ! 8 byte integer - ! 4 byte integer - ! native integer - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE shr_kind_mod diff --git a/test/ncar_kernels/PORT_sw_vrtqdr/CESM_license.txt b/test/ncar_kernels/PORT_sw_vrtqdr/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/PORT_sw_vrtqdr/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/PORT_sw_vrtqdr/data/vrtqdr_sw.1.1 b/test/ncar_kernels/PORT_sw_vrtqdr/data/vrtqdr_sw.1.1 deleted file mode 100644 index 7da330521b..0000000000 Binary files a/test/ncar_kernels/PORT_sw_vrtqdr/data/vrtqdr_sw.1.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_vrtqdr/data/vrtqdr_sw.1.4 b/test/ncar_kernels/PORT_sw_vrtqdr/data/vrtqdr_sw.1.4 deleted file mode 100644 index 113d94e53e..0000000000 Binary files a/test/ncar_kernels/PORT_sw_vrtqdr/data/vrtqdr_sw.1.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_vrtqdr/data/vrtqdr_sw.1.8 b/test/ncar_kernels/PORT_sw_vrtqdr/data/vrtqdr_sw.1.8 deleted file mode 100644 index f3ca5c03d0..0000000000 Binary files a/test/ncar_kernels/PORT_sw_vrtqdr/data/vrtqdr_sw.1.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_vrtqdr/data/vrtqdr_sw.5.1 b/test/ncar_kernels/PORT_sw_vrtqdr/data/vrtqdr_sw.5.1 deleted file mode 100644 index 68a6e5d55b..0000000000 Binary files a/test/ncar_kernels/PORT_sw_vrtqdr/data/vrtqdr_sw.5.1 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_vrtqdr/data/vrtqdr_sw.5.4 b/test/ncar_kernels/PORT_sw_vrtqdr/data/vrtqdr_sw.5.4 deleted file mode 100644 index a7551ef321..0000000000 Binary files a/test/ncar_kernels/PORT_sw_vrtqdr/data/vrtqdr_sw.5.4 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_vrtqdr/data/vrtqdr_sw.5.8 b/test/ncar_kernels/PORT_sw_vrtqdr/data/vrtqdr_sw.5.8 deleted file mode 100644 index bbbb887bf1..0000000000 Binary files a/test/ncar_kernels/PORT_sw_vrtqdr/data/vrtqdr_sw.5.8 and /dev/null differ diff --git a/test/ncar_kernels/PORT_sw_vrtqdr/inc/t1.mk b/test/ncar_kernels/PORT_sw_vrtqdr/inc/t1.mk deleted file mode 100644 index 5636756f5b..0000000000 --- a/test/ncar_kernels/PORT_sw_vrtqdr/inc/t1.mk +++ /dev/null @@ -1,67 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# Intel default flags -# -# FC_FLAGS := -O2 -fp-model source -convert big_endian -assume byterecl -# -ftz -traceback -assume realloc_lhs -xAVX -# -# Makefile for KGEN-generated kernel -FC_FLAGS := $(OPT) - -ifeq ("$(FC)", "pgf90") -endif -ifeq ("$(FC)", "pgfortran") -endif -ifeq ("$(FC)", "flang") -endif -ifeq ("$(FC)", "gfortran") -endif -ifeq ("$(FC)", "ifort") -endif -ifeq ("$(FC)", "xlf") -endif - - - -ALL_OBJS := kernel_driver.o rrtmg_sw_spcvmc.o kgen_utils.o rrtmg_sw_vrtqdr.o shr_kind_mod.o parrrsw.o - -verify: - @(grep "verification.FAIL" $(TEST).rslt && echo "FAILED") || (grep "verification.PASS" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 rrtmg_sw_spcvmc.o kgen_utils.o rrtmg_sw_vrtqdr.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_sw_spcvmc.o: $(SRC_DIR)/rrtmg_sw_spcvmc.f90 kgen_utils.o rrtmg_sw_vrtqdr.o shr_kind_mod.o parrrsw.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -rrtmg_sw_vrtqdr.o: $(SRC_DIR)/rrtmg_sw_vrtqdr.f90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_kind_mod.o: $(SRC_DIR)/shr_kind_mod.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -parrrsw.o: $(SRC_DIR)/parrrsw.f90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -kgen_utils.o: $(SRC_DIR)/kgen_utils.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.rslt diff --git a/test/ncar_kernels/PORT_sw_vrtqdr/lit/runmake b/test/ncar_kernels/PORT_sw_vrtqdr/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/PORT_sw_vrtqdr/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/PORT_sw_vrtqdr/lit/t1.sh b/test/ncar_kernels/PORT_sw_vrtqdr/lit/t1.sh deleted file mode 100644 index 33c953a156..0000000000 --- a/test/ncar_kernels/PORT_sw_vrtqdr/lit/t1.sh +++ /dev/null @@ -1,9 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -# Shared lit script for each tests. Run bash commands that run tests with make. - -# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t -# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/PORT_sw_vrtqdr/makefile b/test/ncar_kernels/PORT_sw_vrtqdr/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/PORT_sw_vrtqdr/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/PORT_sw_vrtqdr/src/kernel_driver.f90 b/test/ncar_kernels/PORT_sw_vrtqdr/src/kernel_driver.f90 deleted file mode 100644 index 04aa111b85..0000000000 --- a/test/ncar_kernels/PORT_sw_vrtqdr/src/kernel_driver.f90 +++ /dev/null @@ -1,79 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-07-31 21:01:00 -! KGEN version: 0.4.13 - - -PROGRAM kernel_driver - USE rrtmg_sw_spcvmc, ONLY : spcvmc_sw - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - - IMPLICIT NONE - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_mpi_rank_at = (/ 1, 4, 8 /) - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(2), PARAMETER :: kgen_counter_at = (/ 1, 5 /) - CHARACTER(LEN=1024) :: kgen_filepath - INTEGER :: nlayers - INTEGER :: ncol - - DO kgen_repeat_counter = 0,5 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 2)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - kgen_filepath = "../data/vrtqdr_sw." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "** Verification against '" // trim(adjustl(kgen_filepath)) // "' **" - - - ! driver variables - READ(UNIT=kgen_unit) nlayers - READ(UNIT=kgen_unit) ncol - - call spcvmc_sw(nlayers, ncol, kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! write subroutines - ! No subroutines - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/PORT_sw_vrtqdr/src/kgen_utils.f90 b/test/ncar_kernels/PORT_sw_vrtqdr/src/kgen_utils.f90 deleted file mode 100644 index cfa8d114e0..0000000000 --- a/test/ncar_kernels/PORT_sw_vrtqdr/src/kgen_utils.f90 +++ /dev/null @@ -1,61 +0,0 @@ -module kgen_utils_mod - -INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - -type check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - real(kind=kgen_dp) :: minvalue -end type check_t - -public kgen_dp, check_t, kgen_init_check, kgen_print_check - -contains - -subroutine kgen_init_check(check, tolerance, minvalue) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - real(kind=kgen_dp), intent(in), optional :: minvalue - - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.0D-15 - endif - if(present(minvalue)) then - check%minvalue = minvalue - else - check%minvalue = 1.0D-15 - endif -end subroutine kgen_init_check - -subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif -end subroutine kgen_print_check - -end module diff --git a/test/ncar_kernels/PORT_sw_vrtqdr/src/parrrsw.f90 b/test/ncar_kernels/PORT_sw_vrtqdr/src/parrrsw.f90 deleted file mode 100644 index 161eecaedd..0000000000 --- a/test/ncar_kernels/PORT_sw_vrtqdr/src/parrrsw.f90 +++ /dev/null @@ -1,81 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : parrrsw.f90 -! Generated at: 2015-07-31 21:01:00 -! KGEN version: 0.4.13 - - - - MODULE parrrsw - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! use parkind ,only : jpim, jprb - IMPLICIT NONE - !------------------------------------------------------------------ - ! rrtmg_sw main parameters - ! - ! Initial version: JJMorcrette, ECMWF, jul1998 - ! Revised: MJIacono, AER, jun2006 - !------------------------------------------------------------------ - ! name type purpose - ! ----- : ---- : ---------------------------------------------- - ! mxlay : integer: maximum number of layers - ! mg : integer: number of original g-intervals per spectral band - ! nbndsw : integer: number of spectral bands - ! naerec : integer: number of aerosols (iaer=6, ecmwf aerosol option) - ! ngptsw : integer: total number of reduced g-intervals for rrtmg_lw - ! ngNN : integer: number of reduced g-intervals per spectral band - ! ngsNN : integer: cumulative number of g-intervals per band - !------------------------------------------------------------------ - ! Settings for single column mode. - ! For GCM use, set nlon to number of longitudes, and - ! mxlay to number of model layers - !jplay, klev - !jpg - !jpsw, ksw - !jpaer - ! Use for 112 g-point model - INTEGER, parameter :: ngptsw = 112 !jpgpt - ! Use for 224 g-point model - ! integer, parameter :: ngptsw = 224 !jpgpt - ! may need to rename these - from v2.6 - !istart - !iend - ! ^ - ! Use for 112 g-point model - ! Use for 224 g-point model - ! integer, parameter :: ng16 = 16 - ! integer, parameter :: ng17 = 16 - ! integer, parameter :: ng18 = 16 - ! integer, parameter :: ng19 = 16 - ! integer, parameter :: ng20 = 16 - ! integer, parameter :: ng21 = 16 - ! integer, parameter :: ng22 = 16 - ! integer, parameter :: ng23 = 16 - ! integer, parameter :: ng24 = 16 - ! integer, parameter :: ng25 = 16 - ! integer, parameter :: ng26 = 16 - ! integer, parameter :: ng27 = 16 - ! integer, parameter :: ng28 = 16 - ! integer, parameter :: ng29 = 16 - ! integer, parameter :: ngs16 = 16 - ! integer, parameter :: ngs17 = 32 - ! integer, parameter :: ngs18 = 48 - ! integer, parameter :: ngs19 = 64 - ! integer, parameter :: ngs20 = 80 - ! integer, parameter :: ngs21 = 96 - ! integer, parameter :: ngs22 = 112 - ! integer, parameter :: ngs23 = 128 - ! integer, parameter :: ngs24 = 144 - ! integer, parameter :: ngs25 = 160 - ! integer, parameter :: ngs26 = 176 - ! integer, parameter :: ngs27 = 192 - ! integer, parameter :: ngs28 = 208 - ! integer, parameter :: ngs29 = 224 - ! Source function solar constant - ! W/m2 - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE parrrsw diff --git a/test/ncar_kernels/PORT_sw_vrtqdr/src/rrtmg_sw_spcvmc.f90 b/test/ncar_kernels/PORT_sw_vrtqdr/src/rrtmg_sw_spcvmc.f90 deleted file mode 100644 index 88c30f8247..0000000000 --- a/test/ncar_kernels/PORT_sw_vrtqdr/src/rrtmg_sw_spcvmc.f90 +++ /dev/null @@ -1,396 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_sw_spcvmc.f90 -! Generated at: 2015-07-31 21:01:00 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_sw_spcvmc - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! ------- Modules ------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only : jpim, jprb - USE parrrsw, ONLY: ngptsw - USE rrtmg_sw_vrtqdr, ONLY: vrtqdr_sw - IMPLICIT NONE - PUBLIC spcvmc_sw - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - ! --------------------------------------------------------------------------- - - SUBROUTINE spcvmc_sw(nlayers, ncol, kgen_unit) - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! --------------------------------------------------------------------------- - ! - ! Purpose: Contains spectral loop to compute the shortwave radiative fluxes, - ! using the two-stream method of H. Barker and McICA, the Monte-Carlo - ! Independent Column Approximation, for the representation of - ! sub-grid cloud variability (i.e. cloud overlap). - ! - ! Interface: *spcvmc_sw* is called from *rrtmg_sw.F90* or rrtmg_sw.1col.F90* - ! - ! Method: - ! Adapted from two-stream model of H. Barker; - ! Two-stream model options (selected with kmodts in rrtmg_sw_reftra.F90): - ! 1: Eddington, 2: PIFM, Zdunkowski et al., 3: discret ordinates - ! - ! Modifications: - ! - ! Original: H. Barker - ! Revision: Merge with RRTMG_SW: J.-J.Morcrette, ECMWF, Feb 2003 - ! Revision: Add adjustment for Earth/Sun distance : MJIacono, AER, Oct 2003 - ! Revision: Bug fix for use of PALBP and PALBD: MJIacono, AER, Nov 2003 - ! Revision: Bug fix to apply delta scaling to clear sky: AER, Dec 2004 - ! Revision: Code modified so that delta scaling is not done in cloudy profiles - ! if routine cldprop is used; delta scaling can be applied by swithcing - ! code below if cldprop is not used to get cloud properties. - ! AER, Jan 2005 - ! Revision: Modified to use McICA: MJIacono, AER, Nov 2005 - ! Revision: Uniform formatting for RRTMG: MJIacono, AER, Jul 2006 - ! Revision: Use exponential lookup table for transmittance: MJIacono, AER, - ! Aug 2007 - ! - ! ------------------------------------------------------------------ - ! ------- Declarations ------ - ! ------- Input ------- - integer, intent(in) :: kgen_unit - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - INTEGER, intent(in) :: nlayers - ! delta-m scaling flag - ! [0 = direct and diffuse fluxes are unscaled] - ! [1 = direct and diffuse fluxes are scaled] - INTEGER, intent(in) :: ncol ! column loop index - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! layer pressure (hPa, mb) - ! Dimensions: (ncol,nlayers) - ! layer temperature (K) - ! Dimensions: (ncol,nlayers) - ! level (interface) pressure (hPa, mb) - ! Dimensions: (ncol,0:nlayers) - ! level temperatures (hPa, mb) - ! Dimensions: (ncol,0:nlayers) - ! surface temperature (K) - ! molecular amounts (mol/cm2) - ! Dimensions: (ncol,mxmol,nlayers) - ! dry air column density (mol/cm2) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Earth/Sun distance adjustment - ! Dimensions: (ncol,jpband) - ! surface albedo (diffuse) - ! Dimensions: (ncol,nbndsw) - ! surface albedo (direct) - ! Dimensions: (ncol, nbndsw) - ! cosine of solar zenith angle - ! cloud fraction [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - ! cloud optical depth [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - ! cloud asymmetry parameter [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - ! cloud single scattering albedo [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - ! cloud optical depth, non-delta scaled [mcica] - ! Dimensions: (ncol,nlayers,ngptsw) - ! aerosol optical depth - ! Dimensions: (ncol,nlayers,nbndsw) - ! aerosol asymmetry parameter - ! Dimensions: (ncol,nlayers,nbndsw) - ! aerosol single scattering albedo - ! Dimensions: (ncol,nlayers,nbndsw) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! Dimensions: (ncol,nlayers) - ! ------- Output ------- - ! All Dimensions: (nlayers+1) - ! Added for net near-IR flux diagnostic - ! Output - inactive ! All Dimensions: (nlayers+1) - ! real(kind=r8), intent(out) :: puvcu(:) - ! real(kind=r8), intent(out) :: puvfu(:) - ! real(kind=r8), intent(out) :: pvscd(:) - ! real(kind=r8), intent(out) :: pvscu(:) - ! real(kind=r8), intent(out) :: pvsfd(:) - ! real(kind=r8), intent(out) :: pvsfu(:) - ! shortwave spectral flux up (nswbands,nlayers+1) - ! shortwave spectral flux down (nswbands,nlayers+1) - ! ------- Local ------- - INTEGER :: klev - INTEGER :: iw(ncol) - ! integer, parameter :: nuv = ?? - ! integer, parameter :: nvs = ?? - REAL(KIND=r8) :: zrdndc(ncol,nlayers+1) - REAL(KIND=r8) :: ref_zrdndc(ncol,nlayers+1) - REAL(KIND=r8) :: zrefc(ncol,nlayers+1) - REAL(KIND=r8) :: zrefdc(ncol,nlayers+1) - REAL(KIND=r8) :: zrupc(ncol,nlayers+1) - REAL(KIND=r8) :: ref_zrupc(ncol,nlayers+1) - REAL(KIND=r8) :: zrupdc(ncol,nlayers+1) - REAL(KIND=r8) :: ref_zrupdc(ncol,nlayers+1) - REAL(KIND=r8) :: ztrac(ncol,nlayers+1) - REAL(KIND=r8) :: ztradc(ncol,nlayers+1) - REAL(KIND=r8) :: ztdbtc(ncol,nlayers+1) - REAL(KIND=r8) :: zdbtc(ncol,nlayers+1) - ! real(kind=r8) :: zincflux ! inactive - ! Arrays from rrtmg_sw_taumoln routines - ! real(kind=r8) :: ztaug(nlayers,16), ztaur(nlayers,16) - ! real(kind=r8) :: zsflxzen(16) - ! Arrays from rrtmg_sw_vrtqdr routine - REAL(KIND=r8) :: zcd(ncol,nlayers+1,ngptsw) - REAL(KIND=r8) :: ref_zcd(ncol,nlayers+1,ngptsw) - REAL(KIND=r8) :: zcu(ncol,nlayers+1,ngptsw) - REAL(KIND=r8) :: ref_zcu(ncol,nlayers+1,ngptsw) - ! Inactive arrays - ! real(kind=r8) :: zbbcd(nlayers+1), zbbcu(nlayers+1) - ! real(kind=r8) :: zbbfd(nlayers+1), zbbfu(nlayers+1) - ! real(kind=r8) :: zbbfddir(nlayers+1), zbbcddir(nlayers+1) - ! ------------------------------------------------------------------ - ! Initializations - ! zincflux = 0.0_r8 - ! ??? ! ??? - tolerance = 1.E-14 - CALL kgen_init_check(check_status, tolerance) - READ(UNIT=kgen_unit) klev - READ(UNIT=kgen_unit) iw - READ(UNIT=kgen_unit) zrdndc - READ(UNIT=kgen_unit) zrefc - READ(UNIT=kgen_unit) zrefdc - READ(UNIT=kgen_unit) zrupc - READ(UNIT=kgen_unit) zrupdc - READ(UNIT=kgen_unit) ztrac - READ(UNIT=kgen_unit) ztradc - READ(UNIT=kgen_unit) ztdbtc - READ(UNIT=kgen_unit) zdbtc - READ(UNIT=kgen_unit) zcd - READ(UNIT=kgen_unit) zcu - - READ(UNIT=kgen_unit) ref_zrdndc - READ(UNIT=kgen_unit) ref_zrupc - READ(UNIT=kgen_unit) ref_zrupdc - READ(UNIT=kgen_unit) ref_zcd - READ(UNIT=kgen_unit) ref_zcu - - - ! call to kernel - call vrtqdr_sw(ncol,klev, iw, & -zrefc, zrefdc, ztrac, ztradc, & -zdbtc, zrdndc, zrupc, zrupdc, ztdbtc, & -zcd, zcu) - ! kernel verification for output variables - CALL kgen_verify_real_r8_dim2( "zrdndc", check_status, zrdndc, ref_zrdndc) - CALL kgen_verify_real_r8_dim2( "zrupc", check_status, zrupc, ref_zrupc) - CALL kgen_verify_real_r8_dim2( "zrupdc", check_status, zrupdc, ref_zrupdc) - CALL kgen_verify_real_r8_dim3( "zcd", check_status, zcd, ref_zcd) - CALL kgen_verify_real_r8_dim3( "zcu", check_status, zcu, ref_zcu) - CALL kgen_print_check("vrtqdr_sw", check_status) - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,10 - CALL vrtqdr_sw(ncol, klev, iw, zrefc, zrefdc, ztrac, ztradc, zdbtc, zrdndc, zrupc, zrupdc, ztdbtc, zcd, zcu) - END DO - CALL system_clock(stop_clock, rate_clock) - WRITE(*,*) - PRINT *, "Elapsed time (sec): ", (stop_clock - start_clock)/REAL(rate_clock*10) - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_r8_dim2(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim2 - - SUBROUTINE kgen_read_real_r8_dim3(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2,idx3 - INTEGER, DIMENSION(2,3) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim3 - - - ! verify subroutines - SUBROUTINE kgen_verify_real_r8_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim2 - - SUBROUTINE kgen_verify_real_r8_dim3( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim3 - - END SUBROUTINE spcvmc_sw - END MODULE rrtmg_sw_spcvmc diff --git a/test/ncar_kernels/PORT_sw_vrtqdr/src/rrtmg_sw_vrtqdr.f90 b/test/ncar_kernels/PORT_sw_vrtqdr/src/rrtmg_sw_vrtqdr.f90 deleted file mode 100644 index 94b3fb8d51..0000000000 --- a/test/ncar_kernels/PORT_sw_vrtqdr/src/rrtmg_sw_vrtqdr.f90 +++ /dev/null @@ -1,138 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : rrtmg_sw_vrtqdr.f90 -! Generated at: 2015-07-31 21:01:00 -! KGEN version: 0.4.13 - - - - MODULE rrtmg_sw_vrtqdr - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! ------- Modules ------- - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - ! use parkind, only: jpim, jprb - ! use parrrsw, only: ngptsw - IMPLICIT NONE - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - ! -------------------------------------------------------------------------- - - SUBROUTINE vrtqdr_sw(ncol, klev, kw, pref, prefd, ptra, ptrad, pdbt, prdnd, prup, prupd, ptdbt, pfd, pfu) - ! -------------------------------------------------------------------------- - ! Purpose: This routine performs the vertical quadrature integration - ! - ! Interface: *vrtqdr_sw* is called from *spcvrt_sw* and *spcvmc_sw* - ! - ! Modifications. - ! - ! Original: H. Barker - ! Revision: Integrated with rrtmg_sw, J.-J. Morcrette, ECMWF, Oct 2002 - ! Revision: Reformatted for consistency with rrtmg_lw: MJIacono, AER, Jul 2006 - ! - !----------------------------------------------------------------------- - ! ------- Declarations ------- - ! Input - INTEGER, intent (in) :: ncol - INTEGER, intent (in) :: klev ! number of model layers - INTEGER, intent (in) :: kw(ncol) ! g-point index - REAL(KIND=r8), intent(in) :: pref(:,:) ! direct beam reflectivity - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(in) :: prefd(:,:) ! diffuse beam reflectivity - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(in) :: ptra(:,:) ! direct beam transmissivity - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(in) :: ptrad(:,:) ! diffuse beam transmissivity - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(in) :: pdbt(:,:) - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(in) :: ptdbt(:,:) - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(inout) :: prdnd(:,:) - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(inout) :: prup(:,:) - ! Dimensions: (nlayers+1) - REAL(KIND=r8), intent(inout) :: prupd(:,:) - ! Dimensions: (nlayers+1) - ! Output - REAL(KIND=r8), intent(out) :: pfd(:,:,:) ! downwelling flux (W/m2) - ! Dimensions: (nlayers+1,ngptsw) - ! unadjusted for earth/sun distance or zenith angle - REAL(KIND=r8), intent(out) :: pfu(:,:,:) ! upwelling flux (W/m2) - ! Dimensions: (nlayers+1,ngptsw) - ! unadjusted for earth/sun distance or zenith angle - ! Local - INTEGER :: jk - INTEGER :: ikp - INTEGER :: icol - INTEGER :: ikx - REAL(KIND=r8) :: zreflect - REAL(KIND=r8) :: ztdn(klev+1) - ! Definitions - ! - ! pref(icol,jk) direct reflectance - ! prefd(icol,jk) diffuse reflectance - ! ptra(icol,jk) direct transmittance - ! ptrad(icol,jk) diffuse transmittance - ! - ! pdbt(icol,jk) layer mean direct beam transmittance - ! ptdbt(icol,jk) total direct beam transmittance at levels - ! - !----------------------------------------------------------------------------- - ! Link lowest layer with surface - do icol=1,ncol - zreflect = 1._r8 / (1._r8 - prefd(icol,klev+1) * prefd(icol,klev)) - prup(icol,klev) = pref(icol,klev) + (ptrad(icol,klev) * & - ((ptra(icol,klev) - pdbt(icol,klev)) * prefd(icol,klev+1) + & - pdbt(icol,klev) * pref(icol,klev+1))) * zreflect - prupd(icol,klev) = prefd(icol,klev) + ptrad(icol,klev) * ptrad(icol,klev) * & - prefd(icol,klev+1) * zreflect - ! Pass from bottom to top - do jk = 1,klev-1 - ikp = klev+1-jk - ikx = ikp-1 - zreflect = 1._r8 / (1._r8 -prupd(icol,ikp) * prefd(icol,ikx)) - prup(icol,ikx) = pref(icol,ikx) + (ptrad(icol,ikx) * & - ((ptra(icol,ikx) - pdbt(icol,ikx)) * prupd(icol,ikp) + & - pdbt(icol,ikx) * prup(icol,ikp))) * zreflect - prupd(icol,ikx) = prefd(icol,ikx) + ptrad(icol,ikx) * ptrad(icol,ikx) * & - prupd(icol,ikp) * zreflect - enddo - ! Upper boundary conditions - ztdn(1) = 1._r8 - prdnd(icol,1) = 0._r8 - ztdn(2) = ptra(icol,1) - prdnd(icol,2) = prefd(icol,1) - ! Pass from top to bottom - do jk = 2,klev - ikp = jk+1 - zreflect = 1._r8 / (1._r8 - prefd(icol,jk) * prdnd(icol,jk)) - ztdn(ikp) = ptdbt(icol,jk) * ptra(icol,jk) + & - (ptrad(icol,jk) * ((ztdn(jk) - ptdbt(icol,jk)) + & - ptdbt(icol,jk) * pref(icol,jk) * prdnd(icol,jk))) * zreflect - prdnd(icol,ikp) = prefd(icol,jk) + ptrad(icol,jk) * ptrad(icol,jk) * & - prdnd(icol,jk) * zreflect - enddo - ! Up and down-welling fluxes at levels - do jk = 1,klev+1 - zreflect = 1._r8 / (1._r8 - prdnd(icol,jk) * prupd(icol,jk)) - pfu(icol,jk,kw(icol)) = (ptdbt(icol,jk) * prup(icol,jk) + & - (ztdn(jk) - ptdbt(icol,jk)) * prupd(icol,jk)) * zreflect - pfd(icol,jk,kw(icol)) = ptdbt(icol,jk) + (ztdn(jk) - ptdbt(icol,jk)+ & - ptdbt(icol,jk) * prup(icol,jk) * prdnd(icol,jk)) * zreflect - enddo - end do - END SUBROUTINE vrtqdr_sw - END MODULE rrtmg_sw_vrtqdr diff --git a/test/ncar_kernels/PORT_sw_vrtqdr/src/shr_kind_mod.f90 b/test/ncar_kernels/PORT_sw_vrtqdr/src/shr_kind_mod.f90 deleted file mode 100644 index 504e659366..0000000000 --- a/test/ncar_kernels/PORT_sw_vrtqdr/src/shr_kind_mod.f90 +++ /dev/null @@ -1,26 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : shr_kind_mod.f90 -! Generated at: 2015-07-31 21:01:00 -! KGEN version: 0.4.13 - - - - MODULE shr_kind_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - PUBLIC - INTEGER, parameter :: shr_kind_r8 = selected_real_kind(12) ! 8 byte real - ! 4 byte real - ! native real - ! 8 byte integer - ! 4 byte integer - ! native integer - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE shr_kind_mod diff --git a/test/ncar_kernels/PSRAD_lrtm/CESM_license.txt b/test/ncar_kernels/PSRAD_lrtm/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/PSRAD_lrtm/data/lrtm.1 b/test/ncar_kernels/PSRAD_lrtm/data/lrtm.1 deleted file mode 100644 index 180c3d36f2..0000000000 Binary files a/test/ncar_kernels/PSRAD_lrtm/data/lrtm.1 and /dev/null differ diff --git a/test/ncar_kernels/PSRAD_lrtm/data/lrtm.10 b/test/ncar_kernels/PSRAD_lrtm/data/lrtm.10 deleted file mode 100644 index 01775e3cc2..0000000000 Binary files a/test/ncar_kernels/PSRAD_lrtm/data/lrtm.10 and /dev/null differ diff --git a/test/ncar_kernels/PSRAD_lrtm/data/lrtm.50 b/test/ncar_kernels/PSRAD_lrtm/data/lrtm.50 deleted file mode 100644 index e1ce33ff53..0000000000 Binary files a/test/ncar_kernels/PSRAD_lrtm/data/lrtm.50 and /dev/null differ diff --git a/test/ncar_kernels/PSRAD_lrtm/inc/t1.mk b/test/ncar_kernels/PSRAD_lrtm/inc/t1.mk deleted file mode 100644 index 223769a5b3..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm/inc/t1.mk +++ /dev/null @@ -1,90 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# Makefile for KGEN-generated kernel -# -# -# PGI default flags -# FC_FLAGS := -fast -Mipa=fast,inline -# -# -# Intel default flags -# FC_FLAGS := -O3 -xHost - - -FC_FLAGS := $(OPT) - -ALL_OBJS := kernel_driver.o mo_psrad_interface.o mo_lrtm_kgs.o mo_cld_sampling.o mo_lrtm_solver.o mo_rrtm_coeffs.o mo_exception_stub.o mo_physical_constants.o mo_radiation_parameters.o mo_kind.o mo_spec_sampling.o mo_random_numbers.o mo_lrtm_setup.o mo_math_constants.o mo_rrtm_params.o mo_rad_fastmath.o mo_lrtm_driver.o mo_lrtm_gas_optics.o - -all: build run verify - -verify: - @(grep "verification.FAIL" $(TEST).rslt && echo "FAILED") || (grep "verification.PASS" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 mo_psrad_interface.o mo_lrtm_kgs.o mo_cld_sampling.o mo_lrtm_solver.o mo_rrtm_coeffs.o mo_exception_stub.o mo_physical_constants.o mo_radiation_parameters.o mo_kind.o mo_spec_sampling.o mo_random_numbers.o mo_lrtm_setup.o mo_math_constants.o mo_rrtm_params.o mo_rad_fastmath.o mo_lrtm_driver.o mo_lrtm_gas_optics.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_psrad_interface.o: $(SRC_DIR)/mo_psrad_interface.f90 mo_lrtm_driver.o mo_rrtm_params.o mo_kind.o mo_spec_sampling.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_lrtm_kgs.o: $(SRC_DIR)/mo_lrtm_kgs.f90 mo_kind.o mo_rrtm_params.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_cld_sampling.o: $(SRC_DIR)/mo_cld_sampling.f90 mo_kind.o mo_random_numbers.o mo_exception_stub.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_lrtm_solver.o: $(SRC_DIR)/mo_lrtm_solver.f90 mo_kind.o mo_rrtm_params.o mo_rad_fastmath.o mo_math_constants.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_rrtm_coeffs.o: $(SRC_DIR)/mo_rrtm_coeffs.f90 mo_kind.o mo_rrtm_params.o mo_lrtm_kgs.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_exception_stub.o: $(SRC_DIR)/mo_exception_stub.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_physical_constants.o: $(SRC_DIR)/mo_physical_constants.f90 mo_kind.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_radiation_parameters.o: $(SRC_DIR)/mo_radiation_parameters.f90 mo_kind.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_kind.o: $(SRC_DIR)/mo_kind.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_spec_sampling.o: $(SRC_DIR)/mo_spec_sampling.f90 mo_kind.o mo_random_numbers.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_random_numbers.o: $(SRC_DIR)/mo_random_numbers.f90 mo_kind.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_lrtm_setup.o: $(SRC_DIR)/mo_lrtm_setup.f90 mo_rrtm_params.o mo_kind.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_math_constants.o: $(SRC_DIR)/mo_math_constants.f90 mo_kind.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_rrtm_params.o: $(SRC_DIR)/mo_rrtm_params.f90 mo_kind.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_rad_fastmath.o: $(SRC_DIR)/mo_rad_fastmath.f90 mo_kind.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_lrtm_driver.o: $(SRC_DIR)/mo_lrtm_driver.f90 mo_rrtm_params.o mo_kind.o mo_spec_sampling.o mo_radiation_parameters.o mo_lrtm_setup.o mo_cld_sampling.o mo_rrtm_coeffs.o mo_lrtm_gas_optics.o mo_lrtm_kgs.o mo_physical_constants.o mo_lrtm_solver.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_lrtm_gas_optics.o: $(SRC_DIR)/mo_lrtm_gas_optics.f90 mo_kind.o mo_lrtm_setup.o mo_lrtm_kgs.o mo_exception_stub.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.oo *.rslt diff --git a/test/ncar_kernels/PSRAD_lrtm/lit/runmake b/test/ncar_kernels/PSRAD_lrtm/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/PSRAD_lrtm/lit/t1.sh b/test/ncar_kernels/PSRAD_lrtm/lit/t1.sh deleted file mode 100644 index 33c953a156..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm/lit/t1.sh +++ /dev/null @@ -1,9 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -# Shared lit script for each tests. Run bash commands that run tests with make. - -# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t -# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/PSRAD_lrtm/makefile b/test/ncar_kernels/PSRAD_lrtm/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/PSRAD_lrtm/src/call_hierarchy.png b/test/ncar_kernels/PSRAD_lrtm/src/call_hierarchy.png deleted file mode 100644 index cdbd948aee..0000000000 Binary files a/test/ncar_kernels/PSRAD_lrtm/src/call_hierarchy.png and /dev/null differ diff --git a/test/ncar_kernels/PSRAD_lrtm/src/kernel_driver.f90 b/test/ncar_kernels/PSRAD_lrtm/src/kernel_driver.f90 deleted file mode 100644 index f40e019a30..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm/src/kernel_driver.f90 +++ /dev/null @@ -1,141 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-02-19 15:30:29 -! KGEN version: 0.4.4 - - -PROGRAM kernel_driver - USE mo_psrad_interface, only : psrad_interface - USE mo_kind, ONLY: wp - USE mo_psrad_interface, only : read_externs_mo_psrad_interface - USE mo_radiation_parameters, only : read_externs_mo_radiation_parameters - USE rrlw_kg12, only : read_externs_rrlw_kg12 - USE rrlw_kg13, only : read_externs_rrlw_kg13 - USE rrlw_planck, only : read_externs_rrlw_planck - USE rrlw_kg11, only : read_externs_rrlw_kg11 - USE rrlw_kg16, only : read_externs_rrlw_kg16 - USE rrlw_kg14, only : read_externs_rrlw_kg14 - USE rrlw_kg15, only : read_externs_rrlw_kg15 - USE rrlw_kg10, only : read_externs_rrlw_kg10 - USE rrlw_kg01, only : read_externs_rrlw_kg01 - USE rrlw_kg03, only : read_externs_rrlw_kg03 - USE rrlw_kg02, only : read_externs_rrlw_kg02 - USE rrlw_kg05, only : read_externs_rrlw_kg05 - USE rrlw_kg04, only : read_externs_rrlw_kg04 - USE rrlw_kg07, only : read_externs_rrlw_kg07 - USE rrlw_kg06, only : read_externs_rrlw_kg06 - USE rrlw_kg09, only : read_externs_rrlw_kg09 - USE rrlw_kg08, only : read_externs_rrlw_kg08 - USE mo_random_numbers, only : read_externs_mo_random_numbers - - IMPLICIT NONE - - ! read interface - !interface kgen_read_var - ! procedure read_var_real_wp_dim1 - !end interface kgen_read_var - - - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_counter_at = (/ 1, 10, 50 /) - CHARACTER(LEN=1024) :: kgen_filepath - INTEGER :: nb_sw - INTEGER :: klev - REAL(KIND=wp), allocatable :: tk_sfc(:) - INTEGER :: kproma - INTEGER :: kbdim - INTEGER :: ktrac - - DO kgen_repeat_counter = 0, 2 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_filepath = "../data/lrtm." // trim(adjustl(kgen_counter_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "************ Verification against '" // trim(adjustl(kgen_filepath)) // "' ************" - - call read_externs_mo_psrad_interface(kgen_unit) - call read_externs_mo_radiation_parameters(kgen_unit) - call read_externs_rrlw_kg12(kgen_unit) - call read_externs_rrlw_kg13(kgen_unit) - call read_externs_rrlw_planck(kgen_unit) - call read_externs_rrlw_kg11(kgen_unit) - call read_externs_rrlw_kg16(kgen_unit) - call read_externs_rrlw_kg14(kgen_unit) - call read_externs_rrlw_kg15(kgen_unit) - call read_externs_rrlw_kg10(kgen_unit) - call read_externs_rrlw_kg01(kgen_unit) - call read_externs_rrlw_kg03(kgen_unit) - call read_externs_rrlw_kg02(kgen_unit) - call read_externs_rrlw_kg05(kgen_unit) - call read_externs_rrlw_kg04(kgen_unit) - call read_externs_rrlw_kg07(kgen_unit) - call read_externs_rrlw_kg06(kgen_unit) - call read_externs_rrlw_kg09(kgen_unit) - call read_externs_rrlw_kg08(kgen_unit) - call read_externs_mo_random_numbers(kgen_unit) - - ! driver variables - READ(UNIT=kgen_unit) kbdim - READ(UNIT=kgen_unit) klev - READ(UNIT=kgen_unit) nb_sw - READ(UNIT=kgen_unit) kproma - READ(UNIT=kgen_unit) ktrac - !call kgen_read_var(tk_sfc, kgen_unit) - call read_var_real_wp_dim1(tk_sfc, kgen_unit) - call psrad_interface(kbdim, klev, nb_sw, kproma, ktrac, tk_sfc, kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/PSRAD_lrtm/src/mo_cld_sampling.f90 b/test/ncar_kernels/PSRAD_lrtm/src/mo_cld_sampling.f90 deleted file mode 100644 index f85e2cdfc3..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm/src/mo_cld_sampling.f90 +++ /dev/null @@ -1,88 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_cld_sampling.f90 -! Generated at: 2015-02-19 15:30:32 -! KGEN version: 0.4.4 - - - - MODULE mo_cld_sampling - USE mo_kind, ONLY: wp - USE mo_exception, ONLY: finish - USE mo_random_numbers, ONLY: get_random - IMPLICIT NONE - PRIVATE - PUBLIC sample_cld_state - CONTAINS - - ! read subroutines - !----------------------------------------------------------------------------- - !> - !! @brief Returns a sample of the cloud state - !! - !! @remarks - ! - - SUBROUTINE sample_cld_state(kproma, kbdim, klev, ksamps, rnseeds, i_overlap, cld_frac, cldy) - INTEGER, intent(in) :: kbdim - INTEGER, intent(in) :: klev - INTEGER, intent(in) :: ksamps - INTEGER, intent(in) :: kproma !< numbers of columns, levels, samples - INTEGER, intent(inout) :: rnseeds(:, :) !< Seeds for random number generator (kbdim, :) - INTEGER, intent(in) :: i_overlap !< 1=max-ran, 2=maximum, 3=random - REAL(KIND=wp), intent(in) :: cld_frac(kbdim,klev) !< cloud fraction - LOGICAL, intent(out) :: cldy(kbdim,klev,ksamps) !< Logical: cloud present? - REAL(KIND=wp) :: rank(kbdim,klev,ksamps) - INTEGER :: js - INTEGER :: jk - ! Here cldy(:,:,1) indicates whether any cloud is present - ! - cldy(1:kproma,1:klev,1) = cld_frac(1:kproma,1:klev) > 0._wp - SELECT CASE ( i_overlap ) - CASE ( 1 ) - ! Maximum-random overlap - DO js = 1, ksamps - DO jk = 1, klev - ! mask means we compute random numbers only when cloud is present - CALL get_random(kproma, kbdim, rnseeds, cldy(:,jk,1), rank(:,jk,js)) - END DO - END DO - ! There may be a better way to structure this calculation... - DO jk = klev-1, 1, -1 - DO js = 1, ksamps - rank(1:kproma,jk,js) = merge(rank(1:kproma,jk+1,js), & - rank(1:kproma,jk,js) * (1._wp - cld_frac(1:kproma,jk+1)), & - rank(1:kproma,jk+1,js) > 1._wp - cld_frac(1:kproma,jk+1)) - ! Max overlap... - ! ... or random overlap in the clear sky portion, - ! depending on whether or not you have cloud in the layer above - END DO - END DO - CASE ( 2 ) - ! - ! Max overlap means every cell in a column is identical - ! - DO js = 1, ksamps - CALL get_random(kproma, kbdim, rnseeds, rank(:, 1, js)) - rank(1:kproma,2:klev,js) = spread(rank(1:kproma,1,js), dim=2, ncopies=(klev-1)) - END DO - CASE ( 3 ) - ! - ! Random overlap means every cell is independent - ! - DO js = 1, ksamps - DO jk = 1, klev - ! mask means we compute random numbers only when cloud is present - CALL get_random(kproma, kbdim, rnseeds, cldy(:,jk,1), rank(:,jk,js)) - END DO - END DO - CASE DEFAULT - CALL finish('In sample_cld_state: unknown overlap assumption') - END SELECT - ! Now cldy indicates whether the sample (ks) is cloudy or not. - DO js = 1, ksamps - cldy(1:kproma,1:klev,js) = rank(1:kproma,1:klev,js) > (1. - cld_frac(1:kproma,1:klev)) - END DO - END SUBROUTINE sample_cld_state - END MODULE mo_cld_sampling diff --git a/test/ncar_kernels/PSRAD_lrtm/src/mo_exception_stub.f90 b/test/ncar_kernels/PSRAD_lrtm/src/mo_exception_stub.f90 deleted file mode 100644 index 51a60be233..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm/src/mo_exception_stub.f90 +++ /dev/null @@ -1,45 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_exception_stub.f90 -! Generated at: 2015-02-19 15:30:31 -! KGEN version: 0.4.4 - - - - MODULE mo_exception - IMPLICIT NONE - PRIVATE - PUBLIC finish - ! normal message - ! informational message - ! warning message: number of warnings counted - ! error message: number of errors counted - ! report parameter value - ! debugging message - !++mgs - CONTAINS - - ! read subroutines - - SUBROUTINE finish(name, text, exit_no) - CHARACTER(LEN=*), intent(in) :: name - CHARACTER(LEN=*), intent(in), optional :: text - INTEGER, intent(in), optional :: exit_no - INTEGER :: ifile - IF (present(exit_no)) THEN - ifile = exit_no - ELSE - ifile = 6 - END IF - WRITE (ifile, '(/,80("*"),/)') - IF (present(text)) THEN - WRITE (ifile, '(1x,a,a,a)') trim(name), ': ', trim(text) - ELSE - WRITE (ifile, '(1x,a,a)') trim(name), ': ' - END IF - WRITE (ifile, '(/,80("-"),/,/)') - STOP - END SUBROUTINE finish - - END MODULE mo_exception diff --git a/test/ncar_kernels/PSRAD_lrtm/src/mo_kind.f90 b/test/ncar_kernels/PSRAD_lrtm/src/mo_kind.f90 deleted file mode 100644 index f10effef4c..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm/src/mo_kind.f90 +++ /dev/null @@ -1,43 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_kind.f90 -! Generated at: 2015-02-19 15:30:37 -! KGEN version: 0.4.4 - - - - MODULE mo_kind - ! L. Kornblueh, MPI, August 2001, added working precision and comments - IMPLICIT NONE - ! Number model from which the SELECTED_*_KIND are requested: - ! - ! 4 byte REAL 8 byte REAL - ! CRAY: - precision = 13 - ! exponent = 2465 - ! IEEE: precision = 6 precision = 15 - ! exponent = 37 exponent = 307 - ! - ! Most likely this are the only possible models. - ! Floating point section: - INTEGER, parameter :: pd = 12 - INTEGER, parameter :: rd = 307 - INTEGER, parameter :: pi8 = 14 - INTEGER, parameter :: dp = selected_real_kind(pd,rd) - ! Floating point working precision - INTEGER, parameter :: wp = dp - ! Integer section - INTEGER, parameter :: i8 = selected_int_kind(pi8) - ! Working precision for index variables - ! - ! predefined preprocessor macros: - ! - ! xlf __64BIT__ checked with P6 and AIX - ! gfortran __LP64__ checked with Darwin and Linux - ! Intel, PGI __x86_64__ checked with Linux - ! Sun __x86_64 checked with Linux - CONTAINS - - ! read subroutines - - END MODULE mo_kind diff --git a/test/ncar_kernels/PSRAD_lrtm/src/mo_lrtm_driver.f90 b/test/ncar_kernels/PSRAD_lrtm/src/mo_lrtm_driver.f90 deleted file mode 100644 index e8c0c688bc..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm/src/mo_lrtm_driver.f90 +++ /dev/null @@ -1,418 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_lrtm_driver.f90 -! Generated at: 2015-02-19 15:30:29 -! KGEN version: 0.4.4 - - - - MODULE mo_lrtm_driver - USE mo_kind, ONLY: wp - USE mo_physical_constants, ONLY: amw - USE mo_physical_constants, ONLY: amd - USE mo_physical_constants, ONLY: grav - USE mo_rrtm_params, ONLY: nbndlw - USE mo_rrtm_params, ONLY: ngptlw - USE mo_radiation_parameters, ONLY: do_gpoint - USE mo_radiation_parameters, ONLY: i_overlap - USE mo_radiation_parameters, ONLY: l_do_sep_clear_sky - USE mo_radiation_parameters, ONLY: rad_undef - USE mo_lrtm_setup, ONLY: ngb - USE mo_lrtm_setup, ONLY: delwave - USE rrlw_planck, ONLY: totplanck - USE mo_rrtm_coeffs, ONLY: lrtm_coeffs - USE mo_lrtm_gas_optics, ONLY: gas_optics_lw - USE mo_lrtm_solver, ONLY: find_secdiff - USE mo_lrtm_solver, ONLY: lrtm_solver - USE mo_cld_sampling, ONLY: sample_cld_state - USE mo_spec_sampling, ONLY: spec_sampling_strategy - USE mo_spec_sampling, ONLY: get_gpoint_set - IMPLICIT NONE - PRIVATE - PUBLIC lrtm - CONTAINS - - ! read subroutines - !----------------------------------------------------------------------------- - !> - !! @brief Prepares information for radiation call - !! - !! @remarks: This program is the driver subroutine for the longwave radiative - !! transfer routine. This routine is adapted from the AER LW RRTMG_LW model - !! that itself has been adapted from RRTM_LW for improved efficiency. Our - !! routine does the spectral integration externally (the solver is explicitly - !! called for each g-point, so as to facilitate sampling of g-points - !! This routine: - !! 1) calls INATM to read in the atmospheric profile from GCM; - !! all layering in RRTMG is ordered from surface to toa. - !! 2) calls COEFFS to calculate various quantities needed for - !! the radiative transfer algorithm. This routine is called only once for - !! any given thermodynamic state, i.e., it does not change if clouds chanege - !! 3) calls TAUMOL to calculate gaseous optical depths for each - !! of the 16 spectral bands, this is updated band by band. - !! 4) calls SOLVER (for both clear and cloudy profiles) to perform the - !! radiative transfer calculation with a maximum-random cloud - !! overlap method, or calls RTRN to use random cloud overlap. - !! 5) passes the necessary fluxes and cooling rates back to GCM - !! - ! - - SUBROUTINE lrtm(kproma, kbdim, klev, play, psfc, tlay, tlev, tsfc, wkl, wx, coldry, emis, cldfr, taucld, tauaer, rnseeds, & - strategy, n_gpts_ts, uflx, dflx, uflxc, dflxc) - INTEGER, intent(in) :: klev - INTEGER, intent(in) :: kbdim - INTEGER, intent(in) :: kproma - !< Maximum block length - !< Number of horizontal columns - !< Number of model layers - REAL(KIND=wp), intent(in) :: wx(:,:,:) - REAL(KIND=wp), intent(in) :: cldfr(kbdim,klev) - REAL(KIND=wp), intent(in) :: taucld(kbdim,klev,nbndlw) - REAL(KIND=wp), intent(in) :: wkl(:,:,:) - REAL(KIND=wp), intent(in) :: coldry(kbdim,klev) - REAL(KIND=wp), intent(in) :: play(kbdim,klev) - REAL(KIND=wp), intent(in) :: tlay(kbdim,klev) - REAL(KIND=wp), intent(in) :: tauaer(kbdim,klev,nbndlw) - REAL(KIND=wp), intent(in) :: tlev(kbdim,klev+1) - REAL(KIND=wp), intent(in) :: tsfc(kbdim) - REAL(KIND=wp), intent(in) :: psfc(kbdim) - REAL(KIND=wp), intent(in) :: emis(kbdim,nbndlw) - !< Layer pressures [hPa, mb] (kbdim,klev) - !< Surface pressure [hPa, mb] (kbdim) - !< Layer temperatures [K] (kbdim,klev) - !< Interface temperatures [K] (kbdim,klev+1) - !< Surface temperature [K] (kbdim) - !< Gas volume mixing ratios - !< CFC type gas volume mixing ratios - !< Column dry amount - !< Surface emissivity (kbdim,nbndlw) - !< Cloud fraction (kbdim,klev) - !< Coud optical depth (kbdim,klev,nbndlw) - !< Aerosol optical depth (kbdim,klev,nbndlw) - ! Variables for sampling cloud state and spectral points - INTEGER, intent(inout) :: rnseeds(:, :) !< Seeds for random number generator (kbdim,:) - TYPE(spec_sampling_strategy), intent(in) :: strategy - INTEGER, intent(in ) :: n_gpts_ts - REAL(KIND=wp), intent(out) :: uflx (kbdim,0:klev) - REAL(KIND=wp), intent(out) :: dflx (kbdim,0:klev) - REAL(KIND=wp), intent(out) :: uflxc(kbdim,0:klev) - REAL(KIND=wp), intent(out) :: dflxc(kbdim,0:klev) - !< Tot sky longwave upward flux [W/m2], (kbdim,0:klev) - !< Tot sky longwave downward flux [W/m2], (kbdim,0:klev) - !< Clr sky longwave upward flux [W/m2], (kbdim,0:klev) - !< Clr sky longwave downward flux [W/m2], (kbdim,0:klev) - REAL(KIND=wp) :: taug(klev) !< Properties for one column at a time - !< gas optical depth - REAL(KIND=wp) :: fracs(kbdim,klev,n_gpts_ts) - REAL(KIND=wp) :: taut (kbdim,klev,n_gpts_ts) - REAL(KIND=wp) :: tautot(kbdim,klev,n_gpts_ts) - REAL(KIND=wp) :: pwvcm(kbdim) - REAL(KIND=wp) :: secdiff(kbdim) - !< Planck fraction per g-point - !< precipitable water vapor [cm] - !< diffusivity angle for RT calculation - !< gaseous + aerosol optical depths for all columns - !< cloud + gaseous + aerosol optical depths for all columns - REAL(KIND=wp) :: planklay(kbdim, klev,nbndlw) - REAL(KIND=wp) :: planklev(kbdim,0:klev,nbndlw) - REAL(KIND=wp) :: plankbnd(kbdim, nbndlw) ! Properties for all bands - ! Planck function at mid-layer - ! Planck function at level interfaces - ! Planck function at surface - REAL(KIND=wp) :: layplnk(kbdim, klev) - REAL(KIND=wp) :: levplnk(kbdim,0:klev) - REAL(KIND=wp) :: bndplnk(kbdim) - REAL(KIND=wp) :: srfemis(kbdim) ! Properties for a single set of columns/g-points - ! Planck function at mid-layer - ! Planck function at level interfaces - ! Planck function at surface - ! Surface emission - REAL(KIND=wp) :: zgpfd(kbdim,0:klev) - REAL(KIND=wp) :: zgpfu(kbdim,0:klev) - REAL(KIND=wp) :: zgpcu(kbdim,0:klev) - REAL(KIND=wp) :: zgpcd(kbdim,0:klev) - ! < gpoint clearsky downward flux - ! < gpoint clearsky downward flux - ! < gpoint fullsky downward flux - ! < gpoint fullsky downward flux - ! ----------------- - ! Variables for gas optics calculations - INTEGER :: jt1 (kbdim,klev) - INTEGER :: indfor (kbdim,klev) - INTEGER :: indself (kbdim,klev) - INTEGER :: indminor(kbdim,klev) - INTEGER :: laytrop (kbdim ) - INTEGER :: jp (kbdim,klev) - INTEGER :: jt (kbdim,klev) - !< tropopause layer index - !< lookup table index - !< lookup table index - !< lookup table index - REAL(KIND=wp) :: wbrodl (kbdim,klev) - REAL(KIND=wp) :: selffac (kbdim,klev) - REAL(KIND=wp) :: colh2o (kbdim,klev) - REAL(KIND=wp) :: colo3 (kbdim,klev) - REAL(KIND=wp) :: coln2o (kbdim,klev) - REAL(KIND=wp) :: colco (kbdim,klev) - REAL(KIND=wp) :: selffrac (kbdim,klev) - REAL(KIND=wp) :: colch4 (kbdim,klev) - REAL(KIND=wp) :: colo2 (kbdim,klev) - REAL(KIND=wp) :: colbrd (kbdim,klev) - REAL(KIND=wp) :: minorfrac (kbdim,klev) - REAL(KIND=wp) :: scaleminorn2(kbdim,klev) - REAL(KIND=wp) :: scaleminor (kbdim,klev) - REAL(KIND=wp) :: forfac (kbdim,klev) - REAL(KIND=wp) :: colco2 (kbdim,klev) - REAL(KIND=wp) :: forfrac (kbdim,klev) - !< column amount (h2o) - !< column amount (co2) - !< column amount (o3) - !< column amount (n2o) - !< column amount (co) - !< column amount (ch4) - !< column amount (o2) - !< column amount (broadening gases) - REAL(KIND=wp) :: wx_loc(size(wx, 2), size(wx, 3)) - !< Normalized CFC amounts (molecules/cm^2) - REAL(KIND=wp) :: fac00(kbdim,klev) - REAL(KIND=wp) :: fac01(kbdim,klev) - REAL(KIND=wp) :: fac10(kbdim,klev) - REAL(KIND=wp) :: fac11(kbdim,klev) - REAL(KIND=wp) :: rat_n2oco2 (kbdim,klev) - REAL(KIND=wp) :: rat_o3co2 (kbdim,klev) - REAL(KIND=wp) :: rat_h2on2o (kbdim,klev) - REAL(KIND=wp) :: rat_n2oco2_1(kbdim,klev) - REAL(KIND=wp) :: rat_h2on2o_1(kbdim,klev) - REAL(KIND=wp) :: rat_h2oco2_1(kbdim,klev) - REAL(KIND=wp) :: rat_h2oo3 (kbdim,klev) - REAL(KIND=wp) :: rat_h2och4 (kbdim,klev) - REAL(KIND=wp) :: rat_h2oco2 (kbdim,klev) - REAL(KIND=wp) :: rat_h2oo3_1 (kbdim,klev) - REAL(KIND=wp) :: rat_o3co2_1 (kbdim,klev) - REAL(KIND=wp) :: rat_h2och4_1(kbdim,klev) - ! ----------------- - INTEGER :: jl - INTEGER :: ig - INTEGER :: jk ! loop indicies - INTEGER :: igs(kbdim, n_gpts_ts) - INTEGER :: ibs(kbdim, n_gpts_ts) - INTEGER :: ib - INTEGER :: igpt - ! minimum val for clouds - ! Variables for sampling strategy - REAL(KIND=wp) :: gpt_scaling - REAL(KIND=wp) :: clrsky_scaling(1:kbdim) - REAL(KIND=wp) :: smp_tau(kbdim, klev, n_gpts_ts) - LOGICAL :: cldmask(kbdim, klev, n_gpts_ts) - LOGICAL :: colcldmask(kbdim, n_gpts_ts) !< cloud mask in each cell - !< cloud mask for each column - ! - ! -------------------------------- - ! - ! 1.0 Choose a set of g-points to do consistent with the spectral sampling strategy - ! - ! -------------------------------- - gpt_scaling = real(ngptlw,kind=wp)/real(n_gpts_ts,kind=wp) - ! Standalone logic - IF (do_gpoint == 0) THEN - igs(1:kproma,1:n_gpts_ts) = get_gpoint_set(kproma, kbdim, strategy, rnseeds) - ELSE IF (n_gpts_ts == 1) THEN ! Standalone logic - IF (do_gpoint > ngptlw) RETURN - igs(:, 1:n_gpts_ts) = do_gpoint - ELSE - PRINT *, "Asking for gpoint fluxes for too many gpoints!" - STOP - END IF - ! Save the band nunber associated with each gpoint - DO jl = 1, kproma - DO ig = 1, n_gpts_ts - ibs(jl, ig) = ngb(igs(jl, ig)) - END DO - END DO - ! - ! --- 2.0 Optical properties - ! - ! --- 2.1 Cloud optical properties. - ! -------------------------------- - ! Cloud optical depth is only saved for the band associated with this g-point - ! We sample clouds first because we may want to adjust water vapor based - ! on presence/absence of clouds - ! - CALL sample_cld_state(kproma, kbdim, klev, n_gpts_ts, rnseeds(:,:), i_overlap, cldfr(:,:), cldmask(:,:,:)) - !IBM* ASSERT(NODEPS) - DO ig = 1, n_gpts_ts - DO jl = 1, kproma - smp_tau(jl,:,ig) = merge(taucld(jl,1:klev,ibs(jl,ig)), 0._wp, cldmask(jl,:,ig)) - END DO - END DO ! Loop over samples - done with cloud optical depth calculations - ! - ! Cloud masks for sorting out clear skies - by cell and by column - ! - IF (.not. l_do_sep_clear_sky) THEN - ! - ! Are any layers cloudy? - ! - colcldmask(1:kproma, 1:n_gpts_ts) = any(cldmask(1:kproma,1:klev,1:n_gpts_ts), dim=2) - ! - ! Clear-sky scaling is gpt_scaling/frac_clr or 0 if all samples are cloudy - ! - clrsky_scaling(1:kproma) = gpt_scaling * & - merge(real(n_gpts_ts,kind=wp) / (real(n_gpts_ts - count(& - colcldmask(1:kproma,:),dim=2),kind=wp)), & - 0._wp, any(.not. colcldmask(1:kproma,:),dim=2)) - END IF - ! - ! --- 2.2. Gas optical depth calculations - ! - ! -------------------------------- - ! - ! 2.2.1 Calculate information needed by the radiative transfer routine - ! that is specific to this atmosphere, especially some of the - ! coefficients and indices needed to compute the optical depths - ! by interpolating data from stored reference atmospheres. - ! The coefficients are functions of temperature and pressure and remain the same - ! for all g-point samples. - ! If gas concentrations, temperatures, or pressures vary with sample (ig) - ! the coefficients need to be calculated inside the loop over samples - ! -------------------------------- - ! - ! Broadening gases -- the number of molecules per cm^2 of all gases not specified explicitly - ! (water is excluded) - wbrodl(1:kproma,1:klev) = coldry(1:kproma,1:klev) - sum(wkl(1:kproma,2:,1:klev), dim=2) - CALL lrtm_coeffs(kproma, kbdim, klev, play, tlay, coldry, wkl, wbrodl, laytrop, jp, jt, jt1, colh2o, colco2, colo3, & - coln2o, colco, colch4, colo2, colbrd, fac00, fac01, fac10, fac11, rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, & - rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, selffac, & - selffrac, indself, forfac, forfrac, indfor, minorfrac, scaleminor, scaleminorn2, indminor) - ! - ! 2.2.2 Loop over g-points calculating gas optical properties. - ! - ! -------------------------------- - !IBM* ASSERT(NODEPS) - DO ig = 1, n_gpts_ts - DO jl = 1, kproma - ib = ibs(jl, ig) - igpt = igs(jl, ig) - ! - ! Gas concentrations in colxx variables are normalized by 1.e-20_wp in lrtm_coeffs - ! CFC gas concentrations (wx) need the same normalization - ! Per Eli Mlawer the k values used in gas optics tables have been multiplied by 1e20 - wx_loc(:,:) = 1.e-20_wp * wx(jl,:,:) - CALL gas_optics_lw(klev, igpt, play (jl,:), wx_loc (:,:), coldry (jl,:), laytrop (jl), jp & - (jl,:), jt (jl,:), jt1 (jl,:), colh2o (jl,:), colco2 (jl,:), colo3 (jl,:)& - , coln2o (jl,:), colco (jl,:), colch4 (jl,:), colo2 (jl,:), colbrd (jl,:), fac00 & - (jl,:), fac01 (jl,:), fac10 (jl,:), fac11 (jl,:), rat_h2oco2 (jl,:), rat_h2oco2_1(jl,:), & - rat_h2oo3 (jl,:), rat_h2oo3_1 (jl,:), rat_h2on2o (jl,:), rat_h2on2o_1(jl,:), rat_h2och4(jl,:), rat_h2och4_1(& - jl,:), rat_n2oco2 (jl,:), rat_n2oco2_1(jl,:), rat_o3co2 (jl,:), rat_o3co2_1 (jl,:), selffac (jl,:), & - selffrac (jl,:), indself (jl,:), forfac (jl,:), forfrac (jl,:), indfor (jl,:), minorfrac (& - jl,:), scaleminor (jl,:), scaleminorn2(jl,:), indminor (jl,:), fracs (jl,:,ig), taug) - DO jk = 1, klev - taut(jl,jk,ig) = taug(jk) + tauaer(jl,jk,ib) - END DO - END DO ! Loop over columns - END DO ! Loop over g point samples - done with gas optical depth calculations - tautot(1:kproma,:,:) = taut(1:kproma,:,:) + smp_tau(1:kproma,:,:) ! All-sky optical depth. Mask for 0 cloud optical depth? - ! - ! --- 3.0 Compute radiative transfer. - ! -------------------------------- - ! - ! Initialize fluxes to zero - ! - uflx(1:kproma,0:klev) = 0.0_wp - dflx(1:kproma,0:klev) = 0.0_wp - uflxc(1:kproma,0:klev) = 0.0_wp - dflxc(1:kproma,0:klev) = 0.0_wp - ! - ! Planck function in each band at layers and boundaries - ! - !IBM* ASSERT(NODEPS) - DO ig = 1, nbndlw - planklay(1:kproma,1:klev,ig) = planckfunction(tlay(1:kproma,1:klev ),ig) - planklev(1:kproma,0:klev,ig) = planckfunction(tlev(1:kproma,1:klev+1),ig) - plankbnd(1:kproma, ig) = planckfunction(tsfc(1:kproma ),ig) - END DO - ! - ! Precipitable water vapor in each column - this can affect the integration angle secdiff - ! - pwvcm(1:kproma) = ((amw * sum(wkl(1:kproma,1,1:klev), dim=2)) / (amd * sum(coldry(1:kproma,& - 1:klev) + wkl(1:kproma,1,1:klev), dim=2))) * (1.e3_wp * psfc(1:kproma)) / (1.e2_wp * grav) - ! - ! Compute radiative transfer for each set of samples - ! - DO ig = 1, n_gpts_ts - secdiff(1:kproma) = find_secdiff(ibs(1:kproma, ig), pwvcm(1:kproma)) - !IBM* ASSERT(NODEPS) - DO jl = 1, kproma - ib = ibs(jl,ig) - layplnk(jl,1:klev) = planklay(jl,1:klev,ib) - levplnk(jl,0:klev) = planklev(jl,0:klev,ib) - bndplnk(jl) = plankbnd(jl, ib) - srfemis(jl) = emis (jl, ib) - END DO - ! - ! All sky fluxes - ! - CALL lrtm_solver(kproma, kbdim, klev, tautot(:,:,ig), layplnk, levplnk, fracs(:,:,ig), secdiff, bndplnk, srfemis, & - zgpfu, zgpfd) - uflx(1:kproma,0:klev) = uflx (1:kproma,0:klev) + zgpfu(1:kproma,0:klev) * gpt_scaling - dflx(1:kproma,0:klev) = dflx (1:kproma,0:klev) + zgpfd(1:kproma,0:klev) * gpt_scaling - ! - ! Clear-sky fluxes - ! - IF (l_do_sep_clear_sky) THEN - ! - ! Remove clouds and do second RT calculation - ! - CALL lrtm_solver(kproma, kbdim, klev, taut (:,:,ig), layplnk, levplnk, fracs(:,:,ig), secdiff, bndplnk, & - srfemis, zgpcu, zgpcd) - uflxc(1:kproma,0:klev) = uflxc(1:kproma,0:klev) + zgpcu(1:kproma,0:klev) * gpt_scaling - dflxc(1:kproma,0:klev) = dflxc(1:kproma,0:klev) + zgpcd(1:kproma,0:klev) * gpt_scaling - ELSE - ! - ! Accumulate fluxes by excluding cloudy subcolumns, weighting to account for smaller sample size - ! - !IBM* ASSERT(NODEPS) - DO jk = 0, klev - uflxc(1:kproma,jk) = uflxc(1:kproma,jk) & - + merge(0._wp, & - zgpfu(1:kproma,jk) * clrsky_scaling(1:kproma), & - colcldmask(1:kproma,ig)) - dflxc(1:kproma,jk) = dflxc(1:kproma,jk) & - + merge(0._wp, & - zgpfd(1:kproma,jk) * clrsky_scaling(1:kproma), & - colcldmask(1:kproma,ig)) - END DO - END IF - END DO ! Loop over samples - ! - ! --- 3.1 If computing clear-sky fluxes from samples, flag any columns where all samples were cloudy - ! - ! -------------------------------- - IF (.not. l_do_sep_clear_sky) THEN - !IBM* ASSERT(NODEPS) - DO jl = 1, kproma - IF (all(colcldmask(jl,:))) THEN - uflxc(jl,0:klev) = rad_undef - dflxc(jl,0:klev) = rad_undef - END IF - END DO - END IF - END SUBROUTINE lrtm - !---------------------------------------------------------------------------- - - elemental FUNCTION planckfunction(temp, band) - ! - ! Compute the blackbody emission in a given band as a function of temperature - ! - REAL(KIND=wp), intent(in) :: temp - INTEGER, intent(in) :: band - REAL(KIND=wp) :: planckfunction - INTEGER :: index - REAL(KIND=wp) :: fraction - index = min(max(1, int(temp - 159._wp)),180) - fraction = temp - 159._wp - float(index) - planckfunction = totplanck(index, band) + fraction * (totplanck(index+1, band) - totplanck(index, & - band)) - planckfunction = planckfunction * delwave(band) - END FUNCTION planckfunction - END MODULE mo_lrtm_driver diff --git a/test/ncar_kernels/PSRAD_lrtm/src/mo_lrtm_gas_optics.f90 b/test/ncar_kernels/PSRAD_lrtm/src/mo_lrtm_gas_optics.f90 deleted file mode 100644 index 2747c4b5af..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm/src/mo_lrtm_gas_optics.f90 +++ /dev/null @@ -1,2996 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_lrtm_gas_optics.f90 -! Generated at: 2015-02-19 15:30:40 -! KGEN version: 0.4.4 - - - - MODULE mo_lrtm_gas_optics - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! ------- Modules ------- - USE mo_kind, ONLY: wp - USE mo_exception, ONLY: finish - USE mo_lrtm_setup, ONLY: ngb - USE mo_lrtm_setup, ONLY: ngs - USE mo_lrtm_setup, ONLY: nspa - USE mo_lrtm_setup, ONLY: nspb - USE mo_lrtm_setup, ONLY: ngc - USE rrlw_planck, ONLY: chi_mls - IMPLICIT NONE - REAL(KIND=wp), parameter :: oneminus = 1.0_wp - 1.0e-06_wp - CONTAINS - - ! read subroutines - !---------------------------------------------------------------------------- - - SUBROUTINE gas_optics_lw(nlayers, igg, pavel, wx, coldry, laytrop, jp, jt, jt1, colh2o, colco2, colo3, coln2o, colco, & - colch4, colo2, colbrd, fac00, fac01, fac10, fac11, rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, rat_h2on2o, & - rat_h2on2o_1, rat_h2och4, rat_h2och4_1, rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, selffac, selffrac, indself, & - forfac, forfrac, indfor, minorfrac, scaleminor, scaleminorn2, indminor, fracs, taug) - !---------------------------------------------------------------------------- - ! ******************************************************************************* - ! * * - ! * Optical depths developed for the * - ! * * - ! * RAPID RADIATIVE TRANSFER MODEL (RRTM) * - ! * * - ! * * - ! * ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC. * - ! * 131 HARTWELL AVENUE * - ! * LEXINGTON, MA 02421 * - ! * * - ! * * - ! * ELI J. MLAWER * - ! * JENNIFER DELAMERE * - ! * STEVEN J. TAUBMAN * - ! * SHEPARD A. CLOUGH * - ! * * - ! * * - ! * * - ! * * - ! * email: mlawer@aer.com * - ! * email: jdelamer@aer.com * - ! * * - ! * The authors wish to acknowledge the contributions of the * - ! * following people: Karen Cady-Pereira, Patrick D. Brown, * - ! * Michael J. Iacono, Ronald E. Farren, Luke Chen, Robert Bergstrom. * - ! * * - ! ******************************************************************************* - ! * * - ! * Revision for g-point reduction: Michael J. Iacono, AER, Inc. * - ! * * - ! ******************************************************************************* - ! * TAUMOL * - ! * * - ! * This file contains the subroutines TAUGBn (where n goes from * - ! * 1 to 16). TAUGBn calculates the optical depths and Planck fractions * - ! * per g-value and layer for band n. * - ! * * - ! * Output: optical depths (unitless) * - ! * fractions needed to compute Planck functions at every layer * - ! * and g-value * - ! * * - ! * COMMON /TAUGCOM/ TAUG(MXLAY,MG) * - ! * COMMON /PLANKG/ FRACS(MXLAY,MG) * - ! * * - ! * Input * - ! * * - ! * COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS) * - ! * COMMON /PRECISE/ ONEMINUS * - ! * COMMON /PROFILE/ NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY), * - ! * & PZ(0:MXLAY),TZ(0:MXLAY) * - ! * COMMON /PROFDATA/ LAYTROP, * - ! * & COLH2O(MXLAY),COLCO2(MXLAY),COLO3(MXLAY), * - ! * & COLN2O(MXLAY),COLCO(MXLAY),COLCH4(MXLAY), * - ! * & COLO2(MXLAY) - ! * COMMON /INTFAC/ FAC00(MXLAY),FAC01(MXLAY), * - ! * & FAC10(MXLAY),FAC11(MXLAY) * - ! * COMMON /INTIND/ JP(MXLAY),JT(MXLAY),JT1(MXLAY) * - ! * COMMON /SELF/ SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(MXLAY) * - ! * * - ! * Description: * - ! * NG(IBAND) - number of g-values in band IBAND * - ! * NSPA(IBAND) - for the lower atmosphere, the number of reference * - ! * atmospheres that are stored for band IBAND per * - ! * pressure level and temperature. Each of these * - ! * atmospheres has different relative amounts of the * - ! * key species for the band (i.e. different binary * - ! * species parameters). * - ! * NSPB(IBAND) - same for upper atmosphere * - ! * ONEMINUS - since problems are caused in some cases by interpolation * - ! * parameters equal to or greater than 1, for these cases * - ! * these parameters are set to this value, slightly < 1. * - ! * PAVEL - layer pressures (mb) * - ! * TAVEL - layer temperatures (degrees K) * - ! * PZ - level pressures (mb) * - ! * TZ - level temperatures (degrees K) * - ! * LAYTROP - layer at which switch is made from one combination of * - ! * key species to another * - ! * COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water * - ! * vapor,carbon dioxide, ozone, nitrous ozide, methane, * - ! * respectively (molecules/cm**2) * - ! * FACij(LAY) - for layer LAY, these are factors that are needed to * - ! * compute the interpolation factors that multiply the * - ! * appropriate reference k-values. A value of 0 (1) for * - ! * i,j indicates that the corresponding factor multiplies * - ! * reference k-value for the lower (higher) of the two * - ! * appropriate temperatures, and altitudes, respectively. * - ! * JP - the index of the lower (in altitude) of the two appropriate * - ! * reference pressure levels needed for interpolation * - ! * JT, JT1 - the indices of the lower of the two appropriate reference * - ! * temperatures needed for interpolation (for pressure * - ! * levels JP and JP+1, respectively) * - ! * SELFFAC - scale factor needed for water vapor self-continuum, equals * - ! * (water vapor density)/(atmospheric density at 296K and * - ! * 1013 mb) * - ! * SELFFRAC - factor needed for temperature interpolation of reference * - ! * water vapor self-continuum data * - ! * INDSELF - index of the lower of the two appropriate reference * - ! * temperatures needed for the self-continuum interpolation * - ! * FORFAC - scale factor needed for water vapor foreign-continuum. * - ! * FORFRAC - factor needed for temperature interpolation of reference * - ! * water vapor foreign-continuum data * - ! * INDFOR - index of the lower of the two appropriate reference * - ! * temperatures needed for the foreign-continuum interpolation * - ! * * - ! * Data input * - ! * COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG),* - ! * FORREF(4,MG), KA_M'MGAS', KB_M'MGAS' * - ! * (note: n is the band number,'MGAS' is the species name of the minor * - ! * gas) * - ! * * - ! * Description: * - ! * KA - k-values for low reference atmospheres (key-species only) * - ! * (units: cm**2/molecule) * - ! * KB - k-values for high reference atmospheres (key-species only) * - ! * (units: cm**2/molecule) * - ! * KA_M'MGAS' - k-values for low reference atmosphere minor species * - ! * (units: cm**2/molecule) * - ! * KB_M'MGAS' - k-values for high reference atmosphere minor species * - ! * (units: cm**2/molecule) * - ! * SELFREF - k-values for water vapor self-continuum for reference * - ! * atmospheres (used below LAYTROP) * - ! * (units: cm**2/molecule) * - ! * FORREF - k-values for water vapor foreign-continuum for reference * - ! * atmospheres (used below/above LAYTROP) * - ! * (units: cm**2/molecule) * - ! * * - ! * DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG) * - ! * EQUIVALENCE (KA,ABSA),(KB,ABSB) * - ! * * - !******************************************************************************* - ! ------- Declarations ------- - ! ----- Input ----- - INTEGER, intent(in) :: igg ! g-point to process - INTEGER, intent(in) :: nlayers ! total number of layers - REAL(KIND=wp), intent(in) :: pavel(:) ! layer pressures (mb) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: wx(:,:) ! cross-section amounts (mol/cm2) - ! Dimensions: (maxxsec,nlayers) - REAL(KIND=wp), intent(in) :: coldry(:) ! column amount (dry air) - ! Dimensions: (nlayers) - INTEGER, intent(in) :: laytrop ! tropopause layer index - INTEGER, intent(in) :: jp(:) ! - ! Dimensions: (nlayers) - INTEGER, intent(in) :: jt(:) ! - ! Dimensions: (nlayers) - INTEGER, intent(in) :: jt1(:) ! - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: colh2o(:) ! column amount (h2o) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: colco2(:) ! column amount (co2) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: colo3(:) ! column amount (o3) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: coln2o(:) ! column amount (n2o) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: colco(:) ! column amount (co) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: colch4(:) ! column amount (ch4) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: colo2(:) ! column amount (o2) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: colbrd(:) ! column amount (broadening gases) - ! Dimensions: (nlayers) - INTEGER, intent(in) :: indself(:) - ! Dimensions: (nlayers) - INTEGER, intent(in) :: indfor(:) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: selffac(:) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: selffrac(:) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: forfac(:) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: forfrac(:) - ! Dimensions: (nlayers) - INTEGER, intent(in) :: indminor(:) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: minorfrac(:) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: scaleminor(:) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: scaleminorn2(:) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: fac11(:) - REAL(KIND=wp), intent(in) :: fac01(:) - REAL(KIND=wp), intent(in) :: fac00(:) - REAL(KIND=wp), intent(in) :: fac10(:) ! - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: rat_h2oco2(:) - REAL(KIND=wp), intent(in) :: rat_h2oco2_1(:) - REAL(KIND=wp), intent(in) :: rat_o3co2(:) - REAL(KIND=wp), intent(in) :: rat_o3co2_1(:) - REAL(KIND=wp), intent(in) :: rat_h2oo3(:) - REAL(KIND=wp), intent(in) :: rat_h2oo3_1(:) - REAL(KIND=wp), intent(in) :: rat_h2och4(:) - REAL(KIND=wp), intent(in) :: rat_h2och4_1(:) - REAL(KIND=wp), intent(in) :: rat_h2on2o(:) - REAL(KIND=wp), intent(in) :: rat_h2on2o_1(:) - REAL(KIND=wp), intent(in) :: rat_n2oco2(:) - REAL(KIND=wp), intent(in) :: rat_n2oco2_1(:) ! - ! Dimensions: (nlayers) - ! ----- Output ----- - REAL(KIND=wp), intent(out) :: fracs(:) ! planck fractions - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(out) :: taug(:) ! gaseous optical depth - ! Dimensions: (nlayers) - INTEGER :: ig - ! Calculate gaseous optical depth and planck fractions for each spectral band. - ! Local (within band) g-point - IF (ngb(igg) == 1) THEN - ig = igg - ELSE - ig = igg - ngs(ngb(igg) - 1) - END IF - SELECT CASE ( ngb(igg) ) - CASE ( 1 ) - CALL taumol01 - CASE ( 2 ) - CALL taumol02 - CASE ( 3 ) - CALL taumol03 - CASE ( 4 ) - CALL taumol04 - CASE ( 5 ) - CALL taumol05 - CASE ( 6 ) - CALL taumol06 - CASE ( 7 ) - CALL taumol07 - CASE ( 8 ) - CALL taumol08 - CASE ( 9 ) - CALL taumol09 - CASE ( 10 ) - CALL taumol10 - CASE ( 11 ) - CALL taumol11 - CASE ( 12 ) - CALL taumol12 - CASE ( 13 ) - CALL taumol13 - CASE ( 14 ) - CALL taumol14 - CASE ( 15 ) - CALL taumol15 - CASE ( 16 ) - CALL taumol16 - CASE DEFAULT - CALL finish('gas_optics_sw', 'Chosen band out of range') - END SELECT - CONTAINS - !---------------------------------------------------------------------------- - - SUBROUTINE taumol01() - !---------------------------------------------------------------------------- - ! ------- Modifications ------- - ! Written by Eli J. Mlawer, Atmospheric & Environmental Research. - ! Revised by Michael J. Iacono, Atmospheric & Environmental Research. - ! - ! band 1: 10-350 cm-1 (low key - h2o; low minor - n2) - ! (high key - h2o; high minor - n2) - ! - ! note: previous versions of rrtm band 1: - ! 10-250 cm-1 (low - h2o; high - h2o) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg01, ONLY: selfref - USE rrlw_kg01, ONLY: forref - USE rrlw_kg01, ONLY: ka_mn2 - USE rrlw_kg01, ONLY: absa - USE rrlw_kg01, ONLY: fracrefa - USE rrlw_kg01, ONLY: kb_mn2 - USE rrlw_kg01, ONLY: absb - USE rrlw_kg01, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - REAL(KIND=wp) :: pp - REAL(KIND=wp) :: corradj - REAL(KIND=wp) :: scalen2 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: taun2 - ! Minor gas mapping levels: - ! lower - n2, p = 142.5490 mbar, t = 215.70 k - ! upper - n2, p = 142.5490 mbar, t = 215.70 k - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature. Below laytrop, the water vapor self-continuum and - ! foreign continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(1) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(1) + 1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - pp = pavel(lay) - corradj = 1. - IF (pp .lt. 250._wp) THEN - corradj = 1._wp - 0.15_wp * (250._wp-pp) / 154.4_wp - END IF - scalen2 = colbrd(lay) * scaleminorn2(lay) - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - & - forref(indf,ig))) - taun2 = scalen2*(ka_mn2(indm,ig) + minorfrac(lay) * (ka_mn2(indm+1,ig) - ka_mn2(indm,& - ig))) - taug(lay) = corradj * (colh2o(lay) * (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) + tauself + taufor + taun2) - fracs(lay) = fracrefa(ig) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(1) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(1) + 1 - indf = indfor(lay) - indm = indminor(lay) - pp = pavel(lay) - corradj = 1._wp - 0.15_wp * (pp / 95.6_wp) - scalen2 = colbrd(lay) * scaleminorn2(lay) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - taun2 = scalen2*(kb_mn2(indm,ig) + minorfrac(lay) * (kb_mn2(indm+1,ig) - kb_mn2(indm,& - ig))) - taug(lay) = corradj * (colh2o(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) + taufor + taun2) - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol01 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol02() - !---------------------------------------------------------------------------- - ! - ! band 2: 350-500 cm-1 (low key - h2o; high key - h2o) - ! - ! note: previous version of rrtm band 2: - ! 250 - 500 cm-1 (low - h2o; high - h2o) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg02, ONLY: selfref - USE rrlw_kg02, ONLY: forref - USE rrlw_kg02, ONLY: absa - USE rrlw_kg02, ONLY: fracrefa - USE rrlw_kg02, ONLY: absb - USE rrlw_kg02, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - REAL(KIND=wp) :: pp - REAL(KIND=wp) :: corradj - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature. Below laytrop, the water vapor self-continuum and - ! foreign continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(2) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(2) + 1 - inds = indself(lay) - indf = indfor(lay) - pp = pavel(lay) - corradj = 1._wp - .05_wp * (pp - 100._wp) / 900._wp - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - taug(lay) = corradj * (colh2o(lay) * (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) + tauself + taufor) - fracs(lay) = fracrefa(ig) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(2) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(2) + 1 - indf = indfor(lay) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - taug(lay) = colh2o(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) + taufor - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol02 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol03() - !---------------------------------------------------------------------------- - ! - ! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o) - ! (high key - h2o,co2; high minor - n2o) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg03, ONLY: selfref - USE rrlw_kg03, ONLY: forref - USE rrlw_kg03, ONLY: ka_mn2o - USE rrlw_kg03, ONLY: absa - USE rrlw_kg03, ONLY: fracrefa - USE rrlw_kg03, ONLY: kb_mn2o - USE rrlw_kg03, ONLY: absb - USE rrlw_kg03, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: js - INTEGER :: js1 - INTEGER :: jmn2o - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_mn2o - REAL(KIND=wp) :: specparm_mn2o - REAL(KIND=wp) :: specmult_mn2o - REAL(KIND=wp) :: fmn2o - REAL(KIND=wp) :: fmn2omf - REAL(KIND=wp) :: chi_n2o - REAL(KIND=wp) :: ratn2o - REAL(KIND=wp) :: adjfac - REAL(KIND=wp) :: adjcoln2o - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: n2om1 - REAL(KIND=wp) :: n2om2 - REAL(KIND=wp) :: absn2o - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: refrat_planck_b - REAL(KIND=wp) :: refrat_m_a - REAL(KIND=wp) :: refrat_m_b - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - ! Minor gas mapping levels: - ! lower - n2o, p = 706.272 mbar, t = 278.94 k - ! upper - n2o, p = 95.58 mbar, t = 215.7 k - ! P = 212.725 mb - refrat_planck_a = chi_mls(1,9)/chi_mls(2,9) - ! P = 95.58 mb - refrat_planck_b = chi_mls(1,13)/chi_mls(2,13) - ! P = 706.270mb - refrat_m_a = chi_mls(1,3)/chi_mls(2,3) - ! P = 95.58 mb - refrat_m_b = chi_mls(1,13)/chi_mls(2,13) - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature, and appropriate species. Below laytrop, the water vapor - ! self-continuum and foreign continuum is interpolated (in temperature) - ! separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_mn2o = colh2o(lay) + refrat_m_a*colco2(lay) - specparm_mn2o = colh2o(lay)/speccomb_mn2o - IF (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus - specmult_mn2o = 8._wp*specparm_mn2o - jmn2o = 1 + int(specmult_mn2o) - fmn2o = mod(specmult_mn2o,1.0_wp) - fmn2omf = minorfrac(lay)*fmn2o - ! In atmospheres where the amount of N2O is too great to be considered - ! a minor species, adjust the column amount of N2O by an empirical factor - ! to obtain the proper contribution. - chi_n2o = coln2o(lay)/coldry(lay) - ratn2o = 1.e20_wp*chi_n2o/chi_mls(4,jp(lay)+1) - IF (ratn2o .gt. 1.5_wp) THEN - adjfac = 0.5_wp+(ratn2o-0.5_wp)**0.65_wp - adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_wp - ELSE - adjcoln2o = coln2o(lay) - END IF - speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(3) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(3) + js1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o * (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,& - indm,ig)) - n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o * (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(& - jmn2o,indm+1,ig)) - absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor + adjcoln2o*absn2o - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 4._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 4._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - speccomb_mn2o = colh2o(lay) + refrat_m_b*colco2(lay) - specparm_mn2o = colh2o(lay)/speccomb_mn2o - IF (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus - specmult_mn2o = 4._wp*specparm_mn2o - jmn2o = 1 + int(specmult_mn2o) - fmn2o = mod(specmult_mn2o,1.0_wp) - fmn2omf = minorfrac(lay)*fmn2o - ! In atmospheres where the amount of N2O is too great to be considered - ! a minor species, adjust the column amount of N2O by an empirical factor - ! to obtain the proper contribution. - chi_n2o = coln2o(lay)/coldry(lay) - ratn2o = 1.e20*chi_n2o/chi_mls(4,jp(lay)+1) - IF (ratn2o .gt. 1.5_wp) THEN - adjfac = 0.5_wp+(ratn2o-0.5_wp)**0.65_wp - adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_wp - ELSE - adjcoln2o = coln2o(lay) - END IF - speccomb_planck = colh2o(lay)+refrat_planck_b*colco2(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 4._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(3) + js - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(3) + js1 - indf = indfor(lay) - indm = indminor(lay) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - n2om1 = kb_mn2o(jmn2o,indm,ig) + fmn2o * (kb_mn2o(jmn2o+1,indm,ig)-kb_mn2o(jmn2o,& - indm,ig)) - n2om2 = kb_mn2o(jmn2o,indm+1,ig) + fmn2o * (kb_mn2o(jmn2o+1,indm+1,ig)-kb_mn2o(jmn2o,& - indm+1,ig)) - absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1) - taug(lay) = speccomb * (fac000 * absb(ind0,ig) + fac100 * & - absb(ind0+1,ig) + fac010 * absb(ind0+5,ig) + fac110 * absb(& - ind0+6,ig)) + speccomb1 * (fac001 * absb(ind1,ig) + & - fac101 * absb(ind1+1,ig) + fac011 * absb(ind1+5,ig) + & - fac111 * absb(ind1+6,ig)) + taufor + adjcoln2o*absn2o - fracs(lay) = fracrefb(ig,jpl) + fpl * (fracrefb(ig,jpl+1)-fracrefb(ig,jpl)) - END DO - END SUBROUTINE taumol03 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol04() - !---------------------------------------------------------------------------- - ! - ! band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg04, ONLY: selfref - USE rrlw_kg04, ONLY: forref - USE rrlw_kg04, ONLY: absa - USE rrlw_kg04, ONLY: fracrefa - USE rrlw_kg04, ONLY: absb - USE rrlw_kg04, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: js - INTEGER :: js1 - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: refrat_planck_b - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - REAL(KIND=wp), dimension(ngc(4)), parameter :: stratcorrect = (/ 1., 1., 1., 1., 1., 1., 1., .92, .88, 1.07, 1.1, & - .99, .88, .943 /) - ! P = 142.5940 mb - refrat_planck_a = chi_mls(1,11)/chi_mls(2,11) - ! P = 95.58350 mb - refrat_planck_b = chi_mls(3,13)/chi_mls(2,13) - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature, and appropriate species. Below laytrop, the water - ! vapor self-continuum and foreign continuum is interpolated (in temperature) - ! separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(4) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(4) + js1 - inds = indself(lay) - indf = indfor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - speccomb = colo3(lay) + rat_o3co2(lay)*colco2(lay) - specparm = colo3(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 4._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colo3(lay) + rat_o3co2_1(lay)*colco2(lay) - specparm1 = colo3(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 4._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - speccomb_planck = colo3(lay)+refrat_planck_b*colco2(lay) - specparm_planck = colo3(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 4._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(4) + js - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(4) + js1 - taug(lay) = speccomb * (fac000 * absb(ind0,ig) + fac100 * & - absb(ind0+1,ig) + fac010 * absb(ind0+5,ig) + fac110 * absb(& - ind0+6,ig)) + speccomb1 * (fac001 * absb(ind1,ig) + & - fac101 * absb(ind1+1,ig) + fac011 * absb(ind1+5,ig) + & - fac111 * absb(ind1+6,ig)) - fracs(lay) = fracrefb(ig,jpl) + fpl * (fracrefb(ig,jpl+1)-fracrefb(ig,jpl)) - ! Empirical modification to code to improve stratospheric cooling rates - ! for co2. Revised to apply weighting for g-point reduction in this band. - ! taug(lay,ngs3+8)=taug(lay,ngs3+8)*0.92 - ! taug(lay,ngs3+9)=taug(lay,ngs3+9)*0.88 - ! taug(lay,ngs3+10)=taug(lay,ngs3+10)*1.07 - ! taug(lay,ngs3+11)=taug(lay,ngs3+11)*1.1 - ! taug(lay,ngs3+12)=taug(lay,ngs3+12)*0.99 - ! taug(lay,ngs3+13)=taug(lay,ngs3+13)*0.88 - ! taug(lay,ngs3+14)=taug(lay,ngs3+14)*0.943 - END DO - taug(laytrop+1:nlayers) = taug(laytrop+1:nlayers) * stratcorrect(ig) - END SUBROUTINE taumol04 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol05() - !---------------------------------------------------------------------------- - ! - ! band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4) - ! (high key - o3,co2) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg05, ONLY: selfref - USE rrlw_kg05, ONLY: forref - USE rrlw_kg05, ONLY: ka_mo3 - USE rrlw_kg05, ONLY: absa - USE rrlw_kg05, ONLY: ccl4 - USE rrlw_kg05, ONLY: fracrefa - USE rrlw_kg05, ONLY: absb - USE rrlw_kg05, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: js - INTEGER :: js1 - INTEGER :: jmo3 - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_mo3 - REAL(KIND=wp) :: specparm_mo3 - REAL(KIND=wp) :: specmult_mo3 - REAL(KIND=wp) :: fmo3 - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: o3m1 - REAL(KIND=wp) :: o3m2 - REAL(KIND=wp) :: abso3 - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: refrat_planck_b - REAL(KIND=wp) :: refrat_m_a - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - ! Minor gas mapping level : - ! lower - o3, p = 317.34 mbar, t = 240.77 k - ! lower - ccl4 - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower/upper atmosphere. - ! P = 473.420 mb - refrat_planck_a = chi_mls(1,5)/chi_mls(2,5) - ! P = 0.2369 mb - refrat_planck_b = chi_mls(3,43)/chi_mls(2,43) - ! P = 317.3480 - refrat_m_a = chi_mls(1,7)/chi_mls(2,7) - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature, and appropriate species. Below laytrop, the - ! water vapor self-continuum and foreign continuum is - ! interpolated (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_mo3 = colh2o(lay) + refrat_m_a*colco2(lay) - specparm_mo3 = colh2o(lay)/speccomb_mo3 - IF (specparm_mo3 .ge. oneminus) specparm_mo3 = oneminus - specmult_mo3 = 8._wp*specparm_mo3 - jmo3 = 1 + int(specmult_mo3) - fmo3 = mod(specmult_mo3,1.0_wp) - speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(5) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(5) + js1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - o3m1 = ka_mo3(jmo3,indm,ig) + fmo3 * (ka_mo3(jmo3+1,indm,ig)-ka_mo3(jmo3,indm,ig)) - o3m2 = ka_mo3(jmo3,indm+1,ig) + fmo3 * (ka_mo3(jmo3+1,indm+1,ig)-ka_mo3(jmo3,indm+1,& - ig)) - abso3 = o3m1 + minorfrac(lay)*(o3m2-o3m1) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor + & - abso3*colo3(lay) + wx(1,lay) * ccl4(ig) - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - speccomb = colo3(lay) + rat_o3co2(lay)*colco2(lay) - specparm = colo3(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 4._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colo3(lay) + rat_o3co2_1(lay)*colco2(lay) - specparm1 = colo3(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 4._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - speccomb_planck = colo3(lay)+refrat_planck_b*colco2(lay) - specparm_planck = colo3(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 4._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(5) + js - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(5) + js1 - taug(lay) = speccomb * (fac000 * absb(ind0,ig) + fac100 * & - absb(ind0+1,ig) + fac010 * absb(ind0+5,ig) + fac110 * absb(& - ind0+6,ig)) + speccomb1 * (fac001 * absb(ind1,ig) + & - fac101 * absb(ind1+1,ig) + fac011 * absb(ind1+5,ig) + & - fac111 * absb(ind1+6,ig)) + wx(1,lay) * ccl4(ig) - fracs(lay) = fracrefb(ig,jpl) + fpl * (fracrefb(ig,jpl+1)-fracrefb(ig,jpl)) - END DO - END SUBROUTINE taumol05 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol06() - !---------------------------------------------------------------------------- - ! - ! band 6: 820-980 cm-1 (low key - h2o; low minor - co2) - ! (high key - nothing; high minor - cfc11, cfc12) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg06, ONLY: selfref - USE rrlw_kg06, ONLY: forref - USE rrlw_kg06, ONLY: ka_mco2 - USE rrlw_kg06, ONLY: cfc12 - USE rrlw_kg06, ONLY: absa - USE rrlw_kg06, ONLY: cfc11adj - USE rrlw_kg06, ONLY: fracrefa - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - REAL(KIND=wp) :: chi_co2 - REAL(KIND=wp) :: ratco2 - REAL(KIND=wp) :: adjfac - REAL(KIND=wp) :: adjcolco2 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: absco2 - ! Minor gas mapping level: - ! lower - co2, p = 706.2720 mb, t = 294.2 k - ! upper - cfc11, cfc12 - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature. The water vapor self-continuum and foreign continuum - ! is interpolated (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - ! In atmospheres where the amount of CO2 is too great to be considered - ! a minor species, adjust the column amount of CO2 by an empirical factor - ! to obtain the proper contribution. - chi_co2 = colco2(lay)/(coldry(lay)) - ratco2 = 1.e20_wp*chi_co2/chi_mls(2,jp(lay)+1) - IF (ratco2 .gt. 3.0_wp) THEN - adjfac = 2.0_wp+(ratco2-2.0_wp)**0.77_wp - adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_wp - ELSE - adjcolco2 = colco2(lay) - END IF - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(6) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(6) + 1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - absco2 = (ka_mco2(indm,ig) + minorfrac(lay) * (ka_mco2(indm+1,ig) - ka_mco2(indm,ig))& - ) - taug(lay) = colh2o(lay) * (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) + tauself + taufor + & - adjcolco2 * absco2 + wx(2,lay) * cfc11adj(ig) + wx(3,lay) * & - cfc12(ig) - fracs(lay) = fracrefa(ig) - END DO - ! Upper atmosphere loop - ! Nothing important goes on above laytrop in this band. - DO lay = laytrop+1, nlayers - taug(lay) = 0.0_wp + wx(2,lay) * cfc11adj(ig) + wx(3,lay) * & - cfc12(ig) - fracs(lay) = fracrefa(ig) - END DO - END SUBROUTINE taumol06 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol07() - !---------------------------------------------------------------------------- - ! - ! band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2) - ! (high key - o3; high minor - co2) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg07, ONLY: selfref - USE rrlw_kg07, ONLY: forref - USE rrlw_kg07, ONLY: ka_mco2 - USE rrlw_kg07, ONLY: absa - USE rrlw_kg07, ONLY: fracrefa - USE rrlw_kg07, ONLY: kb_mco2 - USE rrlw_kg07, ONLY: absb - USE rrlw_kg07, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: js - INTEGER :: js1 - INTEGER :: jmco2 - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_mco2 - REAL(KIND=wp) :: specparm_mco2 - REAL(KIND=wp) :: specmult_mco2 - REAL(KIND=wp) :: fmco2 - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: co2m1 - REAL(KIND=wp) :: co2m2 - REAL(KIND=wp) :: absco2 - REAL(KIND=wp) :: chi_co2 - REAL(KIND=wp) :: ratco2 - REAL(KIND=wp) :: adjfac - REAL(KIND=wp) :: adjcolco2 - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: refrat_m_a - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - REAL(KIND=wp), dimension(ngc(7)), parameter :: stratcorrect = (/ 1., 1., 1., 1., 1., .92, .88, 1.07, 1.1, .99, & - .855, 1. /) - ! Minor gas mapping level : - ! lower - co2, p = 706.2620 mbar, t= 278.94 k - ! upper - co2, p = 12.9350 mbar, t = 234.01 k - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower atmosphere. - ! P = 706.2620 mb - refrat_planck_a = chi_mls(1,3)/chi_mls(3,3) - ! P = 706.2720 mb - refrat_m_a = chi_mls(1,3)/chi_mls(3,3) - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below laytrop, the water - ! vapor self-continuum and foreign continuum is interpolated - ! (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2oo3(lay)*colo3(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2oo3_1(lay)*colo3(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_mco2 = colh2o(lay) + refrat_m_a*colo3(lay) - specparm_mco2 = colh2o(lay)/speccomb_mco2 - IF (specparm_mco2 .ge. oneminus) specparm_mco2 = oneminus - specmult_mco2 = 8._wp*specparm_mco2 - jmco2 = 1 + int(specmult_mco2) - fmco2 = mod(specmult_mco2,1.0_wp) - ! In atmospheres where the amount of CO2 is too great to be considered - ! a minor species, adjust the column amount of CO2 by an empirical factor - ! to obtain the proper contribution. - chi_co2 = colco2(lay)/(coldry(lay)) - ratco2 = 1.e20*chi_co2/chi_mls(2,jp(lay)+1) - IF (ratco2 .gt. 3.0_wp) THEN - adjfac = 3.0_wp+(ratco2-3.0_wp)**0.79_wp - adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_wp - ELSE - adjcolco2 = colco2(lay) - END IF - speccomb_planck = colh2o(lay)+refrat_planck_a*colo3(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(7) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(7) + js1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 * (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,& - indm,ig)) - co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 * (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(& - jmco2,indm+1,ig)) - absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor + adjcolco2*absco2 - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ! In atmospheres where the amount of CO2 is too great to be considered - ! a minor species, adjust the column amount of CO2 by an empirical factor - ! to obtain the proper contribution. - chi_co2 = colco2(lay)/(coldry(lay)) - ratco2 = 1.e20*chi_co2/chi_mls(2,jp(lay)+1) - IF (ratco2 .gt. 3.0_wp) THEN - adjfac = 2.0_wp+(ratco2-2.0_wp)**0.79_wp - adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_wp - ELSE - adjcolco2 = colco2(lay) - END IF - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(7) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(7) + 1 - indm = indminor(lay) - absco2 = kb_mco2(indm,ig) + minorfrac(lay) * (kb_mco2(indm+1,ig) - kb_mco2(indm,ig)) - taug(lay) = colo3(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) + adjcolco2 * absco2 - fracs(lay) = fracrefb(ig) - ! Empirical modification to code to improve stratospheric cooling rates - ! for o3. Revised to apply weighting for g-point reduction in this band. - ! taug(lay,ngs6+6)=taug(lay,ngs6+6)*0.92_wp - ! taug(lay,ngs6+7)=taug(lay,ngs6+7)*0.88_wp - ! taug(lay,ngs6+8)=taug(lay,ngs6+8)*1.07_wp - ! taug(lay,ngs6+9)=taug(lay,ngs6+9)*1.1_wp - ! taug(lay,ngs6+10)=taug(lay,ngs6+10)*0.99_wp - ! taug(lay,ngs6+11)=taug(lay,ngs6+11)*0.855_wp - END DO - taug(laytrop+1:nlayers) = taug(laytrop+1:nlayers) * stratcorrect(ig) - END SUBROUTINE taumol07 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol08() - !---------------------------------------------------------------------------- - ! - ! band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o) - ! (high key - o3; high minor - co2, n2o) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg08, ONLY: selfref - USE rrlw_kg08, ONLY: forref - USE rrlw_kg08, ONLY: ka_mco2 - USE rrlw_kg08, ONLY: ka_mo3 - USE rrlw_kg08, ONLY: ka_mn2o - USE rrlw_kg08, ONLY: absa - USE rrlw_kg08, ONLY: cfc22adj - USE rrlw_kg08, ONLY: cfc12 - USE rrlw_kg08, ONLY: fracrefa - USE rrlw_kg08, ONLY: kb_mco2 - USE rrlw_kg08, ONLY: kb_mn2o - USE rrlw_kg08, ONLY: absb - USE rrlw_kg08, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: absco2 - REAL(KIND=wp) :: abso3 - REAL(KIND=wp) :: absn2o - REAL(KIND=wp) :: chi_co2 - REAL(KIND=wp) :: ratco2 - REAL(KIND=wp) :: adjfac - REAL(KIND=wp) :: adjcolco2 - ! Minor gas mapping level: - ! lower - co2, p = 1053.63 mb, t = 294.2 k - ! lower - o3, p = 317.348 mb, t = 240.77 k - ! lower - n2o, p = 706.2720 mb, t= 278.94 k - ! lower - cfc12,cfc11 - ! upper - co2, p = 35.1632 mb, t = 223.28 k - ! upper - n2o, p = 8.716e-2 mb, t = 226.03 k - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature, and appropriate species. Below laytrop, the water vapor - ! self-continuum and foreign continuum is interpolated (in temperature) - ! separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - ! In atmospheres where the amount of CO2 is too great to be considered - ! a minor species, adjust the column amount of CO2 by an empirical factor - ! to obtain the proper contribution. - chi_co2 = colco2(lay)/(coldry(lay)) - ratco2 = 1.e20_wp*chi_co2/chi_mls(2,jp(lay)+1) - IF (ratco2 .gt. 3.0_wp) THEN - adjfac = 2.0_wp+(ratco2-2.0_wp)**0.65_wp - adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_wp - ELSE - adjcolco2 = colco2(lay) - END IF - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(8) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(8) + 1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - absco2 = (ka_mco2(indm,ig) + minorfrac(lay) * (ka_mco2(indm+1,ig) - ka_mco2(indm,ig))& - ) - abso3 = (ka_mo3(indm,ig) + minorfrac(lay) * (ka_mo3(indm+1,ig) - ka_mo3(indm,ig))) - absn2o = (ka_mn2o(indm,ig) + minorfrac(lay) * (ka_mn2o(indm+1,ig) - ka_mn2o(indm,ig))& - ) - taug(lay) = colh2o(lay) * (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) + tauself + taufor + & - adjcolco2*absco2 + colo3(lay) * abso3 + coln2o(lay) * & - absn2o + wx(3,lay) * cfc12(ig) + wx(4,lay) * cfc22adj(ig) - fracs(lay) = fracrefa(ig) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ! In atmospheres where the amount of CO2 is too great to be considered - ! a minor species, adjust the column amount of CO2 by an empirical factor - ! to obtain the proper contribution. - chi_co2 = colco2(lay)/coldry(lay) - ratco2 = 1.e20_wp*chi_co2/chi_mls(2,jp(lay)+1) - IF (ratco2 .gt. 3.0_wp) THEN - adjfac = 2.0_wp+(ratco2-2.0_wp)**0.65_wp - adjcolco2 = adjfac*chi_mls(2,jp(lay)+1) * coldry(lay)*1.e-20_wp - ELSE - adjcolco2 = colco2(lay) - END IF - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(8) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(8) + 1 - indm = indminor(lay) - absco2 = (kb_mco2(indm,ig) + minorfrac(lay) * (kb_mco2(indm+1,ig) - kb_mco2(indm,ig))& - ) - absn2o = (kb_mn2o(indm,ig) + minorfrac(lay) * (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig))& - ) - taug(lay) = colo3(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) + adjcolco2*absco2 + coln2o(& - lay)*absn2o + wx(3,lay) * cfc12(ig) + wx(4,lay) * cfc22adj(& - ig) - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol08 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol09() - !---------------------------------------------------------------------------- - ! - ! band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o) - ! (high key - ch4; high minor - n2o) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg09, ONLY: selfref - USE rrlw_kg09, ONLY: forref - USE rrlw_kg09, ONLY: ka_mn2o - USE rrlw_kg09, ONLY: absa - USE rrlw_kg09, ONLY: fracrefa - USE rrlw_kg09, ONLY: kb_mn2o - USE rrlw_kg09, ONLY: absb - USE rrlw_kg09, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: js - INTEGER :: js1 - INTEGER :: jmn2o - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_mn2o - REAL(KIND=wp) :: specparm_mn2o - REAL(KIND=wp) :: specmult_mn2o - REAL(KIND=wp) :: fmn2o - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: n2om1 - REAL(KIND=wp) :: n2om2 - REAL(KIND=wp) :: absn2o - REAL(KIND=wp) :: chi_n2o - REAL(KIND=wp) :: ratn2o - REAL(KIND=wp) :: adjfac - REAL(KIND=wp) :: adjcoln2o - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: refrat_m_a - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - ! Minor gas mapping level : - ! lower - n2o, p = 706.272 mbar, t = 278.94 k - ! upper - n2o, p = 95.58 mbar, t = 215.7 k - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower/upper atmosphere. - ! P = 212 mb - refrat_planck_a = chi_mls(1,9)/chi_mls(6,9) - ! P = 706.272 mb - refrat_m_a = chi_mls(1,3)/chi_mls(6,3) - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below laytrop, the water - ! vapor self-continuum and foreign continuum is interpolated - ! (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2och4(lay)*colch4(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2och4_1(lay)*colch4(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_mn2o = colh2o(lay) + refrat_m_a*colch4(lay) - specparm_mn2o = colh2o(lay)/speccomb_mn2o - IF (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus - specmult_mn2o = 8._wp*specparm_mn2o - jmn2o = 1 + int(specmult_mn2o) - fmn2o = mod(specmult_mn2o,1.0_wp) - ! In atmospheres where the amount of N2O is too great to be considered - ! a minor species, adjust the column amount of N2O by an empirical factor - ! to obtain the proper contribution. - chi_n2o = coln2o(lay)/(coldry(lay)) - ratn2o = 1.e20_wp*chi_n2o/chi_mls(4,jp(lay)+1) - IF (ratn2o .gt. 1.5_wp) THEN - adjfac = 0.5_wp+(ratn2o-0.5_wp)**0.65_wp - adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_wp - ELSE - adjcoln2o = coln2o(lay) - END IF - speccomb_planck = colh2o(lay)+refrat_planck_a*colch4(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(9) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(9) + js1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o * (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,& - indm,ig)) - n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o * (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(& - jmn2o,indm+1,ig)) - absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor + adjcoln2o*absn2o - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ! In atmospheres where the amount of N2O is too great to be considered - ! a minor species, adjust the column amount of N2O by an empirical factor - ! to obtain the proper contribution. - chi_n2o = coln2o(lay)/(coldry(lay)) - ratn2o = 1.e20_wp*chi_n2o/chi_mls(4,jp(lay)+1) - IF (ratn2o .gt. 1.5_wp) THEN - adjfac = 0.5_wp+(ratn2o-0.5_wp)**0.65_wp - adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_wp - ELSE - adjcoln2o = coln2o(lay) - END IF - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(9) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(9) + 1 - indm = indminor(lay) - absn2o = kb_mn2o(indm,ig) + minorfrac(lay) * (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig)) - taug(lay) = colch4(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) + adjcoln2o*absn2o - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol09 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol10() - !---------------------------------------------------------------------------- - ! - ! band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg10, ONLY: selfref - USE rrlw_kg10, ONLY: forref - USE rrlw_kg10, ONLY: absa - USE rrlw_kg10, ONLY: fracrefa - USE rrlw_kg10, ONLY: absb - USE rrlw_kg10, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature. Below laytrop, the water vapor self-continuum and - ! foreign continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(10) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(10) + 1 - inds = indself(lay) - indf = indfor(lay) - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - taug(lay) = colh2o(lay) * (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) + tauself + taufor - fracs(lay) = fracrefa(ig) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(10) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(10) + 1 - indf = indfor(lay) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - taug(lay) = colh2o(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) + taufor - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol10 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol11() - !---------------------------------------------------------------------------- - ! - ! band 11: 1480-1800 cm-1 (low - h2o; low minor - o2) - ! (high key - h2o; high minor - o2) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg11, ONLY: selfref - USE rrlw_kg11, ONLY: forref - USE rrlw_kg11, ONLY: ka_mo2 - USE rrlw_kg11, ONLY: absa - USE rrlw_kg11, ONLY: fracrefa - USE rrlw_kg11, ONLY: kb_mo2 - USE rrlw_kg11, ONLY: absb - USE rrlw_kg11, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - REAL(KIND=wp) :: scaleo2 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: tauo2 - ! Minor gas mapping level : - ! lower - o2, p = 706.2720 mbar, t = 278.94 k - ! upper - o2, p = 4.758820 mbarm t = 250.85 k - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature. Below laytrop, the water vapor self-continuum and - ! foreign continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(11) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(11) + 1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - scaleo2 = colo2(lay)*scaleminor(lay) - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - tauo2 = scaleo2 * (ka_mo2(indm,ig) + minorfrac(lay) * (ka_mo2(indm+1,ig) - ka_mo2(& - indm,ig))) - taug(lay) = colh2o(lay) * (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) + tauself + taufor + tauo2 - fracs(lay) = fracrefa(ig) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(11) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(11) + 1 - indf = indfor(lay) - indm = indminor(lay) - scaleo2 = colo2(lay)*scaleminor(lay) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - tauo2 = scaleo2 * (kb_mo2(indm,ig) + minorfrac(lay) * (kb_mo2(indm+1,ig) - kb_mo2(& - indm,ig))) - taug(lay) = colh2o(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) + taufor + tauo2 - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol11 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol12() - !---------------------------------------------------------------------------- - ! - ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg12, ONLY: selfref - USE rrlw_kg12, ONLY: forref - USE rrlw_kg12, ONLY: absa - USE rrlw_kg12, ONLY: fracrefa - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: js - INTEGER :: js1 - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower/upper atmosphere. - ! P = 174.164 mb - refrat_planck_a = chi_mls(1,10)/chi_mls(2,10) - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below laytrop, the water - ! vapor self-continuum adn foreign continuum is interpolated - ! (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(12) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(12) + js1 - inds = indself(lay) - indf = indfor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - taug(lay) = 0.0_wp - fracs(lay) = 0.0_wp - END DO - END SUBROUTINE taumol12 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol13() - !---------------------------------------------------------------------------- - ! - ! band 13: 2080-2250 cm-1 (low key - h2o,n2o; high minor - o3 minor) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg13, ONLY: selfref - USE rrlw_kg13, ONLY: forref - USE rrlw_kg13, ONLY: ka_mco2 - USE rrlw_kg13, ONLY: ka_mco - USE rrlw_kg13, ONLY: absa - USE rrlw_kg13, ONLY: fracrefa - USE rrlw_kg13, ONLY: kb_mo3 - USE rrlw_kg13, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: js - INTEGER :: js1 - INTEGER :: jmco2 - INTEGER :: jmco - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_mco2 - REAL(KIND=wp) :: specparm_mco2 - REAL(KIND=wp) :: specmult_mco2 - REAL(KIND=wp) :: fmco2 - REAL(KIND=wp) :: speccomb_mco - REAL(KIND=wp) :: specparm_mco - REAL(KIND=wp) :: specmult_mco - REAL(KIND=wp) :: fmco - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: co2m1 - REAL(KIND=wp) :: co2m2 - REAL(KIND=wp) :: absco2 - REAL(KIND=wp) :: com1 - REAL(KIND=wp) :: com2 - REAL(KIND=wp) :: absco - REAL(KIND=wp) :: abso3 - REAL(KIND=wp) :: chi_co2 - REAL(KIND=wp) :: ratco2 - REAL(KIND=wp) :: adjfac - REAL(KIND=wp) :: adjcolco2 - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: refrat_m_a - REAL(KIND=wp) :: refrat_m_a3 - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - ! Minor gas mapping levels : - ! lower - co2, p = 1053.63 mb, t = 294.2 k - ! lower - co, p = 706 mb, t = 278.94 k - ! upper - o3, p = 95.5835 mb, t = 215.7 k - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower/upper atmosphere. - ! P = 473.420 mb (Level 5) - refrat_planck_a = chi_mls(1,5)/chi_mls(4,5) - ! P = 1053. (Level 1) - refrat_m_a = chi_mls(1,1)/chi_mls(4,1) - ! P = 706. (Level 3) - refrat_m_a3 = chi_mls(1,3)/chi_mls(4,3) - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below laytrop, the water - ! vapor self-continuum and foreign continuum is interpolated - ! (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2on2o(lay)*coln2o(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2on2o_1(lay)*coln2o(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_mco2 = colh2o(lay) + refrat_m_a*coln2o(lay) - specparm_mco2 = colh2o(lay)/speccomb_mco2 - IF (specparm_mco2 .ge. oneminus) specparm_mco2 = oneminus - specmult_mco2 = 8._wp*specparm_mco2 - jmco2 = 1 + int(specmult_mco2) - fmco2 = mod(specmult_mco2,1.0_wp) - ! In atmospheres where the amount of CO2 is too great to be considered - ! a minor species, adjust the column amount of CO2 by an empirical factor - ! to obtain the proper contribution. - chi_co2 = colco2(lay)/(coldry(lay)) - ratco2 = 1.e20_wp*chi_co2/3.55e-4_wp - IF (ratco2 .gt. 3.0_wp) THEN - adjfac = 2.0_wp+(ratco2-2.0_wp)**0.68_wp - adjcolco2 = adjfac*3.55e-4*coldry(lay)*1.e-20_wp - ELSE - adjcolco2 = colco2(lay) - END IF - speccomb_mco = colh2o(lay) + refrat_m_a3*coln2o(lay) - specparm_mco = colh2o(lay)/speccomb_mco - IF (specparm_mco .ge. oneminus) specparm_mco = oneminus - specmult_mco = 8._wp*specparm_mco - jmco = 1 + int(specmult_mco) - fmco = mod(specmult_mco,1.0_wp) - speccomb_planck = colh2o(lay)+refrat_planck_a*coln2o(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(13) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(13) + js1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 * (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,& - indm,ig)) - co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 * (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(& - jmco2,indm+1,ig)) - absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1) - com1 = ka_mco(jmco,indm,ig) + fmco * (ka_mco(jmco+1,indm,ig) - ka_mco(jmco,indm,ig)) - com2 = ka_mco(jmco,indm+1,ig) + fmco * (ka_mco(jmco+1,indm+1,ig) - ka_mco(jmco,& - indm+1,ig)) - absco = com1 + minorfrac(lay) * (com2 - com1) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor + & - adjcolco2*absco2 + colco(lay)*absco - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - indm = indminor(lay) - abso3 = kb_mo3(indm,ig) + minorfrac(lay) * (kb_mo3(indm+1,ig) - kb_mo3(indm,ig)) - taug(lay) = colo3(lay)*abso3 - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol13 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol14() - !---------------------------------------------------------------------------- - ! - ! band 14: 2250-2380 cm-1 (low - co2; high - co2) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg14, ONLY: selfref - USE rrlw_kg14, ONLY: forref - USE rrlw_kg14, ONLY: absa - USE rrlw_kg14, ONLY: fracrefa - USE rrlw_kg14, ONLY: absb - USE rrlw_kg14, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature. Below laytrop, the water vapor self-continuum - ! and foreign continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(14) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(14) + 1 - inds = indself(lay) - indf = indfor(lay) - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - taug(lay) = colco2(lay) * (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) + tauself + taufor - fracs(lay) = fracrefa(ig) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(14) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(14) + 1 - taug(lay) = colco2(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol14 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol15() - !---------------------------------------------------------------------------- - ! - ! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2) - ! (high - nothing) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg15, ONLY: selfref - USE rrlw_kg15, ONLY: forref - USE rrlw_kg15, ONLY: ka_mn2 - USE rrlw_kg15, ONLY: absa - USE rrlw_kg15, ONLY: fracrefa - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: js - INTEGER :: js1 - INTEGER :: jmn2 - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_mn2 - REAL(KIND=wp) :: specparm_mn2 - REAL(KIND=wp) :: specmult_mn2 - REAL(KIND=wp) :: fmn2 - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: scalen2 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: n2m1 - REAL(KIND=wp) :: n2m2 - REAL(KIND=wp) :: taun2 - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: refrat_m_a - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - ! Minor gas mapping level : - ! Lower - Nitrogen Continuum, P = 1053., T = 294. - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower atmosphere. - ! P = 1053. mb (Level 1) - refrat_planck_a = chi_mls(4,1)/chi_mls(2,1) - ! P = 1053. - refrat_m_a = chi_mls(4,1)/chi_mls(2,1) - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below laytrop, the water - ! vapor self-continuum and foreign continuum is interpolated - ! (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = coln2o(lay) + rat_n2oco2(lay)*colco2(lay) - specparm = coln2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = coln2o(lay) + rat_n2oco2_1(lay)*colco2(lay) - specparm1 = coln2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_mn2 = coln2o(lay) + refrat_m_a*colco2(lay) - specparm_mn2 = coln2o(lay)/speccomb_mn2 - IF (specparm_mn2 .ge. oneminus) specparm_mn2 = oneminus - specmult_mn2 = 8._wp*specparm_mn2 - jmn2 = 1 + int(specmult_mn2) - fmn2 = mod(specmult_mn2,1.0_wp) - speccomb_planck = coln2o(lay)+refrat_planck_a*colco2(lay) - specparm_planck = coln2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(15) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(15) + js1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - scalen2 = colbrd(lay)*scaleminor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - n2m1 = ka_mn2(jmn2,indm,ig) + fmn2 * (ka_mn2(jmn2+1,indm,ig) - ka_mn2(jmn2,indm,ig)) - n2m2 = ka_mn2(jmn2,indm+1,ig) + fmn2 * (ka_mn2(jmn2+1,indm+1,ig) - ka_mn2(jmn2,& - indm+1,ig)) - taun2 = scalen2 * (n2m1 + minorfrac(lay) * (n2m2 - n2m1)) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor + taun2 - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - taug(lay) = 0.0_wp - fracs(lay) = 0.0_wp - END DO - END SUBROUTINE taumol15 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol16() - !---------------------------------------------------------------------------- - ! - ! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg16, ONLY: selfref - USE rrlw_kg16, ONLY: forref - USE rrlw_kg16, ONLY: absa - USE rrlw_kg16, ONLY: fracrefa - USE rrlw_kg16, ONLY: absb - USE rrlw_kg16, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: js - INTEGER :: js1 - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower atmosphere. - ! P = 387. mb (Level 6) - refrat_planck_a = chi_mls(1,6)/chi_mls(6,6) - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature,and appropriate species. Below laytrop, the water - ! vapor self-continuum and foreign continuum is interpolated - ! (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2och4(lay)*colch4(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2och4_1(lay)*colch4(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_planck = colh2o(lay)+refrat_planck_a*colch4(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(16) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(16) + js1 - inds = indself(lay) - indf = indfor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(16) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(16) + 1 - taug(lay) = colch4(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol16 - END SUBROUTINE gas_optics_lw - END MODULE mo_lrtm_gas_optics diff --git a/test/ncar_kernels/PSRAD_lrtm/src/mo_lrtm_kgs.f90 b/test/ncar_kernels/PSRAD_lrtm/src/mo_lrtm_kgs.f90 deleted file mode 100644 index 4a142f95b9..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm/src/mo_lrtm_kgs.f90 +++ /dev/null @@ -1,1217 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_lrtm_kgs.f90 -! Generated at: 2015-02-19 15:30:31 -! KGEN version: 0.4.4 - - - - MODULE rrlw_planck - USE mo_kind, ONLY: wp - USE mo_rrtm_params, ONLY: nbndlw - REAL(KIND=wp) :: chi_mls(7,59) - REAL(KIND=wp) :: totplanck(181,nbndlw) !< planck function for each band - !< for band 16 - PUBLIC read_externs_rrlw_planck - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_planck(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) chi_mls - READ(UNIT=kgen_unit) totplanck - END SUBROUTINE read_externs_rrlw_planck - - - ! read subroutines - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_planck - - MODULE rrlw_kg01 - USE mo_kind, ONLY: wp - IMPLICIT NONE - !< original abs coefficients - INTEGER, parameter :: ng1 = 10 !< combined abs. coefficients - REAL(KIND=wp) :: fracrefa(ng1) - REAL(KIND=wp) :: fracrefb(ng1) - REAL(KIND=wp) :: absa(65,ng1) - REAL(KIND=wp) :: absb(235,ng1) - REAL(KIND=wp) :: ka_mn2(19,ng1) - REAL(KIND=wp) :: kb_mn2(19,ng1) - REAL(KIND=wp) :: selfref(10,ng1) - REAL(KIND=wp) :: forref(4,ng1) - PUBLIC read_externs_rrlw_kg01 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg01(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mn2 - READ(UNIT=kgen_unit) kb_mn2 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg01 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg01 - - MODULE rrlw_kg02 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng2 = 12 - REAL(KIND=wp) :: fracrefa(ng2) - REAL(KIND=wp) :: fracrefb(ng2) - REAL(KIND=wp) :: absa(65,ng2) - REAL(KIND=wp) :: absb(235,ng2) - REAL(KIND=wp) :: selfref(10,ng2) - REAL(KIND=wp) :: forref(4,ng2) - PUBLIC read_externs_rrlw_kg02 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg02(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg02 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg02 - - MODULE rrlw_kg03 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng3 = 16 - REAL(KIND=wp) :: fracrefa(ng3,9) - REAL(KIND=wp) :: fracrefb(ng3,5) - REAL(KIND=wp) :: absa(585,ng3) - REAL(KIND=wp) :: absb(1175,ng3) - REAL(KIND=wp) :: ka_mn2o(9,19,ng3) - REAL(KIND=wp) :: kb_mn2o(5,19,ng3) - REAL(KIND=wp) :: selfref(10,ng3) - REAL(KIND=wp) :: forref(4,ng3) - PUBLIC read_externs_rrlw_kg03 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim2 - module procedure read_var_real_wp_dim3 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg03(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mn2o - READ(UNIT=kgen_unit) kb_mn2o - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg03 - - - ! read subroutines - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim3(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:,:), allocatable :: var - integer, dimension(2,3) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg03 - - MODULE rrlw_kg04 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng4 = 14 - REAL(KIND=wp) :: fracrefa(ng4,9) - REAL(KIND=wp) :: fracrefb(ng4,5) - REAL(KIND=wp) :: absa(585,ng4) - REAL(KIND=wp) :: absb(1175,ng4) - REAL(KIND=wp) :: selfref(10,ng4) - REAL(KIND=wp) :: forref(4,ng4) - PUBLIC read_externs_rrlw_kg04 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg04(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg04 - - - ! read subroutines - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg04 - - MODULE rrlw_kg05 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng5 = 16 - REAL(KIND=wp) :: fracrefa(ng5,9) - REAL(KIND=wp) :: fracrefb(ng5,5) - REAL(KIND=wp) :: absa(585,ng5) - REAL(KIND=wp) :: absb(1175,ng5) - REAL(KIND=wp) :: ka_mo3(9,19,ng5) - REAL(KIND=wp) :: selfref(10,ng5) - REAL(KIND=wp) :: forref(4,ng5) - REAL(KIND=wp) :: ccl4(ng5) - PUBLIC read_externs_rrlw_kg05 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim2 - module procedure read_var_real_wp_dim3 - module procedure read_var_real_wp_dim1 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg05(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mo3 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) ccl4 - END SUBROUTINE read_externs_rrlw_kg05 - - - ! read subroutines - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim3(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:,:), allocatable :: var - integer, dimension(2,3) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg05 - - MODULE rrlw_kg06 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng6 = 8 - REAL(KIND=wp), dimension(ng6) :: fracrefa - REAL(KIND=wp) :: absa(65,ng6) - REAL(KIND=wp) :: ka_mco2(19,ng6) - REAL(KIND=wp) :: selfref(10,ng6) - REAL(KIND=wp) :: forref(4,ng6) - REAL(KIND=wp), dimension(ng6) :: cfc11adj - REAL(KIND=wp), dimension(ng6) :: cfc12 - PUBLIC read_externs_rrlw_kg06 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg06(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) ka_mco2 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) cfc11adj - READ(UNIT=kgen_unit) cfc12 - END SUBROUTINE read_externs_rrlw_kg06 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg06 - - MODULE rrlw_kg07 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng7 = 12 - REAL(KIND=wp), dimension(ng7) :: fracrefb - REAL(KIND=wp) :: fracrefa(ng7,9) - REAL(KIND=wp) :: absa(585,ng7) - REAL(KIND=wp) :: absb(235,ng7) - REAL(KIND=wp) :: ka_mco2(9,19,ng7) - REAL(KIND=wp) :: kb_mco2(19,ng7) - REAL(KIND=wp) :: selfref(10,ng7) - REAL(KIND=wp) :: forref(4,ng7) - PUBLIC read_externs_rrlw_kg07 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - module procedure read_var_real_wp_dim3 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg07(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mco2 - READ(UNIT=kgen_unit) kb_mco2 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg07 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim3(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:,:), allocatable :: var - integer, dimension(2,3) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg07 - - MODULE rrlw_kg08 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng8 = 8 - REAL(KIND=wp), dimension(ng8) :: fracrefa - REAL(KIND=wp), dimension(ng8) :: fracrefb - REAL(KIND=wp), dimension(ng8) :: cfc12 - REAL(KIND=wp), dimension(ng8) :: cfc22adj - REAL(KIND=wp) :: absa(65,ng8) - REAL(KIND=wp) :: absb(235,ng8) - REAL(KIND=wp) :: ka_mco2(19,ng8) - REAL(KIND=wp) :: ka_mn2o(19,ng8) - REAL(KIND=wp) :: ka_mo3(19,ng8) - REAL(KIND=wp) :: kb_mco2(19,ng8) - REAL(KIND=wp) :: kb_mn2o(19,ng8) - REAL(KIND=wp) :: selfref(10,ng8) - REAL(KIND=wp) :: forref(4,ng8) - PUBLIC read_externs_rrlw_kg08 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg08(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) cfc12 - READ(UNIT=kgen_unit) cfc22adj - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mco2 - READ(UNIT=kgen_unit) ka_mn2o - READ(UNIT=kgen_unit) ka_mo3 - READ(UNIT=kgen_unit) kb_mco2 - READ(UNIT=kgen_unit) kb_mn2o - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg08 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg08 - - MODULE rrlw_kg09 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng9 = 12 - REAL(KIND=wp), dimension(ng9) :: fracrefb - REAL(KIND=wp) :: fracrefa(ng9,9) - REAL(KIND=wp) :: absa(585,ng9) - REAL(KIND=wp) :: absb(235,ng9) - REAL(KIND=wp) :: ka_mn2o(9,19,ng9) - REAL(KIND=wp) :: kb_mn2o(19,ng9) - REAL(KIND=wp) :: selfref(10,ng9) - REAL(KIND=wp) :: forref(4,ng9) - PUBLIC read_externs_rrlw_kg09 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - module procedure read_var_real_wp_dim3 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg09(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mn2o - READ(UNIT=kgen_unit) kb_mn2o - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg09 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim3(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:,:), allocatable :: var - integer, dimension(2,3) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg09 - - MODULE rrlw_kg10 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng10 = 6 - REAL(KIND=wp), dimension(ng10) :: fracrefa - REAL(KIND=wp), dimension(ng10) :: fracrefb - REAL(KIND=wp) :: absa(65,ng10) - REAL(KIND=wp) :: absb(235,ng10) - REAL(KIND=wp) :: selfref(10,ng10) - REAL(KIND=wp) :: forref(4,ng10) - PUBLIC read_externs_rrlw_kg10 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg10(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg10 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg10 - - MODULE rrlw_kg11 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng11 = 8 - REAL(KIND=wp), dimension(ng11) :: fracrefa - REAL(KIND=wp), dimension(ng11) :: fracrefb - REAL(KIND=wp) :: absa(65,ng11) - REAL(KIND=wp) :: absb(235,ng11) - REAL(KIND=wp) :: ka_mo2(19,ng11) - REAL(KIND=wp) :: kb_mo2(19,ng11) - REAL(KIND=wp) :: selfref(10,ng11) - REAL(KIND=wp) :: forref(4,ng11) - PUBLIC read_externs_rrlw_kg11 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg11(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mo2 - READ(UNIT=kgen_unit) kb_mo2 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg11 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg11 - - MODULE rrlw_kg12 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng12 = 8 - REAL(KIND=wp) :: fracrefa(ng12,9) - REAL(KIND=wp) :: absa(585,ng12) - REAL(KIND=wp) :: selfref(10,ng12) - REAL(KIND=wp) :: forref(4,ng12) - PUBLIC read_externs_rrlw_kg12 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg12(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg12 - - - ! read subroutines - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg12 - - MODULE rrlw_kg13 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng13 = 4 - REAL(KIND=wp), dimension(ng13) :: fracrefb - REAL(KIND=wp) :: fracrefa(ng13,9) - REAL(KIND=wp) :: absa(585,ng13) - REAL(KIND=wp) :: ka_mco2(9,19,ng13) - REAL(KIND=wp) :: ka_mco(9,19,ng13) - REAL(KIND=wp) :: kb_mo3(19,ng13) - REAL(KIND=wp) :: selfref(10,ng13) - REAL(KIND=wp) :: forref(4,ng13) - PUBLIC read_externs_rrlw_kg13 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - module procedure read_var_real_wp_dim3 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg13(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) ka_mco2 - READ(UNIT=kgen_unit) ka_mco - READ(UNIT=kgen_unit) kb_mo3 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg13 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim3(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:,:), allocatable :: var - integer, dimension(2,3) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg13 - - MODULE rrlw_kg14 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng14 = 2 - REAL(KIND=wp), dimension(ng14) :: fracrefa - REAL(KIND=wp), dimension(ng14) :: fracrefb - REAL(KIND=wp) :: absa(65,ng14) - REAL(KIND=wp) :: absb(235,ng14) - REAL(KIND=wp) :: selfref(10,ng14) - REAL(KIND=wp) :: forref(4,ng14) - PUBLIC read_externs_rrlw_kg14 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg14(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg14 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg14 - - MODULE rrlw_kg15 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng15 = 2 - REAL(KIND=wp) :: fracrefa(ng15,9) - REAL(KIND=wp) :: absa(585,ng15) - REAL(KIND=wp) :: ka_mn2(9,19,ng15) - REAL(KIND=wp) :: selfref(10,ng15) - REAL(KIND=wp) :: forref(4,ng15) - PUBLIC read_externs_rrlw_kg15 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim2 - module procedure read_var_real_wp_dim3 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg15(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) ka_mn2 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg15 - - - ! read subroutines - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim3(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:,:), allocatable :: var - integer, dimension(2,3) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg15 - - MODULE rrlw_kg16 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng16 = 2 - REAL(KIND=wp), dimension(ng16) :: fracrefb - REAL(KIND=wp) :: fracrefa(ng16,9) - REAL(KIND=wp) :: absa(585,ng16) - REAL(KIND=wp) :: absb(235,ng16) - REAL(KIND=wp) :: selfref(10,ng16) - REAL(KIND=wp) :: forref(4,ng16) - PUBLIC read_externs_rrlw_kg16 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg16(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg16 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg16 diff --git a/test/ncar_kernels/PSRAD_lrtm/src/mo_lrtm_setup.f90 b/test/ncar_kernels/PSRAD_lrtm/src/mo_lrtm_setup.f90 deleted file mode 100644 index d5159218ee..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm/src/mo_lrtm_setup.f90 +++ /dev/null @@ -1,123 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_lrtm_setup.f90 -! Generated at: 2015-02-19 15:30:32 -! KGEN version: 0.4.4 - - - - MODULE mo_lrtm_setup - USE mo_kind, ONLY: wp - USE mo_rrtm_params, ONLY: ngptlw - USE mo_rrtm_params, ONLY: nbndlw - IMPLICIT NONE - ! - ! spectra information that is entered at run time - ! - !< Weights for combining original gpts into reduced gpts - !< Number of cross-section molecules - !< Flag for active cross-sections in calculation - INTEGER, parameter :: ngc(nbndlw) = (/ 10,12,16,14,16,8,12,8,12,6,8,8,4,2,2,2/) !< The number of new g-intervals in each band - INTEGER, parameter :: ngs(nbndlw) = (/ 10,22,38,52,68,76,88,96,108,114,122,130,134,136,138,140/) !< The cumulative sum of new g-intervals for each band - !< The index of each new gpt relative to the orignal - ! band 1 - ! band 2 - ! band 3 - ! band 4 - ! band 5 - ! band 6 - ! band 7 - ! band 8 - ! band 9 - ! band 10 - ! band 11 - ! band 12 - ! band 13 - ! band 14 - ! band 15 - ! band 16 - !< The number of original gs combined to make new pts - ! band 1 - ! band 2 - ! band 3 - ! band 4 - ! band 5 - ! band 6 - ! band 7 - ! band 8 - ! band 9 - ! band 10 - ! band 11 - ! band 12 - ! band 13 - ! band 14 - ! band 15 - ! band 16 - INTEGER, parameter :: ngb(ngptlw) = (/ 1,1,1,1,1,1,1,1,1,1, 2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,& - 3,3,3,3,3,3,3,3, 4,4,4,4,4,4,4,4,4,4,4,4,4,4, 5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5, 6,6,6,6,6,6,6,6, & - 7,7,7,7,7,7,7,7,7,7,7,7, 8,8,8,8,8,8,8,8, 9,9,9,9,9,9,9,9,9,9,9,9, 10,10,10,10,10,10, 11,11,& - 11,11,11,11,11,11, 12,12,12,12,12,12,12,12, 13,13,13,13, 14,14, 15,15, 16,16/) !< The band index for each new g-interval - ! band 1 - ! band 2 - ! band 3 - ! band 4 - ! band 5 - ! band 6 - ! band 7 - ! band 8 - ! band 9 - ! band 10 - ! band 11 - ! band 12 - ! band 13 - ! band 14 - ! band 15 - ! band 16 - !< RRTM weights for the original 16 g-intervals - INTEGER, parameter :: nspa(nbndlw) = (/ 1,1,9,9,9,1,9,1,9,1,1,9,9,1,9,9/) !< Number of reference atmospheres for lower atmosphere - INTEGER, parameter :: nspb(nbndlw) = (/ 1,1,5,5,5,0,1,1,1,1,1,0,0,1,0,0/) !< Number of reference atmospheres for upper atmosphere - ! < Number of g intervals in each band - !< Spectral band lower boundary in wavenumbers - !< Spectral band upper boundary in wavenumbers - REAL(KIND=wp), parameter :: delwave(nbndlw) = (/ 340._wp, 150._wp, 130._wp, 70._wp, 120._wp, 160._wp, & - 100._wp, 100._wp, 210._wp, 90._wp, 320._wp, 280._wp, 170._wp, 130._wp, 220._wp, 650._wp/) !< Spectral band width in wavenumbers - CONTAINS - - ! read subroutines - ! ************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - END MODULE mo_lrtm_setup diff --git a/test/ncar_kernels/PSRAD_lrtm/src/mo_lrtm_solver.f90 b/test/ncar_kernels/PSRAD_lrtm/src/mo_lrtm_solver.f90 deleted file mode 100644 index 841db2d6b8..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm/src/mo_lrtm_solver.f90 +++ /dev/null @@ -1,161 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_lrtm_solver.f90 -! Generated at: 2015-02-19 15:30:36 -! KGEN version: 0.4.4 - - - - MODULE mo_lrtm_solver - USE mo_kind, ONLY: wp - USE mo_math_constants, ONLY: pi - USE mo_rrtm_params, ONLY: nbndlw - USE mo_rad_fastmath, ONLY: tautrans - USE mo_rad_fastmath, ONLY: transmit - IMPLICIT NONE - REAL(KIND=wp), parameter :: fluxfac = 2.0e+04_wp * pi - CONTAINS - - ! read subroutines - ! ------------------------------------------------------------------------------- - - SUBROUTINE lrtm_solver(kproma, kbdim, klev, tau, layplnk, levplnk, weights, secdiff, surfplanck, surfemis, fluxup, fluxdn) - ! - ! Compute IR (no scattering) radiative transfer for a set of columns - ! Based on AER code RRTMG_LW_RTNMC, including approximations used there - ! Layers are ordered from botton to top (i.e. tau(1) is tau in lowest layer) - ! Computes all-sky RT given a total optical thickness in each layer - ! - INTEGER, intent(in) :: kbdim - INTEGER, intent(in) :: klev - INTEGER, intent(in) :: kproma - !< Number of columns - !< Maximum number of columns as declared in calling (sub)program - !< number of layers (one fewer than levels) - REAL(KIND=wp), intent(in) :: tau(kbdim,klev) - REAL(KIND=wp), intent(in) :: layplnk(kbdim,klev) - REAL(KIND=wp), intent(in) :: weights(kbdim,klev) !< dimension (kbdim, klev) - !< Longwave optical thickness - !< Planck function at layer centers - !< Fraction of total Planck function for this g-point - REAL(KIND=wp), intent(in) :: levplnk(kbdim, 0:klev) - !< Planck function at layer edges, level i is the top of layer i - REAL(KIND=wp), intent(in) :: secdiff(kbdim) - REAL(KIND=wp), intent(in) :: surfemis(kbdim) - REAL(KIND=wp), intent(in) :: surfplanck(kbdim) !< dimension (kbdim) - !< Planck function at surface - !< Surface emissivity - !< secant of integration angle - depends on band, column water vapor - REAL(KIND=wp), intent(out) :: fluxup(kbdim, 0:klev) - REAL(KIND=wp), intent(out) :: fluxdn(kbdim, 0:klev) !< dimension (kbdim, 0:klev) - !< Fluxes at the interfaces - ! ----------- - INTEGER :: jk - !< Loop index for layers - REAL(KIND=wp) :: odepth(kbdim,klev) - REAL(KIND=wp) :: tfn(kbdim) - REAL(KIND=wp) :: dplnkup(kbdim,klev) - REAL(KIND=wp) :: dplnkdn(kbdim,klev) - REAL(KIND=wp) :: bbup(kbdim,klev) - REAL(KIND=wp) :: bbdn(kbdim,klev) - REAL(KIND=wp) :: trans(kbdim,klev) - !< Layer transmissivity - !< TFN_TBL - !< Tau transition function; i.e. the transition of the Planck - !< function from that for the mean layer temperature to that for - !< the layer boundary temperature as a function of optical depth. - !< The "linear in tau" method is used to make the table. - !< Upward derivative of Planck function - !< Downward derivative of Planck function - !< Interpolated downward emission - !< Interpolated upward emission - !< Effective IR optical depth of layer - REAL(KIND=wp) :: rad_dn(kbdim,0:klev) - REAL(KIND=wp) :: rad_up(kbdim,0:klev) - !< Radiance down at propagation angle - !< Radiance down at propagation angle - ! This secant and weight corresponds to the standard diffusivity - ! angle. The angle is redefined for some bands. - REAL(KIND=wp), parameter :: wtdiff = 0.5_wp - ! ----------- - ! - ! 1.0 Initial preparations - ! Weight optical depth by 1/cos(diffusivity angle), which depends on band - ! This will be used to compute layer transmittance - ! ----- - !IBM* ASSERT(NODEPS) - DO jk = 1, klev - odepth(1:kproma,jk) = max(0._wp, secdiff(1:kproma) * tau(1:kproma,jk)) - END DO - ! - ! 2.0 Radiative transfer - ! - ! ----- - ! - ! Plank function derivatives and total emission for linear-in-tau approximation - ! - !IBM* ASSERT(NODEPS) - DO jk = 1, klev - tfn(1:kproma) = tautrans(odepth(:,jk), kproma) - dplnkup(1:kproma,jk) = levplnk(1:kproma,jk) - layplnk(1:kproma,jk) - dplnkdn(1:kproma,jk) = levplnk(1:kproma,jk-1) - layplnk(1:kproma,jk) - bbup(1:kproma,jk) = weights(1:kproma,jk) * (layplnk(1:kproma,jk) + dplnkup(1:kproma,jk) * tfn(1:kproma)) - bbdn(1:kproma,jk) = weights(1:kproma,jk) * (layplnk(1:kproma,jk) + dplnkdn(1:kproma,jk) * tfn(1:kproma)) - END DO - ! ----- - ! 2.1 Downward radiative transfer - ! - ! Level 0 is closest to the ground - ! - rad_dn(:, klev) = 0. ! Upper boundary condition - no downwelling IR - DO jk = klev, 1, -1 - trans(1:kproma,jk) = transmit(odepth(:,jk), kproma) - ! RHS is a rearrangment of rad_dn(:,jk) * (1._wp - trans(:,jk)) + trans(:,jk) * bbdn(:) - rad_dn(1:kproma,jk-1) = rad_dn(1:kproma,jk) + (bbdn(1:kproma,jk) - rad_dn(1:kproma,jk)) * trans(1:kproma,jk) - END DO - ! - ! 2.2 Surface contribution, including reflection - ! - rad_up(1:kproma, 0) = weights(1:kproma, 1) * surfemis(1:kproma) * surfplanck(1:kproma) + (1._wp - & - surfemis(1:kproma)) * rad_dn(1:kproma, 0) - ! - ! 2.3 Upward radiative transfer - ! - DO jk = 1, klev - rad_up(1:kproma,jk) = rad_up(1:kproma,jk-1) * (1._wp - trans(1:kproma,jk)) + trans(1:kproma,jk) * bbup(1:kproma,& - jk) - END DO - ! - ! 3.0 Covert intensities at diffusivity angles to fluxes - ! - ! ----- - fluxup(1:kproma, 0:klev) = rad_up(1:kproma,:) * wtdiff * fluxfac - fluxdn(1:kproma, 0:klev) = rad_dn(1:kproma,:) * wtdiff * fluxfac - END SUBROUTINE lrtm_solver - ! ------------------------------------------------------------------------------- - - elemental FUNCTION find_secdiff(iband, pwvcm) - INTEGER, intent(in) :: iband - !< RRTMG LW band number - REAL(KIND=wp), intent(in) :: pwvcm - !< Precipitable water vapor (cm) - REAL(KIND=wp) :: find_secdiff - ! Compute diffusivity angle for Bands 2-3 and 5-9 to vary (between 1.50 - ! and 1.80) as a function of total column water vapor. The function - ! has been defined to minimize flux and cooling rate errors in these bands - ! over a wide range of precipitable water values. - REAL(KIND=wp), dimension(nbndlw), parameter :: a0 = (/ 1.66_wp, 1.55_wp, 1.58_wp, 1.66_wp, 1.54_wp, 1.454_wp, & - 1.89_wp, 1.33_wp, 1.668_wp, 1.66_wp, 1.66_wp, 1.66_wp, 1.66_wp, 1.66_wp, 1.66_wp, 1.66_wp /) - REAL(KIND=wp), dimension(nbndlw), parameter :: a1 = (/ 0.00_wp, 0.25_wp, 0.22_wp, 0.00_wp, 0.13_wp, 0.446_wp, & - -0.10_wp, 0.40_wp, -0.006_wp, 0.00_wp, 0.00_wp, 0.00_wp, 0.00_wp, 0.00_wp, 0.00_wp, 0.00_wp /) - REAL(KIND=wp), dimension(nbndlw), parameter :: a2 = (/ 0.00_wp, -12.0_wp, -11.7_wp, 0.00_wp, -0.72_wp,-0.243_wp, & - 0.19_wp,-0.062_wp, 0.414_wp, 0.00_wp, 0.00_wp, 0.00_wp, 0.00_wp, 0.00_wp, 0.00_wp, 0.00_wp /) - IF (iband == 1 .or. iband == 4 .or. iband >= 10) THEN - find_secdiff = 1.66_wp - ELSE - find_secdiff = max(min(a0(iband) + a1(iband) * exp(a2(iband)*pwvcm), 1.8_wp), 1.5_wp) - END IF - END FUNCTION find_secdiff - ! ------------------------------------------------------------------------------- - END MODULE mo_lrtm_solver diff --git a/test/ncar_kernels/PSRAD_lrtm/src/mo_math_constants.f90 b/test/ncar_kernels/PSRAD_lrtm/src/mo_math_constants.f90 deleted file mode 100644 index 792ef885ed..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm/src/mo_math_constants.f90 +++ /dev/null @@ -1,48 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_math_constants.f90 -! Generated at: 2015-02-19 15:30:32 -! KGEN version: 0.4.4 - - - - MODULE mo_math_constants - USE mo_kind, ONLY: wp - IMPLICIT NONE - PUBLIC - ! Mathematical constants defined: - ! - !-------------------------------------------------------------- - ! Fortran name | C name | meaning | - !-------------------------------------------------------------- - ! euler | M_E | e | - ! log2e | M_LOG2E | log2(e) | - ! log10e | M_LOG10E | log10(e) | - ! ln2 | M_LN2 | ln(2) | - ! ln10 | M_LN10 | ln(10) | - ! pi | M_PI | pi | - ! pi_2 | M_PI_2 | pi/2 | - ! pi_4 | M_PI_4 | pi/4 | - ! rpi | M_1_PI | 1/pi | - ! rpi_2 | M_2_PI | 2/pi | - ! rsqrtpi_2 | M_2_SQRTPI | 2/(sqrt(pi)) | - ! sqrt2 | M_SQRT2 | sqrt(2) | - ! sqrt1_2 | M_SQRT1_2 | 1/sqrt(2) | - ! sqrt3 | | sqrt(3) | - ! sqrt1_3 | | 1/sqrt(3) | - ! half angle of pentagon | - ! pi_5 | | pi/5 | - ! latitude of the lowest major triangle corner | - ! and latitude of the major hexagonal faces centers | - ! phi0 | | pi/2 -2acos(1/(2*sin(pi/5))) | - ! conversion factor from radians to degree | - ! rad2deg | | 180/pi | - ! conversion factor from degree to radians | - ! deg2rad | | pi/180 | - ! one_third | | 1/3 | - !-------------------------------------------------------------| - REAL(KIND=wp), parameter :: pi = 3.14159265358979323846264338327950288419717_wp - - ! read subroutines - END MODULE mo_math_constants diff --git a/test/ncar_kernels/PSRAD_lrtm/src/mo_physical_constants.f90 b/test/ncar_kernels/PSRAD_lrtm/src/mo_physical_constants.f90 deleted file mode 100644 index 926757551a..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm/src/mo_physical_constants.f90 +++ /dev/null @@ -1,199 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_physical_constants.f90 -! Generated at: 2015-02-19 15:30:36 -! KGEN version: 0.4.4 - - - - MODULE mo_physical_constants - USE mo_kind, ONLY: wp - IMPLICIT NONE - PUBLIC - ! Natural constants - ! ----------------- - ! - ! WMO/SI values - !> [1/mo] Avogadro constant - !! [J/K] Boltzmann constant - !! [J/K/mol] molar/universal/ideal gas constant - !! [W/m2/K4] Stephan-Boltzmann constant - ! - !> Molar weights - !! ------------- - !! - !! Pure species - !>[g/mol] CO2 (National Institute for - !! Standards and Technology (NIST)) - !! [g/mol] CH4 - !! [g/mol] O3 - !! [g/mol] O2 - !! [g/mol] N2O - !! [g/mol] CFC11 - !! [g/mol] CFC12 - REAL(KIND=wp), parameter :: amw = 18.0154_wp !! [g/mol] H2O - ! - !> Mixed species - REAL(KIND=wp), parameter :: amd = 28.970_wp !> [g/mol] dry air - ! - !> Auxiliary constants - ! ppmv2gg converts ozone from volume mixing ratio in ppmv - ! to mass mixing ratio in g/g - ! - !> Earth and Earth orbit constants - !! ------------------------------- - !! - !! [m] average radius - !! [1/m] - !! [1/s] angular velocity - ! - ! WMO/SI value - REAL(KIND=wp), parameter :: grav = 9.80665_wp !> [m/s2] av. gravitational acceleration - !! [s2/m] - ! - !> [m/m] ratio of atm. scale height - ! !! to Earth radius - ! seconds per day - ! - !> Thermodynamic constants for the dry and moist atmosphere - !! -------------------------------------------------------- - ! - !> Dry air - !> [J/K/kg] gas constant - !! [J/K/kg] specific heat at constant pressure - !! [J/K/kg] specific heat at constant volume - !! [m^2/s] kinematic viscosity of dry air - !! [m^2/s] scalar conductivity of dry air - !! [J/m/s/K]thermal conductivity of dry air - !! [N*s/m2] dyn viscosity of dry air at tmelt - ! - !> H2O - !! - gas - !> [J/K/kg] gas constant for water vapor - !! [J/K/kg] specific heat at constant pressure - !! [J/K/kg] specific heat at constant volume - !! [m^2/s] diff coeff of H2O vapor in dry air at tmelt - !> - liquid / water - !> [kg/m3] density of liquid water - !> H2O related constants (liquid, ice, snow), phase change constants - ! echam values - ! density of sea water in kg/m3 - ! density of ice in kg/m3 - ! density of snow in kg/m3 - ! density ratio (ice/water) - ! specific heat for liquid water J/K/kg - ! specific heat for sea water J/K/kg - ! specific heat for ice J/K/kg - ! specific heat for snow J/K/kg - ! thermal conductivity of ice in W/K/m - ! thermal conductivity of snow in W/K/m - ! echam values end - ! - !REAL(wp), PARAMETER :: clw = 4186.84_wp !! [J/K/kg] specific heat of water - ! !! see below - !> - phase changes - !> [J/kg] latent heat for vaporisation - !! [J/kg] latent heat for sublimation - !! [J/kg] latent heat for fusion - !! [K] melting temperature of ice/snow - ! - !> Auxiliary constants - !> [ ] - ! the next 2 values not as parameters due to ECHAM-dyn - !! [ ] - !! [ ] - !! [ ] - !! [K] - !! [K] - !! [K*kg/J] - !! [K*kg/J] - !! cp_d / cp_l - 1 - ! - !> specific heat capacity of liquid water - ! - !> [ ] - !! [ ] - !! [ ] - ! - !> [Pa] reference pressure for Exner function - !> Auxiliary constants used in ECHAM - ! Constants used for computation of saturation mixing ratio - ! over liquid water (*c_les*) or ice(*c_ies*) - ! - ! - ! - ! - ! - ! - ! - !> Variables for computing cloud cover in RH scheme - ! - !> vertical profile parameters (vpp) of CH4 and N2O - ! - !> constants for radiation module - !> lw sfc default emissivity factor - ! - !--------------------------- - ! Specifications, thresholds, and derived constants for the following subroutines: - ! s_lake, s_licetemp, s_sicetemp, meltpond, meltpond_ice, update_albedo_ice_meltpond - ! - ! mixed-layer depth of lakes in m - ! mixed-layer depth of ocean in m - ! minimum ice thickness in m - ! minimum ice thickness of pond ice in m - ! threshold ice thickness for pond closing in m - ! minimum pond depth for pond fraction in m - ! albedo of pond ice - ! - ! heat capacity of lake mixed layer - ! ! in J/K/m2 - ! heat capacity of upper ice layer - ! heat capacity of upper pond ice layer - ! - ! [J/m3] - ! [J/m3] - ! [m/K] - ! [K/m] - ! cooling below tmelt required to form dice - !--------------------------- - ! - !------------below are parameters for ocean model--------------- - ! coefficients in linear EOS - ! thermal expansion coefficient (kg/m3/K) - ! haline contraction coefficient (kg/m3/psu) - ! - ! density reference values, to be constant in Boussinesq ocean models - ! reference density [kg/m^3] - ! inverse reference density [m^3/kg] - ! reference salinity [psu] - ! - !Conversion from pressure [p] to pressure [bar] - ! !used in ocean thermodynamics - ! - ! [Pa] sea level pressure - ! - !----------below are parameters for sea-ice model--------------- - ! heat conductivity snow [J / (m s K)] - ! heat conductivity ice [J / (m s K)] - ! density of sea ice [kg / m3] - ! density of snow [kg / m3] - ! Heat capacity of ice [J / (kg K)] - ! Temperature ice bottom [C] - ! Sea-ice bulk salinity [ppt] - ! Constant in linear freezing- - ! ! point relationship [C/ppt] - ! = - (sea-ice liquidus - ! ! (aka melting) temperature) [C] - !REAL(wp), PARAMETER :: muS = -(-0.0575 + 1.710523E-3*Sqrt(Sice) - 2.154996E-4*Sice) * Sice - ! Albedo of snow (not melting) - ! Albedo of snow (melting) - ! Albedo of ice (not melting) - ! Albedo of ice (melting) - ! albedo of the ocean - !REAL(wp), PARAMETER :: I_0 = 0.3 ! Ice-surface penetrating shortwave fraction - ! Ice-surface penetrating shortwave fraction - !------------------------------------------------------------ - - ! read subroutines - END MODULE mo_physical_constants diff --git a/test/ncar_kernels/PSRAD_lrtm/src/mo_psrad_interface.f90 b/test/ncar_kernels/PSRAD_lrtm/src/mo_psrad_interface.f90 deleted file mode 100644 index a5862b7109..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm/src/mo_psrad_interface.f90 +++ /dev/null @@ -1,770 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_psrad_interface.f90 -! Generated at: 2015-02-19 15:30:28 -! KGEN version: 0.4.4 - - - - MODULE mo_psrad_interface - USE mo_spec_sampling, only : read_var_mod5 => kgen_read_var - USE mo_kind, ONLY: wp - USE mo_rrtm_params, ONLY: nbndlw - USE mo_rrtm_params, ONLY: maxinpx - USE mo_rrtm_params, ONLY: maxxsec - USE mo_lrtm_driver, ONLY: lrtm - USE mo_spec_sampling, ONLY: spec_sampling_strategy - IMPLICIT NONE - PUBLIC lw_strat - PUBLIC read_externs_mo_psrad_interface - INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - PUBLIC psrad_interface - type, public :: check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - end type check_t - TYPE(spec_sampling_strategy), save :: lw_strat - !< Spectral sampling strategies for longwave, shortwave - INTEGER, parameter :: rng_seed_size = 4 - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_mo_psrad_interface(kgen_unit) - integer, intent(in) :: kgen_unit - call read_var_mod5(lw_strat, kgen_unit) - END SUBROUTINE read_externs_mo_psrad_interface - - subroutine kgen_init_check(check,tolerance) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.E-14 - endif - end subroutine kgen_init_check - subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif - end subroutine kgen_print_check - !--------------------------------------------------------------------------- - !> - !! @brief Sets up (initializes) radation routines - !! - !! @remarks - !! Modify preset variables of module MO_RADIATION which control the - !! configuration of the radiation scheme. - ! - - !----------------------------------------------------------------------------- - !> - !! @brief arranges input and calls rrtm sw and lw routines - !! - !! @par Revision History - !! Original Source Rewritten and renamed by B. Stevens (2009-08) - !! - !! @remarks - !! Because the RRTM indexes vertical levels differently than ECHAM a chief - !! function of thise routine is to reorder the input in the vertical. In - !! addition some cloud physical properties are prescribed, which are - !! required to derive cloud optical properties - !! - !! @par The gases are passed into RRTM via two multi-constituent arrays: - !! zwkl and wx_r. zwkl has maxinpx species and wx_r has maxxsec species - !! The species are identifed as follows. - !! ZWKL [#/cm2] WX_R [#/cm2] - !! index = 1 => H20 index = 1 => n/a - !! index = 2 => CO2 index = 2 => CFC11 - !! index = 3 => O3 index = 3 => CFC12 - !! index = 4 => N2O index = 4 => n/a - !! index = 5 => n/a - !! index = 6 => CH4 - !! index = 7 => O2 - ! - - SUBROUTINE psrad_interface(kbdim, klev, nb_sw, kproma, ktrac, tk_sfc, kgen_unit) - integer, intent(in) :: kgen_unit - - ! read interface - !interface kgen_read_var - ! procedure read_var_real_wp_dim2 - ! procedure read_var_real_wp_dim1 - ! procedure read_var_real_wp_dim3 - ! procedure read_var_integer_4_dim2 - !end interface kgen_read_var - - - - ! verification interface - !interface kgen_verify_var - ! procedure verify_var_logical - ! procedure verify_var_integer - ! procedure verify_var_real - ! procedure verify_var_character - ! procedure verify_var_real_wp_dim2 - ! procedure verify_var_real_wp_dim1 - ! procedure verify_var_real_wp_dim3 - ! procedure verify_var_integer_4_dim2 - !end interface kgen_verify_var - - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - INTEGER, intent(in) :: kbdim - INTEGER, intent(in) :: klev - INTEGER, intent(in) :: nb_sw - INTEGER, intent(in) :: kproma - INTEGER, intent(in) :: ktrac - !< aerosol control - !< number of longitudes - !< first dimension of 2-d arrays - !< first dimension of 2-d arrays - !< number of levels - !< number of tracers - !< type of convection - !< number of shortwave bands - !< land sea mask, land=.true. - !< glacier mask, glacier=.true. - REAL(KIND=wp), intent(in) :: tk_sfc(kbdim) - !< surface emissivity - !< mu0 for solar zenith angle - !< geopotential above ground - !< surface albedo for vis range and dir light - !< surface albedo for NIR range and dir light - !< surface albedo for vis range and dif light - !< surface albedo for NIR range and dif light - !< full level pressure in Pa - !< half level pressure in Pa - !< surface pressure in Pa - !< full level temperature in K - !< half level temperature in K - !< surface temperature in K - !< specific humidity in g/g - !< specific liquid water content - !< specific ice content in g/g - !< cloud nuclei concentration - !< fractional cloud cover - !< total cloud cover in m2/m2 - !< o3 mass mixing ratio - !< co2 mass mixing ratio - !< ch4 mass mixing ratio - !< n2o mass mixing ratio - !< cfc volume mixing ratio - !< o2 mass mixing ratio - !< tracer mass mixing ratios - !< upward LW flux profile, all sky - !< upward LW flux profile, clear sky - !< downward LW flux profile, all sky - !< downward LW flux profile, clear sky - !< upward SW flux profile, all sky - !< upward SW flux profile, clear sky - !< downward SW flux profile, all sky - !< downward SW flux profile, clear sky - !< Visible (250-680) fraction of net surface radiation - !< Downward Photosynthetically Active Radiation (PAR) at surface - !< Diffuse fraction of downward surface near-infrared radiation - !< Diffuse fraction of downward surface visible radiation - !< Diffuse fraction of downward surface PAR - ! ------------------------------------------------------------------------------------- - !< loop indicies - !< index for clear or cloudy - REAL(KIND=wp) :: zsemiss (kbdim,nbndlw) - REAL(KIND=wp) :: pm_sfc (kbdim) - !< LW surface emissivity by band - !< pressure thickness in Pa - !< surface pressure in mb - !< pressure thickness - !< scratch array - ! - ! --- vertically reversed _vr variables - ! - REAL(KIND=wp) :: cld_frc_vr(kbdim,klev) - REAL(KIND=wp) :: aer_tau_lw_vr(kbdim,klev,nbndlw) - REAL(KIND=wp) :: pm_fl_vr (kbdim,klev) - REAL(KIND=wp) :: tk_fl_vr (kbdim,klev) - REAL(KIND=wp) :: tk_hl_vr (kbdim,klev+1) - REAL(KIND=wp) :: cld_tau_lw_vr(kbdim,klev,nbndlw) - REAL(KIND=wp) :: wkl_vr (kbdim,maxinpx,klev) - REAL(KIND=wp) :: wx_vr (kbdim,maxxsec,klev) - REAL(KIND=wp) :: col_dry_vr(kbdim,klev) - !< number of molecules/cm2 of - !< full level pressure [mb] - !< half level pressure [mb] - !< full level temperature [K] - !< half level temperature [K] - !< cloud nuclei concentration - !< secure cloud fraction - !< specific ice water content - !< ice water content per volume - !< ice water path in g/m2 - !< specific liquid water content - !< liquid water path in g/m2 - !< liquid water content per - !< effective radius of liquid - !< effective radius of ice - !< number of molecules/cm2 of - !< number of molecules/cm2 of - !< LW optical thickness of clouds - !< extincion - !< asymmetry factor - !< single scattering albedo - !< LW optical thickness of aerosols - !< aerosol optical thickness - !< aerosol asymmetry factor - !< aerosol single scattering albedo - REAL(KIND=wp) :: flx_uplw_vr(kbdim,klev+1) - REAL(KIND=wp), allocatable :: ref_flx_uplw_vr(:,:) - REAL(KIND=wp) :: flx_uplw_clr_vr(kbdim,klev+1) - REAL(KIND=wp), allocatable :: ref_flx_uplw_clr_vr(:,:) - REAL(KIND=wp) :: flx_dnlw_clr_vr(kbdim,klev+1) - REAL(KIND=wp), allocatable :: ref_flx_dnlw_clr_vr(:,:) - REAL(KIND=wp) :: flx_dnlw_vr(kbdim,klev+1) - REAL(KIND=wp), allocatable :: ref_flx_dnlw_vr(:,:) - !< upward flux, total sky - !< upward flux, clear sky - !< downward flux, total sky - !< downward flux, clear sky - ! - ! Random seeds for sampling. Needs to get somewhere upstream - ! - INTEGER :: rnseeds(kbdim,rng_seed_size) - INTEGER, allocatable :: ref_rnseeds(:,:) - ! - ! Number of g-points per time step. Determine here to allow automatic array allocation in - ! lrtm, srtm subroutines. - ! - INTEGER :: n_gpts_ts - ! 1.0 Constituent properties - !-------------------------------- - !IBM* ASSERT(NODEPS) - ! - ! --- control for zero, infintesimal or negative cloud fractions - ! - ! - ! --- main constituent reordering - ! - !IBM* ASSERT(NODEPS) - !IBM* ASSERT(NODEPS) - !IBM* ASSERT(NODEPS) - ! - ! --- CFCs are in volume mixing ratio - ! - !IBM* ASSERT(NODEPS) - ! - ! -- Convert to molecules/cm^2 - ! - ! - ! 2.0 Surface Properties - ! -------------------------------- - ! - ! 3.0 Particulate Optical Properties - ! -------------------------------- - ! - ! 3.5 Interface for submodels that provide aerosol and/or cloud radiative properties: - ! ----------------------------------------------------------------------------------- - ! - ! 4.0 Radiative Transfer Routines - ! -------------------------------- - ! - ! Seeds for random numbers come from least significant digits of pressure field - ! - tolerance = 1.E-12 - CALL kgen_init_check(check_status, tolerance) - READ(UNIT=kgen_unit) zsemiss - READ(UNIT=kgen_unit) pm_sfc - READ(UNIT=kgen_unit) cld_frc_vr - READ(UNIT=kgen_unit) aer_tau_lw_vr - READ(UNIT=kgen_unit) pm_fl_vr - READ(UNIT=kgen_unit) tk_fl_vr - READ(UNIT=kgen_unit) tk_hl_vr - READ(UNIT=kgen_unit) cld_tau_lw_vr - READ(UNIT=kgen_unit) wkl_vr - READ(UNIT=kgen_unit) wx_vr - READ(UNIT=kgen_unit) col_dry_vr - READ(UNIT=kgen_unit) flx_uplw_vr - READ(UNIT=kgen_unit) flx_uplw_clr_vr - READ(UNIT=kgen_unit) flx_dnlw_clr_vr - READ(UNIT=kgen_unit) flx_dnlw_vr - READ(UNIT=kgen_unit) rnseeds - READ(UNIT=kgen_unit) n_gpts_ts - - !call kgen_read_var(ref_flx_uplw_vr, kgen_unit) - !call kgen_read_var(ref_flx_uplw_clr_vr, kgen_unit) - !call kgen_read_var(ref_flx_dnlw_clr_vr, kgen_unit) - !call kgen_read_var(ref_flx_dnlw_vr, kgen_unit) - !call kgen_read_var(ref_rnseeds, kgen_unit) - call read_var_real_wp_dim2(ref_flx_uplw_vr, kgen_unit) - call read_var_real_wp_dim2(ref_flx_uplw_clr_vr, kgen_unit) - call read_var_real_wp_dim2(ref_flx_dnlw_clr_vr, kgen_unit) - call read_var_real_wp_dim2(ref_flx_dnlw_vr, kgen_unit) - call read_var_integer_4_dim2(ref_rnseeds, kgen_unit) - - ! call to kernel - CALL lrtm(kproma, kbdim, klev, pm_fl_vr, pm_sfc, tk_fl_vr, tk_hl_vr, tk_sfc, wkl_vr, wx_vr, col_dry_vr, zsemiss, cld_frc_vr, cld_tau_lw_vr, aer_tau_lw_vr, rnseeds, lw_strat, n_gpts_ts, flx_uplw_vr, flx_dnlw_vr, flx_uplw_clr_vr, flx_dnlw_clr_vr) - ! kernel verification for output variables - call verify_var_real_wp_dim2("flx_uplw_vr", check_status, flx_uplw_vr, ref_flx_uplw_vr) - call verify_var_real_wp_dim2("flx_uplw_clr_vr", check_status, flx_uplw_clr_vr, ref_flx_uplw_clr_vr) - call verify_var_real_wp_dim2("flx_dnlw_clr_vr", check_status, flx_dnlw_clr_vr, ref_flx_dnlw_clr_vr) - call verify_var_real_wp_dim2("flx_dnlw_vr", check_status, flx_dnlw_vr, ref_flx_dnlw_vr) - call verify_var_integer_4_dim2("rnseeds", check_status, rnseeds, ref_rnseeds) - CALL kgen_print_check("lrtm", check_status) - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,10 - CALL lrtm(kproma, kbdim, klev, pm_fl_vr, pm_sfc, tk_fl_vr, tk_hl_vr, tk_sfc, wkl_vr, wx_vr, col_dry_vr, zsemiss, cld_frc_vr, cld_tau_lw_vr, aer_tau_lw_vr, rnseeds, lw_strat, n_gpts_ts, flx_uplw_vr, flx_dnlw_vr, flx_uplw_clr_vr, flx_dnlw_clr_vr) - END DO - CALL system_clock(stop_clock, rate_clock) - WRITE(*,*) - PRINT *, "Elapsed time (sec): ", (stop_clock - start_clock)/REAL(rate_clock*10) - ! - ! Reset random seeds so SW doesn't depend on what's happened in LW but is also independent - ! - ! - ! Potential pitfall - we're passing every argument but some may not be present - ! - ! - ! 5.0 Post Processing - ! -------------------------------- - ! - ! Lw fluxes are vertically revered but SW fluxes are not - ! - ! - ! 6.0 Interface for submodel diagnosics after radiation calculation: - ! ------------------------------------------------------------------ - CONTAINS - - ! read subroutines - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim3(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:,:), allocatable :: var - integer, dimension(2,3) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_integer_4_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - integer(kind=4), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - - subroutine verify_var_logical(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - logical, intent(in) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - IF ( var .eqv. ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - endif - endif - check_status%numFatal = check_status%numFatal + 1 - END IF - end subroutine - - subroutine verify_var_integer(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - endif - endif - check_status%numFatal = check_status%numFatal + 1 - END IF - end subroutine - - subroutine verify_var_real(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real, intent(in) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - endif - endif - check_status%numFatal = check_status%numFatal + 1 - END IF - end subroutine - - subroutine verify_var_character(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - character(*), intent(in) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - end subroutine - - subroutine verify_var_real_wp_dim2(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(kind=wp), intent(in), dimension(:,:) :: var - real(kind=wp), intent(in), allocatable, dimension(:,:) :: ref_var - real(kind=wp) :: nrmsdiff, rmsdiff - real(kind=wp), allocatable :: temp(:,:), temp2(:,:) - integer :: n - - - IF ( ALLOCATED(ref_var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - IF ( ALL( var == ref_var ) ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - n = count(var/=ref_var) - where(ref_var .NE. 0) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - END IF - deallocate(temp,temp2) - END IF - end subroutine - - subroutine verify_var_real_wp_dim1(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(kind=wp), intent(in), dimension(:) :: var - real(kind=wp), intent(in), allocatable, dimension(:) :: ref_var - real(kind=wp) :: nrmsdiff, rmsdiff - real(kind=wp), allocatable :: temp(:), temp2(:) - integer :: n - - - IF ( ALLOCATED(ref_var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - allocate(temp(SIZE(var,dim=1))) - allocate(temp2(SIZE(var,dim=1))) - IF ( ALL( var == ref_var ) ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - n = count(var/=ref_var) - where(ref_var .NE. 0) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - END IF - deallocate(temp,temp2) - END IF - end subroutine - - subroutine verify_var_real_wp_dim3(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(kind=wp), intent(in), dimension(:,:,:) :: var - real(kind=wp), intent(in), allocatable, dimension(:,:,:) :: ref_var - real(kind=wp) :: nrmsdiff, rmsdiff - real(kind=wp), allocatable :: temp(:,:,:), temp2(:,:,:) - integer :: n - - - IF ( ALLOCATED(ref_var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - IF ( ALL( var == ref_var ) ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - n = count(var/=ref_var) - where(ref_var .NE. 0) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - END IF - deallocate(temp,temp2) - END IF - end subroutine - - subroutine verify_var_integer_4_dim2(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer(kind=4), intent(in), dimension(:,:) :: var - integer(kind=4), intent(in), allocatable, dimension(:,:) :: ref_var - integer(kind=4) :: nrmsdiff, rmsdiff - integer(kind=4), allocatable :: temp(:,:), temp2(:,:) - integer :: n - - - IF ( ALLOCATED(ref_var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - IF ( ALL( var == ref_var ) ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - n = count(var/=ref_var) - where(ref_var .NE. 0) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - END IF - deallocate(temp,temp2) - END IF - end subroutine - - END SUBROUTINE psrad_interface - END MODULE mo_psrad_interface diff --git a/test/ncar_kernels/PSRAD_lrtm/src/mo_rad_fastmath.f90 b/test/ncar_kernels/PSRAD_lrtm/src/mo_rad_fastmath.f90 deleted file mode 100644 index 0df00ac882..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm/src/mo_rad_fastmath.f90 +++ /dev/null @@ -1,84 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_rad_fastmath.f90 -! Generated at: 2015-02-19 15:30:32 -! KGEN version: 0.4.4 - - - - MODULE mo_rad_fastmath - USE mo_kind, ONLY: dp - USE mo_kind, ONLY: wp - IMPLICIT NONE - PRIVATE - PUBLIC tautrans, inv_expon, transmit - !< Optical depth - !< Exponential lookup table (EXP(-tau)) - !< Tau transition function - ! i.e. the transition of the Planck function from that for the mean layer temperature - ! to that for the layer boundary temperature as a function of optical depth. - ! The "linear in tau" method is used to make the table. - !< Value of tau below which expansion is used - !< Smallest value for exponential table - !< Pade approximation constant - REAL(KIND=wp), parameter :: rec_6 = 1._wp/6._wp - ! - ! The RRTMG tables are indexed with INT(tblint * x(i)/(bpade + x(i)) + 0.5_wp) - ! But these yield unstable values in the SW solver for some parameter sets, so - ! we'll remove this option (though the tables are initialized if people want them). - ! RRTMG table lookups are approximated second-order Taylor series expansion - ! (e.g. exp(-x) = 1._wp - x(1:n) + 0.5_wp * x(1:n)**2, tautrans = x/6._wp) for x < od_lo - ! - CONTAINS - - ! read subroutines - ! ------------------------------------------------------------ - - ! ------------------------------------------------------------ - - ! ------------------------------------------------------------ - - FUNCTION inv_expon(x, n) - ! - ! Compute EXP(-x) - but do it fast - ! - INTEGER, intent(in) :: n - REAL(KIND=dp), intent(in) :: x(n) - REAL(KIND=dp) :: inv_expon(n) - inv_expon(1:n) = exp(-x(1:n)) - END FUNCTION inv_expon - ! ------------------------------------------------------------ - - FUNCTION transmit(x, n) - ! - ! Compute transmittance 1 - EXP(-x) - ! - INTEGER, intent(in) :: n - REAL(KIND=dp), intent(in) :: x(n) - REAL(KIND=dp) :: transmit(n) - ! - ! MASS and MKL libraries have exp(x) - 1 functions; we could - ! use those here - ! - transmit(1:n) = 1._wp - inv_expon(x,n) - END FUNCTION transmit - ! ------------------------------------------------------------ - - FUNCTION tautrans(x, n) - ! - ! Compute "tau transition" using linear-in-tau approximation - ! - INTEGER, intent(in) :: n - REAL(KIND=dp), intent(in) :: x(n) - REAL(KIND=dp) :: tautrans(n) - REAL(KIND=dp) :: y(n) - ! - ! Default calculation is unstable (NaN) for the very lowest value of tau (3.6e-4) - ! - y(:) = inv_expon(x,n) - tautrans(:) = merge(1._wp - 2._wp*(1._wp/x(1:n) - y(:)/(1._wp-y(:))), x * rec_6, & - x > 1.e-3_wp) - END FUNCTION tautrans - ! ------------------------------------------------------------ - END MODULE mo_rad_fastmath diff --git a/test/ncar_kernels/PSRAD_lrtm/src/mo_radiation_parameters.f90 b/test/ncar_kernels/PSRAD_lrtm/src/mo_radiation_parameters.f90 deleted file mode 100644 index dc08eb4811..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm/src/mo_radiation_parameters.f90 +++ /dev/null @@ -1,115 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_radiation_parameters.f90 -! Generated at: 2015-02-19 15:30:29 -! KGEN version: 0.4.4 - - - - MODULE mo_radiation_parameters - USE mo_kind, ONLY: wp - IMPLICIT NONE - PRIVATE - PUBLIC i_overlap, l_do_sep_clear_sky - PUBLIC rad_undef - ! Standalone radiative transfer parameters - PUBLIC do_gpoint ! Standalone use only - ! 1.0 NAMELIST global variables and parameters - ! -------------------------------- - !< diurnal cycle - !< &! switch on/off diagnostic - !of instantaneous aerosol solar (lradforcing(1)) and - !thermal (lradforcing(2)) radiation forcing - !< switch to specify perpetual vsop87 year - !< year if (lyr_perp == .TRUE.) - !< 0=annual cycle; 1-12 for perpetual month - ! nmonth currently works for zonal mean ozone and the orbit (year 1987) only - !< mode of solar constant calculation - !< default is rrtm solar constant - !< number of shortwave bands, set in setup - ! Spectral sampling - ! 1 is broadband, 2 is MCSI, 3 and up are teams - ! Number of g-points per time step using MCSI - ! Integer for perturbing random number seeds - ! Use unique spectral samples under MCSI? Not yet implemented - INTEGER :: do_gpoint = 0 ! Standalone use only - specify gpoint to use - ! Radiation driver - LOGICAL :: l_do_sep_clear_sky = .true. ! Compute clear-sky fluxes by removing clouds - INTEGER :: i_overlap = 1 ! 1 = max-ran, 2 = max, 3 = ran - ! Use separate water vapor amounts in clear, cloudy skies - ! - ! --- Switches for radiative agents - ! - !< water vapor, clouds and ice for radiation - !< carbon dioxide - !< methane - !< ozone - !< molecular oxygen - !< nitrous oxide - !< cfc11 and cfc12 - !< greenhouse gase scenario - !< aerosol model - !< factor for external co2 scenario (ico2=4) - ! - ! --- Default gas volume mixing ratios - 1990 values (CMIP5) - ! - !< CO2 - !< CH4 - !< O2 - !< N20 - !< CFC 11 and CFC 12 - ! - ! 2.0 Non NAMELIST global variables and parameters - ! -------------------------------- - ! - ! --- radiative transfer parameters - ! - !< LW Emissivity Factor - !< LW Diffusivity Factor - REAL(KIND=wp), parameter :: rad_undef = -999._wp - ! - ! - !< default solar constant [W/m2] for - ! AMIP-type CMIP5 simulation - !++hs - !< local (orbit relative and possibly - ! time dependent) solar constant - !< orbit and time dependent solar constant for radiation time step - !< fraction of TSI in the 14 RRTM SW bands - !--hs - !< solar declination at current time step - ! - ! 3.0 Variables computed by routines in mo_radiation (export to submodels) - ! -------------------------------- - ! - ! setup_radiation - PUBLIC read_externs_mo_radiation_parameters - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_mo_radiation_parameters(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) do_gpoint - READ(UNIT=kgen_unit) l_do_sep_clear_sky - READ(UNIT=kgen_unit) i_overlap - END SUBROUTINE read_externs_mo_radiation_parameters - - - ! read subroutines - !--------------------------------------------------------------------------- - !> - !! @brief Scans a block and fills with solar parameters - !! - !! @remarks: This routine calculates the solar zenith angle for each - !! point in a block of data. For simulations with no dirunal cycle - !! the cosine of the zenith angle is set to its average value (assuming - !! negatives to be zero and for a day divided into nds intervals). - !! Additionally a field is set indicating the fraction of the day over - !! which the solar zenith angle is greater than zero. Otherwise the field - !! is set to 1 or 0 depending on whether the zenith angle is greater or - !! less than 1. - ! - - END MODULE mo_radiation_parameters diff --git a/test/ncar_kernels/PSRAD_lrtm/src/mo_random_numbers.f90 b/test/ncar_kernels/PSRAD_lrtm/src/mo_random_numbers.f90 deleted file mode 100644 index cf0916b327..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm/src/mo_random_numbers.f90 +++ /dev/null @@ -1,141 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_random_numbers.f90 -! Generated at: 2015-02-19 15:30:29 -! KGEN version: 0.4.4 - - - - MODULE mo_random_numbers - USE mo_kind, ONLY: dp - USE mo_kind, ONLY: i8 - IMPLICIT NONE - LOGICAL, parameter :: big_endian = (transfer(1_i8, 1) == 0) - INTEGER, parameter :: state_size = 4 - INTEGER :: global_seed(state_size) = (/123456789,362436069,21288629,14921776/) - PRIVATE - PUBLIC get_random - - INTERFACE get_random - MODULE PROCEDURE kisssca, kiss_global, kissvec, kissvec_all, kissvec_global - END INTERFACE get_random - PUBLIC read_externs_mo_random_numbers - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_integer_4_dim1 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_mo_random_numbers(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) global_seed - END SUBROUTINE read_externs_mo_random_numbers - - - ! read subroutines - subroutine read_var_integer_4_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - integer(kind=4), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - ! ----------------------------------------------- - - ! ----------------------------------------------- - - ! ----------------------------------------------- - - SUBROUTINE kissvec_all(kproma, kbdim, seed, harvest) - INTEGER, intent(in ) :: kbdim - INTEGER, intent(in ) :: kproma - INTEGER, intent(inout) :: seed(:,:) ! Dimension nproma, seed_size - REAL(KIND=dp), intent( out) :: harvest(:) ! Dimension nproma - LOGICAL :: mask(kbdim) - mask(:) = .true. - CALL kissvec(kproma, kbdim, seed, mask, harvest) - END SUBROUTINE kissvec_all - ! ----------------------------------------------- - - SUBROUTINE kissvec(kproma, kbdim, seed, mask, harvest) - INTEGER, intent(in ) :: kbdim - INTEGER, intent(in ) :: kproma - INTEGER, intent(inout) :: seed(:,:) ! Dimension kbdim, seed_size or bigger - LOGICAL, intent(in ) :: mask(kbdim) - REAL(KIND=dp), intent( out) :: harvest(kbdim) - INTEGER(KIND=i8) :: kiss(kproma) - INTEGER :: jk - DO jk = 1, kproma - IF (mask(jk)) THEN - kiss(jk) = 69069_i8 * seed(jk,1) + 1327217885 - seed(jk,1) = low_byte(kiss(jk)) - seed(jk,2) = m (m (m (seed(jk,2), 13), - 17), 5) - seed(jk,3) = 18000 * iand (seed(jk,3), 65535) + ishft (seed(jk,3), - 16) - seed(jk,4) = 30903 * iand (seed(jk,4), 65535) + ishft (seed(jk,4), - 16) - kiss(jk) = int(seed(jk,1), i8) + seed(jk,2) + ishft (seed(jk,3), 16) + seed(jk,4) - harvest(jk) = low_byte(kiss(jk))*2.328306e-10_dp + 0.5_dp - ELSE - harvest(jk) = 0._dp - END IF - END DO - END SUBROUTINE kissvec - ! ----------------------------------------------- - - SUBROUTINE kisssca(seed, harvest) - INTEGER, intent(inout) :: seed(:) - REAL(KIND=dp), intent( out) :: harvest - INTEGER(KIND=i8) :: kiss - kiss = 69069_i8 * seed(1) + 1327217885 - seed(1) = low_byte(kiss) - seed(2) = m (m (m (seed(2), 13), - 17), 5) - seed(3) = 18000 * iand (seed(3), 65535) + ishft (seed(3), - 16) - seed(4) = 30903 * iand (seed(4), 65535) + ishft (seed(4), - 16) - kiss = int(seed(1), i8) + seed(2) + ishft (seed(3), 16) + seed(4) - harvest = low_byte(kiss)*2.328306e-10_dp + 0.5_dp - END SUBROUTINE kisssca - ! ----------------------------------------------- - - SUBROUTINE kiss_global(harvest) - REAL(KIND=dp), intent(inout) :: harvest - CALL kisssca(global_seed, harvest) - END SUBROUTINE kiss_global - ! ----------------------------------------------- - - SUBROUTINE kissvec_global(harvest) - REAL(KIND=dp), intent(inout) :: harvest(:) - INTEGER :: i - DO i = 1, size(harvest) - CALL kisssca(global_seed, harvest(i)) - END DO - END SUBROUTINE kissvec_global - ! ----------------------------------------------- - - elemental integer FUNCTION m(k, n) - INTEGER, intent(in) :: k - INTEGER, intent(in) :: n - m = ieor (k, ishft (k, n)) ! UNRESOLVED: m - END FUNCTION m - ! ----------------------------------------------- - - elemental integer FUNCTION low_byte(i) - INTEGER(KIND=i8), intent(in) :: i - IF (big_endian) THEN - low_byte = transfer(ishft(i,bit_size(1)),1) ! UNRESOLVED: low_byte - ELSE - low_byte = transfer(i,1) ! UNRESOLVED: low_byte - END IF - END FUNCTION low_byte - END MODULE mo_random_numbers diff --git a/test/ncar_kernels/PSRAD_lrtm/src/mo_rrtm_coeffs.f90 b/test/ncar_kernels/PSRAD_lrtm/src/mo_rrtm_coeffs.f90 deleted file mode 100644 index 6ce71ad64b..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm/src/mo_rrtm_coeffs.f90 +++ /dev/null @@ -1,314 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_rrtm_coeffs.f90 -! Generated at: 2015-02-19 15:30:32 -! KGEN version: 0.4.4 - - - - MODULE mo_rrtm_coeffs - USE mo_kind, ONLY: wp - USE mo_rrtm_params, ONLY: preflog - USE mo_rrtm_params, ONLY: tref - USE rrlw_planck, ONLY: chi_mls - IMPLICIT NONE - REAL(KIND=wp), parameter :: stpfac = 296._wp/1013._wp - CONTAINS - - ! read subroutines - ! -------------------------------------------------------------------------------------------- - - SUBROUTINE lrtm_coeffs(kproma, kbdim, klev, play, tlay, coldry, wkl, wbroad, laytrop, jp, jt, jt1, colh2o, colco2, colo3, & - coln2o, colco, colch4, colo2, colbrd, fac00, fac01, fac10, fac11, rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, & - rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, selffac, selffrac, & - indself, forfac, forfrac, indfor, minorfrac, scaleminor, scaleminorn2, indminor) - INTEGER, intent(in) :: kbdim - INTEGER, intent(in) :: klev - INTEGER, intent(in) :: kproma - ! number of columns - ! maximum number of column as first dim is declared in calling (sub)prog. - ! total number of layers - REAL(KIND=wp), intent(in) :: wkl(:,:,:) - REAL(KIND=wp), intent(in) :: play(kbdim,klev) - REAL(KIND=wp), intent(in) :: tlay(kbdim,klev) - REAL(KIND=wp), intent(in) :: coldry(kbdim,klev) - REAL(KIND=wp), intent(in) :: wbroad(kbdim,klev) - ! layer pressures (mb) - ! layer temperatures (K) - ! dry air column density (mol/cm2) - ! broadening gas column density (mol/cm2) - !< molecular amounts (mol/cm-2) (mxmol,klev) - ! - ! Output Dimensions kproma, klev unless otherwise specified - ! - INTEGER, intent(out) :: laytrop(kbdim) - INTEGER, intent(out) :: jp(kbdim,klev) - INTEGER, intent(out) :: jt(kbdim,klev) - INTEGER, intent(out) :: jt1(kbdim,klev) - INTEGER, intent(out) :: indfor(kbdim,klev) - INTEGER, intent(out) :: indself(kbdim,klev) - INTEGER, intent(out) :: indminor(kbdim,klev) - !< tropopause layer index - ! - ! - ! - ! - ! - ! - REAL(KIND=wp), intent(out) :: forfac(kbdim,klev) - REAL(KIND=wp), intent(out) :: colch4(kbdim,klev) - REAL(KIND=wp), intent(out) :: colco2(kbdim,klev) - REAL(KIND=wp), intent(out) :: colh2o(kbdim,klev) - REAL(KIND=wp), intent(out) :: coln2o(kbdim,klev) - REAL(KIND=wp), intent(out) :: forfrac(kbdim,klev) - REAL(KIND=wp), intent(out) :: selffrac(kbdim,klev) - REAL(KIND=wp), intent(out) :: colo3(kbdim,klev) - REAL(KIND=wp), intent(out) :: fac00(kbdim,klev) - REAL(KIND=wp), intent(out) :: colo2(kbdim,klev) - REAL(KIND=wp), intent(out) :: fac01(kbdim,klev) - REAL(KIND=wp), intent(out) :: fac10(kbdim,klev) - REAL(KIND=wp), intent(out) :: fac11(kbdim,klev) - REAL(KIND=wp), intent(out) :: selffac(kbdim,klev) - REAL(KIND=wp), intent(out) :: colbrd(kbdim,klev) - REAL(KIND=wp), intent(out) :: colco(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_h2oco2(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_h2oco2_1(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_h2oo3(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_h2oo3_1(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_h2on2o(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_h2on2o_1(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_h2och4(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_h2och4_1(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_n2oco2(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_n2oco2_1(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_o3co2(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_o3co2_1(kbdim,klev) - REAL(KIND=wp), intent(out) :: scaleminor(kbdim,klev) - REAL(KIND=wp), intent(out) :: scaleminorn2(kbdim,klev) - REAL(KIND=wp), intent(out) :: minorfrac(kbdim,klev) - !< column amount (h2o) - !< column amount (co2) - !< column amount (o3) - !< column amount (n2o) - !< column amount (co) - !< column amount (ch4) - !< column amount (o2) - !< column amount (broadening gases) - !< - !< - !< - !< - !< - INTEGER :: jk - REAL(KIND=wp) :: colmol(kbdim,klev) - REAL(KIND=wp) :: factor(kbdim,klev) - ! ------------------------------------------------ - CALL srtm_coeffs(kproma, kbdim, klev, play, tlay, coldry, wkl, laytrop, jp, jt, jt1, colch4, colco2, colh2o, colmol, & - coln2o, colo2, colo3, fac00, fac01, fac10, fac11, selffac, selffrac, indself, forfac, forfrac, indfor) - colbrd(1:kproma,1:klev) = 1.e-20_wp * wbroad(1:kproma,1:klev) - colco(1:kproma,1:klev) = merge(1.e-20_wp * wkl(1:kproma,5,1:klev), 1.e-32_wp * & - coldry(1:kproma,1:klev), wkl(1:kproma,5,1:klev) > 0._wp) - ! - ! Water vapor continuum broadening factors are used differently in LW and SW? - ! - forfac(1:kproma,1:klev) = forfac(1:kproma,1:klev) * colh2o(1:kproma,1:klev) - selffac(1:kproma,1:klev) = selffac(1:kproma,1:klev) * colh2o(1:kproma,1:klev) - ! - ! Setup reference ratio to be used in calculation of binary species parameter. - ! - DO jk = 1, klev - rat_h2oco2(1:kproma, jk) = chi_mls(1,jp(1:kproma, jk))/chi_mls(2,jp(1:kproma, jk)) - rat_h2oco2_1(1:kproma, jk) = chi_mls(1,jp(1:kproma, jk)+1)/chi_mls(2,jp(1:kproma, jk)+1) - ! - ! Needed only in lower atmos (plog > 4.56_wp) - ! - rat_h2oo3(1:kproma, jk) = chi_mls(1,jp(1:kproma, jk))/chi_mls(3,jp(1:kproma, jk)) - rat_h2oo3_1(1:kproma, jk) = chi_mls(1,jp(1:kproma, jk)+1)/chi_mls(3,jp(1:kproma, jk)+1) - rat_h2on2o(1:kproma, jk) = chi_mls(1,jp(1:kproma, jk))/chi_mls(4,jp(1:kproma, jk)) - rat_h2on2o_1(1:kproma, jk) = chi_mls(1,jp(1:kproma, jk)+1)/chi_mls(4,jp(1:kproma, jk)+1) - rat_h2och4(1:kproma, jk) = chi_mls(1,jp(1:kproma, jk))/chi_mls(6,jp(1:kproma, jk)) - rat_h2och4_1(1:kproma, jk) = chi_mls(1,jp(1:kproma, jk)+1)/chi_mls(6,jp(1:kproma, jk)+1) - rat_n2oco2(1:kproma, jk) = chi_mls(4,jp(1:kproma, jk))/chi_mls(2,jp(1:kproma, jk)) - rat_n2oco2_1(1:kproma, jk) = chi_mls(4,jp(1:kproma, jk)+1)/chi_mls(2,jp(1:kproma, jk)+1) - ! - ! Needed only in upper atmos (plog <= 4.56_wp) - ! - rat_o3co2(1:kproma, jk) = chi_mls(3,jp(1:kproma, jk))/chi_mls(2,jp(1:kproma, jk)) - rat_o3co2_1(1:kproma, jk) = chi_mls(3,jp(1:kproma, jk)+1)/chi_mls(2,jp(1:kproma, jk)+1) - END DO - ! - ! Set up factors needed to separately include the minor gases - ! in the calculation of absorption coefficient - ! - scaleminor(1:kproma,1:klev) = play(1:kproma,1:klev)/tlay(1:kproma,1:klev) - scaleminorn2(1:kproma,1:klev) = scaleminor(1:kproma,1:klev) * (wbroad(1:kproma,1:klev)/(& - coldry(1:kproma,1:klev)+wkl(1:kproma,1,1:klev))) - factor(1:kproma,1:klev) = (tlay(1:kproma,1:klev)-180.8_wp)/7.2_wp - indminor(1:kproma,1:klev) = min(18, max(1, int(factor(1:kproma,1:klev)))) - minorfrac(1:kproma,1:klev) = (tlay(1:kproma,1:klev)-180.8_wp)/7.2_wp - float(indminor(1:kproma,1:klev)) - END SUBROUTINE lrtm_coeffs - ! -------------------------------------------------------------------------------------------- - - SUBROUTINE srtm_coeffs(kproma, kbdim, klev, play, tlay, coldry, wkl, laytrop, jp, jt, jt1, colch4, colco2, colh2o, colmol,& - coln2o, colo2, colo3, fac00, fac01, fac10, fac11, selffac, selffrac, indself, forfac, forfrac, indfor) - INTEGER, intent(in) :: kbdim - INTEGER, intent(in) :: klev - INTEGER, intent(in) :: kproma - ! number of columns - ! maximum number of col. as declared in calling (sub)programs - ! total number of layers - REAL(KIND=wp), intent(in) :: play(kbdim,klev) - REAL(KIND=wp), intent(in) :: tlay(kbdim,klev) - REAL(KIND=wp), intent(in) :: wkl(:,:,:) - REAL(KIND=wp), intent(in) :: coldry(kbdim,klev) - ! layer pressures (mb) - ! layer temperatures (K) - ! dry air column density (mol/cm2) - !< molecular amounts (mol/cm-2) (mxmol,klev) - ! - ! Output Dimensions kproma, klev unless otherwise specified - ! - INTEGER, intent(out) :: jp(kbdim,klev) - INTEGER, intent(out) :: jt(kbdim,klev) - INTEGER, intent(out) :: jt1(kbdim,klev) - INTEGER, intent(out) :: laytrop(kbdim) - INTEGER, intent(out) :: indfor(kbdim,klev) - INTEGER, intent(out) :: indself(kbdim,klev) - !< tropopause layer index - ! - ! - ! - ! - REAL(KIND=wp), intent(out) :: fac10(kbdim,klev) - REAL(KIND=wp), intent(out) :: fac00(kbdim,klev) - REAL(KIND=wp), intent(out) :: fac11(kbdim,klev) - REAL(KIND=wp), intent(out) :: fac01(kbdim,klev) - REAL(KIND=wp), intent(out) :: colh2o(kbdim,klev) - REAL(KIND=wp), intent(out) :: colco2(kbdim,klev) - REAL(KIND=wp), intent(out) :: colo3(kbdim,klev) - REAL(KIND=wp), intent(out) :: coln2o(kbdim,klev) - REAL(KIND=wp), intent(out) :: colch4(kbdim,klev) - REAL(KIND=wp), intent(out) :: colo2(kbdim,klev) - REAL(KIND=wp), intent(out) :: colmol(kbdim,klev) - REAL(KIND=wp), intent(out) :: forfac(kbdim,klev) - REAL(KIND=wp), intent(out) :: selffac(kbdim,klev) - REAL(KIND=wp), intent(out) :: forfrac(kbdim,klev) - REAL(KIND=wp), intent(out) :: selffrac(kbdim,klev) - !< column amount (h2o) - !< column amount (co2) - !< column amount (o3) - !< column amount (n2o) - !< column amount (ch4) - !< column amount (o2) - !< - !< - !< - !< - !< - INTEGER :: jp1(kbdim,klev) - INTEGER :: jk - REAL(KIND=wp) :: plog (kbdim,klev) - REAL(KIND=wp) :: fp (kbdim,klev) - REAL(KIND=wp) :: ft (kbdim,klev) - REAL(KIND=wp) :: ft1 (kbdim,klev) - REAL(KIND=wp) :: water (kbdim,klev) - REAL(KIND=wp) :: scalefac(kbdim,klev) - REAL(KIND=wp) :: compfp(kbdim,klev) - REAL(KIND=wp) :: factor (kbdim,klev) - ! ------------------------------------------------------------------------- - ! - ! Find the two reference pressures on either side of the - ! layer pressure. Store them in JP and JP1. Store in FP the - ! fraction of the difference (in ln(pressure)) between these - ! two values that the layer pressure lies. - ! - plog(1:kproma,1:klev) = log(play(1:kproma,1:klev)) - jp(1:kproma,1:klev) = min(58,max(1,int(36._wp - 5*(plog(1:kproma,1:klev)+0.04_wp)))) - jp1(1:kproma,1:klev) = jp(1:kproma,1:klev) + 1 - DO jk = 1, klev - fp(1:kproma,jk) = 5._wp *(preflog(jp(1:kproma,jk)) - plog(1:kproma,jk)) - END DO - ! - ! Determine, for each reference pressure (JP and JP1), which - ! reference temperature (these are different for each - ! reference pressure) is nearest the layer temperature but does - ! not exceed it. Store these indices in JT and JT1, resp. - ! Store in FT (resp. FT1) the fraction of the way between JT - ! (JT1) and the next highest reference temperature that the - ! layer temperature falls. - ! - DO jk = 1, klev - jt(1:kproma,jk) = min(4,max(1,int(3._wp + (tlay(1:kproma,jk) - tref(& - jp (1:kproma,jk)))/15._wp))) - jt1(1:kproma,jk) = min(4,max(1,int(3._wp + (tlay(1:kproma,jk) - & - tref(jp1(1:kproma,jk)))/15._wp))) - END DO - DO jk = 1, klev - ft(1:kproma,jk) = ((tlay(1:kproma,jk)-tref(jp (1:kproma,jk)))/15._wp) - float(jt (& - 1:kproma,jk)-3) - ft1(1:kproma,jk) = ((tlay(1:kproma,jk)-tref(jp1(1:kproma,jk)))/15._wp) - float(jt1(& - 1:kproma,jk)-3) - END DO - water(1:kproma,1:klev) = wkl(1:kproma,1,1:klev)/coldry(1:kproma,1:klev) - scalefac(1:kproma,1:klev) = play(1:kproma,1:klev) * stpfac / tlay(1:kproma,1:klev) - ! - ! We have now isolated the layer ln pressure and temperature, - ! between two reference pressures and two reference temperatures - ! (for each reference pressure). We multiply the pressure - ! fraction FP with the appropriate temperature fractions to get - ! the factors that will be needed for the interpolation that yields - ! the optical depths (performed in routines TAUGBn for band n).` - ! - compfp(1:kproma,1:klev) = 1. - fp(1:kproma,1:klev) - fac10(1:kproma,1:klev) = compfp(1:kproma,1:klev) * ft(1:kproma,1:klev) - fac00(1:kproma,1:klev) = compfp(1:kproma,1:klev) * (1._wp - ft(1:kproma,1:klev)) - fac11(1:kproma,1:klev) = fp(1:kproma,1:klev) * ft1(1:kproma,1:klev) - fac01(1:kproma,1:klev) = fp(1:kproma,1:klev) * (1._wp - ft1(1:kproma,1:klev)) - ! Tropopause defined in terms of pressure (~100 hPa) - ! We're looking for the first layer (counted from the bottom) at which the pressure reaches - ! or falls below this value - ! - laytrop(1:kproma) = count(plog(1:kproma,1:klev) > 4.56_wp, dim = 2) - ! - ! Calculate needed column amounts. - ! Only a few ratios are used in the upper atmosphere but masking may be less efficient - ! - colh2o(1:kproma,1:klev) = merge(1.e-20_wp * wkl(1:kproma,1,1:klev), 1.e-32_wp * & - coldry(1:kproma,1:klev), wkl(1:kproma,1,1:klev) > 0._wp) - colco2(1:kproma,1:klev) = merge(1.e-20_wp * wkl(1:kproma,2,1:klev), 1.e-32_wp * & - coldry(1:kproma,1:klev), wkl(1:kproma,2,1:klev) > 0._wp) - colo3(1:kproma,1:klev) = merge(1.e-20_wp * wkl(1:kproma,3,1:klev), 1.e-32_wp * & - coldry(1:kproma,1:klev), wkl(1:kproma,3,1:klev) > 0._wp) - coln2o(1:kproma,1:klev) = merge(1.e-20_wp * wkl(1:kproma,4,1:klev), 1.e-32_wp * & - coldry(1:kproma,1:klev), wkl(1:kproma,4,1:klev) > 0._wp) - colch4(1:kproma,1:klev) = merge(1.e-20_wp * wkl(1:kproma,6,1:klev), 1.e-32_wp * & - coldry(1:kproma,1:klev), wkl(1:kproma,6,1:klev) > 0._wp) - colo2(1:kproma,1:klev) = merge(1.e-20_wp * wkl(1:kproma,7,1:klev), 1.e-32_wp * & - coldry(1:kproma,1:klev), wkl(1:kproma,7,1:klev) > 0._wp) - colmol(1:kproma,1:klev) = 1.e-20_wp * coldry(1:kproma,1:klev) + colh2o(1:kproma,1:klev) - ! ------------------------------------------ - ! Interpolation coefficients - ! - forfac(1:kproma,1:klev) = scalefac(1:kproma,1:klev) / (1._wp+water(1:kproma,1:klev)) - ! - ! Set up factors needed to separately include the water vapor - ! self-continuum in the calculation of absorption coefficient. - ! - selffac(1:kproma,1:klev) = water(1:kproma,1:klev) * forfac(1:kproma,1:klev) - ! - ! If the pressure is less than ~100mb, perform a different set of species - ! interpolations. - ! - factor(1:kproma,1:klev) = (332.0_wp-tlay(1:kproma,1:klev))/36.0_wp - indfor(1:kproma,1:klev) = merge(3, min(2, max(1, int(factor(1:kproma,& - 1:klev)))), plog(1:kproma,1:klev) <= 4.56_wp) - forfrac(1:kproma,1:klev) = merge((tlay(1:kproma,1:klev)-188.0_wp)/36.0_wp - 1.0_wp, factor(1:kproma,& - 1:klev) - float(indfor(1:kproma,1:klev)), plog(1:kproma,1:klev) <= 4.56_wp) - ! In RRTMG code, this calculation is done only in the lower atmosphere (plog > 4.56) - ! - factor(1:kproma,1:klev) = (tlay(1:kproma,1:klev)-188.0_wp)/7.2_wp - indself(1:kproma,1:klev) = min(9, max(1, int(factor(1:kproma,1:klev))-7)) - selffrac(1:kproma,1:klev) = factor(1:kproma,1:klev) - float(indself(1:kproma,1:klev) + 7) - END SUBROUTINE srtm_coeffs - END MODULE mo_rrtm_coeffs diff --git a/test/ncar_kernels/PSRAD_lrtm/src/mo_rrtm_params.f90 b/test/ncar_kernels/PSRAD_lrtm/src/mo_rrtm_params.f90 deleted file mode 100644 index fac2c9c41a..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm/src/mo_rrtm_params.f90 +++ /dev/null @@ -1,56 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_rrtm_params.f90 -! Generated at: 2015-02-19 15:30:37 -! KGEN version: 0.4.4 - - - - MODULE mo_rrtm_params - USE mo_kind, ONLY: wp - IMPLICIT NONE - PUBLIC - !! ----------------------------------------------------------------------------------------- - !! - !! Shared parameters - !! - !< number of original g-intervals per spectral band - INTEGER, parameter :: maxxsec= 4 !< maximum number of cross-section molecules (cfcs) - INTEGER, parameter :: maxinpx= 38 - !< number of last band (lw and sw share band 16) - !< number of spectral bands in sw model - !< total number of gpts - !< first band in sw - !< last band in sw - INTEGER, parameter :: nbndlw = 16 !< number of spectral bands in lw model - INTEGER, parameter :: ngptlw = 140 !< total number of reduced g-intervals for rrtmg_lw - ! - ! These pressures are chosen such that the ln of the first pressure - ! has only a few non-zero digits (i.e. ln(PREF(1)) = 6.96000) and - ! each subsequent ln(pressure) differs from the previous one by 0.2. - ! - REAL(KIND=wp), parameter :: preflog(59) = (/ 6.9600e+00_wp, 6.7600e+00_wp, 6.5600e+00_wp, 6.3600e+00_wp, & - 6.1600e+00_wp, 5.9600e+00_wp, 5.7600e+00_wp, 5.5600e+00_wp, 5.3600e+00_wp, 5.1600e+00_wp, 4.9600e+00_wp, & - 4.7600e+00_wp, 4.5600e+00_wp, 4.3600e+00_wp, 4.1600e+00_wp, 3.9600e+00_wp, 3.7600e+00_wp, 3.5600e+00_wp, & - 3.3600e+00_wp, 3.1600e+00_wp, 2.9600e+00_wp, 2.7600e+00_wp, 2.5600e+00_wp, 2.3600e+00_wp, 2.1600e+00_wp, & - 1.9600e+00_wp, 1.7600e+00_wp, 1.5600e+00_wp, 1.3600e+00_wp, 1.1600e+00_wp, 9.6000e-01_wp, 7.6000e-01_wp, & - 5.6000e-01_wp, 3.6000e-01_wp, 1.6000e-01_wp, -4.0000e-02_wp,-2.4000e-01_wp,-4.4000e-01_wp,-6.4000e-01_wp,& - -8.4000e-01_wp, -1.0400e+00_wp,-1.2400e+00_wp,-1.4400e+00_wp,-1.6400e+00_wp,-1.8400e+00_wp, -2.0400e+00_wp,& - -2.2400e+00_wp,-2.4400e+00_wp,-2.6400e+00_wp,-2.8400e+00_wp, -3.0400e+00_wp,-3.2400e+00_wp,-3.4400e+00_wp,& - -3.6400e+00_wp,-3.8400e+00_wp, -4.0400e+00_wp,-4.2400e+00_wp,-4.4400e+00_wp,-4.6400e+00_wp /) - ! - ! These are the temperatures associated with the respective pressures - ! - REAL(KIND=wp), parameter :: tref(59) = (/ 2.9420e+02_wp, 2.8799e+02_wp, 2.7894e+02_wp, 2.6925e+02_wp, & - 2.5983e+02_wp, 2.5017e+02_wp, 2.4077e+02_wp, 2.3179e+02_wp, 2.2306e+02_wp, 2.1578e+02_wp, 2.1570e+02_wp, & - 2.1570e+02_wp, 2.1570e+02_wp, 2.1706e+02_wp, 2.1858e+02_wp, 2.2018e+02_wp, 2.2174e+02_wp, 2.2328e+02_wp, & - 2.2479e+02_wp, 2.2655e+02_wp, 2.2834e+02_wp, 2.3113e+02_wp, 2.3401e+02_wp, 2.3703e+02_wp, 2.4022e+02_wp, & - 2.4371e+02_wp, 2.4726e+02_wp, 2.5085e+02_wp, 2.5457e+02_wp, 2.5832e+02_wp, 2.6216e+02_wp, 2.6606e+02_wp, & - 2.6999e+02_wp, 2.7340e+02_wp, 2.7536e+02_wp, 2.7568e+02_wp, 2.7372e+02_wp, 2.7163e+02_wp, 2.6955e+02_wp, & - 2.6593e+02_wp, 2.6211e+02_wp, 2.5828e+02_wp, 2.5360e+02_wp, 2.4854e+02_wp, 2.4348e+02_wp, 2.3809e+02_wp, & - 2.3206e+02_wp, 2.2603e+02_wp, 2.2000e+02_wp, 2.1435e+02_wp, 2.0887e+02_wp, 2.0340e+02_wp, 1.9792e+02_wp, & - 1.9290e+02_wp, 1.8809e+02_wp, 1.8329e+02_wp, 1.7849e+02_wp, 1.7394e+02_wp, 1.7212e+02_wp /) - - ! read subroutines - END MODULE mo_rrtm_params diff --git a/test/ncar_kernels/PSRAD_lrtm/src/mo_spec_sampling.f90 b/test/ncar_kernels/PSRAD_lrtm/src/mo_spec_sampling.f90 deleted file mode 100644 index 5cdee52320..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm/src/mo_spec_sampling.f90 +++ /dev/null @@ -1,149 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_spec_sampling.f90 -! Generated at: 2015-02-19 15:30:31 -! KGEN version: 0.4.4 - - - - MODULE mo_spec_sampling - USE mo_random_numbers, ONLY: get_random - USE mo_kind, ONLY: wp - IMPLICIT NONE - PRIVATE - ! - ! Team choices - Longwave - ! - ! - ! Team choices - Shortwave - ! - ! - ! Encapsulate the strategy - ! - TYPE spec_sampling_strategy - PRIVATE - INTEGER, dimension(:, :), pointer :: teams => null() - INTEGER :: num_gpts_ts ! How many g points at each time step - LOGICAL :: unique = .false. - END TYPE spec_sampling_strategy - PUBLIC spec_sampling_strategy, get_gpoint_set - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_integer_4_dim2_pointer - module procedure read_var_spec_sampling_strategy - end interface kgen_read_var - - CONTAINS - subroutine read_var_spec_sampling_strategy(var, kgen_unit) - integer, intent(in) :: kgen_unit - type(spec_sampling_strategy), intent(out) :: var - - call kgen_read_var(var%teams, kgen_unit, .true.) - READ(UNIT=kgen_unit) var%num_gpts_ts - READ(UNIT=kgen_unit) var%unique - end subroutine - - ! read subroutines - subroutine read_var_integer_4_dim2_pointer(var, kgen_unit, is_pointer) - integer, intent(in) :: kgen_unit - logical, intent(in) :: is_pointer - integer(kind=4), intent(out), dimension(:,:), pointer :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - ! ----------------------------------------------------------------------------------------------- - !> - !! @brief Sets a spectral sampling strategy - !! - !! @remarks: Choose a set of g-point teams to use. - !! Two end-member choices: - !! strategy = 1 : a single team comprising all g-points, i.e. broadband integration - !! strategy = 2 : ngpts teams of a single g-point each, i.e. a single randomly chosen g-point - !! This can be modified to choose m samples at each time step (with or without replacement, eventually) - !! Other strategies must combine n teams of m gpoints each such that m * n = ngpts - !! strategy 1 (broadband) is the default - !! - ! - - ! ----------------------------------------------------------------------------------------------- - ! ----------------------------------------------------------------------------------------------- - !> - !! @brief Sets a spectral sampling strategy - !! - !! @remarks: Choose a set of g-point teams to use. - !! Two end-member choices: - !! strategy = 1 : a single team comprising all g-points, i.e. broadband integration - !! strategy = 2 : ngpts teams of a single g-point each, i.e. a single randomly chosen g-point - !! This can be modified to choose m samples at each time step (with or without replacement, eventually) - !! Other strategies must combine n teams of m gpoints each such that m * n = ngpts - !! strategy 1 (broadband) is the default - !! - ! - - ! ----------------------------------------------------------------------------------------------- - !> - !! @brief Returns the number of g-points to compute at each time step - !! - - ! ----------------------------------------------------------------------------------------------- - !> - !! @brief Returns one set of g-points consistent with sampling strategy - !! - - FUNCTION get_gpoint_set(kproma, kbdim, strategy, seeds) - INTEGER, intent(in) :: kproma - INTEGER, intent(in) :: kbdim - TYPE(spec_sampling_strategy), intent(in) :: strategy - INTEGER, intent(inout) :: seeds(:,:) ! dimensions kbdim, rng seed_size - INTEGER, dimension(kproma, strategy%num_gpts_ts) :: get_gpoint_set - REAL(KIND=wp) :: rn(kbdim) - INTEGER :: team(kbdim) - INTEGER :: num_teams - INTEGER :: num_gpts_team - INTEGER :: jl - INTEGER :: it - ! -------- - num_teams = size(strategy%teams, 2) - num_gpts_team = size(strategy%teams, 1) - IF (num_teams == 1) THEN - ! - ! Broadband integration - ! - get_gpoint_set(1:kproma,:) = spread(strategy%teams(:, 1), dim = 1, ncopies = kproma) - ELSE IF (num_gpts_team > 1) THEN - ! - ! Mutiple g-points per team, including broadband integration - ! Return just one team - ! - CALL get_random(kproma, kbdim, seeds, rn) - team(1:kproma) = min(int(rn(1:kproma) * num_teams) + 1, num_teams) - DO jl = 1, kproma - get_gpoint_set(jl, :) = strategy%teams(:,team(jl)) - END DO - ELSE - ! - ! MCSI - return one or more individual points chosen randomly - ! Need to add option for sampling without replacement - ! - DO it = 1, strategy%num_gpts_ts - CALL get_random(kproma, kbdim, seeds, rn) - team(1:kproma) = min(int(rn(1:kproma) * num_teams) + 1, num_teams) - get_gpoint_set(1:kproma, it) = strategy%teams(1, team(1:kproma)) - END DO - END IF - END FUNCTION get_gpoint_set - ! ----------------------------------------------------------------------------------------------- - END MODULE mo_spec_sampling diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/CESM_license.txt b/test/ncar_kernels/PSRAD_lrtm_Bangalore/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/README b/test/ncar_kernels/PSRAD_lrtm_Bangalore/README deleted file mode 100644 index d495b7eef2..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/README +++ /dev/null @@ -1,21 +0,0 @@ -* kernel and supporting files - - lrtm subroutine is located at line #61 of mo_lrtm_driver.f90 file - - program statement or subroutine call is on line #320 in mo_psrad_interface.f90 - - call_hierarchy.png is a diagram showing function call hierarchy in PSrad - - The other files are subset of PSrad source files that contain information to execute lrtm - -* compilation and execution - - Place all files in a directory - - Adjust FC and FFLAGS macros in Makefile to use a specific compiler. Default compiler is ifort - - run "make" - -* verification - - "make" command will run kernel and print verification output on screen - - Verification is considered as pass if it shows "PASSED" or "Normalized RMS of difference" is around machine-precision (apprx. 10e-15) - - Verification check is performed using three data files- lrtm.1, lrtm.10 and lrtm.50. The data files are generated from running PSrad using Intel 15.0 compiler with "-O3 -xHost" compiler flags - -* performance measurement - - The kernel prints elapsed time (in seconds) as the time taken to execute the kernel - - The elapsed time is printed three times for each kernel executed using the three data files - - diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/data/lrtm.1 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/data/lrtm.1 deleted file mode 100644 index 180c3d36f2..0000000000 Binary files a/test/ncar_kernels/PSRAD_lrtm_Bangalore/data/lrtm.1 and /dev/null differ diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/data/lrtm.10 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/data/lrtm.10 deleted file mode 100644 index 01775e3cc2..0000000000 Binary files a/test/ncar_kernels/PSRAD_lrtm_Bangalore/data/lrtm.10 and /dev/null differ diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/data/lrtm.50 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/data/lrtm.50 deleted file mode 100644 index e1ce33ff53..0000000000 Binary files a/test/ncar_kernels/PSRAD_lrtm_Bangalore/data/lrtm.50 and /dev/null differ diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/inc/t1.mk b/test/ncar_kernels/PSRAD_lrtm_Bangalore/inc/t1.mk deleted file mode 100644 index 517a45d8fe..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/inc/t1.mk +++ /dev/null @@ -1,101 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# Makefile for KGEN-generated kernel - -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# Intel default flags -# -# FC_FLAGS := -O3 -xHost -mkl -# - -FC_FLAGS := $(OPT) - - -ALL_OBJS := kernel_driver.o mo_psrad_interface.o mo_lrtm_kgs.o mo_cld_sampling.o mo_lrtm_solver.o mo_rrtm_coeffs.o mo_exception_stub.o mo_physical_constants.o mo_radiation_parameters.o mo_kind.o mo_spec_sampling.o mo_random_numbers.o mo_lrtm_setup.o mo_math_constants.o mo_rrtm_params.o mo_rad_fastmath.o mo_taumol03.o mo_taumol04.o mo_lrtm_driver.o mo_lrtm_gas_optics.o - -all: build run verify - -verify: - @(grep "verification.FAIL" $(TEST).rslt && echo "FAILED") || (grep "verification.PASS" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 mo_psrad_interface.o mo_lrtm_kgs.o mo_cld_sampling.o mo_lrtm_solver.o mo_rrtm_coeffs.o mo_exception_stub.o mo_physical_constants.o mo_radiation_parameters.o mo_kind.o mo_spec_sampling.o mo_random_numbers.o mo_lrtm_setup.o mo_math_constants.o mo_rrtm_params.o mo_rad_fastmath.o mo_lrtm_driver.o mo_lrtm_gas_optics.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_psrad_interface.o: $(SRC_DIR)/mo_psrad_interface.f90 mo_lrtm_driver.o mo_rrtm_params.o mo_kind.o mo_spec_sampling.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_lrtm_kgs.o: $(SRC_DIR)/mo_lrtm_kgs.f90 mo_kind.o mo_rrtm_params.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_cld_sampling.o: $(SRC_DIR)/mo_cld_sampling.f90 mo_kind.o mo_random_numbers.o mo_exception_stub.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_lrtm_solver.o: $(SRC_DIR)/mo_lrtm_solver.f90 mo_kind.o mo_rrtm_params.o mo_rad_fastmath.o mo_math_constants.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_taumol03.o: $(SRC_DIR)/mo_taumol03.f90 mo_kind.o mo_lrtm_setup.o mo_lrtm_kgs.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_taumol04.o: $(SRC_DIR)/mo_taumol04.f90 mo_kind.o mo_lrtm_setup.o mo_lrtm_kgs.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_rrlw_planck.o: $(SRC_DIR)/mo_rrlw_planck.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_rrtm_coeffs.o: $(SRC_DIR)/mo_rrtm_coeffs.f90 mo_kind.o mo_rrtm_params.o mo_lrtm_kgs.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_exception_stub.o: $(SRC_DIR)/mo_exception_stub.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_physical_constants.o: $(SRC_DIR)/mo_physical_constants.f90 mo_kind.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_radiation_parameters.o: $(SRC_DIR)/mo_radiation_parameters.f90 mo_kind.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_kind.o: $(SRC_DIR)/mo_kind.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_spec_sampling.o: $(SRC_DIR)/mo_spec_sampling.f90 mo_kind.o mo_random_numbers.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_random_numbers.o: $(SRC_DIR)/mo_random_numbers.f90 mo_kind.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_lrtm_setup.o: $(SRC_DIR)/mo_lrtm_setup.f90 mo_rrtm_params.o mo_kind.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_math_constants.o: $(SRC_DIR)/mo_math_constants.f90 mo_kind.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_rrtm_params.o: $(SRC_DIR)/mo_rrtm_params.f90 mo_kind.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_rad_fastmath.o: $(SRC_DIR)/mo_rad_fastmath.f90 mo_kind.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_lrtm_driver.o: $(SRC_DIR)/mo_lrtm_driver.f90 mo_rrtm_params.o mo_kind.o mo_spec_sampling.o mo_radiation_parameters.o mo_lrtm_setup.o mo_cld_sampling.o mo_rrtm_coeffs.o mo_lrtm_gas_optics.o mo_taumol03.o mo_taumol04.o mo_lrtm_kgs.o mo_physical_constants.o mo_lrtm_solver.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_lrtm_gas_optics.o: $(SRC_DIR)/mo_lrtm_gas_optics.f90 mo_kind.o mo_lrtm_setup.o mo_lrtm_kgs.o mo_exception_stub.o - ${FC} ${FC_FLAGS} -c -o $@ $< - - -clean: - rm -f kernel.exe *.mod *.o *.oo *.rslt diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/lit/runmake b/test/ncar_kernels/PSRAD_lrtm_Bangalore/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/lit/t1.sh b/test/ncar_kernels/PSRAD_lrtm_Bangalore/lit/t1.sh deleted file mode 100644 index 33c953a156..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/lit/t1.sh +++ /dev/null @@ -1,9 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -# Shared lit script for each tests. Run bash commands that run tests with make. - -# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t -# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/makefile b/test/ncar_kernels/PSRAD_lrtm_Bangalore/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/kernel_driver.f90 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/kernel_driver.f90 deleted file mode 100644 index f40e019a30..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/kernel_driver.f90 +++ /dev/null @@ -1,141 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-02-19 15:30:29 -! KGEN version: 0.4.4 - - -PROGRAM kernel_driver - USE mo_psrad_interface, only : psrad_interface - USE mo_kind, ONLY: wp - USE mo_psrad_interface, only : read_externs_mo_psrad_interface - USE mo_radiation_parameters, only : read_externs_mo_radiation_parameters - USE rrlw_kg12, only : read_externs_rrlw_kg12 - USE rrlw_kg13, only : read_externs_rrlw_kg13 - USE rrlw_planck, only : read_externs_rrlw_planck - USE rrlw_kg11, only : read_externs_rrlw_kg11 - USE rrlw_kg16, only : read_externs_rrlw_kg16 - USE rrlw_kg14, only : read_externs_rrlw_kg14 - USE rrlw_kg15, only : read_externs_rrlw_kg15 - USE rrlw_kg10, only : read_externs_rrlw_kg10 - USE rrlw_kg01, only : read_externs_rrlw_kg01 - USE rrlw_kg03, only : read_externs_rrlw_kg03 - USE rrlw_kg02, only : read_externs_rrlw_kg02 - USE rrlw_kg05, only : read_externs_rrlw_kg05 - USE rrlw_kg04, only : read_externs_rrlw_kg04 - USE rrlw_kg07, only : read_externs_rrlw_kg07 - USE rrlw_kg06, only : read_externs_rrlw_kg06 - USE rrlw_kg09, only : read_externs_rrlw_kg09 - USE rrlw_kg08, only : read_externs_rrlw_kg08 - USE mo_random_numbers, only : read_externs_mo_random_numbers - - IMPLICIT NONE - - ! read interface - !interface kgen_read_var - ! procedure read_var_real_wp_dim1 - !end interface kgen_read_var - - - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_counter_at = (/ 1, 10, 50 /) - CHARACTER(LEN=1024) :: kgen_filepath - INTEGER :: nb_sw - INTEGER :: klev - REAL(KIND=wp), allocatable :: tk_sfc(:) - INTEGER :: kproma - INTEGER :: kbdim - INTEGER :: ktrac - - DO kgen_repeat_counter = 0, 2 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_filepath = "../data/lrtm." // trim(adjustl(kgen_counter_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "************ Verification against '" // trim(adjustl(kgen_filepath)) // "' ************" - - call read_externs_mo_psrad_interface(kgen_unit) - call read_externs_mo_radiation_parameters(kgen_unit) - call read_externs_rrlw_kg12(kgen_unit) - call read_externs_rrlw_kg13(kgen_unit) - call read_externs_rrlw_planck(kgen_unit) - call read_externs_rrlw_kg11(kgen_unit) - call read_externs_rrlw_kg16(kgen_unit) - call read_externs_rrlw_kg14(kgen_unit) - call read_externs_rrlw_kg15(kgen_unit) - call read_externs_rrlw_kg10(kgen_unit) - call read_externs_rrlw_kg01(kgen_unit) - call read_externs_rrlw_kg03(kgen_unit) - call read_externs_rrlw_kg02(kgen_unit) - call read_externs_rrlw_kg05(kgen_unit) - call read_externs_rrlw_kg04(kgen_unit) - call read_externs_rrlw_kg07(kgen_unit) - call read_externs_rrlw_kg06(kgen_unit) - call read_externs_rrlw_kg09(kgen_unit) - call read_externs_rrlw_kg08(kgen_unit) - call read_externs_mo_random_numbers(kgen_unit) - - ! driver variables - READ(UNIT=kgen_unit) kbdim - READ(UNIT=kgen_unit) klev - READ(UNIT=kgen_unit) nb_sw - READ(UNIT=kgen_unit) kproma - READ(UNIT=kgen_unit) ktrac - !call kgen_read_var(tk_sfc, kgen_unit) - call read_var_real_wp_dim1(tk_sfc, kgen_unit) - call psrad_interface(kbdim, klev, nb_sw, kproma, ktrac, tk_sfc, kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_cld_sampling.f90 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_cld_sampling.f90 deleted file mode 100644 index f85e2cdfc3..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_cld_sampling.f90 +++ /dev/null @@ -1,88 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_cld_sampling.f90 -! Generated at: 2015-02-19 15:30:32 -! KGEN version: 0.4.4 - - - - MODULE mo_cld_sampling - USE mo_kind, ONLY: wp - USE mo_exception, ONLY: finish - USE mo_random_numbers, ONLY: get_random - IMPLICIT NONE - PRIVATE - PUBLIC sample_cld_state - CONTAINS - - ! read subroutines - !----------------------------------------------------------------------------- - !> - !! @brief Returns a sample of the cloud state - !! - !! @remarks - ! - - SUBROUTINE sample_cld_state(kproma, kbdim, klev, ksamps, rnseeds, i_overlap, cld_frac, cldy) - INTEGER, intent(in) :: kbdim - INTEGER, intent(in) :: klev - INTEGER, intent(in) :: ksamps - INTEGER, intent(in) :: kproma !< numbers of columns, levels, samples - INTEGER, intent(inout) :: rnseeds(:, :) !< Seeds for random number generator (kbdim, :) - INTEGER, intent(in) :: i_overlap !< 1=max-ran, 2=maximum, 3=random - REAL(KIND=wp), intent(in) :: cld_frac(kbdim,klev) !< cloud fraction - LOGICAL, intent(out) :: cldy(kbdim,klev,ksamps) !< Logical: cloud present? - REAL(KIND=wp) :: rank(kbdim,klev,ksamps) - INTEGER :: js - INTEGER :: jk - ! Here cldy(:,:,1) indicates whether any cloud is present - ! - cldy(1:kproma,1:klev,1) = cld_frac(1:kproma,1:klev) > 0._wp - SELECT CASE ( i_overlap ) - CASE ( 1 ) - ! Maximum-random overlap - DO js = 1, ksamps - DO jk = 1, klev - ! mask means we compute random numbers only when cloud is present - CALL get_random(kproma, kbdim, rnseeds, cldy(:,jk,1), rank(:,jk,js)) - END DO - END DO - ! There may be a better way to structure this calculation... - DO jk = klev-1, 1, -1 - DO js = 1, ksamps - rank(1:kproma,jk,js) = merge(rank(1:kproma,jk+1,js), & - rank(1:kproma,jk,js) * (1._wp - cld_frac(1:kproma,jk+1)), & - rank(1:kproma,jk+1,js) > 1._wp - cld_frac(1:kproma,jk+1)) - ! Max overlap... - ! ... or random overlap in the clear sky portion, - ! depending on whether or not you have cloud in the layer above - END DO - END DO - CASE ( 2 ) - ! - ! Max overlap means every cell in a column is identical - ! - DO js = 1, ksamps - CALL get_random(kproma, kbdim, rnseeds, rank(:, 1, js)) - rank(1:kproma,2:klev,js) = spread(rank(1:kproma,1,js), dim=2, ncopies=(klev-1)) - END DO - CASE ( 3 ) - ! - ! Random overlap means every cell is independent - ! - DO js = 1, ksamps - DO jk = 1, klev - ! mask means we compute random numbers only when cloud is present - CALL get_random(kproma, kbdim, rnseeds, cldy(:,jk,1), rank(:,jk,js)) - END DO - END DO - CASE DEFAULT - CALL finish('In sample_cld_state: unknown overlap assumption') - END SELECT - ! Now cldy indicates whether the sample (ks) is cloudy or not. - DO js = 1, ksamps - cldy(1:kproma,1:klev,js) = rank(1:kproma,1:klev,js) > (1. - cld_frac(1:kproma,1:klev)) - END DO - END SUBROUTINE sample_cld_state - END MODULE mo_cld_sampling diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_exception_stub.f90 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_exception_stub.f90 deleted file mode 100644 index 51a60be233..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_exception_stub.f90 +++ /dev/null @@ -1,45 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_exception_stub.f90 -! Generated at: 2015-02-19 15:30:31 -! KGEN version: 0.4.4 - - - - MODULE mo_exception - IMPLICIT NONE - PRIVATE - PUBLIC finish - ! normal message - ! informational message - ! warning message: number of warnings counted - ! error message: number of errors counted - ! report parameter value - ! debugging message - !++mgs - CONTAINS - - ! read subroutines - - SUBROUTINE finish(name, text, exit_no) - CHARACTER(LEN=*), intent(in) :: name - CHARACTER(LEN=*), intent(in), optional :: text - INTEGER, intent(in), optional :: exit_no - INTEGER :: ifile - IF (present(exit_no)) THEN - ifile = exit_no - ELSE - ifile = 6 - END IF - WRITE (ifile, '(/,80("*"),/)') - IF (present(text)) THEN - WRITE (ifile, '(1x,a,a,a)') trim(name), ': ', trim(text) - ELSE - WRITE (ifile, '(1x,a,a)') trim(name), ': ' - END IF - WRITE (ifile, '(/,80("-"),/,/)') - STOP - END SUBROUTINE finish - - END MODULE mo_exception diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_kind.f90 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_kind.f90 deleted file mode 100644 index f10effef4c..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_kind.f90 +++ /dev/null @@ -1,43 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_kind.f90 -! Generated at: 2015-02-19 15:30:37 -! KGEN version: 0.4.4 - - - - MODULE mo_kind - ! L. Kornblueh, MPI, August 2001, added working precision and comments - IMPLICIT NONE - ! Number model from which the SELECTED_*_KIND are requested: - ! - ! 4 byte REAL 8 byte REAL - ! CRAY: - precision = 13 - ! exponent = 2465 - ! IEEE: precision = 6 precision = 15 - ! exponent = 37 exponent = 307 - ! - ! Most likely this are the only possible models. - ! Floating point section: - INTEGER, parameter :: pd = 12 - INTEGER, parameter :: rd = 307 - INTEGER, parameter :: pi8 = 14 - INTEGER, parameter :: dp = selected_real_kind(pd,rd) - ! Floating point working precision - INTEGER, parameter :: wp = dp - ! Integer section - INTEGER, parameter :: i8 = selected_int_kind(pi8) - ! Working precision for index variables - ! - ! predefined preprocessor macros: - ! - ! xlf __64BIT__ checked with P6 and AIX - ! gfortran __LP64__ checked with Darwin and Linux - ! Intel, PGI __x86_64__ checked with Linux - ! Sun __x86_64 checked with Linux - CONTAINS - - ! read subroutines - - END MODULE mo_kind diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_lrtm_driver.f90 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_lrtm_driver.f90 deleted file mode 100644 index 495c67b5da..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_lrtm_driver.f90 +++ /dev/null @@ -1,490 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_lrtm_driver.f90 -! Generated at: 2015-02-19 15:30:29 -! KGEN version: 0.4.4 - - - - MODULE mo_lrtm_driver - USE mo_kind, ONLY: wp - USE mo_physical_constants, ONLY: amw - USE mo_physical_constants, ONLY: amd - USE mo_physical_constants, ONLY: grav - USE mo_rrtm_params, ONLY: nbndlw - USE mo_rrtm_params, ONLY: ngptlw - USE mo_radiation_parameters, ONLY: do_gpoint - USE mo_radiation_parameters, ONLY: i_overlap - USE mo_radiation_parameters, ONLY: l_do_sep_clear_sky - USE mo_radiation_parameters, ONLY: rad_undef - USE mo_lrtm_setup, ONLY: ngb - USE mo_lrtm_setup, ONLY: ngs - USE mo_lrtm_setup, ONLY: delwave - USE mo_lrtm_setup, ONLY: nspa - USE mo_lrtm_setup, ONLY: nspb - USE rrlw_planck, ONLY: totplanck - USE mo_rrtm_coeffs, ONLY: lrtm_coeffs - USE mo_lrtm_gas_optics, ONLY: gas_optics_lw - USE mo_lrtm_solver, ONLY: find_secdiff - USE mo_lrtm_solver, ONLY: lrtm_solver - USE mo_cld_sampling, ONLY: sample_cld_state - USE mo_spec_sampling, ONLY: spec_sampling_strategy - USE mo_spec_sampling, ONLY: get_gpoint_set - USE mo_taumol03, ONLY: taumol03_lwr,taumol03_upr - USE mo_taumol04, ONLY: taumol04_lwr,taumol04_upr - USE rrlw_planck, ONLY: chi_mls - USE rrlw_kg03, ONLY: selfref - USE rrlw_kg03, ONLY: forref - USE rrlw_kg03, ONLY: ka_mn2o - USE rrlw_kg03, ONLY: absa - USE rrlw_kg03, ONLY: fracrefa - USE rrlw_kg03, ONLY: kb_mn2o - USE rrlw_kg03, ONLY: absb - USE rrlw_kg03, ONLY: fracrefb - IMPLICIT NONE - PRIVATE - PUBLIC lrtm - CONTAINS - - ! read subroutines - !----------------------------------------------------------------------------- - !> - !! @brief Prepares information for radiation call - !! - !! @remarks: This program is the driver subroutine for the longwave radiative - !! transfer routine. This routine is adapted from the AER LW RRTMG_LW model - !! that itself has been adapted from RRTM_LW for improved efficiency. Our - !! routine does the spectral integration externally (the solver is explicitly - !! called for each g-point, so as to facilitate sampling of g-points - !! This routine: - !! 1) calls INATM to read in the atmospheric profile from GCM; - !! all layering in RRTMG is ordered from surface to toa. - !! 2) calls COEFFS to calculate various quantities needed for - !! the radiative transfer algorithm. This routine is called only once for - !! any given thermodynamic state, i.e., it does not change if clouds chanege - !! 3) calls TAUMOL to calculate gaseous optical depths for each - !! of the 16 spectral bands, this is updated band by band. - !! 4) calls SOLVER (for both clear and cloudy profiles) to perform the - !! radiative transfer calculation with a maximum-random cloud - !! overlap method, or calls RTRN to use random cloud overlap. - !! 5) passes the necessary fluxes and cooling rates back to GCM - !! - ! - - SUBROUTINE lrtm(kproma, kbdim, klev, play, psfc, tlay, tlev, tsfc, wkl, wx, coldry, emis, cldfr, taucld, tauaer, rnseeds, & - strategy, n_gpts_ts, uflx, dflx, uflxc, dflxc) - INTEGER, intent(in) :: klev - INTEGER, intent(in) :: kbdim - INTEGER, intent(in) :: kproma - !< Maximum block length - !< Number of horizontal columns - !< Number of model layers - REAL(KIND=wp), intent(in) :: wx(:,:,:) - REAL(KIND=wp), intent(in) :: cldfr(kbdim,klev) - REAL(KIND=wp), intent(in) :: taucld(kbdim,klev,nbndlw) - REAL(KIND=wp), intent(in) :: wkl(:,:,:) - REAL(KIND=wp), intent(in) :: coldry(kbdim,klev) - REAL(KIND=wp), intent(in) :: play(kbdim,klev) - REAL(KIND=wp), intent(in) :: tlay(kbdim,klev) - REAL(KIND=wp), intent(in) :: tauaer(kbdim,klev,nbndlw) - REAL(KIND=wp), intent(in) :: tlev(kbdim,klev+1) - REAL(KIND=wp), intent(in) :: tsfc(kbdim) - REAL(KIND=wp), intent(in) :: psfc(kbdim) - REAL(KIND=wp), intent(in) :: emis(kbdim,nbndlw) - !< Layer pressures [hPa, mb] (kbdim,klev) - !< Surface pressure [hPa, mb] (kbdim) - !< Layer temperatures [K] (kbdim,klev) - !< Interface temperatures [K] (kbdim,klev+1) - !< Surface temperature [K] (kbdim) - !< Gas volume mixing ratios - !< CFC type gas volume mixing ratios - !< Column dry amount - !< Surface emissivity (kbdim,nbndlw) - !< Cloud fraction (kbdim,klev) - !< Coud optical depth (kbdim,klev,nbndlw) - !< Aerosol optical depth (kbdim,klev,nbndlw) - ! Variables for sampling cloud state and spectral points - INTEGER, intent(inout) :: rnseeds(:, :) !< Seeds for random number generator (kbdim,:) - TYPE(spec_sampling_strategy), intent(in) :: strategy - INTEGER, intent(in ) :: n_gpts_ts - REAL(KIND=wp), intent(out) :: uflx (kbdim,0:klev) - REAL(KIND=wp), intent(out) :: dflx (kbdim,0:klev) - REAL(KIND=wp), intent(out) :: uflxc(kbdim,0:klev) - REAL(KIND=wp), intent(out) :: dflxc(kbdim,0:klev) - !< Tot sky longwave upward flux [W/m2], (kbdim,0:klev) - !< Tot sky longwave downward flux [W/m2], (kbdim,0:klev) - !< Clr sky longwave upward flux [W/m2], (kbdim,0:klev) - !< Clr sky longwave downward flux [W/m2], (kbdim,0:klev) - REAL(KIND=wp) :: taug(klev) !< Properties for one column at a time >! gas optical depth - REAL(KIND=wp) :: rrpk_taug03(kbdim,klev) - REAL(KIND=wp) :: rrpk_taug04(kbdim,klev) - REAL(KIND=wp) :: fracs(kbdim,klev,n_gpts_ts) - REAL(KIND=wp) :: taut (kbdim,klev,n_gpts_ts) - REAL(KIND=wp) :: tautot(kbdim,klev,n_gpts_ts) - REAL(KIND=wp) :: pwvcm(kbdim) - REAL(KIND=wp) :: secdiff(kbdim) - !< Planck fraction per g-point - !< precipitable water vapor [cm] - !< diffusivity angle for RT calculation - !< gaseous + aerosol optical depths for all columns - !< cloud + gaseous + aerosol optical depths for all columns - REAL(KIND=wp) :: planklay(kbdim, klev,nbndlw) - REAL(KIND=wp) :: planklev(kbdim,0:klev,nbndlw) - REAL(KIND=wp) :: plankbnd(kbdim, nbndlw) ! Properties for all bands - ! Planck function at mid-layer - ! Planck function at level interfaces - ! Planck function at surface - REAL(KIND=wp) :: layplnk(kbdim, klev) - REAL(KIND=wp) :: levplnk(kbdim,0:klev) - REAL(KIND=wp) :: bndplnk(kbdim) - REAL(KIND=wp) :: srfemis(kbdim) ! Properties for a single set of columns/g-points - ! Planck function at mid-layer - ! Planck function at level interfaces - ! Planck function at surface - ! Surface emission - REAL(KIND=wp) :: zgpfd(kbdim,0:klev) - REAL(KIND=wp) :: zgpfu(kbdim,0:klev) - REAL(KIND=wp) :: zgpcu(kbdim,0:klev) - REAL(KIND=wp) :: zgpcd(kbdim,0:klev) - ! < gpoint clearsky downward flux - ! < gpoint clearsky downward flux - ! < gpoint fullsky downward flux - ! < gpoint fullsky downward flux - ! ----------------- - ! Variables for gas optics calculations - INTEGER :: jt1 (kbdim,klev) - INTEGER :: indfor (kbdim,klev) - INTEGER :: indself (kbdim,klev) - INTEGER :: indminor(kbdim,klev) - INTEGER :: laytrop (kbdim ) - INTEGER :: jp (kbdim,klev) - INTEGER :: rrpk_jp (klev,kbdim) - INTEGER :: jt (kbdim,klev) - INTEGER :: rrpk_jt (kbdim,0:1,klev) - !< tropopause layer index - !< lookup table index - !< lookup table index - !< lookup table index - REAL(KIND=wp) :: wbrodl (kbdim,klev) - REAL(KIND=wp) :: selffac (kbdim,klev) - REAL(KIND=wp) :: colh2o (kbdim,klev) - REAL(KIND=wp) :: colo3 (kbdim,klev) - REAL(KIND=wp) :: coln2o (kbdim,klev) - REAL(KIND=wp) :: colco (kbdim,klev) - REAL(KIND=wp) :: selffrac (kbdim,klev) - REAL(KIND=wp) :: colch4 (kbdim,klev) - REAL(KIND=wp) :: colo2 (kbdim,klev) - REAL(KIND=wp) :: colbrd (kbdim,klev) - REAL(KIND=wp) :: minorfrac (kbdim,klev) - REAL(KIND=wp) :: scaleminorn2(kbdim,klev) - REAL(KIND=wp) :: scaleminor (kbdim,klev) - REAL(KIND=wp) :: forfac (kbdim,klev) - REAL(KIND=wp) :: colco2 (kbdim,klev) - REAL(KIND=wp) :: forfrac (kbdim,klev) - !< column amount (h2o) - !< column amount (co2) - !< column amount (o3) - !< column amount (n2o) - !< column amount (co) - !< column amount (ch4) - !< column amount (o2) - !< column amount (broadening gases) - REAL(KIND=wp) :: wx_loc(size(wx, 2), size(wx, 3)) - !< Normalized CFC amounts (molecules/cm^2) - REAL(KIND=wp) :: fac00(kbdim,klev) - REAL(KIND=wp) :: fac01(kbdim,klev) - REAL(KIND=wp) :: fac10(kbdim,klev) - REAL(KIND=wp) :: fac11(kbdim,klev) - REAL(KIND=wp) :: rrpk_fac0(kbdim,0:1,klev) - REAL(KIND=wp) :: rrpk_fac1(kbdim,0:1,klev) - REAL(KIND=wp) :: rat_n2oco2 (kbdim,klev) - REAL(KIND=wp) :: rat_o3co2 (kbdim,klev) - REAL(KIND=wp) :: rat_h2on2o (kbdim,klev) - REAL(KIND=wp) :: rat_n2oco2_1(kbdim,klev) - REAL(KIND=wp) :: rat_h2on2o_1(kbdim,klev) - REAL(KIND=wp) :: rat_h2oco2_1(kbdim,klev) - REAL(KIND=wp) :: rat_h2oo3 (kbdim,klev) - REAL(KIND=wp) :: rat_h2och4 (kbdim,klev) - REAL(KIND=wp) :: rat_h2oco2 (kbdim,klev) - REAL(KIND=wp) :: rrpk_rat_h2oco2 (kbdim,0:1,klev) - REAL(KIND=wp) :: rrpk_rat_o3co2 (kbdim,0:1,klev) - REAL(KIND=wp) :: rat_h2oo3_1 (kbdim,klev) - REAL(KIND=wp) :: rat_o3co2_1 (kbdim,klev) - REAL(KIND=wp) :: rat_h2och4_1(kbdim,klev) - ! ----------------- - INTEGER :: jl - INTEGER :: ig - INTEGER :: jk ! loop indicies - INTEGER :: igs(kbdim, n_gpts_ts) - INTEGER :: ibs(kbdim, n_gpts_ts) - INTEGER :: ib - INTEGER :: igpt - ! minimum val for clouds - ! Variables for sampling strategy - REAL(KIND=wp) :: gpt_scaling - REAL(KIND=wp) :: clrsky_scaling(1:kbdim) - REAL(KIND=wp) :: smp_tau(kbdim, klev, n_gpts_ts) - LOGICAL :: cldmask(kbdim, klev, n_gpts_ts) - LOGICAL :: colcldmask(kbdim, n_gpts_ts) !< cloud mask in each cell - !< cloud mask for each column - ! - ! -------------------------------- - ! - ! 1.0 Choose a set of g-points to do consistent with the spectral sampling strategy - ! - ! -------------------------------- - gpt_scaling = real(ngptlw,kind=wp)/real(n_gpts_ts,kind=wp) - ! Standalone logic - IF (do_gpoint == 0) THEN - igs(1:kproma,1:n_gpts_ts) = get_gpoint_set(kproma, kbdim, strategy, rnseeds) - ELSE IF (n_gpts_ts == 1) THEN ! Standalone logic - IF (do_gpoint > ngptlw) RETURN - igs(:, 1:n_gpts_ts) = do_gpoint - ELSE - PRINT *, "Asking for gpoint fluxes for too many gpoints!" - STOP - END IF - ! Save the band nunber associated with each gpoint - DO jl = 1, kproma - DO ig = 1, n_gpts_ts - ibs(jl, ig) = ngb(igs(jl, ig)) - END DO - END DO - ! - ! --- 2.0 Optical properties - ! - ! --- 2.1 Cloud optical properties. - ! -------------------------------- - ! Cloud optical depth is only saved for the band associated with this g-point - ! We sample clouds first because we may want to adjust water vapor based - ! on presence/absence of clouds - ! - CALL sample_cld_state(kproma, kbdim, klev, n_gpts_ts, rnseeds(:,:), i_overlap, cldfr(:,:), cldmask(:,:,:)) - !IBM* ASSERT(NODEPS) - DO ig = 1, n_gpts_ts - DO jl = 1, kproma - smp_tau(jl,:,ig) = merge(taucld(jl,1:klev,ibs(jl,ig)), 0._wp, cldmask(jl,:,ig)) - END DO - END DO ! Loop over samples - done with cloud optical depth calculations - ! - ! Cloud masks for sorting out clear skies - by cell and by column - ! - IF (.not. l_do_sep_clear_sky) THEN - ! - ! Are any layers cloudy? - ! - colcldmask(1:kproma, 1:n_gpts_ts) = any(cldmask(1:kproma,1:klev,1:n_gpts_ts), dim=2) - ! - ! Clear-sky scaling is gpt_scaling/frac_clr or 0 if all samples are cloudy - ! - clrsky_scaling(1:kproma) = gpt_scaling * & - merge(real(n_gpts_ts,kind=wp) / (real(n_gpts_ts - count(& - colcldmask(1:kproma,:),dim=2),kind=wp)), & - 0._wp, any(.not. colcldmask(1:kproma,:),dim=2)) - END IF - ! - ! --- 2.2. Gas optical depth calculations - ! - ! -------------------------------- - ! - ! 2.2.1 Calculate information needed by the radiative transfer routine - ! that is specific to this atmosphere, especially some of the - ! coefficients and indices needed to compute the optical depths - ! by interpolating data from stored reference atmospheres. - ! The coefficients are functions of temperature and pressure and remain the same - ! for all g-point samples. - ! If gas concentrations, temperatures, or pressures vary with sample (ig) - ! the coefficients need to be calculated inside the loop over samples - ! -------------------------------- - ! - ! Broadening gases -- the number of molecules per cm^2 of all gases not specified explicitly - ! (water is excluded) - wbrodl(1:kproma,1:klev) = coldry(1:kproma,1:klev) - sum(wkl(1:kproma,2:,1:klev), dim=2) - CALL lrtm_coeffs(kproma, kbdim, klev, play, tlay, coldry, wkl, wbrodl, laytrop, jp, jt, jt1, colh2o, colco2, colo3, & - coln2o, colco, colch4, colo2, colbrd, fac00, fac01, fac10, fac11, rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, & - rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, selffac, & - selffrac, indself, forfac, forfrac, indfor, minorfrac, scaleminor, scaleminorn2, indminor) - ! - ! 2.2.2 Loop over g-points calculating gas optical properties. - ! - ! -------------------------------- - !IBM* ASSERT(NODEPS) - rrpk_rat_h2oco2(:,0,:) = rat_h2oco2 - rrpk_rat_h2oco2(:,1,:) = (rat_h2oco2_1) - rrpk_rat_o3co2(:,0,:) = rat_o3co2 - rrpk_rat_o3co2(:,1,:) = (rat_o3co2_1) - rrpk_fac0(:,0,:) = fac00 - rrpk_fac0(:,1,:) = fac01 - rrpk_fac1(:,0,:) = fac10 - rrpk_fac1(:,1,:) = fac11 - rrpk_jt(:,0,:) = jt - rrpk_jt(:,1,:) = jt1 - DO ig = 1, n_gpts_ts - igpt=igs(1,ig) - IF(ngb(igpt) == 3) Then - jl=kproma - call taumol03_lwr(jl,laytrop(1), klev, & - rrpk_rat_h2oco2(1:jl,:,:), colco2(1:jl,:), colh2o(1:jl,:), coln2o(1:jl,:), coldry(1:jl,:), & - rrpk_fac0(1:jl,:,:), rrpk_fac1(1:jl,:,:), minorfrac(1:jl,:), & - selffac(1:jl,:),selffrac(1:jl,:),forfac(1:jl,:),forfrac(1:jl,:), & - jp(1:jl,:), rrpk_jt(1:jl,:,:), (igpt-ngs(ngb(igpt)-1)), indself(1:jl,:), & - indfor(1:jl,:), indminor(1:jl,:), & - rrpk_taug03(1:jl,:),fracs(1:jl,:,ig)) - call taumol03_upr(jl,laytrop(1), klev, & - rrpk_rat_h2oco2(1:jl,:,:), colco2(1:jl,:), colh2o(1:jl,:), coln2o(1:jl,:), coldry(1:jl,:), & - rrpk_fac0(1:jl,:,:), rrpk_fac1(1:jl,:,:), minorfrac(1:jl,:), & - forfac(1:jl,:),forfrac(1:jl,:), & - jp(1:jl,:), rrpk_jt(1:jl,:,:), (igpt-ngs(ngb(igpt)-1)), & - indfor(1:jl,:), indminor(1:jl,:), & - rrpk_taug03(1:jl,:),fracs(1:jl,:,ig)) - ENDIF - IF(ngb(igpt) == 4) Then - jl=kproma - call taumol04_lwr(jl,laytrop(1), klev, & - rrpk_rat_h2oco2(1:jl,:,:), colco2(1:jl,:), colh2o(1:jl,:), coldry(1:jl,:), & - rrpk_fac0(1:jl,:,:), rrpk_fac1(1:jl,:,:), minorfrac(1:jl,:), & - selffac(1:jl,:),selffrac(1:jl,:),forfac(1:jl,:),forfrac(1:jl,:), & - jp(1:jl,:), rrpk_jt(1:jl,:,:), (igpt-ngs(ngb(igpt)-1)), indself(1:jl,:), & - indfor(1:jl,:), & - rrpk_taug04(1:jl,:),fracs(1:jl,:,ig)) - call taumol04_upr(jl,laytrop(1), klev, & - rrpk_rat_o3co2(1:jl,:,:), colco2(1:jl,:), colo3(1:jl,:), coldry(1:jl,:), & - rrpk_fac0(1:jl,:,:), rrpk_fac1(1:jl,:,:), minorfrac(1:jl,:), & - forfac(1:jl,:),forfrac(1:jl,:), & - jp(1:jl,:), rrpk_jt(1:jl,:,:), (igpt-ngs(ngb(igpt)-1)), & - indfor(1:jl,:), & - rrpk_taug04(1:jl,:),fracs(1:jl,:,ig)) - ENDIF - DO jl = 1, kproma - ib = ibs(jl, ig) - igpt = igs(jl, ig) - ! - ! Gas concentrations in colxx variables are normalized by 1.e-20_wp in lrtm_coeffs - ! CFC gas concentrations (wx) need the same normalization - ! Per Eli Mlawer the k values used in gas optics tables have been multiplied by 1e20 - wx_loc(:,:) = 1.e-20_wp * wx(jl,:,:) - IF (ngb(igpt) == 3) THEN - taug = rrpk_taug03(jl,:) - ELSEIF (ngb(igpt) == 4) THEN - taug = rrpk_taug04(jl,:) - ELSE - CALL gas_optics_lw(klev, igpt, play (jl,:), wx_loc (:,:), coldry (jl,:), laytrop (jl), jp & - (jl,:), jt (jl,:), jt1 (jl,:), colh2o (jl,:), colco2 (jl,:), colo3 (jl,:)& - , coln2o (jl,:), colco (jl,:), colch4 (jl,:), colo2 (jl,:), colbrd (jl,:), fac00 & - (jl,:), fac01 (jl,:), fac10 (jl,:), fac11 (jl,:), rat_h2oco2 (jl,:), rat_h2oco2_1(jl,:), & - rat_h2oo3 (jl,:), rat_h2oo3_1 (jl,:), rat_h2on2o (jl,:), rat_h2on2o_1(jl,:), rat_h2och4(jl,:), rat_h2och4_1(& - jl,:), rat_n2oco2 (jl,:), rat_n2oco2_1(jl,:), rat_o3co2 (jl,:), rat_o3co2_1 (jl,:), selffac (jl,:), & - selffrac (jl,:), indself (jl,:), forfac (jl,:), forfrac (jl,:), indfor (jl,:), minorfrac (& - jl,:), scaleminor (jl,:), scaleminorn2(jl,:), indminor (jl,:), fracs (jl,:,ig), taug) - END IF - DO jk = 1, klev - taut(jl,jk,ig) = taug(jk) + tauaer(jl,jk,ib) - END DO - END DO ! Loop over columns - END DO ! Loop over g point samples - done with gas optical depth calculations - tautot(1:kproma,:,:) = taut(1:kproma,:,:) + smp_tau(1:kproma,:,:) ! All-sky optical depth. Mask for 0 cloud optical depth? - ! - ! --- 3.0 Compute radiative transfer. - ! -------------------------------- - ! - ! Initialize fluxes to zero - ! - uflx(1:kproma,0:klev) = 0.0_wp - dflx(1:kproma,0:klev) = 0.0_wp - uflxc(1:kproma,0:klev) = 0.0_wp - dflxc(1:kproma,0:klev) = 0.0_wp - ! - ! Planck function in each band at layers and boundaries - ! - !IBM* ASSERT(NODEPS) - DO ig = 1, nbndlw - planklay(1:kproma,1:klev,ig) = planckfunction(tlay(1:kproma,1:klev ),ig) - planklev(1:kproma,0:klev,ig) = planckfunction(tlev(1:kproma,1:klev+1),ig) - plankbnd(1:kproma, ig) = planckfunction(tsfc(1:kproma ),ig) - END DO - ! - ! Precipitable water vapor in each column - this can affect the integration angle secdiff - ! - pwvcm(1:kproma) = ((amw * sum(wkl(1:kproma,1,1:klev), dim=2)) / (amd * sum(coldry(1:kproma,& - 1:klev) + wkl(1:kproma,1,1:klev), dim=2))) * (1.e3_wp * psfc(1:kproma)) / (1.e2_wp * grav) - ! - ! Compute radiative transfer for each set of samples - ! - DO ig = 1, n_gpts_ts - secdiff(1:kproma) = find_secdiff(ibs(1:kproma, ig), pwvcm(1:kproma)) - !IBM* ASSERT(NODEPS) - DO jl = 1, kproma - ib = ibs(jl,ig) - layplnk(jl,1:klev) = planklay(jl,1:klev,ib) - levplnk(jl,0:klev) = planklev(jl,0:klev,ib) - bndplnk(jl) = plankbnd(jl, ib) - srfemis(jl) = emis (jl, ib) - END DO - ! - ! All sky fluxes - ! - CALL lrtm_solver(kproma, kbdim, klev, tautot(:,:,ig), layplnk, levplnk, fracs(:,:,ig), secdiff, bndplnk, srfemis, & - zgpfu, zgpfd) - uflx(1:kproma,0:klev) = uflx (1:kproma,0:klev) + zgpfu(1:kproma,0:klev) * gpt_scaling - dflx(1:kproma,0:klev) = dflx (1:kproma,0:klev) + zgpfd(1:kproma,0:klev) * gpt_scaling - ! - ! Clear-sky fluxes - ! - IF (l_do_sep_clear_sky) THEN - ! - ! Remove clouds and do second RT calculation - ! - CALL lrtm_solver(kproma, kbdim, klev, taut (:,:,ig), layplnk, levplnk, fracs(:,:,ig), secdiff, bndplnk, & - srfemis, zgpcu, zgpcd) - uflxc(1:kproma,0:klev) = uflxc(1:kproma,0:klev) + zgpcu(1:kproma,0:klev) * gpt_scaling - dflxc(1:kproma,0:klev) = dflxc(1:kproma,0:klev) + zgpcd(1:kproma,0:klev) * gpt_scaling - ELSE - ! - ! Accumulate fluxes by excluding cloudy subcolumns, weighting to account for smaller sample size - ! - !IBM* ASSERT(NODEPS) - DO jk = 0, klev - uflxc(1:kproma,jk) = uflxc(1:kproma,jk) & - + merge(0._wp, & - zgpfu(1:kproma,jk) * clrsky_scaling(1:kproma), & - colcldmask(1:kproma,ig)) - dflxc(1:kproma,jk) = dflxc(1:kproma,jk) & - + merge(0._wp, & - zgpfd(1:kproma,jk) * clrsky_scaling(1:kproma), & - colcldmask(1:kproma,ig)) - END DO - END IF - END DO ! Loop over samples - ! - ! --- 3.1 If computing clear-sky fluxes from samples, flag any columns where all samples were cloudy - ! - ! -------------------------------- - IF (.not. l_do_sep_clear_sky) THEN - !IBM* ASSERT(NODEPS) - DO jl = 1, kproma - IF (all(colcldmask(jl,:))) THEN - uflxc(jl,0:klev) = rad_undef - dflxc(jl,0:klev) = rad_undef - END IF - END DO - END IF - END SUBROUTINE lrtm - !---------------------------------------------------------------------------- - - elemental FUNCTION planckfunction(temp, band) - ! - ! Compute the blackbody emission in a given band as a function of temperature - ! - REAL(KIND=wp), intent(in) :: temp - INTEGER, intent(in) :: band - REAL(KIND=wp) :: planckfunction - INTEGER :: index - REAL(KIND=wp) :: fraction - index = min(max(1, int(temp - 159._wp)),180) - fraction = temp - 159._wp - float(index) - planckfunction = totplanck(index, band) + fraction * (totplanck(index+1, band) - totplanck(index, & - band)) - planckfunction = planckfunction * delwave(band) - END FUNCTION planckfunction - END MODULE mo_lrtm_driver diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_lrtm_gas_optics.f90 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_lrtm_gas_optics.f90 deleted file mode 100644 index 8c45cdbbf5..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_lrtm_gas_optics.f90 +++ /dev/null @@ -1,2998 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_lrtm_gas_optics.f90 -! Generated at: 2015-02-19 15:30:40 -! KGEN version: 0.4.4 - - - - MODULE mo_lrtm_gas_optics - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! ------- Modules ------- - USE mo_kind, ONLY: wp - USE mo_exception, ONLY: finish - USE mo_lrtm_setup, ONLY: ngb - USE mo_lrtm_setup, ONLY: ngs - USE mo_lrtm_setup, ONLY: nspa - USE mo_lrtm_setup, ONLY: nspb - USE mo_lrtm_setup, ONLY: ngc - USE rrlw_planck, ONLY: chi_mls - IMPLICIT NONE - REAL(KIND=wp), parameter :: oneminus = 1.0_wp - 1.0e-06_wp - CONTAINS - - ! read subroutines - !---------------------------------------------------------------------------- - - SUBROUTINE gas_optics_lw(nlayers, igg, pavel, wx, coldry, laytrop, jp, jt, jt1, colh2o, colco2, colo3, coln2o, colco, & - colch4, colo2, colbrd, fac00, fac01, fac10, fac11, rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, rat_h2on2o, & - rat_h2on2o_1, rat_h2och4, rat_h2och4_1, rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, selffac, selffrac, indself, & - forfac, forfrac, indfor, minorfrac, scaleminor, scaleminorn2, indminor, fracs, taug) - !---------------------------------------------------------------------------- - ! ******************************************************************************* - ! * * - ! * Optical depths developed for the * - ! * * - ! * RAPID RADIATIVE TRANSFER MODEL (RRTM) * - ! * * - ! * * - ! * ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC. * - ! * 131 HARTWELL AVENUE * - ! * LEXINGTON, MA 02421 * - ! * * - ! * * - ! * ELI J. MLAWER * - ! * JENNIFER DELAMERE * - ! * STEVEN J. TAUBMAN * - ! * SHEPARD A. CLOUGH * - ! * * - ! * * - ! * * - ! * * - ! * email: mlawer@aer.com * - ! * email: jdelamer@aer.com * - ! * * - ! * The authors wish to acknowledge the contributions of the * - ! * following people: Karen Cady-Pereira, Patrick D. Brown, * - ! * Michael J. Iacono, Ronald E. Farren, Luke Chen, Robert Bergstrom. * - ! * * - ! ******************************************************************************* - ! * * - ! * Revision for g-point reduction: Michael J. Iacono, AER, Inc. * - ! * * - ! ******************************************************************************* - ! * TAUMOL * - ! * * - ! * This file contains the subroutines TAUGBn (where n goes from * - ! * 1 to 16). TAUGBn calculates the optical depths and Planck fractions * - ! * per g-value and layer for band n. * - ! * * - ! * Output: optical depths (unitless) * - ! * fractions needed to compute Planck functions at every layer * - ! * and g-value * - ! * * - ! * COMMON /TAUGCOM/ TAUG(MXLAY,MG) * - ! * COMMON /PLANKG/ FRACS(MXLAY,MG) * - ! * * - ! * Input * - ! * * - ! * COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS) * - ! * COMMON /PRECISE/ ONEMINUS * - ! * COMMON /PROFILE/ NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY), * - ! * & PZ(0:MXLAY),TZ(0:MXLAY) * - ! * COMMON /PROFDATA/ LAYTROP, * - ! * & COLH2O(MXLAY),COLCO2(MXLAY),COLO3(MXLAY), * - ! * & COLN2O(MXLAY),COLCO(MXLAY),COLCH4(MXLAY), * - ! * & COLO2(MXLAY) - ! * COMMON /INTFAC/ FAC00(MXLAY),FAC01(MXLAY), * - ! * & FAC10(MXLAY),FAC11(MXLAY) * - ! * COMMON /INTIND/ JP(MXLAY),JT(MXLAY),JT1(MXLAY) * - ! * COMMON /SELF/ SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(MXLAY) * - ! * * - ! * Description: * - ! * NG(IBAND) - number of g-values in band IBAND * - ! * NSPA(IBAND) - for the lower atmosphere, the number of reference * - ! * atmospheres that are stored for band IBAND per * - ! * pressure level and temperature. Each of these * - ! * atmospheres has different relative amounts of the * - ! * key species for the band (i.e. different binary * - ! * species parameters). * - ! * NSPB(IBAND) - same for upper atmosphere * - ! * ONEMINUS - since problems are caused in some cases by interpolation * - ! * parameters equal to or greater than 1, for these cases * - ! * these parameters are set to this value, slightly < 1. * - ! * PAVEL - layer pressures (mb) * - ! * TAVEL - layer temperatures (degrees K) * - ! * PZ - level pressures (mb) * - ! * TZ - level temperatures (degrees K) * - ! * LAYTROP - layer at which switch is made from one combination of * - ! * key species to another * - ! * COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water * - ! * vapor,carbon dioxide, ozone, nitrous ozide, methane, * - ! * respectively (molecules/cm**2) * - ! * FACij(LAY) - for layer LAY, these are factors that are needed to * - ! * compute the interpolation factors that multiply the * - ! * appropriate reference k-values. A value of 0 (1) for * - ! * i,j indicates that the corresponding factor multiplies * - ! * reference k-value for the lower (higher) of the two * - ! * appropriate temperatures, and altitudes, respectively. * - ! * JP - the index of the lower (in altitude) of the two appropriate * - ! * reference pressure levels needed for interpolation * - ! * JT, JT1 - the indices of the lower of the two appropriate reference * - ! * temperatures needed for interpolation (for pressure * - ! * levels JP and JP+1, respectively) * - ! * SELFFAC - scale factor needed for water vapor self-continuum, equals * - ! * (water vapor density)/(atmospheric density at 296K and * - ! * 1013 mb) * - ! * SELFFRAC - factor needed for temperature interpolation of reference * - ! * water vapor self-continuum data * - ! * INDSELF - index of the lower of the two appropriate reference * - ! * temperatures needed for the self-continuum interpolation * - ! * FORFAC - scale factor needed for water vapor foreign-continuum. * - ! * FORFRAC - factor needed for temperature interpolation of reference * - ! * water vapor foreign-continuum data * - ! * INDFOR - index of the lower of the two appropriate reference * - ! * temperatures needed for the foreign-continuum interpolation * - ! * * - ! * Data input * - ! * COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG),* - ! * FORREF(4,MG), KA_M'MGAS', KB_M'MGAS' * - ! * (note: n is the band number,'MGAS' is the species name of the minor * - ! * gas) * - ! * * - ! * Description: * - ! * KA - k-values for low reference atmospheres (key-species only) * - ! * (units: cm**2/molecule) * - ! * KB - k-values for high reference atmospheres (key-species only) * - ! * (units: cm**2/molecule) * - ! * KA_M'MGAS' - k-values for low reference atmosphere minor species * - ! * (units: cm**2/molecule) * - ! * KB_M'MGAS' - k-values for high reference atmosphere minor species * - ! * (units: cm**2/molecule) * - ! * SELFREF - k-values for water vapor self-continuum for reference * - ! * atmospheres (used below LAYTROP) * - ! * (units: cm**2/molecule) * - ! * FORREF - k-values for water vapor foreign-continuum for reference * - ! * atmospheres (used below/above LAYTROP) * - ! * (units: cm**2/molecule) * - ! * * - ! * DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG) * - ! * EQUIVALENCE (KA,ABSA),(KB,ABSB) * - ! * * - !******************************************************************************* - ! ------- Declarations ------- - ! ----- Input ----- - INTEGER, intent(in) :: igg ! g-point to process - INTEGER, intent(in) :: nlayers ! total number of layers - REAL(KIND=wp), intent(in) :: pavel(:) ! layer pressures (mb) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: wx(:,:) ! cross-section amounts (mol/cm2) - ! Dimensions: (maxxsec,nlayers) - REAL(KIND=wp), intent(in) :: coldry(:) ! column amount (dry air) - ! Dimensions: (nlayers) - INTEGER, intent(in) :: laytrop ! tropopause layer index - INTEGER, intent(in) :: jp(:) ! - ! Dimensions: (nlayers) - INTEGER, intent(in) :: jt(:) ! - ! Dimensions: (nlayers) - INTEGER, intent(in) :: jt1(:) ! - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: colh2o(:) ! column amount (h2o) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: colco2(:) ! column amount (co2) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: colo3(:) ! column amount (o3) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: coln2o(:) ! column amount (n2o) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: colco(:) ! column amount (co) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: colch4(:) ! column amount (ch4) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: colo2(:) ! column amount (o2) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: colbrd(:) ! column amount (broadening gases) - ! Dimensions: (nlayers) - INTEGER, intent(in) :: indself(:) - ! Dimensions: (nlayers) - INTEGER, intent(in) :: indfor(:) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: selffac(:) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: selffrac(:) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: forfac(:) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: forfrac(:) - ! Dimensions: (nlayers) - INTEGER, intent(in) :: indminor(:) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: minorfrac(:) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: scaleminor(:) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: scaleminorn2(:) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: fac11(:) - REAL(KIND=wp), intent(in) :: fac01(:) - REAL(KIND=wp), intent(in) :: fac00(:) - REAL(KIND=wp), intent(in) :: fac10(:) ! - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: rat_h2oco2(:) - REAL(KIND=wp), intent(in) :: rat_h2oco2_1(:) - REAL(KIND=wp), intent(in) :: rat_o3co2(:) - REAL(KIND=wp), intent(in) :: rat_o3co2_1(:) - REAL(KIND=wp), intent(in) :: rat_h2oo3(:) - REAL(KIND=wp), intent(in) :: rat_h2oo3_1(:) - REAL(KIND=wp), intent(in) :: rat_h2och4(:) - REAL(KIND=wp), intent(in) :: rat_h2och4_1(:) - REAL(KIND=wp), intent(in) :: rat_h2on2o(:) - REAL(KIND=wp), intent(in) :: rat_h2on2o_1(:) - REAL(KIND=wp), intent(in) :: rat_n2oco2(:) - REAL(KIND=wp), intent(in) :: rat_n2oco2_1(:) ! - ! Dimensions: (nlayers) - ! ----- Output ----- - REAL(KIND=wp), intent(out) :: fracs(:) ! planck fractions - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(out) :: taug(:) ! gaseous optical depth - ! Dimensions: (nlayers) - INTEGER :: ig - ! Calculate gaseous optical depth and planck fractions for each spectral band. - ! Local (within band) g-point - IF (ngb(igg) == 1) THEN - ig = igg - ELSE - ig = igg - ngs(ngb(igg) - 1) - END IF - SELECT CASE ( ngb(igg) ) - CASE ( 1 ) - CALL taumol01 - CASE ( 2 ) - CALL taumol02 - CASE ( 3 ) - CALL taumol03 - CASE ( 4 ) - CALL taumol04 - CASE ( 5 ) - CALL taumol05 - CASE ( 6 ) - CALL taumol06 - CASE ( 7 ) - CALL taumol07 - CASE ( 8 ) - CALL taumol08 - CASE ( 9 ) - CALL taumol09 - CASE ( 10 ) - CALL taumol10 - CASE ( 11 ) - CALL taumol11 - CASE ( 12 ) - CALL taumol12 - CASE ( 13 ) - CALL taumol13 - CASE ( 14 ) - CALL taumol14 - CASE ( 15 ) - CALL taumol15 - CASE ( 16 ) - CALL taumol16 - CASE DEFAULT - CALL finish('gas_optics_sw', 'Chosen band out of range') - END SELECT - CONTAINS - !---------------------------------------------------------------------------- - - SUBROUTINE taumol01() - !---------------------------------------------------------------------------- - ! ------- Modifications ------- - ! Written by Eli J. Mlawer, Atmospheric & Environmental Research. - ! Revised by Michael J. Iacono, Atmospheric & Environmental Research. - ! - ! band 1: 10-350 cm-1 (low key - h2o; low minor - n2) - ! (high key - h2o; high minor - n2) - ! - ! note: previous versions of rrtm band 1: - ! 10-250 cm-1 (low - h2o; high - h2o) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg01, ONLY: selfref - USE rrlw_kg01, ONLY: forref - USE rrlw_kg01, ONLY: ka_mn2 - USE rrlw_kg01, ONLY: absa - USE rrlw_kg01, ONLY: fracrefa - USE rrlw_kg01, ONLY: kb_mn2 - USE rrlw_kg01, ONLY: absb - USE rrlw_kg01, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - REAL(KIND=wp) :: pp - REAL(KIND=wp) :: corradj - REAL(KIND=wp) :: scalen2 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: taun2 - ! Minor gas mapping levels: - ! lower - n2, p = 142.5490 mbar, t = 215.70 k - ! upper - n2, p = 142.5490 mbar, t = 215.70 k - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature. Below laytrop, the water vapor self-continuum and - ! foreign continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(1) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(1) + 1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - pp = pavel(lay) - corradj = 1. - IF (pp .lt. 250._wp) THEN - corradj = 1._wp - 0.15_wp * (250._wp-pp) / 154.4_wp - END IF - scalen2 = colbrd(lay) * scaleminorn2(lay) - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - & - forref(indf,ig))) - taun2 = scalen2*(ka_mn2(indm,ig) + minorfrac(lay) * (ka_mn2(indm+1,ig) - ka_mn2(indm,& - ig))) - taug(lay) = corradj * (colh2o(lay) * (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) + tauself + taufor + taun2) - fracs(lay) = fracrefa(ig) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(1) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(1) + 1 - indf = indfor(lay) - indm = indminor(lay) - pp = pavel(lay) - corradj = 1._wp - 0.15_wp * (pp / 95.6_wp) - scalen2 = colbrd(lay) * scaleminorn2(lay) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - taun2 = scalen2*(kb_mn2(indm,ig) + minorfrac(lay) * (kb_mn2(indm+1,ig) - kb_mn2(indm,& - ig))) - taug(lay) = corradj * (colh2o(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) + taufor + taun2) - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol01 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol02() - !---------------------------------------------------------------------------- - ! - ! band 2: 350-500 cm-1 (low key - h2o; high key - h2o) - ! - ! note: previous version of rrtm band 2: - ! 250 - 500 cm-1 (low - h2o; high - h2o) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg02, ONLY: selfref - USE rrlw_kg02, ONLY: forref - USE rrlw_kg02, ONLY: absa - USE rrlw_kg02, ONLY: fracrefa - USE rrlw_kg02, ONLY: absb - USE rrlw_kg02, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - REAL(KIND=wp) :: pp - REAL(KIND=wp) :: corradj - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature. Below laytrop, the water vapor self-continuum and - ! foreign continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(2) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(2) + 1 - inds = indself(lay) - indf = indfor(lay) - pp = pavel(lay) - corradj = 1._wp - .05_wp * (pp - 100._wp) / 900._wp - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - taug(lay) = corradj * (colh2o(lay) * (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) + tauself + taufor) - fracs(lay) = fracrefa(ig) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(2) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(2) + 1 - indf = indfor(lay) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - taug(lay) = colh2o(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) + taufor - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol02 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol03() - !---------------------------------------------------------------------------- - ! - ! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o) - ! (high key - h2o,co2; high minor - n2o) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg03, ONLY: selfref - USE rrlw_kg03, ONLY: forref - USE rrlw_kg03, ONLY: ka_mn2o - USE rrlw_kg03, ONLY: absa - USE rrlw_kg03, ONLY: fracrefa - USE rrlw_kg03, ONLY: kb_mn2o - USE rrlw_kg03, ONLY: absb - USE rrlw_kg03, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: js - INTEGER :: js1 - INTEGER :: jmn2o - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_mn2o - REAL(KIND=wp) :: specparm_mn2o - REAL(KIND=wp) :: specmult_mn2o - REAL(KIND=wp) :: fmn2o - REAL(KIND=wp) :: fmn2omf - REAL(KIND=wp) :: chi_n2o - REAL(KIND=wp) :: ratn2o - REAL(KIND=wp) :: adjfac - REAL(KIND=wp) :: adjcoln2o - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: n2om1 - REAL(KIND=wp) :: n2om2 - REAL(KIND=wp) :: absn2o - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: refrat_planck_b - REAL(KIND=wp) :: refrat_m_a - REAL(KIND=wp) :: refrat_m_b - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - INTEGER :: rrpk_counter=0 - ! Minor gas mapping levels: - ! lower - n2o, p = 706.272 mbar, t = 278.94 k - ! upper - n2o, p = 95.58 mbar, t = 215.7 k - ! P = 212.725 mb - refrat_planck_a = chi_mls(1,9)/chi_mls(2,9) - ! P = 95.58 mb - refrat_planck_b = chi_mls(1,13)/chi_mls(2,13) - ! P = 706.270mb - refrat_m_a = chi_mls(1,3)/chi_mls(2,3) - ! P = 95.58 mb - refrat_m_b = chi_mls(1,13)/chi_mls(2,13) - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature, and appropriate species. Below laytrop, the water vapor - ! self-continuum and foreign continuum is interpolated (in temperature) - ! separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_mn2o = colh2o(lay) + refrat_m_a*colco2(lay) - specparm_mn2o = colh2o(lay)/speccomb_mn2o - IF (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus - specmult_mn2o = 8._wp*specparm_mn2o - jmn2o = 1 + int(specmult_mn2o) - fmn2o = mod(specmult_mn2o,1.0_wp) - fmn2omf = minorfrac(lay)*fmn2o - ! In atmospheres where the amount of N2O is too great to be considered - ! a minor species, adjust the column amount of N2O by an empirical factor - ! to obtain the proper contribution. - chi_n2o = coln2o(lay)/coldry(lay) - ratn2o = 1.e20_wp*chi_n2o/chi_mls(4,jp(lay)+1) - IF (ratn2o .gt. 1.5_wp) THEN - adjfac = 0.5_wp+(ratn2o-0.5_wp)**0.65_wp - adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_wp - ELSE - adjcoln2o = coln2o(lay) - END IF - speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(3) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(3) + js1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o * (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,& - indm,ig)) - n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o * (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(& - jmn2o,indm+1,ig)) - absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor + adjcoln2o*absn2o - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - rrpk_counter=rrpk_counter+1 - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 4._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 4._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - speccomb_mn2o = colh2o(lay) + refrat_m_b*colco2(lay) - specparm_mn2o = colh2o(lay)/speccomb_mn2o - IF (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus - specmult_mn2o = 4._wp*specparm_mn2o - jmn2o = 1 + int(specmult_mn2o) - fmn2o = mod(specmult_mn2o,1.0_wp) - fmn2omf = minorfrac(lay)*fmn2o - ! In atmospheres where the amount of N2O is too great to be considered - ! a minor species, adjust the column amount of N2O by an empirical factor - ! to obtain the proper contribution. - chi_n2o = coln2o(lay)/coldry(lay) - ratn2o = 1.e20*chi_n2o/chi_mls(4,jp(lay)+1) - IF (ratn2o .gt. 1.5_wp) THEN - adjfac = 0.5_wp+(ratn2o-0.5_wp)**0.65_wp - adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_wp - ELSE - adjcoln2o = coln2o(lay) - END IF - speccomb_planck = colh2o(lay)+refrat_planck_b*colco2(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 4._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(3) + js - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(3) + js1 - indf = indfor(lay) - indm = indminor(lay) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - n2om1 = kb_mn2o(jmn2o,indm,ig) + fmn2o * (kb_mn2o(jmn2o+1,indm,ig)-kb_mn2o(jmn2o,& - indm,ig)) - n2om2 = kb_mn2o(jmn2o,indm+1,ig) + fmn2o * (kb_mn2o(jmn2o+1,indm+1,ig)-kb_mn2o(jmn2o,& - indm+1,ig)) - absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1) - taug(lay) = speccomb * (fac000 * absb(ind0,ig) + fac100 * & - absb(ind0+1,ig) + fac010 * absb(ind0+5,ig) + fac110 * absb(& - ind0+6,ig)) + speccomb1 * (fac001 * absb(ind1,ig) + & - fac101 * absb(ind1+1,ig) + fac011 * absb(ind1+5,ig) + & - fac111 * absb(ind1+6,ig)) + taufor + adjcoln2o*absn2o - fracs(lay) = fracrefb(ig,jpl) + fpl * (fracrefb(ig,jpl+1)-fracrefb(ig,jpl)) - END DO - END SUBROUTINE taumol03 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol04() - !---------------------------------------------------------------------------- - ! - ! band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg04, ONLY: selfref - USE rrlw_kg04, ONLY: forref - USE rrlw_kg04, ONLY: absa - USE rrlw_kg04, ONLY: fracrefa - USE rrlw_kg04, ONLY: absb - USE rrlw_kg04, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: js - INTEGER :: js1 - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: refrat_planck_b - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - REAL(KIND=wp), dimension(ngc(4)), parameter :: stratcorrect = (/ 1., 1., 1., 1., 1., 1., 1., .92, .88, 1.07, 1.1, & - .99, .88, .943 /) - ! P = 142.5940 mb - refrat_planck_a = chi_mls(1,11)/chi_mls(2,11) - ! P = 95.58350 mb - refrat_planck_b = chi_mls(3,13)/chi_mls(2,13) - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature, and appropriate species. Below laytrop, the water - ! vapor self-continuum and foreign continuum is interpolated (in temperature) - ! separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(4) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(4) + js1 - inds = indself(lay) - indf = indfor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - speccomb = colo3(lay) + rat_o3co2(lay)*colco2(lay) - specparm = colo3(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 4._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colo3(lay) + rat_o3co2_1(lay)*colco2(lay) - specparm1 = colo3(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 4._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - speccomb_planck = colo3(lay)+refrat_planck_b*colco2(lay) - specparm_planck = colo3(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 4._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(4) + js - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(4) + js1 - taug(lay) = speccomb * (fac000 * absb(ind0,ig) + fac100 * & - absb(ind0+1,ig) + fac010 * absb(ind0+5,ig) + fac110 * absb(& - ind0+6,ig)) + speccomb1 * (fac001 * absb(ind1,ig) + & - fac101 * absb(ind1+1,ig) + fac011 * absb(ind1+5,ig) + & - fac111 * absb(ind1+6,ig)) - fracs(lay) = fracrefb(ig,jpl) + fpl * (fracrefb(ig,jpl+1)-fracrefb(ig,jpl)) - ! Empirical modification to code to improve stratospheric cooling rates - ! for co2. Revised to apply weighting for g-point reduction in this band. - ! taug(lay,ngs3+8)=taug(lay,ngs3+8)*0.92 - ! taug(lay,ngs3+9)=taug(lay,ngs3+9)*0.88 - ! taug(lay,ngs3+10)=taug(lay,ngs3+10)*1.07 - ! taug(lay,ngs3+11)=taug(lay,ngs3+11)*1.1 - ! taug(lay,ngs3+12)=taug(lay,ngs3+12)*0.99 - ! taug(lay,ngs3+13)=taug(lay,ngs3+13)*0.88 - ! taug(lay,ngs3+14)=taug(lay,ngs3+14)*0.943 - END DO - taug(laytrop+1:nlayers) = taug(laytrop+1:nlayers) * stratcorrect(ig) - END SUBROUTINE taumol04 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol05() - !---------------------------------------------------------------------------- - ! - ! band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4) - ! (high key - o3,co2) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg05, ONLY: selfref - USE rrlw_kg05, ONLY: forref - USE rrlw_kg05, ONLY: ka_mo3 - USE rrlw_kg05, ONLY: absa - USE rrlw_kg05, ONLY: ccl4 - USE rrlw_kg05, ONLY: fracrefa - USE rrlw_kg05, ONLY: absb - USE rrlw_kg05, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: js - INTEGER :: js1 - INTEGER :: jmo3 - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_mo3 - REAL(KIND=wp) :: specparm_mo3 - REAL(KIND=wp) :: specmult_mo3 - REAL(KIND=wp) :: fmo3 - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: o3m1 - REAL(KIND=wp) :: o3m2 - REAL(KIND=wp) :: abso3 - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: refrat_planck_b - REAL(KIND=wp) :: refrat_m_a - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - ! Minor gas mapping level : - ! lower - o3, p = 317.34 mbar, t = 240.77 k - ! lower - ccl4 - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower/upper atmosphere. - ! P = 473.420 mb - refrat_planck_a = chi_mls(1,5)/chi_mls(2,5) - ! P = 0.2369 mb - refrat_planck_b = chi_mls(3,43)/chi_mls(2,43) - ! P = 317.3480 - refrat_m_a = chi_mls(1,7)/chi_mls(2,7) - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature, and appropriate species. Below laytrop, the - ! water vapor self-continuum and foreign continuum is - ! interpolated (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_mo3 = colh2o(lay) + refrat_m_a*colco2(lay) - specparm_mo3 = colh2o(lay)/speccomb_mo3 - IF (specparm_mo3 .ge. oneminus) specparm_mo3 = oneminus - specmult_mo3 = 8._wp*specparm_mo3 - jmo3 = 1 + int(specmult_mo3) - fmo3 = mod(specmult_mo3,1.0_wp) - speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(5) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(5) + js1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - o3m1 = ka_mo3(jmo3,indm,ig) + fmo3 * (ka_mo3(jmo3+1,indm,ig)-ka_mo3(jmo3,indm,ig)) - o3m2 = ka_mo3(jmo3,indm+1,ig) + fmo3 * (ka_mo3(jmo3+1,indm+1,ig)-ka_mo3(jmo3,indm+1,& - ig)) - abso3 = o3m1 + minorfrac(lay)*(o3m2-o3m1) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor + & - abso3*colo3(lay) + wx(1,lay) * ccl4(ig) - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - speccomb = colo3(lay) + rat_o3co2(lay)*colco2(lay) - specparm = colo3(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 4._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colo3(lay) + rat_o3co2_1(lay)*colco2(lay) - specparm1 = colo3(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 4._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - speccomb_planck = colo3(lay)+refrat_planck_b*colco2(lay) - specparm_planck = colo3(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 4._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(5) + js - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(5) + js1 - taug(lay) = speccomb * (fac000 * absb(ind0,ig) + fac100 * & - absb(ind0+1,ig) + fac010 * absb(ind0+5,ig) + fac110 * absb(& - ind0+6,ig)) + speccomb1 * (fac001 * absb(ind1,ig) + & - fac101 * absb(ind1+1,ig) + fac011 * absb(ind1+5,ig) + & - fac111 * absb(ind1+6,ig)) + wx(1,lay) * ccl4(ig) - fracs(lay) = fracrefb(ig,jpl) + fpl * (fracrefb(ig,jpl+1)-fracrefb(ig,jpl)) - END DO - END SUBROUTINE taumol05 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol06() - !---------------------------------------------------------------------------- - ! - ! band 6: 820-980 cm-1 (low key - h2o; low minor - co2) - ! (high key - nothing; high minor - cfc11, cfc12) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg06, ONLY: selfref - USE rrlw_kg06, ONLY: forref - USE rrlw_kg06, ONLY: ka_mco2 - USE rrlw_kg06, ONLY: cfc12 - USE rrlw_kg06, ONLY: absa - USE rrlw_kg06, ONLY: cfc11adj - USE rrlw_kg06, ONLY: fracrefa - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - REAL(KIND=wp) :: chi_co2 - REAL(KIND=wp) :: ratco2 - REAL(KIND=wp) :: adjfac - REAL(KIND=wp) :: adjcolco2 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: absco2 - ! Minor gas mapping level: - ! lower - co2, p = 706.2720 mb, t = 294.2 k - ! upper - cfc11, cfc12 - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature. The water vapor self-continuum and foreign continuum - ! is interpolated (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - ! In atmospheres where the amount of CO2 is too great to be considered - ! a minor species, adjust the column amount of CO2 by an empirical factor - ! to obtain the proper contribution. - chi_co2 = colco2(lay)/(coldry(lay)) - ratco2 = 1.e20_wp*chi_co2/chi_mls(2,jp(lay)+1) - IF (ratco2 .gt. 3.0_wp) THEN - adjfac = 2.0_wp+(ratco2-2.0_wp)**0.77_wp - adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_wp - ELSE - adjcolco2 = colco2(lay) - END IF - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(6) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(6) + 1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - absco2 = (ka_mco2(indm,ig) + minorfrac(lay) * (ka_mco2(indm+1,ig) - ka_mco2(indm,ig))& - ) - taug(lay) = colh2o(lay) * (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) + tauself + taufor + & - adjcolco2 * absco2 + wx(2,lay) * cfc11adj(ig) + wx(3,lay) * & - cfc12(ig) - fracs(lay) = fracrefa(ig) - END DO - ! Upper atmosphere loop - ! Nothing important goes on above laytrop in this band. - DO lay = laytrop+1, nlayers - taug(lay) = 0.0_wp + wx(2,lay) * cfc11adj(ig) + wx(3,lay) * & - cfc12(ig) - fracs(lay) = fracrefa(ig) - END DO - END SUBROUTINE taumol06 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol07() - !---------------------------------------------------------------------------- - ! - ! band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2) - ! (high key - o3; high minor - co2) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg07, ONLY: selfref - USE rrlw_kg07, ONLY: forref - USE rrlw_kg07, ONLY: ka_mco2 - USE rrlw_kg07, ONLY: absa - USE rrlw_kg07, ONLY: fracrefa - USE rrlw_kg07, ONLY: kb_mco2 - USE rrlw_kg07, ONLY: absb - USE rrlw_kg07, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: js - INTEGER :: js1 - INTEGER :: jmco2 - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_mco2 - REAL(KIND=wp) :: specparm_mco2 - REAL(KIND=wp) :: specmult_mco2 - REAL(KIND=wp) :: fmco2 - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: co2m1 - REAL(KIND=wp) :: co2m2 - REAL(KIND=wp) :: absco2 - REAL(KIND=wp) :: chi_co2 - REAL(KIND=wp) :: ratco2 - REAL(KIND=wp) :: adjfac - REAL(KIND=wp) :: adjcolco2 - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: refrat_m_a - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - REAL(KIND=wp), dimension(ngc(7)), parameter :: stratcorrect = (/ 1., 1., 1., 1., 1., .92, .88, 1.07, 1.1, .99, & - .855, 1. /) - ! Minor gas mapping level : - ! lower - co2, p = 706.2620 mbar, t= 278.94 k - ! upper - co2, p = 12.9350 mbar, t = 234.01 k - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower atmosphere. - ! P = 706.2620 mb - refrat_planck_a = chi_mls(1,3)/chi_mls(3,3) - ! P = 706.2720 mb - refrat_m_a = chi_mls(1,3)/chi_mls(3,3) - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below laytrop, the water - ! vapor self-continuum and foreign continuum is interpolated - ! (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2oo3(lay)*colo3(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2oo3_1(lay)*colo3(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_mco2 = colh2o(lay) + refrat_m_a*colo3(lay) - specparm_mco2 = colh2o(lay)/speccomb_mco2 - IF (specparm_mco2 .ge. oneminus) specparm_mco2 = oneminus - specmult_mco2 = 8._wp*specparm_mco2 - jmco2 = 1 + int(specmult_mco2) - fmco2 = mod(specmult_mco2,1.0_wp) - ! In atmospheres where the amount of CO2 is too great to be considered - ! a minor species, adjust the column amount of CO2 by an empirical factor - ! to obtain the proper contribution. - chi_co2 = colco2(lay)/(coldry(lay)) - ratco2 = 1.e20*chi_co2/chi_mls(2,jp(lay)+1) - IF (ratco2 .gt. 3.0_wp) THEN - adjfac = 3.0_wp+(ratco2-3.0_wp)**0.79_wp - adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_wp - ELSE - adjcolco2 = colco2(lay) - END IF - speccomb_planck = colh2o(lay)+refrat_planck_a*colo3(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(7) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(7) + js1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 * (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,& - indm,ig)) - co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 * (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(& - jmco2,indm+1,ig)) - absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor + adjcolco2*absco2 - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ! In atmospheres where the amount of CO2 is too great to be considered - ! a minor species, adjust the column amount of CO2 by an empirical factor - ! to obtain the proper contribution. - chi_co2 = colco2(lay)/(coldry(lay)) - ratco2 = 1.e20*chi_co2/chi_mls(2,jp(lay)+1) - IF (ratco2 .gt. 3.0_wp) THEN - adjfac = 2.0_wp+(ratco2-2.0_wp)**0.79_wp - adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_wp - ELSE - adjcolco2 = colco2(lay) - END IF - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(7) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(7) + 1 - indm = indminor(lay) - absco2 = kb_mco2(indm,ig) + minorfrac(lay) * (kb_mco2(indm+1,ig) - kb_mco2(indm,ig)) - taug(lay) = colo3(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) + adjcolco2 * absco2 - fracs(lay) = fracrefb(ig) - ! Empirical modification to code to improve stratospheric cooling rates - ! for o3. Revised to apply weighting for g-point reduction in this band. - ! taug(lay,ngs6+6)=taug(lay,ngs6+6)*0.92_wp - ! taug(lay,ngs6+7)=taug(lay,ngs6+7)*0.88_wp - ! taug(lay,ngs6+8)=taug(lay,ngs6+8)*1.07_wp - ! taug(lay,ngs6+9)=taug(lay,ngs6+9)*1.1_wp - ! taug(lay,ngs6+10)=taug(lay,ngs6+10)*0.99_wp - ! taug(lay,ngs6+11)=taug(lay,ngs6+11)*0.855_wp - END DO - taug(laytrop+1:nlayers) = taug(laytrop+1:nlayers) * stratcorrect(ig) - END SUBROUTINE taumol07 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol08() - !---------------------------------------------------------------------------- - ! - ! band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o) - ! (high key - o3; high minor - co2, n2o) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg08, ONLY: selfref - USE rrlw_kg08, ONLY: forref - USE rrlw_kg08, ONLY: ka_mco2 - USE rrlw_kg08, ONLY: ka_mo3 - USE rrlw_kg08, ONLY: ka_mn2o - USE rrlw_kg08, ONLY: absa - USE rrlw_kg08, ONLY: cfc22adj - USE rrlw_kg08, ONLY: cfc12 - USE rrlw_kg08, ONLY: fracrefa - USE rrlw_kg08, ONLY: kb_mco2 - USE rrlw_kg08, ONLY: kb_mn2o - USE rrlw_kg08, ONLY: absb - USE rrlw_kg08, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: absco2 - REAL(KIND=wp) :: abso3 - REAL(KIND=wp) :: absn2o - REAL(KIND=wp) :: chi_co2 - REAL(KIND=wp) :: ratco2 - REAL(KIND=wp) :: adjfac - REAL(KIND=wp) :: adjcolco2 - ! Minor gas mapping level: - ! lower - co2, p = 1053.63 mb, t = 294.2 k - ! lower - o3, p = 317.348 mb, t = 240.77 k - ! lower - n2o, p = 706.2720 mb, t= 278.94 k - ! lower - cfc12,cfc11 - ! upper - co2, p = 35.1632 mb, t = 223.28 k - ! upper - n2o, p = 8.716e-2 mb, t = 226.03 k - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature, and appropriate species. Below laytrop, the water vapor - ! self-continuum and foreign continuum is interpolated (in temperature) - ! separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - ! In atmospheres where the amount of CO2 is too great to be considered - ! a minor species, adjust the column amount of CO2 by an empirical factor - ! to obtain the proper contribution. - chi_co2 = colco2(lay)/(coldry(lay)) - ratco2 = 1.e20_wp*chi_co2/chi_mls(2,jp(lay)+1) - IF (ratco2 .gt. 3.0_wp) THEN - adjfac = 2.0_wp+(ratco2-2.0_wp)**0.65_wp - adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_wp - ELSE - adjcolco2 = colco2(lay) - END IF - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(8) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(8) + 1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - absco2 = (ka_mco2(indm,ig) + minorfrac(lay) * (ka_mco2(indm+1,ig) - ka_mco2(indm,ig))& - ) - abso3 = (ka_mo3(indm,ig) + minorfrac(lay) * (ka_mo3(indm+1,ig) - ka_mo3(indm,ig))) - absn2o = (ka_mn2o(indm,ig) + minorfrac(lay) * (ka_mn2o(indm+1,ig) - ka_mn2o(indm,ig))& - ) - taug(lay) = colh2o(lay) * (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) + tauself + taufor + & - adjcolco2*absco2 + colo3(lay) * abso3 + coln2o(lay) * & - absn2o + wx(3,lay) * cfc12(ig) + wx(4,lay) * cfc22adj(ig) - fracs(lay) = fracrefa(ig) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ! In atmospheres where the amount of CO2 is too great to be considered - ! a minor species, adjust the column amount of CO2 by an empirical factor - ! to obtain the proper contribution. - chi_co2 = colco2(lay)/coldry(lay) - ratco2 = 1.e20_wp*chi_co2/chi_mls(2,jp(lay)+1) - IF (ratco2 .gt. 3.0_wp) THEN - adjfac = 2.0_wp+(ratco2-2.0_wp)**0.65_wp - adjcolco2 = adjfac*chi_mls(2,jp(lay)+1) * coldry(lay)*1.e-20_wp - ELSE - adjcolco2 = colco2(lay) - END IF - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(8) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(8) + 1 - indm = indminor(lay) - absco2 = (kb_mco2(indm,ig) + minorfrac(lay) * (kb_mco2(indm+1,ig) - kb_mco2(indm,ig))& - ) - absn2o = (kb_mn2o(indm,ig) + minorfrac(lay) * (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig))& - ) - taug(lay) = colo3(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) + adjcolco2*absco2 + coln2o(& - lay)*absn2o + wx(3,lay) * cfc12(ig) + wx(4,lay) * cfc22adj(& - ig) - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol08 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol09() - !---------------------------------------------------------------------------- - ! - ! band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o) - ! (high key - ch4; high minor - n2o) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg09, ONLY: selfref - USE rrlw_kg09, ONLY: forref - USE rrlw_kg09, ONLY: ka_mn2o - USE rrlw_kg09, ONLY: absa - USE rrlw_kg09, ONLY: fracrefa - USE rrlw_kg09, ONLY: kb_mn2o - USE rrlw_kg09, ONLY: absb - USE rrlw_kg09, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: js - INTEGER :: js1 - INTEGER :: jmn2o - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_mn2o - REAL(KIND=wp) :: specparm_mn2o - REAL(KIND=wp) :: specmult_mn2o - REAL(KIND=wp) :: fmn2o - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: n2om1 - REAL(KIND=wp) :: n2om2 - REAL(KIND=wp) :: absn2o - REAL(KIND=wp) :: chi_n2o - REAL(KIND=wp) :: ratn2o - REAL(KIND=wp) :: adjfac - REAL(KIND=wp) :: adjcoln2o - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: refrat_m_a - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - ! Minor gas mapping level : - ! lower - n2o, p = 706.272 mbar, t = 278.94 k - ! upper - n2o, p = 95.58 mbar, t = 215.7 k - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower/upper atmosphere. - ! P = 212 mb - refrat_planck_a = chi_mls(1,9)/chi_mls(6,9) - ! P = 706.272 mb - refrat_m_a = chi_mls(1,3)/chi_mls(6,3) - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below laytrop, the water - ! vapor self-continuum and foreign continuum is interpolated - ! (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2och4(lay)*colch4(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2och4_1(lay)*colch4(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_mn2o = colh2o(lay) + refrat_m_a*colch4(lay) - specparm_mn2o = colh2o(lay)/speccomb_mn2o - IF (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus - specmult_mn2o = 8._wp*specparm_mn2o - jmn2o = 1 + int(specmult_mn2o) - fmn2o = mod(specmult_mn2o,1.0_wp) - ! In atmospheres where the amount of N2O is too great to be considered - ! a minor species, adjust the column amount of N2O by an empirical factor - ! to obtain the proper contribution. - chi_n2o = coln2o(lay)/(coldry(lay)) - ratn2o = 1.e20_wp*chi_n2o/chi_mls(4,jp(lay)+1) - IF (ratn2o .gt. 1.5_wp) THEN - adjfac = 0.5_wp+(ratn2o-0.5_wp)**0.65_wp - adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_wp - ELSE - adjcoln2o = coln2o(lay) - END IF - speccomb_planck = colh2o(lay)+refrat_planck_a*colch4(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(9) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(9) + js1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o * (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,& - indm,ig)) - n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o * (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(& - jmn2o,indm+1,ig)) - absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor + adjcoln2o*absn2o - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ! In atmospheres where the amount of N2O is too great to be considered - ! a minor species, adjust the column amount of N2O by an empirical factor - ! to obtain the proper contribution. - chi_n2o = coln2o(lay)/(coldry(lay)) - ratn2o = 1.e20_wp*chi_n2o/chi_mls(4,jp(lay)+1) - IF (ratn2o .gt. 1.5_wp) THEN - adjfac = 0.5_wp+(ratn2o-0.5_wp)**0.65_wp - adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_wp - ELSE - adjcoln2o = coln2o(lay) - END IF - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(9) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(9) + 1 - indm = indminor(lay) - absn2o = kb_mn2o(indm,ig) + minorfrac(lay) * (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig)) - taug(lay) = colch4(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) + adjcoln2o*absn2o - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol09 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol10() - !---------------------------------------------------------------------------- - ! - ! band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg10, ONLY: selfref - USE rrlw_kg10, ONLY: forref - USE rrlw_kg10, ONLY: absa - USE rrlw_kg10, ONLY: fracrefa - USE rrlw_kg10, ONLY: absb - USE rrlw_kg10, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature. Below laytrop, the water vapor self-continuum and - ! foreign continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(10) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(10) + 1 - inds = indself(lay) - indf = indfor(lay) - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - taug(lay) = colh2o(lay) * (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) + tauself + taufor - fracs(lay) = fracrefa(ig) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(10) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(10) + 1 - indf = indfor(lay) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - taug(lay) = colh2o(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) + taufor - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol10 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol11() - !---------------------------------------------------------------------------- - ! - ! band 11: 1480-1800 cm-1 (low - h2o; low minor - o2) - ! (high key - h2o; high minor - o2) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg11, ONLY: selfref - USE rrlw_kg11, ONLY: forref - USE rrlw_kg11, ONLY: ka_mo2 - USE rrlw_kg11, ONLY: absa - USE rrlw_kg11, ONLY: fracrefa - USE rrlw_kg11, ONLY: kb_mo2 - USE rrlw_kg11, ONLY: absb - USE rrlw_kg11, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - REAL(KIND=wp) :: scaleo2 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: tauo2 - ! Minor gas mapping level : - ! lower - o2, p = 706.2720 mbar, t = 278.94 k - ! upper - o2, p = 4.758820 mbarm t = 250.85 k - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature. Below laytrop, the water vapor self-continuum and - ! foreign continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(11) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(11) + 1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - scaleo2 = colo2(lay)*scaleminor(lay) - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - tauo2 = scaleo2 * (ka_mo2(indm,ig) + minorfrac(lay) * (ka_mo2(indm+1,ig) - ka_mo2(& - indm,ig))) - taug(lay) = colh2o(lay) * (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) + tauself + taufor + tauo2 - fracs(lay) = fracrefa(ig) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(11) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(11) + 1 - indf = indfor(lay) - indm = indminor(lay) - scaleo2 = colo2(lay)*scaleminor(lay) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - tauo2 = scaleo2 * (kb_mo2(indm,ig) + minorfrac(lay) * (kb_mo2(indm+1,ig) - kb_mo2(& - indm,ig))) - taug(lay) = colh2o(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) + taufor + tauo2 - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol11 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol12() - !---------------------------------------------------------------------------- - ! - ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg12, ONLY: selfref - USE rrlw_kg12, ONLY: forref - USE rrlw_kg12, ONLY: absa - USE rrlw_kg12, ONLY: fracrefa - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: js - INTEGER :: js1 - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower/upper atmosphere. - ! P = 174.164 mb - refrat_planck_a = chi_mls(1,10)/chi_mls(2,10) - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below laytrop, the water - ! vapor self-continuum adn foreign continuum is interpolated - ! (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(12) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(12) + js1 - inds = indself(lay) - indf = indfor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - taug(lay) = 0.0_wp - fracs(lay) = 0.0_wp - END DO - END SUBROUTINE taumol12 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol13() - !---------------------------------------------------------------------------- - ! - ! band 13: 2080-2250 cm-1 (low key - h2o,n2o; high minor - o3 minor) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg13, ONLY: selfref - USE rrlw_kg13, ONLY: forref - USE rrlw_kg13, ONLY: ka_mco2 - USE rrlw_kg13, ONLY: ka_mco - USE rrlw_kg13, ONLY: absa - USE rrlw_kg13, ONLY: fracrefa - USE rrlw_kg13, ONLY: kb_mo3 - USE rrlw_kg13, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: js - INTEGER :: js1 - INTEGER :: jmco2 - INTEGER :: jmco - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_mco2 - REAL(KIND=wp) :: specparm_mco2 - REAL(KIND=wp) :: specmult_mco2 - REAL(KIND=wp) :: fmco2 - REAL(KIND=wp) :: speccomb_mco - REAL(KIND=wp) :: specparm_mco - REAL(KIND=wp) :: specmult_mco - REAL(KIND=wp) :: fmco - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: co2m1 - REAL(KIND=wp) :: co2m2 - REAL(KIND=wp) :: absco2 - REAL(KIND=wp) :: com1 - REAL(KIND=wp) :: com2 - REAL(KIND=wp) :: absco - REAL(KIND=wp) :: abso3 - REAL(KIND=wp) :: chi_co2 - REAL(KIND=wp) :: ratco2 - REAL(KIND=wp) :: adjfac - REAL(KIND=wp) :: adjcolco2 - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: refrat_m_a - REAL(KIND=wp) :: refrat_m_a3 - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - ! Minor gas mapping levels : - ! lower - co2, p = 1053.63 mb, t = 294.2 k - ! lower - co, p = 706 mb, t = 278.94 k - ! upper - o3, p = 95.5835 mb, t = 215.7 k - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower/upper atmosphere. - ! P = 473.420 mb (Level 5) - refrat_planck_a = chi_mls(1,5)/chi_mls(4,5) - ! P = 1053. (Level 1) - refrat_m_a = chi_mls(1,1)/chi_mls(4,1) - ! P = 706. (Level 3) - refrat_m_a3 = chi_mls(1,3)/chi_mls(4,3) - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below laytrop, the water - ! vapor self-continuum and foreign continuum is interpolated - ! (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2on2o(lay)*coln2o(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2on2o_1(lay)*coln2o(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_mco2 = colh2o(lay) + refrat_m_a*coln2o(lay) - specparm_mco2 = colh2o(lay)/speccomb_mco2 - IF (specparm_mco2 .ge. oneminus) specparm_mco2 = oneminus - specmult_mco2 = 8._wp*specparm_mco2 - jmco2 = 1 + int(specmult_mco2) - fmco2 = mod(specmult_mco2,1.0_wp) - ! In atmospheres where the amount of CO2 is too great to be considered - ! a minor species, adjust the column amount of CO2 by an empirical factor - ! to obtain the proper contribution. - chi_co2 = colco2(lay)/(coldry(lay)) - ratco2 = 1.e20_wp*chi_co2/3.55e-4_wp - IF (ratco2 .gt. 3.0_wp) THEN - adjfac = 2.0_wp+(ratco2-2.0_wp)**0.68_wp - adjcolco2 = adjfac*3.55e-4*coldry(lay)*1.e-20_wp - ELSE - adjcolco2 = colco2(lay) - END IF - speccomb_mco = colh2o(lay) + refrat_m_a3*coln2o(lay) - specparm_mco = colh2o(lay)/speccomb_mco - IF (specparm_mco .ge. oneminus) specparm_mco = oneminus - specmult_mco = 8._wp*specparm_mco - jmco = 1 + int(specmult_mco) - fmco = mod(specmult_mco,1.0_wp) - speccomb_planck = colh2o(lay)+refrat_planck_a*coln2o(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(13) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(13) + js1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 * (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,& - indm,ig)) - co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 * (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(& - jmco2,indm+1,ig)) - absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1) - com1 = ka_mco(jmco,indm,ig) + fmco * (ka_mco(jmco+1,indm,ig) - ka_mco(jmco,indm,ig)) - com2 = ka_mco(jmco,indm+1,ig) + fmco * (ka_mco(jmco+1,indm+1,ig) - ka_mco(jmco,& - indm+1,ig)) - absco = com1 + minorfrac(lay) * (com2 - com1) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor + & - adjcolco2*absco2 + colco(lay)*absco - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - indm = indminor(lay) - abso3 = kb_mo3(indm,ig) + minorfrac(lay) * (kb_mo3(indm+1,ig) - kb_mo3(indm,ig)) - taug(lay) = colo3(lay)*abso3 - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol13 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol14() - !---------------------------------------------------------------------------- - ! - ! band 14: 2250-2380 cm-1 (low - co2; high - co2) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg14, ONLY: selfref - USE rrlw_kg14, ONLY: forref - USE rrlw_kg14, ONLY: absa - USE rrlw_kg14, ONLY: fracrefa - USE rrlw_kg14, ONLY: absb - USE rrlw_kg14, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature. Below laytrop, the water vapor self-continuum - ! and foreign continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(14) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(14) + 1 - inds = indself(lay) - indf = indfor(lay) - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - taug(lay) = colco2(lay) * (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) + tauself + taufor - fracs(lay) = fracrefa(ig) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(14) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(14) + 1 - taug(lay) = colco2(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol14 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol15() - !---------------------------------------------------------------------------- - ! - ! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2) - ! (high - nothing) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg15, ONLY: selfref - USE rrlw_kg15, ONLY: forref - USE rrlw_kg15, ONLY: ka_mn2 - USE rrlw_kg15, ONLY: absa - USE rrlw_kg15, ONLY: fracrefa - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: js - INTEGER :: js1 - INTEGER :: jmn2 - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_mn2 - REAL(KIND=wp) :: specparm_mn2 - REAL(KIND=wp) :: specmult_mn2 - REAL(KIND=wp) :: fmn2 - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: scalen2 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: n2m1 - REAL(KIND=wp) :: n2m2 - REAL(KIND=wp) :: taun2 - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: refrat_m_a - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - ! Minor gas mapping level : - ! Lower - Nitrogen Continuum, P = 1053., T = 294. - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower atmosphere. - ! P = 1053. mb (Level 1) - refrat_planck_a = chi_mls(4,1)/chi_mls(2,1) - ! P = 1053. - refrat_m_a = chi_mls(4,1)/chi_mls(2,1) - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below laytrop, the water - ! vapor self-continuum and foreign continuum is interpolated - ! (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = coln2o(lay) + rat_n2oco2(lay)*colco2(lay) - specparm = coln2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = coln2o(lay) + rat_n2oco2_1(lay)*colco2(lay) - specparm1 = coln2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_mn2 = coln2o(lay) + refrat_m_a*colco2(lay) - specparm_mn2 = coln2o(lay)/speccomb_mn2 - IF (specparm_mn2 .ge. oneminus) specparm_mn2 = oneminus - specmult_mn2 = 8._wp*specparm_mn2 - jmn2 = 1 + int(specmult_mn2) - fmn2 = mod(specmult_mn2,1.0_wp) - speccomb_planck = coln2o(lay)+refrat_planck_a*colco2(lay) - specparm_planck = coln2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(15) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(15) + js1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - scalen2 = colbrd(lay)*scaleminor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - n2m1 = ka_mn2(jmn2,indm,ig) + fmn2 * (ka_mn2(jmn2+1,indm,ig) - ka_mn2(jmn2,indm,ig)) - n2m2 = ka_mn2(jmn2,indm+1,ig) + fmn2 * (ka_mn2(jmn2+1,indm+1,ig) - ka_mn2(jmn2,& - indm+1,ig)) - taun2 = scalen2 * (n2m1 + minorfrac(lay) * (n2m2 - n2m1)) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor + taun2 - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - taug(lay) = 0.0_wp - fracs(lay) = 0.0_wp - END DO - END SUBROUTINE taumol15 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol16() - !---------------------------------------------------------------------------- - ! - ! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg16, ONLY: selfref - USE rrlw_kg16, ONLY: forref - USE rrlw_kg16, ONLY: absa - USE rrlw_kg16, ONLY: fracrefa - USE rrlw_kg16, ONLY: absb - USE rrlw_kg16, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: js - INTEGER :: js1 - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower atmosphere. - ! P = 387. mb (Level 6) - refrat_planck_a = chi_mls(1,6)/chi_mls(6,6) - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature,and appropriate species. Below laytrop, the water - ! vapor self-continuum and foreign continuum is interpolated - ! (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2och4(lay)*colch4(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2och4_1(lay)*colch4(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_planck = colh2o(lay)+refrat_planck_a*colch4(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(16) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(16) + js1 - inds = indself(lay) - indf = indfor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(16) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(16) + 1 - taug(lay) = colch4(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol16 - END SUBROUTINE gas_optics_lw - END MODULE mo_lrtm_gas_optics diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_lrtm_kgs.f90 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_lrtm_kgs.f90 deleted file mode 100644 index 4a142f95b9..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_lrtm_kgs.f90 +++ /dev/null @@ -1,1217 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_lrtm_kgs.f90 -! Generated at: 2015-02-19 15:30:31 -! KGEN version: 0.4.4 - - - - MODULE rrlw_planck - USE mo_kind, ONLY: wp - USE mo_rrtm_params, ONLY: nbndlw - REAL(KIND=wp) :: chi_mls(7,59) - REAL(KIND=wp) :: totplanck(181,nbndlw) !< planck function for each band - !< for band 16 - PUBLIC read_externs_rrlw_planck - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_planck(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) chi_mls - READ(UNIT=kgen_unit) totplanck - END SUBROUTINE read_externs_rrlw_planck - - - ! read subroutines - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_planck - - MODULE rrlw_kg01 - USE mo_kind, ONLY: wp - IMPLICIT NONE - !< original abs coefficients - INTEGER, parameter :: ng1 = 10 !< combined abs. coefficients - REAL(KIND=wp) :: fracrefa(ng1) - REAL(KIND=wp) :: fracrefb(ng1) - REAL(KIND=wp) :: absa(65,ng1) - REAL(KIND=wp) :: absb(235,ng1) - REAL(KIND=wp) :: ka_mn2(19,ng1) - REAL(KIND=wp) :: kb_mn2(19,ng1) - REAL(KIND=wp) :: selfref(10,ng1) - REAL(KIND=wp) :: forref(4,ng1) - PUBLIC read_externs_rrlw_kg01 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg01(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mn2 - READ(UNIT=kgen_unit) kb_mn2 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg01 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg01 - - MODULE rrlw_kg02 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng2 = 12 - REAL(KIND=wp) :: fracrefa(ng2) - REAL(KIND=wp) :: fracrefb(ng2) - REAL(KIND=wp) :: absa(65,ng2) - REAL(KIND=wp) :: absb(235,ng2) - REAL(KIND=wp) :: selfref(10,ng2) - REAL(KIND=wp) :: forref(4,ng2) - PUBLIC read_externs_rrlw_kg02 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg02(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg02 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg02 - - MODULE rrlw_kg03 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng3 = 16 - REAL(KIND=wp) :: fracrefa(ng3,9) - REAL(KIND=wp) :: fracrefb(ng3,5) - REAL(KIND=wp) :: absa(585,ng3) - REAL(KIND=wp) :: absb(1175,ng3) - REAL(KIND=wp) :: ka_mn2o(9,19,ng3) - REAL(KIND=wp) :: kb_mn2o(5,19,ng3) - REAL(KIND=wp) :: selfref(10,ng3) - REAL(KIND=wp) :: forref(4,ng3) - PUBLIC read_externs_rrlw_kg03 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim2 - module procedure read_var_real_wp_dim3 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg03(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mn2o - READ(UNIT=kgen_unit) kb_mn2o - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg03 - - - ! read subroutines - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim3(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:,:), allocatable :: var - integer, dimension(2,3) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg03 - - MODULE rrlw_kg04 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng4 = 14 - REAL(KIND=wp) :: fracrefa(ng4,9) - REAL(KIND=wp) :: fracrefb(ng4,5) - REAL(KIND=wp) :: absa(585,ng4) - REAL(KIND=wp) :: absb(1175,ng4) - REAL(KIND=wp) :: selfref(10,ng4) - REAL(KIND=wp) :: forref(4,ng4) - PUBLIC read_externs_rrlw_kg04 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg04(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg04 - - - ! read subroutines - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg04 - - MODULE rrlw_kg05 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng5 = 16 - REAL(KIND=wp) :: fracrefa(ng5,9) - REAL(KIND=wp) :: fracrefb(ng5,5) - REAL(KIND=wp) :: absa(585,ng5) - REAL(KIND=wp) :: absb(1175,ng5) - REAL(KIND=wp) :: ka_mo3(9,19,ng5) - REAL(KIND=wp) :: selfref(10,ng5) - REAL(KIND=wp) :: forref(4,ng5) - REAL(KIND=wp) :: ccl4(ng5) - PUBLIC read_externs_rrlw_kg05 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim2 - module procedure read_var_real_wp_dim3 - module procedure read_var_real_wp_dim1 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg05(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mo3 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) ccl4 - END SUBROUTINE read_externs_rrlw_kg05 - - - ! read subroutines - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim3(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:,:), allocatable :: var - integer, dimension(2,3) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg05 - - MODULE rrlw_kg06 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng6 = 8 - REAL(KIND=wp), dimension(ng6) :: fracrefa - REAL(KIND=wp) :: absa(65,ng6) - REAL(KIND=wp) :: ka_mco2(19,ng6) - REAL(KIND=wp) :: selfref(10,ng6) - REAL(KIND=wp) :: forref(4,ng6) - REAL(KIND=wp), dimension(ng6) :: cfc11adj - REAL(KIND=wp), dimension(ng6) :: cfc12 - PUBLIC read_externs_rrlw_kg06 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg06(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) ka_mco2 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) cfc11adj - READ(UNIT=kgen_unit) cfc12 - END SUBROUTINE read_externs_rrlw_kg06 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg06 - - MODULE rrlw_kg07 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng7 = 12 - REAL(KIND=wp), dimension(ng7) :: fracrefb - REAL(KIND=wp) :: fracrefa(ng7,9) - REAL(KIND=wp) :: absa(585,ng7) - REAL(KIND=wp) :: absb(235,ng7) - REAL(KIND=wp) :: ka_mco2(9,19,ng7) - REAL(KIND=wp) :: kb_mco2(19,ng7) - REAL(KIND=wp) :: selfref(10,ng7) - REAL(KIND=wp) :: forref(4,ng7) - PUBLIC read_externs_rrlw_kg07 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - module procedure read_var_real_wp_dim3 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg07(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mco2 - READ(UNIT=kgen_unit) kb_mco2 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg07 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim3(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:,:), allocatable :: var - integer, dimension(2,3) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg07 - - MODULE rrlw_kg08 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng8 = 8 - REAL(KIND=wp), dimension(ng8) :: fracrefa - REAL(KIND=wp), dimension(ng8) :: fracrefb - REAL(KIND=wp), dimension(ng8) :: cfc12 - REAL(KIND=wp), dimension(ng8) :: cfc22adj - REAL(KIND=wp) :: absa(65,ng8) - REAL(KIND=wp) :: absb(235,ng8) - REAL(KIND=wp) :: ka_mco2(19,ng8) - REAL(KIND=wp) :: ka_mn2o(19,ng8) - REAL(KIND=wp) :: ka_mo3(19,ng8) - REAL(KIND=wp) :: kb_mco2(19,ng8) - REAL(KIND=wp) :: kb_mn2o(19,ng8) - REAL(KIND=wp) :: selfref(10,ng8) - REAL(KIND=wp) :: forref(4,ng8) - PUBLIC read_externs_rrlw_kg08 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg08(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) cfc12 - READ(UNIT=kgen_unit) cfc22adj - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mco2 - READ(UNIT=kgen_unit) ka_mn2o - READ(UNIT=kgen_unit) ka_mo3 - READ(UNIT=kgen_unit) kb_mco2 - READ(UNIT=kgen_unit) kb_mn2o - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg08 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg08 - - MODULE rrlw_kg09 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng9 = 12 - REAL(KIND=wp), dimension(ng9) :: fracrefb - REAL(KIND=wp) :: fracrefa(ng9,9) - REAL(KIND=wp) :: absa(585,ng9) - REAL(KIND=wp) :: absb(235,ng9) - REAL(KIND=wp) :: ka_mn2o(9,19,ng9) - REAL(KIND=wp) :: kb_mn2o(19,ng9) - REAL(KIND=wp) :: selfref(10,ng9) - REAL(KIND=wp) :: forref(4,ng9) - PUBLIC read_externs_rrlw_kg09 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - module procedure read_var_real_wp_dim3 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg09(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mn2o - READ(UNIT=kgen_unit) kb_mn2o - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg09 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim3(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:,:), allocatable :: var - integer, dimension(2,3) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg09 - - MODULE rrlw_kg10 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng10 = 6 - REAL(KIND=wp), dimension(ng10) :: fracrefa - REAL(KIND=wp), dimension(ng10) :: fracrefb - REAL(KIND=wp) :: absa(65,ng10) - REAL(KIND=wp) :: absb(235,ng10) - REAL(KIND=wp) :: selfref(10,ng10) - REAL(KIND=wp) :: forref(4,ng10) - PUBLIC read_externs_rrlw_kg10 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg10(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg10 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg10 - - MODULE rrlw_kg11 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng11 = 8 - REAL(KIND=wp), dimension(ng11) :: fracrefa - REAL(KIND=wp), dimension(ng11) :: fracrefb - REAL(KIND=wp) :: absa(65,ng11) - REAL(KIND=wp) :: absb(235,ng11) - REAL(KIND=wp) :: ka_mo2(19,ng11) - REAL(KIND=wp) :: kb_mo2(19,ng11) - REAL(KIND=wp) :: selfref(10,ng11) - REAL(KIND=wp) :: forref(4,ng11) - PUBLIC read_externs_rrlw_kg11 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg11(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mo2 - READ(UNIT=kgen_unit) kb_mo2 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg11 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg11 - - MODULE rrlw_kg12 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng12 = 8 - REAL(KIND=wp) :: fracrefa(ng12,9) - REAL(KIND=wp) :: absa(585,ng12) - REAL(KIND=wp) :: selfref(10,ng12) - REAL(KIND=wp) :: forref(4,ng12) - PUBLIC read_externs_rrlw_kg12 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg12(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg12 - - - ! read subroutines - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg12 - - MODULE rrlw_kg13 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng13 = 4 - REAL(KIND=wp), dimension(ng13) :: fracrefb - REAL(KIND=wp) :: fracrefa(ng13,9) - REAL(KIND=wp) :: absa(585,ng13) - REAL(KIND=wp) :: ka_mco2(9,19,ng13) - REAL(KIND=wp) :: ka_mco(9,19,ng13) - REAL(KIND=wp) :: kb_mo3(19,ng13) - REAL(KIND=wp) :: selfref(10,ng13) - REAL(KIND=wp) :: forref(4,ng13) - PUBLIC read_externs_rrlw_kg13 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - module procedure read_var_real_wp_dim3 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg13(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) ka_mco2 - READ(UNIT=kgen_unit) ka_mco - READ(UNIT=kgen_unit) kb_mo3 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg13 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim3(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:,:), allocatable :: var - integer, dimension(2,3) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg13 - - MODULE rrlw_kg14 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng14 = 2 - REAL(KIND=wp), dimension(ng14) :: fracrefa - REAL(KIND=wp), dimension(ng14) :: fracrefb - REAL(KIND=wp) :: absa(65,ng14) - REAL(KIND=wp) :: absb(235,ng14) - REAL(KIND=wp) :: selfref(10,ng14) - REAL(KIND=wp) :: forref(4,ng14) - PUBLIC read_externs_rrlw_kg14 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg14(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg14 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg14 - - MODULE rrlw_kg15 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng15 = 2 - REAL(KIND=wp) :: fracrefa(ng15,9) - REAL(KIND=wp) :: absa(585,ng15) - REAL(KIND=wp) :: ka_mn2(9,19,ng15) - REAL(KIND=wp) :: selfref(10,ng15) - REAL(KIND=wp) :: forref(4,ng15) - PUBLIC read_externs_rrlw_kg15 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim2 - module procedure read_var_real_wp_dim3 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg15(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) ka_mn2 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg15 - - - ! read subroutines - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim3(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:,:), allocatable :: var - integer, dimension(2,3) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg15 - - MODULE rrlw_kg16 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng16 = 2 - REAL(KIND=wp), dimension(ng16) :: fracrefb - REAL(KIND=wp) :: fracrefa(ng16,9) - REAL(KIND=wp) :: absa(585,ng16) - REAL(KIND=wp) :: absb(235,ng16) - REAL(KIND=wp) :: selfref(10,ng16) - REAL(KIND=wp) :: forref(4,ng16) - PUBLIC read_externs_rrlw_kg16 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg16(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg16 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg16 diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_lrtm_setup.f90 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_lrtm_setup.f90 deleted file mode 100644 index d5159218ee..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_lrtm_setup.f90 +++ /dev/null @@ -1,123 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_lrtm_setup.f90 -! Generated at: 2015-02-19 15:30:32 -! KGEN version: 0.4.4 - - - - MODULE mo_lrtm_setup - USE mo_kind, ONLY: wp - USE mo_rrtm_params, ONLY: ngptlw - USE mo_rrtm_params, ONLY: nbndlw - IMPLICIT NONE - ! - ! spectra information that is entered at run time - ! - !< Weights for combining original gpts into reduced gpts - !< Number of cross-section molecules - !< Flag for active cross-sections in calculation - INTEGER, parameter :: ngc(nbndlw) = (/ 10,12,16,14,16,8,12,8,12,6,8,8,4,2,2,2/) !< The number of new g-intervals in each band - INTEGER, parameter :: ngs(nbndlw) = (/ 10,22,38,52,68,76,88,96,108,114,122,130,134,136,138,140/) !< The cumulative sum of new g-intervals for each band - !< The index of each new gpt relative to the orignal - ! band 1 - ! band 2 - ! band 3 - ! band 4 - ! band 5 - ! band 6 - ! band 7 - ! band 8 - ! band 9 - ! band 10 - ! band 11 - ! band 12 - ! band 13 - ! band 14 - ! band 15 - ! band 16 - !< The number of original gs combined to make new pts - ! band 1 - ! band 2 - ! band 3 - ! band 4 - ! band 5 - ! band 6 - ! band 7 - ! band 8 - ! band 9 - ! band 10 - ! band 11 - ! band 12 - ! band 13 - ! band 14 - ! band 15 - ! band 16 - INTEGER, parameter :: ngb(ngptlw) = (/ 1,1,1,1,1,1,1,1,1,1, 2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,& - 3,3,3,3,3,3,3,3, 4,4,4,4,4,4,4,4,4,4,4,4,4,4, 5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5, 6,6,6,6,6,6,6,6, & - 7,7,7,7,7,7,7,7,7,7,7,7, 8,8,8,8,8,8,8,8, 9,9,9,9,9,9,9,9,9,9,9,9, 10,10,10,10,10,10, 11,11,& - 11,11,11,11,11,11, 12,12,12,12,12,12,12,12, 13,13,13,13, 14,14, 15,15, 16,16/) !< The band index for each new g-interval - ! band 1 - ! band 2 - ! band 3 - ! band 4 - ! band 5 - ! band 6 - ! band 7 - ! band 8 - ! band 9 - ! band 10 - ! band 11 - ! band 12 - ! band 13 - ! band 14 - ! band 15 - ! band 16 - !< RRTM weights for the original 16 g-intervals - INTEGER, parameter :: nspa(nbndlw) = (/ 1,1,9,9,9,1,9,1,9,1,1,9,9,1,9,9/) !< Number of reference atmospheres for lower atmosphere - INTEGER, parameter :: nspb(nbndlw) = (/ 1,1,5,5,5,0,1,1,1,1,1,0,0,1,0,0/) !< Number of reference atmospheres for upper atmosphere - ! < Number of g intervals in each band - !< Spectral band lower boundary in wavenumbers - !< Spectral band upper boundary in wavenumbers - REAL(KIND=wp), parameter :: delwave(nbndlw) = (/ 340._wp, 150._wp, 130._wp, 70._wp, 120._wp, 160._wp, & - 100._wp, 100._wp, 210._wp, 90._wp, 320._wp, 280._wp, 170._wp, 130._wp, 220._wp, 650._wp/) !< Spectral band width in wavenumbers - CONTAINS - - ! read subroutines - ! ************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - END MODULE mo_lrtm_setup diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_lrtm_solver.f90 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_lrtm_solver.f90 deleted file mode 100644 index 841db2d6b8..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_lrtm_solver.f90 +++ /dev/null @@ -1,161 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_lrtm_solver.f90 -! Generated at: 2015-02-19 15:30:36 -! KGEN version: 0.4.4 - - - - MODULE mo_lrtm_solver - USE mo_kind, ONLY: wp - USE mo_math_constants, ONLY: pi - USE mo_rrtm_params, ONLY: nbndlw - USE mo_rad_fastmath, ONLY: tautrans - USE mo_rad_fastmath, ONLY: transmit - IMPLICIT NONE - REAL(KIND=wp), parameter :: fluxfac = 2.0e+04_wp * pi - CONTAINS - - ! read subroutines - ! ------------------------------------------------------------------------------- - - SUBROUTINE lrtm_solver(kproma, kbdim, klev, tau, layplnk, levplnk, weights, secdiff, surfplanck, surfemis, fluxup, fluxdn) - ! - ! Compute IR (no scattering) radiative transfer for a set of columns - ! Based on AER code RRTMG_LW_RTNMC, including approximations used there - ! Layers are ordered from botton to top (i.e. tau(1) is tau in lowest layer) - ! Computes all-sky RT given a total optical thickness in each layer - ! - INTEGER, intent(in) :: kbdim - INTEGER, intent(in) :: klev - INTEGER, intent(in) :: kproma - !< Number of columns - !< Maximum number of columns as declared in calling (sub)program - !< number of layers (one fewer than levels) - REAL(KIND=wp), intent(in) :: tau(kbdim,klev) - REAL(KIND=wp), intent(in) :: layplnk(kbdim,klev) - REAL(KIND=wp), intent(in) :: weights(kbdim,klev) !< dimension (kbdim, klev) - !< Longwave optical thickness - !< Planck function at layer centers - !< Fraction of total Planck function for this g-point - REAL(KIND=wp), intent(in) :: levplnk(kbdim, 0:klev) - !< Planck function at layer edges, level i is the top of layer i - REAL(KIND=wp), intent(in) :: secdiff(kbdim) - REAL(KIND=wp), intent(in) :: surfemis(kbdim) - REAL(KIND=wp), intent(in) :: surfplanck(kbdim) !< dimension (kbdim) - !< Planck function at surface - !< Surface emissivity - !< secant of integration angle - depends on band, column water vapor - REAL(KIND=wp), intent(out) :: fluxup(kbdim, 0:klev) - REAL(KIND=wp), intent(out) :: fluxdn(kbdim, 0:klev) !< dimension (kbdim, 0:klev) - !< Fluxes at the interfaces - ! ----------- - INTEGER :: jk - !< Loop index for layers - REAL(KIND=wp) :: odepth(kbdim,klev) - REAL(KIND=wp) :: tfn(kbdim) - REAL(KIND=wp) :: dplnkup(kbdim,klev) - REAL(KIND=wp) :: dplnkdn(kbdim,klev) - REAL(KIND=wp) :: bbup(kbdim,klev) - REAL(KIND=wp) :: bbdn(kbdim,klev) - REAL(KIND=wp) :: trans(kbdim,klev) - !< Layer transmissivity - !< TFN_TBL - !< Tau transition function; i.e. the transition of the Planck - !< function from that for the mean layer temperature to that for - !< the layer boundary temperature as a function of optical depth. - !< The "linear in tau" method is used to make the table. - !< Upward derivative of Planck function - !< Downward derivative of Planck function - !< Interpolated downward emission - !< Interpolated upward emission - !< Effective IR optical depth of layer - REAL(KIND=wp) :: rad_dn(kbdim,0:klev) - REAL(KIND=wp) :: rad_up(kbdim,0:klev) - !< Radiance down at propagation angle - !< Radiance down at propagation angle - ! This secant and weight corresponds to the standard diffusivity - ! angle. The angle is redefined for some bands. - REAL(KIND=wp), parameter :: wtdiff = 0.5_wp - ! ----------- - ! - ! 1.0 Initial preparations - ! Weight optical depth by 1/cos(diffusivity angle), which depends on band - ! This will be used to compute layer transmittance - ! ----- - !IBM* ASSERT(NODEPS) - DO jk = 1, klev - odepth(1:kproma,jk) = max(0._wp, secdiff(1:kproma) * tau(1:kproma,jk)) - END DO - ! - ! 2.0 Radiative transfer - ! - ! ----- - ! - ! Plank function derivatives and total emission for linear-in-tau approximation - ! - !IBM* ASSERT(NODEPS) - DO jk = 1, klev - tfn(1:kproma) = tautrans(odepth(:,jk), kproma) - dplnkup(1:kproma,jk) = levplnk(1:kproma,jk) - layplnk(1:kproma,jk) - dplnkdn(1:kproma,jk) = levplnk(1:kproma,jk-1) - layplnk(1:kproma,jk) - bbup(1:kproma,jk) = weights(1:kproma,jk) * (layplnk(1:kproma,jk) + dplnkup(1:kproma,jk) * tfn(1:kproma)) - bbdn(1:kproma,jk) = weights(1:kproma,jk) * (layplnk(1:kproma,jk) + dplnkdn(1:kproma,jk) * tfn(1:kproma)) - END DO - ! ----- - ! 2.1 Downward radiative transfer - ! - ! Level 0 is closest to the ground - ! - rad_dn(:, klev) = 0. ! Upper boundary condition - no downwelling IR - DO jk = klev, 1, -1 - trans(1:kproma,jk) = transmit(odepth(:,jk), kproma) - ! RHS is a rearrangment of rad_dn(:,jk) * (1._wp - trans(:,jk)) + trans(:,jk) * bbdn(:) - rad_dn(1:kproma,jk-1) = rad_dn(1:kproma,jk) + (bbdn(1:kproma,jk) - rad_dn(1:kproma,jk)) * trans(1:kproma,jk) - END DO - ! - ! 2.2 Surface contribution, including reflection - ! - rad_up(1:kproma, 0) = weights(1:kproma, 1) * surfemis(1:kproma) * surfplanck(1:kproma) + (1._wp - & - surfemis(1:kproma)) * rad_dn(1:kproma, 0) - ! - ! 2.3 Upward radiative transfer - ! - DO jk = 1, klev - rad_up(1:kproma,jk) = rad_up(1:kproma,jk-1) * (1._wp - trans(1:kproma,jk)) + trans(1:kproma,jk) * bbup(1:kproma,& - jk) - END DO - ! - ! 3.0 Covert intensities at diffusivity angles to fluxes - ! - ! ----- - fluxup(1:kproma, 0:klev) = rad_up(1:kproma,:) * wtdiff * fluxfac - fluxdn(1:kproma, 0:klev) = rad_dn(1:kproma,:) * wtdiff * fluxfac - END SUBROUTINE lrtm_solver - ! ------------------------------------------------------------------------------- - - elemental FUNCTION find_secdiff(iband, pwvcm) - INTEGER, intent(in) :: iband - !< RRTMG LW band number - REAL(KIND=wp), intent(in) :: pwvcm - !< Precipitable water vapor (cm) - REAL(KIND=wp) :: find_secdiff - ! Compute diffusivity angle for Bands 2-3 and 5-9 to vary (between 1.50 - ! and 1.80) as a function of total column water vapor. The function - ! has been defined to minimize flux and cooling rate errors in these bands - ! over a wide range of precipitable water values. - REAL(KIND=wp), dimension(nbndlw), parameter :: a0 = (/ 1.66_wp, 1.55_wp, 1.58_wp, 1.66_wp, 1.54_wp, 1.454_wp, & - 1.89_wp, 1.33_wp, 1.668_wp, 1.66_wp, 1.66_wp, 1.66_wp, 1.66_wp, 1.66_wp, 1.66_wp, 1.66_wp /) - REAL(KIND=wp), dimension(nbndlw), parameter :: a1 = (/ 0.00_wp, 0.25_wp, 0.22_wp, 0.00_wp, 0.13_wp, 0.446_wp, & - -0.10_wp, 0.40_wp, -0.006_wp, 0.00_wp, 0.00_wp, 0.00_wp, 0.00_wp, 0.00_wp, 0.00_wp, 0.00_wp /) - REAL(KIND=wp), dimension(nbndlw), parameter :: a2 = (/ 0.00_wp, -12.0_wp, -11.7_wp, 0.00_wp, -0.72_wp,-0.243_wp, & - 0.19_wp,-0.062_wp, 0.414_wp, 0.00_wp, 0.00_wp, 0.00_wp, 0.00_wp, 0.00_wp, 0.00_wp, 0.00_wp /) - IF (iband == 1 .or. iband == 4 .or. iband >= 10) THEN - find_secdiff = 1.66_wp - ELSE - find_secdiff = max(min(a0(iband) + a1(iband) * exp(a2(iband)*pwvcm), 1.8_wp), 1.5_wp) - END IF - END FUNCTION find_secdiff - ! ------------------------------------------------------------------------------- - END MODULE mo_lrtm_solver diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_math_constants.f90 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_math_constants.f90 deleted file mode 100644 index 792ef885ed..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_math_constants.f90 +++ /dev/null @@ -1,48 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_math_constants.f90 -! Generated at: 2015-02-19 15:30:32 -! KGEN version: 0.4.4 - - - - MODULE mo_math_constants - USE mo_kind, ONLY: wp - IMPLICIT NONE - PUBLIC - ! Mathematical constants defined: - ! - !-------------------------------------------------------------- - ! Fortran name | C name | meaning | - !-------------------------------------------------------------- - ! euler | M_E | e | - ! log2e | M_LOG2E | log2(e) | - ! log10e | M_LOG10E | log10(e) | - ! ln2 | M_LN2 | ln(2) | - ! ln10 | M_LN10 | ln(10) | - ! pi | M_PI | pi | - ! pi_2 | M_PI_2 | pi/2 | - ! pi_4 | M_PI_4 | pi/4 | - ! rpi | M_1_PI | 1/pi | - ! rpi_2 | M_2_PI | 2/pi | - ! rsqrtpi_2 | M_2_SQRTPI | 2/(sqrt(pi)) | - ! sqrt2 | M_SQRT2 | sqrt(2) | - ! sqrt1_2 | M_SQRT1_2 | 1/sqrt(2) | - ! sqrt3 | | sqrt(3) | - ! sqrt1_3 | | 1/sqrt(3) | - ! half angle of pentagon | - ! pi_5 | | pi/5 | - ! latitude of the lowest major triangle corner | - ! and latitude of the major hexagonal faces centers | - ! phi0 | | pi/2 -2acos(1/(2*sin(pi/5))) | - ! conversion factor from radians to degree | - ! rad2deg | | 180/pi | - ! conversion factor from degree to radians | - ! deg2rad | | pi/180 | - ! one_third | | 1/3 | - !-------------------------------------------------------------| - REAL(KIND=wp), parameter :: pi = 3.14159265358979323846264338327950288419717_wp - - ! read subroutines - END MODULE mo_math_constants diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_physical_constants.f90 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_physical_constants.f90 deleted file mode 100644 index 926757551a..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_physical_constants.f90 +++ /dev/null @@ -1,199 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_physical_constants.f90 -! Generated at: 2015-02-19 15:30:36 -! KGEN version: 0.4.4 - - - - MODULE mo_physical_constants - USE mo_kind, ONLY: wp - IMPLICIT NONE - PUBLIC - ! Natural constants - ! ----------------- - ! - ! WMO/SI values - !> [1/mo] Avogadro constant - !! [J/K] Boltzmann constant - !! [J/K/mol] molar/universal/ideal gas constant - !! [W/m2/K4] Stephan-Boltzmann constant - ! - !> Molar weights - !! ------------- - !! - !! Pure species - !>[g/mol] CO2 (National Institute for - !! Standards and Technology (NIST)) - !! [g/mol] CH4 - !! [g/mol] O3 - !! [g/mol] O2 - !! [g/mol] N2O - !! [g/mol] CFC11 - !! [g/mol] CFC12 - REAL(KIND=wp), parameter :: amw = 18.0154_wp !! [g/mol] H2O - ! - !> Mixed species - REAL(KIND=wp), parameter :: amd = 28.970_wp !> [g/mol] dry air - ! - !> Auxiliary constants - ! ppmv2gg converts ozone from volume mixing ratio in ppmv - ! to mass mixing ratio in g/g - ! - !> Earth and Earth orbit constants - !! ------------------------------- - !! - !! [m] average radius - !! [1/m] - !! [1/s] angular velocity - ! - ! WMO/SI value - REAL(KIND=wp), parameter :: grav = 9.80665_wp !> [m/s2] av. gravitational acceleration - !! [s2/m] - ! - !> [m/m] ratio of atm. scale height - ! !! to Earth radius - ! seconds per day - ! - !> Thermodynamic constants for the dry and moist atmosphere - !! -------------------------------------------------------- - ! - !> Dry air - !> [J/K/kg] gas constant - !! [J/K/kg] specific heat at constant pressure - !! [J/K/kg] specific heat at constant volume - !! [m^2/s] kinematic viscosity of dry air - !! [m^2/s] scalar conductivity of dry air - !! [J/m/s/K]thermal conductivity of dry air - !! [N*s/m2] dyn viscosity of dry air at tmelt - ! - !> H2O - !! - gas - !> [J/K/kg] gas constant for water vapor - !! [J/K/kg] specific heat at constant pressure - !! [J/K/kg] specific heat at constant volume - !! [m^2/s] diff coeff of H2O vapor in dry air at tmelt - !> - liquid / water - !> [kg/m3] density of liquid water - !> H2O related constants (liquid, ice, snow), phase change constants - ! echam values - ! density of sea water in kg/m3 - ! density of ice in kg/m3 - ! density of snow in kg/m3 - ! density ratio (ice/water) - ! specific heat for liquid water J/K/kg - ! specific heat for sea water J/K/kg - ! specific heat for ice J/K/kg - ! specific heat for snow J/K/kg - ! thermal conductivity of ice in W/K/m - ! thermal conductivity of snow in W/K/m - ! echam values end - ! - !REAL(wp), PARAMETER :: clw = 4186.84_wp !! [J/K/kg] specific heat of water - ! !! see below - !> - phase changes - !> [J/kg] latent heat for vaporisation - !! [J/kg] latent heat for sublimation - !! [J/kg] latent heat for fusion - !! [K] melting temperature of ice/snow - ! - !> Auxiliary constants - !> [ ] - ! the next 2 values not as parameters due to ECHAM-dyn - !! [ ] - !! [ ] - !! [ ] - !! [K] - !! [K] - !! [K*kg/J] - !! [K*kg/J] - !! cp_d / cp_l - 1 - ! - !> specific heat capacity of liquid water - ! - !> [ ] - !! [ ] - !! [ ] - ! - !> [Pa] reference pressure for Exner function - !> Auxiliary constants used in ECHAM - ! Constants used for computation of saturation mixing ratio - ! over liquid water (*c_les*) or ice(*c_ies*) - ! - ! - ! - ! - ! - ! - ! - !> Variables for computing cloud cover in RH scheme - ! - !> vertical profile parameters (vpp) of CH4 and N2O - ! - !> constants for radiation module - !> lw sfc default emissivity factor - ! - !--------------------------- - ! Specifications, thresholds, and derived constants for the following subroutines: - ! s_lake, s_licetemp, s_sicetemp, meltpond, meltpond_ice, update_albedo_ice_meltpond - ! - ! mixed-layer depth of lakes in m - ! mixed-layer depth of ocean in m - ! minimum ice thickness in m - ! minimum ice thickness of pond ice in m - ! threshold ice thickness for pond closing in m - ! minimum pond depth for pond fraction in m - ! albedo of pond ice - ! - ! heat capacity of lake mixed layer - ! ! in J/K/m2 - ! heat capacity of upper ice layer - ! heat capacity of upper pond ice layer - ! - ! [J/m3] - ! [J/m3] - ! [m/K] - ! [K/m] - ! cooling below tmelt required to form dice - !--------------------------- - ! - !------------below are parameters for ocean model--------------- - ! coefficients in linear EOS - ! thermal expansion coefficient (kg/m3/K) - ! haline contraction coefficient (kg/m3/psu) - ! - ! density reference values, to be constant in Boussinesq ocean models - ! reference density [kg/m^3] - ! inverse reference density [m^3/kg] - ! reference salinity [psu] - ! - !Conversion from pressure [p] to pressure [bar] - ! !used in ocean thermodynamics - ! - ! [Pa] sea level pressure - ! - !----------below are parameters for sea-ice model--------------- - ! heat conductivity snow [J / (m s K)] - ! heat conductivity ice [J / (m s K)] - ! density of sea ice [kg / m3] - ! density of snow [kg / m3] - ! Heat capacity of ice [J / (kg K)] - ! Temperature ice bottom [C] - ! Sea-ice bulk salinity [ppt] - ! Constant in linear freezing- - ! ! point relationship [C/ppt] - ! = - (sea-ice liquidus - ! ! (aka melting) temperature) [C] - !REAL(wp), PARAMETER :: muS = -(-0.0575 + 1.710523E-3*Sqrt(Sice) - 2.154996E-4*Sice) * Sice - ! Albedo of snow (not melting) - ! Albedo of snow (melting) - ! Albedo of ice (not melting) - ! Albedo of ice (melting) - ! albedo of the ocean - !REAL(wp), PARAMETER :: I_0 = 0.3 ! Ice-surface penetrating shortwave fraction - ! Ice-surface penetrating shortwave fraction - !------------------------------------------------------------ - - ! read subroutines - END MODULE mo_physical_constants diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_psrad_interface.f90 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_psrad_interface.f90 deleted file mode 100644 index 4bac487a99..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_psrad_interface.f90 +++ /dev/null @@ -1,770 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_psrad_interface.f90 -! Generated at: 2015-02-19 15:30:28 -! KGEN version: 0.4.4 - - - - MODULE mo_psrad_interface - USE mo_spec_sampling, only : read_var_mod5 => kgen_read_var - USE mo_kind, ONLY: wp - USE mo_rrtm_params, ONLY: nbndlw - USE mo_rrtm_params, ONLY: maxinpx - USE mo_rrtm_params, ONLY: maxxsec - USE mo_lrtm_driver, ONLY: lrtm - USE mo_spec_sampling, ONLY: spec_sampling_strategy - IMPLICIT NONE - PUBLIC lw_strat - PUBLIC read_externs_mo_psrad_interface - INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - PUBLIC psrad_interface - type, public :: check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - end type check_t - TYPE(spec_sampling_strategy), save :: lw_strat - !< Spectral sampling strategies for longwave, shortwave - INTEGER, parameter :: rng_seed_size = 4 - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_mo_psrad_interface(kgen_unit) - integer, intent(in) :: kgen_unit - call read_var_mod5(lw_strat, kgen_unit) - END SUBROUTINE read_externs_mo_psrad_interface - - subroutine kgen_init_check(check,tolerance) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.E-14 - endif - end subroutine kgen_init_check - subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif - end subroutine kgen_print_check - !--------------------------------------------------------------------------- - !> - !! @brief Sets up (initializes) radation routines - !! - !! @remarks - !! Modify preset variables of module MO_RADIATION which control the - !! configuration of the radiation scheme. - ! - - !----------------------------------------------------------------------------- - !> - !! @brief arranges input and calls rrtm sw and lw routines - !! - !! @par Revision History - !! Original Source Rewritten and renamed by B. Stevens (2009-08) - !! - !! @remarks - !! Because the RRTM indexes vertical levels differently than ECHAM a chief - !! function of thise routine is to reorder the input in the vertical. In - !! addition some cloud physical properties are prescribed, which are - !! required to derive cloud optical properties - !! - !! @par The gases are passed into RRTM via two multi-constituent arrays: - !! zwkl and wx_r. zwkl has maxinpx species and wx_r has maxxsec species - !! The species are identifed as follows. - !! ZWKL [#/cm2] WX_R [#/cm2] - !! index = 1 => H20 index = 1 => n/a - !! index = 2 => CO2 index = 2 => CFC11 - !! index = 3 => O3 index = 3 => CFC12 - !! index = 4 => N2O index = 4 => n/a - !! index = 5 => n/a - !! index = 6 => CH4 - !! index = 7 => O2 - ! - - SUBROUTINE psrad_interface(kbdim, klev, nb_sw, kproma, ktrac, tk_sfc, kgen_unit) - integer, intent(in) :: kgen_unit - - ! read interface - !interface kgen_read_var - ! procedure read_var_real_wp_dim2 - ! procedure read_var_real_wp_dim1 - ! procedure read_var_real_wp_dim3 - ! procedure read_var_integer_4_dim2 - !end interface kgen_read_var - - - - ! verification interface - !interface kgen_verify_var - ! procedure verify_var_logical - ! procedure verify_var_integer - ! procedure verify_var_real - ! procedure verify_var_character - ! procedure verify_var_real_wp_dim2 - ! procedure verify_var_real_wp_dim1 - ! procedure verify_var_real_wp_dim3 - ! procedure verify_var_integer_4_dim2 - !end interface kgen_verify_var - - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - INTEGER, intent(in) :: kbdim - INTEGER, intent(in) :: klev - INTEGER, intent(in) :: nb_sw - INTEGER, intent(in) :: kproma - INTEGER, intent(in) :: ktrac - !< aerosol control - !< number of longitudes - !< first dimension of 2-d arrays - !< first dimension of 2-d arrays - !< number of levels - !< number of tracers - !< type of convection - !< number of shortwave bands - !< land sea mask, land=.true. - !< glacier mask, glacier=.true. - REAL(KIND=wp), intent(in) :: tk_sfc(kbdim) - !< surface emissivity - !< mu0 for solar zenith angle - !< geopotential above ground - !< surface albedo for vis range and dir light - !< surface albedo for NIR range and dir light - !< surface albedo for vis range and dif light - !< surface albedo for NIR range and dif light - !< full level pressure in Pa - !< half level pressure in Pa - !< surface pressure in Pa - !< full level temperature in K - !< half level temperature in K - !< surface temperature in K - !< specific humidity in g/g - !< specific liquid water content - !< specific ice content in g/g - !< cloud nuclei concentration - !< fractional cloud cover - !< total cloud cover in m2/m2 - !< o3 mass mixing ratio - !< co2 mass mixing ratio - !< ch4 mass mixing ratio - !< n2o mass mixing ratio - !< cfc volume mixing ratio - !< o2 mass mixing ratio - !< tracer mass mixing ratios - !< upward LW flux profile, all sky - !< upward LW flux profile, clear sky - !< downward LW flux profile, all sky - !< downward LW flux profile, clear sky - !< upward SW flux profile, all sky - !< upward SW flux profile, clear sky - !< downward SW flux profile, all sky - !< downward SW flux profile, clear sky - !< Visible (250-680) fraction of net surface radiation - !< Downward Photosynthetically Active Radiation (PAR) at surface - !< Diffuse fraction of downward surface near-infrared radiation - !< Diffuse fraction of downward surface visible radiation - !< Diffuse fraction of downward surface PAR - ! ------------------------------------------------------------------------------------- - !< loop indicies - !< index for clear or cloudy - REAL(KIND=wp) :: zsemiss (kbdim,nbndlw) - REAL(KIND=wp) :: pm_sfc (kbdim) - !< LW surface emissivity by band - !< pressure thickness in Pa - !< surface pressure in mb - !< pressure thickness - !< scratch array - ! - ! --- vertically reversed _vr variables - ! - REAL(KIND=wp) :: cld_frc_vr(kbdim,klev) - REAL(KIND=wp) :: aer_tau_lw_vr(kbdim,klev,nbndlw) - REAL(KIND=wp) :: pm_fl_vr (kbdim,klev) - REAL(KIND=wp) :: tk_fl_vr (kbdim,klev) - REAL(KIND=wp) :: tk_hl_vr (kbdim,klev+1) - REAL(KIND=wp) :: cld_tau_lw_vr(kbdim,klev,nbndlw) - REAL(KIND=wp) :: wkl_vr (kbdim,maxinpx,klev) - REAL(KIND=wp) :: wx_vr (kbdim,maxxsec,klev) - REAL(KIND=wp) :: col_dry_vr(kbdim,klev) - !< number of molecules/cm2 of - !< full level pressure [mb] - !< half level pressure [mb] - !< full level temperature [K] - !< half level temperature [K] - !< cloud nuclei concentration - !< secure cloud fraction - !< specific ice water content - !< ice water content per volume - !< ice water path in g/m2 - !< specific liquid water content - !< liquid water path in g/m2 - !< liquid water content per - !< effective radius of liquid - !< effective radius of ice - !< number of molecules/cm2 of - !< number of molecules/cm2 of - !< LW optical thickness of clouds - !< extincion - !< asymmetry factor - !< single scattering albedo - !< LW optical thickness of aerosols - !< aerosol optical thickness - !< aerosol asymmetry factor - !< aerosol single scattering albedo - REAL(KIND=wp) :: flx_uplw_vr(kbdim,klev+1) - REAL(KIND=wp), allocatable :: ref_flx_uplw_vr(:,:) - REAL(KIND=wp) :: flx_uplw_clr_vr(kbdim,klev+1) - REAL(KIND=wp), allocatable :: ref_flx_uplw_clr_vr(:,:) - REAL(KIND=wp) :: flx_dnlw_clr_vr(kbdim,klev+1) - REAL(KIND=wp), allocatable :: ref_flx_dnlw_clr_vr(:,:) - REAL(KIND=wp) :: flx_dnlw_vr(kbdim,klev+1) - REAL(KIND=wp), allocatable :: ref_flx_dnlw_vr(:,:) - !< upward flux, total sky - !< upward flux, clear sky - !< downward flux, total sky - !< downward flux, clear sky - ! - ! Random seeds for sampling. Needs to get somewhere upstream - ! - INTEGER :: rnseeds(kbdim,rng_seed_size) - INTEGER, allocatable :: ref_rnseeds(:,:) - ! - ! Number of g-points per time step. Determine here to allow automatic array allocation in - ! lrtm, srtm subroutines. - ! - INTEGER :: n_gpts_ts - ! 1.0 Constituent properties - !-------------------------------- - !IBM* ASSERT(NODEPS) - ! - ! --- control for zero, infintesimal or negative cloud fractions - ! - ! - ! --- main constituent reordering - ! - !IBM* ASSERT(NODEPS) - !IBM* ASSERT(NODEPS) - !IBM* ASSERT(NODEPS) - ! - ! --- CFCs are in volume mixing ratio - ! - !IBM* ASSERT(NODEPS) - ! - ! -- Convert to molecules/cm^2 - ! - ! - ! 2.0 Surface Properties - ! -------------------------------- - ! - ! 3.0 Particulate Optical Properties - ! -------------------------------- - ! - ! 3.5 Interface for submodels that provide aerosol and/or cloud radiative properties: - ! ----------------------------------------------------------------------------------- - ! - ! 4.0 Radiative Transfer Routines - ! -------------------------------- - ! - ! Seeds for random numbers come from least significant digits of pressure field - ! - tolerance = 1.E-12 - CALL kgen_init_check(check_status, tolerance) - READ(UNIT=kgen_unit) zsemiss - READ(UNIT=kgen_unit) pm_sfc - READ(UNIT=kgen_unit) cld_frc_vr - READ(UNIT=kgen_unit) aer_tau_lw_vr - READ(UNIT=kgen_unit) pm_fl_vr - READ(UNIT=kgen_unit) tk_fl_vr - READ(UNIT=kgen_unit) tk_hl_vr - READ(UNIT=kgen_unit) cld_tau_lw_vr - READ(UNIT=kgen_unit) wkl_vr - READ(UNIT=kgen_unit) wx_vr - READ(UNIT=kgen_unit) col_dry_vr - READ(UNIT=kgen_unit) flx_uplw_vr - READ(UNIT=kgen_unit) flx_uplw_clr_vr - READ(UNIT=kgen_unit) flx_dnlw_clr_vr - READ(UNIT=kgen_unit) flx_dnlw_vr - READ(UNIT=kgen_unit) rnseeds - READ(UNIT=kgen_unit) n_gpts_ts - - !call kgen_read_var(ref_flx_uplw_vr, kgen_unit) - !call kgen_read_var(ref_flx_uplw_clr_vr, kgen_unit) - !call kgen_read_var(ref_flx_dnlw_clr_vr, kgen_unit) - !call kgen_read_var(ref_flx_dnlw_vr, kgen_unit) - !call kgen_read_var(ref_rnseeds, kgen_unit) - call read_var_real_wp_dim2(ref_flx_uplw_vr, kgen_unit) - call read_var_real_wp_dim2(ref_flx_uplw_clr_vr, kgen_unit) - call read_var_real_wp_dim2(ref_flx_dnlw_clr_vr, kgen_unit) - call read_var_real_wp_dim2(ref_flx_dnlw_vr, kgen_unit) - call read_var_integer_4_dim2(ref_rnseeds, kgen_unit) - - ! call to kernel - CALL lrtm(kproma, kbdim, klev, pm_fl_vr, pm_sfc, tk_fl_vr, tk_hl_vr, tk_sfc, wkl_vr, wx_vr, col_dry_vr, zsemiss, cld_frc_vr, cld_tau_lw_vr, aer_tau_lw_vr, rnseeds, lw_strat, n_gpts_ts, flx_uplw_vr, flx_dnlw_vr, flx_uplw_clr_vr, flx_dnlw_clr_vr) - ! kernel verification for output variables - call verify_var_real_wp_dim2("flx_uplw_vr", check_status, flx_uplw_vr, ref_flx_uplw_vr) - call verify_var_real_wp_dim2("flx_uplw_clr_vr", check_status, flx_uplw_clr_vr, ref_flx_uplw_clr_vr) - call verify_var_real_wp_dim2("flx_dnlw_clr_vr", check_status, flx_dnlw_clr_vr, ref_flx_dnlw_clr_vr) - call verify_var_real_wp_dim2("flx_dnlw_vr", check_status, flx_dnlw_vr, ref_flx_dnlw_vr) - call verify_var_integer_4_dim2("rnseeds", check_status, rnseeds, ref_rnseeds) - CALL kgen_print_check("lrtm", check_status) - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,100 - CALL lrtm(kproma, kbdim, klev, pm_fl_vr, pm_sfc, tk_fl_vr, tk_hl_vr, tk_sfc, wkl_vr, wx_vr, col_dry_vr, zsemiss, cld_frc_vr, cld_tau_lw_vr, aer_tau_lw_vr, rnseeds, lw_strat, n_gpts_ts, flx_uplw_vr, flx_dnlw_vr, flx_uplw_clr_vr, flx_dnlw_clr_vr) - END DO - CALL system_clock(stop_clock, rate_clock) - WRITE(*,*) - PRINT *, "Elapsed time (sec): ", (stop_clock - start_clock)/REAL(rate_clock*100) - ! - ! Reset random seeds so SW doesn't depend on what's happened in LW but is also independent - ! - ! - ! Potential pitfall - we're passing every argument but some may not be present - ! - ! - ! 5.0 Post Processing - ! -------------------------------- - ! - ! Lw fluxes are vertically revered but SW fluxes are not - ! - ! - ! 6.0 Interface for submodel diagnosics after radiation calculation: - ! ------------------------------------------------------------------ - CONTAINS - - ! read subroutines - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim3(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:,:), allocatable :: var - integer, dimension(2,3) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_integer_4_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - integer(kind=4), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - - subroutine verify_var_logical(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - logical, intent(in) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - IF ( var .eqv. ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - endif - endif - check_status%numFatal = check_status%numFatal + 1 - END IF - end subroutine - - subroutine verify_var_integer(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - endif - endif - check_status%numFatal = check_status%numFatal + 1 - END IF - end subroutine - - subroutine verify_var_real(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real, intent(in) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - endif - endif - check_status%numFatal = check_status%numFatal + 1 - END IF - end subroutine - - subroutine verify_var_character(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - character(*), intent(in) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - end subroutine - - subroutine verify_var_real_wp_dim2(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(kind=wp), intent(in), dimension(:,:) :: var - real(kind=wp), intent(in), allocatable, dimension(:,:) :: ref_var - real(kind=wp) :: nrmsdiff, rmsdiff - real(kind=wp), allocatable :: temp(:,:), temp2(:,:) - integer :: n - - - IF ( ALLOCATED(ref_var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - IF ( ALL( var == ref_var ) ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - n = count(var/=ref_var) - where(ref_var .NE. 0) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - END IF - deallocate(temp,temp2) - END IF - end subroutine - - subroutine verify_var_real_wp_dim1(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(kind=wp), intent(in), dimension(:) :: var - real(kind=wp), intent(in), allocatable, dimension(:) :: ref_var - real(kind=wp) :: nrmsdiff, rmsdiff - real(kind=wp), allocatable :: temp(:), temp2(:) - integer :: n - - - IF ( ALLOCATED(ref_var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - allocate(temp(SIZE(var,dim=1))) - allocate(temp2(SIZE(var,dim=1))) - IF ( ALL( var == ref_var ) ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - n = count(var/=ref_var) - where(ref_var .NE. 0) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - END IF - deallocate(temp,temp2) - END IF - end subroutine - - subroutine verify_var_real_wp_dim3(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(kind=wp), intent(in), dimension(:,:,:) :: var - real(kind=wp), intent(in), allocatable, dimension(:,:,:) :: ref_var - real(kind=wp) :: nrmsdiff, rmsdiff - real(kind=wp), allocatable :: temp(:,:,:), temp2(:,:,:) - integer :: n - - - IF ( ALLOCATED(ref_var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - IF ( ALL( var == ref_var ) ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - n = count(var/=ref_var) - where(ref_var .NE. 0) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - END IF - deallocate(temp,temp2) - END IF - end subroutine - - subroutine verify_var_integer_4_dim2(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer(kind=4), intent(in), dimension(:,:) :: var - integer(kind=4), intent(in), allocatable, dimension(:,:) :: ref_var - integer(kind=4) :: nrmsdiff, rmsdiff - integer(kind=4), allocatable :: temp(:,:), temp2(:,:) - integer :: n - - - IF ( ALLOCATED(ref_var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - IF ( ALL( var == ref_var ) ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - n = count(var/=ref_var) - where(ref_var .NE. 0) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - END IF - deallocate(temp,temp2) - END IF - end subroutine - - END SUBROUTINE psrad_interface - END MODULE mo_psrad_interface diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_rad_fastmath.f90 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_rad_fastmath.f90 deleted file mode 100644 index 0df00ac882..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_rad_fastmath.f90 +++ /dev/null @@ -1,84 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_rad_fastmath.f90 -! Generated at: 2015-02-19 15:30:32 -! KGEN version: 0.4.4 - - - - MODULE mo_rad_fastmath - USE mo_kind, ONLY: dp - USE mo_kind, ONLY: wp - IMPLICIT NONE - PRIVATE - PUBLIC tautrans, inv_expon, transmit - !< Optical depth - !< Exponential lookup table (EXP(-tau)) - !< Tau transition function - ! i.e. the transition of the Planck function from that for the mean layer temperature - ! to that for the layer boundary temperature as a function of optical depth. - ! The "linear in tau" method is used to make the table. - !< Value of tau below which expansion is used - !< Smallest value for exponential table - !< Pade approximation constant - REAL(KIND=wp), parameter :: rec_6 = 1._wp/6._wp - ! - ! The RRTMG tables are indexed with INT(tblint * x(i)/(bpade + x(i)) + 0.5_wp) - ! But these yield unstable values in the SW solver for some parameter sets, so - ! we'll remove this option (though the tables are initialized if people want them). - ! RRTMG table lookups are approximated second-order Taylor series expansion - ! (e.g. exp(-x) = 1._wp - x(1:n) + 0.5_wp * x(1:n)**2, tautrans = x/6._wp) for x < od_lo - ! - CONTAINS - - ! read subroutines - ! ------------------------------------------------------------ - - ! ------------------------------------------------------------ - - ! ------------------------------------------------------------ - - FUNCTION inv_expon(x, n) - ! - ! Compute EXP(-x) - but do it fast - ! - INTEGER, intent(in) :: n - REAL(KIND=dp), intent(in) :: x(n) - REAL(KIND=dp) :: inv_expon(n) - inv_expon(1:n) = exp(-x(1:n)) - END FUNCTION inv_expon - ! ------------------------------------------------------------ - - FUNCTION transmit(x, n) - ! - ! Compute transmittance 1 - EXP(-x) - ! - INTEGER, intent(in) :: n - REAL(KIND=dp), intent(in) :: x(n) - REAL(KIND=dp) :: transmit(n) - ! - ! MASS and MKL libraries have exp(x) - 1 functions; we could - ! use those here - ! - transmit(1:n) = 1._wp - inv_expon(x,n) - END FUNCTION transmit - ! ------------------------------------------------------------ - - FUNCTION tautrans(x, n) - ! - ! Compute "tau transition" using linear-in-tau approximation - ! - INTEGER, intent(in) :: n - REAL(KIND=dp), intent(in) :: x(n) - REAL(KIND=dp) :: tautrans(n) - REAL(KIND=dp) :: y(n) - ! - ! Default calculation is unstable (NaN) for the very lowest value of tau (3.6e-4) - ! - y(:) = inv_expon(x,n) - tautrans(:) = merge(1._wp - 2._wp*(1._wp/x(1:n) - y(:)/(1._wp-y(:))), x * rec_6, & - x > 1.e-3_wp) - END FUNCTION tautrans - ! ------------------------------------------------------------ - END MODULE mo_rad_fastmath diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_radiation_parameters.f90 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_radiation_parameters.f90 deleted file mode 100644 index dc08eb4811..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_radiation_parameters.f90 +++ /dev/null @@ -1,115 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_radiation_parameters.f90 -! Generated at: 2015-02-19 15:30:29 -! KGEN version: 0.4.4 - - - - MODULE mo_radiation_parameters - USE mo_kind, ONLY: wp - IMPLICIT NONE - PRIVATE - PUBLIC i_overlap, l_do_sep_clear_sky - PUBLIC rad_undef - ! Standalone radiative transfer parameters - PUBLIC do_gpoint ! Standalone use only - ! 1.0 NAMELIST global variables and parameters - ! -------------------------------- - !< diurnal cycle - !< &! switch on/off diagnostic - !of instantaneous aerosol solar (lradforcing(1)) and - !thermal (lradforcing(2)) radiation forcing - !< switch to specify perpetual vsop87 year - !< year if (lyr_perp == .TRUE.) - !< 0=annual cycle; 1-12 for perpetual month - ! nmonth currently works for zonal mean ozone and the orbit (year 1987) only - !< mode of solar constant calculation - !< default is rrtm solar constant - !< number of shortwave bands, set in setup - ! Spectral sampling - ! 1 is broadband, 2 is MCSI, 3 and up are teams - ! Number of g-points per time step using MCSI - ! Integer for perturbing random number seeds - ! Use unique spectral samples under MCSI? Not yet implemented - INTEGER :: do_gpoint = 0 ! Standalone use only - specify gpoint to use - ! Radiation driver - LOGICAL :: l_do_sep_clear_sky = .true. ! Compute clear-sky fluxes by removing clouds - INTEGER :: i_overlap = 1 ! 1 = max-ran, 2 = max, 3 = ran - ! Use separate water vapor amounts in clear, cloudy skies - ! - ! --- Switches for radiative agents - ! - !< water vapor, clouds and ice for radiation - !< carbon dioxide - !< methane - !< ozone - !< molecular oxygen - !< nitrous oxide - !< cfc11 and cfc12 - !< greenhouse gase scenario - !< aerosol model - !< factor for external co2 scenario (ico2=4) - ! - ! --- Default gas volume mixing ratios - 1990 values (CMIP5) - ! - !< CO2 - !< CH4 - !< O2 - !< N20 - !< CFC 11 and CFC 12 - ! - ! 2.0 Non NAMELIST global variables and parameters - ! -------------------------------- - ! - ! --- radiative transfer parameters - ! - !< LW Emissivity Factor - !< LW Diffusivity Factor - REAL(KIND=wp), parameter :: rad_undef = -999._wp - ! - ! - !< default solar constant [W/m2] for - ! AMIP-type CMIP5 simulation - !++hs - !< local (orbit relative and possibly - ! time dependent) solar constant - !< orbit and time dependent solar constant for radiation time step - !< fraction of TSI in the 14 RRTM SW bands - !--hs - !< solar declination at current time step - ! - ! 3.0 Variables computed by routines in mo_radiation (export to submodels) - ! -------------------------------- - ! - ! setup_radiation - PUBLIC read_externs_mo_radiation_parameters - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_mo_radiation_parameters(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) do_gpoint - READ(UNIT=kgen_unit) l_do_sep_clear_sky - READ(UNIT=kgen_unit) i_overlap - END SUBROUTINE read_externs_mo_radiation_parameters - - - ! read subroutines - !--------------------------------------------------------------------------- - !> - !! @brief Scans a block and fills with solar parameters - !! - !! @remarks: This routine calculates the solar zenith angle for each - !! point in a block of data. For simulations with no dirunal cycle - !! the cosine of the zenith angle is set to its average value (assuming - !! negatives to be zero and for a day divided into nds intervals). - !! Additionally a field is set indicating the fraction of the day over - !! which the solar zenith angle is greater than zero. Otherwise the field - !! is set to 1 or 0 depending on whether the zenith angle is greater or - !! less than 1. - ! - - END MODULE mo_radiation_parameters diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_random_numbers.f90 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_random_numbers.f90 deleted file mode 100644 index cf0916b327..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_random_numbers.f90 +++ /dev/null @@ -1,141 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_random_numbers.f90 -! Generated at: 2015-02-19 15:30:29 -! KGEN version: 0.4.4 - - - - MODULE mo_random_numbers - USE mo_kind, ONLY: dp - USE mo_kind, ONLY: i8 - IMPLICIT NONE - LOGICAL, parameter :: big_endian = (transfer(1_i8, 1) == 0) - INTEGER, parameter :: state_size = 4 - INTEGER :: global_seed(state_size) = (/123456789,362436069,21288629,14921776/) - PRIVATE - PUBLIC get_random - - INTERFACE get_random - MODULE PROCEDURE kisssca, kiss_global, kissvec, kissvec_all, kissvec_global - END INTERFACE get_random - PUBLIC read_externs_mo_random_numbers - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_integer_4_dim1 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_mo_random_numbers(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) global_seed - END SUBROUTINE read_externs_mo_random_numbers - - - ! read subroutines - subroutine read_var_integer_4_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - integer(kind=4), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - ! ----------------------------------------------- - - ! ----------------------------------------------- - - ! ----------------------------------------------- - - SUBROUTINE kissvec_all(kproma, kbdim, seed, harvest) - INTEGER, intent(in ) :: kbdim - INTEGER, intent(in ) :: kproma - INTEGER, intent(inout) :: seed(:,:) ! Dimension nproma, seed_size - REAL(KIND=dp), intent( out) :: harvest(:) ! Dimension nproma - LOGICAL :: mask(kbdim) - mask(:) = .true. - CALL kissvec(kproma, kbdim, seed, mask, harvest) - END SUBROUTINE kissvec_all - ! ----------------------------------------------- - - SUBROUTINE kissvec(kproma, kbdim, seed, mask, harvest) - INTEGER, intent(in ) :: kbdim - INTEGER, intent(in ) :: kproma - INTEGER, intent(inout) :: seed(:,:) ! Dimension kbdim, seed_size or bigger - LOGICAL, intent(in ) :: mask(kbdim) - REAL(KIND=dp), intent( out) :: harvest(kbdim) - INTEGER(KIND=i8) :: kiss(kproma) - INTEGER :: jk - DO jk = 1, kproma - IF (mask(jk)) THEN - kiss(jk) = 69069_i8 * seed(jk,1) + 1327217885 - seed(jk,1) = low_byte(kiss(jk)) - seed(jk,2) = m (m (m (seed(jk,2), 13), - 17), 5) - seed(jk,3) = 18000 * iand (seed(jk,3), 65535) + ishft (seed(jk,3), - 16) - seed(jk,4) = 30903 * iand (seed(jk,4), 65535) + ishft (seed(jk,4), - 16) - kiss(jk) = int(seed(jk,1), i8) + seed(jk,2) + ishft (seed(jk,3), 16) + seed(jk,4) - harvest(jk) = low_byte(kiss(jk))*2.328306e-10_dp + 0.5_dp - ELSE - harvest(jk) = 0._dp - END IF - END DO - END SUBROUTINE kissvec - ! ----------------------------------------------- - - SUBROUTINE kisssca(seed, harvest) - INTEGER, intent(inout) :: seed(:) - REAL(KIND=dp), intent( out) :: harvest - INTEGER(KIND=i8) :: kiss - kiss = 69069_i8 * seed(1) + 1327217885 - seed(1) = low_byte(kiss) - seed(2) = m (m (m (seed(2), 13), - 17), 5) - seed(3) = 18000 * iand (seed(3), 65535) + ishft (seed(3), - 16) - seed(4) = 30903 * iand (seed(4), 65535) + ishft (seed(4), - 16) - kiss = int(seed(1), i8) + seed(2) + ishft (seed(3), 16) + seed(4) - harvest = low_byte(kiss)*2.328306e-10_dp + 0.5_dp - END SUBROUTINE kisssca - ! ----------------------------------------------- - - SUBROUTINE kiss_global(harvest) - REAL(KIND=dp), intent(inout) :: harvest - CALL kisssca(global_seed, harvest) - END SUBROUTINE kiss_global - ! ----------------------------------------------- - - SUBROUTINE kissvec_global(harvest) - REAL(KIND=dp), intent(inout) :: harvest(:) - INTEGER :: i - DO i = 1, size(harvest) - CALL kisssca(global_seed, harvest(i)) - END DO - END SUBROUTINE kissvec_global - ! ----------------------------------------------- - - elemental integer FUNCTION m(k, n) - INTEGER, intent(in) :: k - INTEGER, intent(in) :: n - m = ieor (k, ishft (k, n)) ! UNRESOLVED: m - END FUNCTION m - ! ----------------------------------------------- - - elemental integer FUNCTION low_byte(i) - INTEGER(KIND=i8), intent(in) :: i - IF (big_endian) THEN - low_byte = transfer(ishft(i,bit_size(1)),1) ! UNRESOLVED: low_byte - ELSE - low_byte = transfer(i,1) ! UNRESOLVED: low_byte - END IF - END FUNCTION low_byte - END MODULE mo_random_numbers diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_rrtm_coeffs.f90 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_rrtm_coeffs.f90 deleted file mode 100644 index 6ce71ad64b..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_rrtm_coeffs.f90 +++ /dev/null @@ -1,314 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_rrtm_coeffs.f90 -! Generated at: 2015-02-19 15:30:32 -! KGEN version: 0.4.4 - - - - MODULE mo_rrtm_coeffs - USE mo_kind, ONLY: wp - USE mo_rrtm_params, ONLY: preflog - USE mo_rrtm_params, ONLY: tref - USE rrlw_planck, ONLY: chi_mls - IMPLICIT NONE - REAL(KIND=wp), parameter :: stpfac = 296._wp/1013._wp - CONTAINS - - ! read subroutines - ! -------------------------------------------------------------------------------------------- - - SUBROUTINE lrtm_coeffs(kproma, kbdim, klev, play, tlay, coldry, wkl, wbroad, laytrop, jp, jt, jt1, colh2o, colco2, colo3, & - coln2o, colco, colch4, colo2, colbrd, fac00, fac01, fac10, fac11, rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, & - rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, selffac, selffrac, & - indself, forfac, forfrac, indfor, minorfrac, scaleminor, scaleminorn2, indminor) - INTEGER, intent(in) :: kbdim - INTEGER, intent(in) :: klev - INTEGER, intent(in) :: kproma - ! number of columns - ! maximum number of column as first dim is declared in calling (sub)prog. - ! total number of layers - REAL(KIND=wp), intent(in) :: wkl(:,:,:) - REAL(KIND=wp), intent(in) :: play(kbdim,klev) - REAL(KIND=wp), intent(in) :: tlay(kbdim,klev) - REAL(KIND=wp), intent(in) :: coldry(kbdim,klev) - REAL(KIND=wp), intent(in) :: wbroad(kbdim,klev) - ! layer pressures (mb) - ! layer temperatures (K) - ! dry air column density (mol/cm2) - ! broadening gas column density (mol/cm2) - !< molecular amounts (mol/cm-2) (mxmol,klev) - ! - ! Output Dimensions kproma, klev unless otherwise specified - ! - INTEGER, intent(out) :: laytrop(kbdim) - INTEGER, intent(out) :: jp(kbdim,klev) - INTEGER, intent(out) :: jt(kbdim,klev) - INTEGER, intent(out) :: jt1(kbdim,klev) - INTEGER, intent(out) :: indfor(kbdim,klev) - INTEGER, intent(out) :: indself(kbdim,klev) - INTEGER, intent(out) :: indminor(kbdim,klev) - !< tropopause layer index - ! - ! - ! - ! - ! - ! - REAL(KIND=wp), intent(out) :: forfac(kbdim,klev) - REAL(KIND=wp), intent(out) :: colch4(kbdim,klev) - REAL(KIND=wp), intent(out) :: colco2(kbdim,klev) - REAL(KIND=wp), intent(out) :: colh2o(kbdim,klev) - REAL(KIND=wp), intent(out) :: coln2o(kbdim,klev) - REAL(KIND=wp), intent(out) :: forfrac(kbdim,klev) - REAL(KIND=wp), intent(out) :: selffrac(kbdim,klev) - REAL(KIND=wp), intent(out) :: colo3(kbdim,klev) - REAL(KIND=wp), intent(out) :: fac00(kbdim,klev) - REAL(KIND=wp), intent(out) :: colo2(kbdim,klev) - REAL(KIND=wp), intent(out) :: fac01(kbdim,klev) - REAL(KIND=wp), intent(out) :: fac10(kbdim,klev) - REAL(KIND=wp), intent(out) :: fac11(kbdim,klev) - REAL(KIND=wp), intent(out) :: selffac(kbdim,klev) - REAL(KIND=wp), intent(out) :: colbrd(kbdim,klev) - REAL(KIND=wp), intent(out) :: colco(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_h2oco2(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_h2oco2_1(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_h2oo3(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_h2oo3_1(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_h2on2o(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_h2on2o_1(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_h2och4(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_h2och4_1(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_n2oco2(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_n2oco2_1(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_o3co2(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_o3co2_1(kbdim,klev) - REAL(KIND=wp), intent(out) :: scaleminor(kbdim,klev) - REAL(KIND=wp), intent(out) :: scaleminorn2(kbdim,klev) - REAL(KIND=wp), intent(out) :: minorfrac(kbdim,klev) - !< column amount (h2o) - !< column amount (co2) - !< column amount (o3) - !< column amount (n2o) - !< column amount (co) - !< column amount (ch4) - !< column amount (o2) - !< column amount (broadening gases) - !< - !< - !< - !< - !< - INTEGER :: jk - REAL(KIND=wp) :: colmol(kbdim,klev) - REAL(KIND=wp) :: factor(kbdim,klev) - ! ------------------------------------------------ - CALL srtm_coeffs(kproma, kbdim, klev, play, tlay, coldry, wkl, laytrop, jp, jt, jt1, colch4, colco2, colh2o, colmol, & - coln2o, colo2, colo3, fac00, fac01, fac10, fac11, selffac, selffrac, indself, forfac, forfrac, indfor) - colbrd(1:kproma,1:klev) = 1.e-20_wp * wbroad(1:kproma,1:klev) - colco(1:kproma,1:klev) = merge(1.e-20_wp * wkl(1:kproma,5,1:klev), 1.e-32_wp * & - coldry(1:kproma,1:klev), wkl(1:kproma,5,1:klev) > 0._wp) - ! - ! Water vapor continuum broadening factors are used differently in LW and SW? - ! - forfac(1:kproma,1:klev) = forfac(1:kproma,1:klev) * colh2o(1:kproma,1:klev) - selffac(1:kproma,1:klev) = selffac(1:kproma,1:klev) * colh2o(1:kproma,1:klev) - ! - ! Setup reference ratio to be used in calculation of binary species parameter. - ! - DO jk = 1, klev - rat_h2oco2(1:kproma, jk) = chi_mls(1,jp(1:kproma, jk))/chi_mls(2,jp(1:kproma, jk)) - rat_h2oco2_1(1:kproma, jk) = chi_mls(1,jp(1:kproma, jk)+1)/chi_mls(2,jp(1:kproma, jk)+1) - ! - ! Needed only in lower atmos (plog > 4.56_wp) - ! - rat_h2oo3(1:kproma, jk) = chi_mls(1,jp(1:kproma, jk))/chi_mls(3,jp(1:kproma, jk)) - rat_h2oo3_1(1:kproma, jk) = chi_mls(1,jp(1:kproma, jk)+1)/chi_mls(3,jp(1:kproma, jk)+1) - rat_h2on2o(1:kproma, jk) = chi_mls(1,jp(1:kproma, jk))/chi_mls(4,jp(1:kproma, jk)) - rat_h2on2o_1(1:kproma, jk) = chi_mls(1,jp(1:kproma, jk)+1)/chi_mls(4,jp(1:kproma, jk)+1) - rat_h2och4(1:kproma, jk) = chi_mls(1,jp(1:kproma, jk))/chi_mls(6,jp(1:kproma, jk)) - rat_h2och4_1(1:kproma, jk) = chi_mls(1,jp(1:kproma, jk)+1)/chi_mls(6,jp(1:kproma, jk)+1) - rat_n2oco2(1:kproma, jk) = chi_mls(4,jp(1:kproma, jk))/chi_mls(2,jp(1:kproma, jk)) - rat_n2oco2_1(1:kproma, jk) = chi_mls(4,jp(1:kproma, jk)+1)/chi_mls(2,jp(1:kproma, jk)+1) - ! - ! Needed only in upper atmos (plog <= 4.56_wp) - ! - rat_o3co2(1:kproma, jk) = chi_mls(3,jp(1:kproma, jk))/chi_mls(2,jp(1:kproma, jk)) - rat_o3co2_1(1:kproma, jk) = chi_mls(3,jp(1:kproma, jk)+1)/chi_mls(2,jp(1:kproma, jk)+1) - END DO - ! - ! Set up factors needed to separately include the minor gases - ! in the calculation of absorption coefficient - ! - scaleminor(1:kproma,1:klev) = play(1:kproma,1:klev)/tlay(1:kproma,1:klev) - scaleminorn2(1:kproma,1:klev) = scaleminor(1:kproma,1:klev) * (wbroad(1:kproma,1:klev)/(& - coldry(1:kproma,1:klev)+wkl(1:kproma,1,1:klev))) - factor(1:kproma,1:klev) = (tlay(1:kproma,1:klev)-180.8_wp)/7.2_wp - indminor(1:kproma,1:klev) = min(18, max(1, int(factor(1:kproma,1:klev)))) - minorfrac(1:kproma,1:klev) = (tlay(1:kproma,1:klev)-180.8_wp)/7.2_wp - float(indminor(1:kproma,1:klev)) - END SUBROUTINE lrtm_coeffs - ! -------------------------------------------------------------------------------------------- - - SUBROUTINE srtm_coeffs(kproma, kbdim, klev, play, tlay, coldry, wkl, laytrop, jp, jt, jt1, colch4, colco2, colh2o, colmol,& - coln2o, colo2, colo3, fac00, fac01, fac10, fac11, selffac, selffrac, indself, forfac, forfrac, indfor) - INTEGER, intent(in) :: kbdim - INTEGER, intent(in) :: klev - INTEGER, intent(in) :: kproma - ! number of columns - ! maximum number of col. as declared in calling (sub)programs - ! total number of layers - REAL(KIND=wp), intent(in) :: play(kbdim,klev) - REAL(KIND=wp), intent(in) :: tlay(kbdim,klev) - REAL(KIND=wp), intent(in) :: wkl(:,:,:) - REAL(KIND=wp), intent(in) :: coldry(kbdim,klev) - ! layer pressures (mb) - ! layer temperatures (K) - ! dry air column density (mol/cm2) - !< molecular amounts (mol/cm-2) (mxmol,klev) - ! - ! Output Dimensions kproma, klev unless otherwise specified - ! - INTEGER, intent(out) :: jp(kbdim,klev) - INTEGER, intent(out) :: jt(kbdim,klev) - INTEGER, intent(out) :: jt1(kbdim,klev) - INTEGER, intent(out) :: laytrop(kbdim) - INTEGER, intent(out) :: indfor(kbdim,klev) - INTEGER, intent(out) :: indself(kbdim,klev) - !< tropopause layer index - ! - ! - ! - ! - REAL(KIND=wp), intent(out) :: fac10(kbdim,klev) - REAL(KIND=wp), intent(out) :: fac00(kbdim,klev) - REAL(KIND=wp), intent(out) :: fac11(kbdim,klev) - REAL(KIND=wp), intent(out) :: fac01(kbdim,klev) - REAL(KIND=wp), intent(out) :: colh2o(kbdim,klev) - REAL(KIND=wp), intent(out) :: colco2(kbdim,klev) - REAL(KIND=wp), intent(out) :: colo3(kbdim,klev) - REAL(KIND=wp), intent(out) :: coln2o(kbdim,klev) - REAL(KIND=wp), intent(out) :: colch4(kbdim,klev) - REAL(KIND=wp), intent(out) :: colo2(kbdim,klev) - REAL(KIND=wp), intent(out) :: colmol(kbdim,klev) - REAL(KIND=wp), intent(out) :: forfac(kbdim,klev) - REAL(KIND=wp), intent(out) :: selffac(kbdim,klev) - REAL(KIND=wp), intent(out) :: forfrac(kbdim,klev) - REAL(KIND=wp), intent(out) :: selffrac(kbdim,klev) - !< column amount (h2o) - !< column amount (co2) - !< column amount (o3) - !< column amount (n2o) - !< column amount (ch4) - !< column amount (o2) - !< - !< - !< - !< - !< - INTEGER :: jp1(kbdim,klev) - INTEGER :: jk - REAL(KIND=wp) :: plog (kbdim,klev) - REAL(KIND=wp) :: fp (kbdim,klev) - REAL(KIND=wp) :: ft (kbdim,klev) - REAL(KIND=wp) :: ft1 (kbdim,klev) - REAL(KIND=wp) :: water (kbdim,klev) - REAL(KIND=wp) :: scalefac(kbdim,klev) - REAL(KIND=wp) :: compfp(kbdim,klev) - REAL(KIND=wp) :: factor (kbdim,klev) - ! ------------------------------------------------------------------------- - ! - ! Find the two reference pressures on either side of the - ! layer pressure. Store them in JP and JP1. Store in FP the - ! fraction of the difference (in ln(pressure)) between these - ! two values that the layer pressure lies. - ! - plog(1:kproma,1:klev) = log(play(1:kproma,1:klev)) - jp(1:kproma,1:klev) = min(58,max(1,int(36._wp - 5*(plog(1:kproma,1:klev)+0.04_wp)))) - jp1(1:kproma,1:klev) = jp(1:kproma,1:klev) + 1 - DO jk = 1, klev - fp(1:kproma,jk) = 5._wp *(preflog(jp(1:kproma,jk)) - plog(1:kproma,jk)) - END DO - ! - ! Determine, for each reference pressure (JP and JP1), which - ! reference temperature (these are different for each - ! reference pressure) is nearest the layer temperature but does - ! not exceed it. Store these indices in JT and JT1, resp. - ! Store in FT (resp. FT1) the fraction of the way between JT - ! (JT1) and the next highest reference temperature that the - ! layer temperature falls. - ! - DO jk = 1, klev - jt(1:kproma,jk) = min(4,max(1,int(3._wp + (tlay(1:kproma,jk) - tref(& - jp (1:kproma,jk)))/15._wp))) - jt1(1:kproma,jk) = min(4,max(1,int(3._wp + (tlay(1:kproma,jk) - & - tref(jp1(1:kproma,jk)))/15._wp))) - END DO - DO jk = 1, klev - ft(1:kproma,jk) = ((tlay(1:kproma,jk)-tref(jp (1:kproma,jk)))/15._wp) - float(jt (& - 1:kproma,jk)-3) - ft1(1:kproma,jk) = ((tlay(1:kproma,jk)-tref(jp1(1:kproma,jk)))/15._wp) - float(jt1(& - 1:kproma,jk)-3) - END DO - water(1:kproma,1:klev) = wkl(1:kproma,1,1:klev)/coldry(1:kproma,1:klev) - scalefac(1:kproma,1:klev) = play(1:kproma,1:klev) * stpfac / tlay(1:kproma,1:klev) - ! - ! We have now isolated the layer ln pressure and temperature, - ! between two reference pressures and two reference temperatures - ! (for each reference pressure). We multiply the pressure - ! fraction FP with the appropriate temperature fractions to get - ! the factors that will be needed for the interpolation that yields - ! the optical depths (performed in routines TAUGBn for band n).` - ! - compfp(1:kproma,1:klev) = 1. - fp(1:kproma,1:klev) - fac10(1:kproma,1:klev) = compfp(1:kproma,1:klev) * ft(1:kproma,1:klev) - fac00(1:kproma,1:klev) = compfp(1:kproma,1:klev) * (1._wp - ft(1:kproma,1:klev)) - fac11(1:kproma,1:klev) = fp(1:kproma,1:klev) * ft1(1:kproma,1:klev) - fac01(1:kproma,1:klev) = fp(1:kproma,1:klev) * (1._wp - ft1(1:kproma,1:klev)) - ! Tropopause defined in terms of pressure (~100 hPa) - ! We're looking for the first layer (counted from the bottom) at which the pressure reaches - ! or falls below this value - ! - laytrop(1:kproma) = count(plog(1:kproma,1:klev) > 4.56_wp, dim = 2) - ! - ! Calculate needed column amounts. - ! Only a few ratios are used in the upper atmosphere but masking may be less efficient - ! - colh2o(1:kproma,1:klev) = merge(1.e-20_wp * wkl(1:kproma,1,1:klev), 1.e-32_wp * & - coldry(1:kproma,1:klev), wkl(1:kproma,1,1:klev) > 0._wp) - colco2(1:kproma,1:klev) = merge(1.e-20_wp * wkl(1:kproma,2,1:klev), 1.e-32_wp * & - coldry(1:kproma,1:klev), wkl(1:kproma,2,1:klev) > 0._wp) - colo3(1:kproma,1:klev) = merge(1.e-20_wp * wkl(1:kproma,3,1:klev), 1.e-32_wp * & - coldry(1:kproma,1:klev), wkl(1:kproma,3,1:klev) > 0._wp) - coln2o(1:kproma,1:klev) = merge(1.e-20_wp * wkl(1:kproma,4,1:klev), 1.e-32_wp * & - coldry(1:kproma,1:klev), wkl(1:kproma,4,1:klev) > 0._wp) - colch4(1:kproma,1:klev) = merge(1.e-20_wp * wkl(1:kproma,6,1:klev), 1.e-32_wp * & - coldry(1:kproma,1:klev), wkl(1:kproma,6,1:klev) > 0._wp) - colo2(1:kproma,1:klev) = merge(1.e-20_wp * wkl(1:kproma,7,1:klev), 1.e-32_wp * & - coldry(1:kproma,1:klev), wkl(1:kproma,7,1:klev) > 0._wp) - colmol(1:kproma,1:klev) = 1.e-20_wp * coldry(1:kproma,1:klev) + colh2o(1:kproma,1:klev) - ! ------------------------------------------ - ! Interpolation coefficients - ! - forfac(1:kproma,1:klev) = scalefac(1:kproma,1:klev) / (1._wp+water(1:kproma,1:klev)) - ! - ! Set up factors needed to separately include the water vapor - ! self-continuum in the calculation of absorption coefficient. - ! - selffac(1:kproma,1:klev) = water(1:kproma,1:klev) * forfac(1:kproma,1:klev) - ! - ! If the pressure is less than ~100mb, perform a different set of species - ! interpolations. - ! - factor(1:kproma,1:klev) = (332.0_wp-tlay(1:kproma,1:klev))/36.0_wp - indfor(1:kproma,1:klev) = merge(3, min(2, max(1, int(factor(1:kproma,& - 1:klev)))), plog(1:kproma,1:klev) <= 4.56_wp) - forfrac(1:kproma,1:klev) = merge((tlay(1:kproma,1:klev)-188.0_wp)/36.0_wp - 1.0_wp, factor(1:kproma,& - 1:klev) - float(indfor(1:kproma,1:klev)), plog(1:kproma,1:klev) <= 4.56_wp) - ! In RRTMG code, this calculation is done only in the lower atmosphere (plog > 4.56) - ! - factor(1:kproma,1:klev) = (tlay(1:kproma,1:klev)-188.0_wp)/7.2_wp - indself(1:kproma,1:klev) = min(9, max(1, int(factor(1:kproma,1:klev))-7)) - selffrac(1:kproma,1:klev) = factor(1:kproma,1:klev) - float(indself(1:kproma,1:klev) + 7) - END SUBROUTINE srtm_coeffs - END MODULE mo_rrtm_coeffs diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_rrtm_params.f90 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_rrtm_params.f90 deleted file mode 100644 index fac2c9c41a..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_rrtm_params.f90 +++ /dev/null @@ -1,56 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_rrtm_params.f90 -! Generated at: 2015-02-19 15:30:37 -! KGEN version: 0.4.4 - - - - MODULE mo_rrtm_params - USE mo_kind, ONLY: wp - IMPLICIT NONE - PUBLIC - !! ----------------------------------------------------------------------------------------- - !! - !! Shared parameters - !! - !< number of original g-intervals per spectral band - INTEGER, parameter :: maxxsec= 4 !< maximum number of cross-section molecules (cfcs) - INTEGER, parameter :: maxinpx= 38 - !< number of last band (lw and sw share band 16) - !< number of spectral bands in sw model - !< total number of gpts - !< first band in sw - !< last band in sw - INTEGER, parameter :: nbndlw = 16 !< number of spectral bands in lw model - INTEGER, parameter :: ngptlw = 140 !< total number of reduced g-intervals for rrtmg_lw - ! - ! These pressures are chosen such that the ln of the first pressure - ! has only a few non-zero digits (i.e. ln(PREF(1)) = 6.96000) and - ! each subsequent ln(pressure) differs from the previous one by 0.2. - ! - REAL(KIND=wp), parameter :: preflog(59) = (/ 6.9600e+00_wp, 6.7600e+00_wp, 6.5600e+00_wp, 6.3600e+00_wp, & - 6.1600e+00_wp, 5.9600e+00_wp, 5.7600e+00_wp, 5.5600e+00_wp, 5.3600e+00_wp, 5.1600e+00_wp, 4.9600e+00_wp, & - 4.7600e+00_wp, 4.5600e+00_wp, 4.3600e+00_wp, 4.1600e+00_wp, 3.9600e+00_wp, 3.7600e+00_wp, 3.5600e+00_wp, & - 3.3600e+00_wp, 3.1600e+00_wp, 2.9600e+00_wp, 2.7600e+00_wp, 2.5600e+00_wp, 2.3600e+00_wp, 2.1600e+00_wp, & - 1.9600e+00_wp, 1.7600e+00_wp, 1.5600e+00_wp, 1.3600e+00_wp, 1.1600e+00_wp, 9.6000e-01_wp, 7.6000e-01_wp, & - 5.6000e-01_wp, 3.6000e-01_wp, 1.6000e-01_wp, -4.0000e-02_wp,-2.4000e-01_wp,-4.4000e-01_wp,-6.4000e-01_wp,& - -8.4000e-01_wp, -1.0400e+00_wp,-1.2400e+00_wp,-1.4400e+00_wp,-1.6400e+00_wp,-1.8400e+00_wp, -2.0400e+00_wp,& - -2.2400e+00_wp,-2.4400e+00_wp,-2.6400e+00_wp,-2.8400e+00_wp, -3.0400e+00_wp,-3.2400e+00_wp,-3.4400e+00_wp,& - -3.6400e+00_wp,-3.8400e+00_wp, -4.0400e+00_wp,-4.2400e+00_wp,-4.4400e+00_wp,-4.6400e+00_wp /) - ! - ! These are the temperatures associated with the respective pressures - ! - REAL(KIND=wp), parameter :: tref(59) = (/ 2.9420e+02_wp, 2.8799e+02_wp, 2.7894e+02_wp, 2.6925e+02_wp, & - 2.5983e+02_wp, 2.5017e+02_wp, 2.4077e+02_wp, 2.3179e+02_wp, 2.2306e+02_wp, 2.1578e+02_wp, 2.1570e+02_wp, & - 2.1570e+02_wp, 2.1570e+02_wp, 2.1706e+02_wp, 2.1858e+02_wp, 2.2018e+02_wp, 2.2174e+02_wp, 2.2328e+02_wp, & - 2.2479e+02_wp, 2.2655e+02_wp, 2.2834e+02_wp, 2.3113e+02_wp, 2.3401e+02_wp, 2.3703e+02_wp, 2.4022e+02_wp, & - 2.4371e+02_wp, 2.4726e+02_wp, 2.5085e+02_wp, 2.5457e+02_wp, 2.5832e+02_wp, 2.6216e+02_wp, 2.6606e+02_wp, & - 2.6999e+02_wp, 2.7340e+02_wp, 2.7536e+02_wp, 2.7568e+02_wp, 2.7372e+02_wp, 2.7163e+02_wp, 2.6955e+02_wp, & - 2.6593e+02_wp, 2.6211e+02_wp, 2.5828e+02_wp, 2.5360e+02_wp, 2.4854e+02_wp, 2.4348e+02_wp, 2.3809e+02_wp, & - 2.3206e+02_wp, 2.2603e+02_wp, 2.2000e+02_wp, 2.1435e+02_wp, 2.0887e+02_wp, 2.0340e+02_wp, 1.9792e+02_wp, & - 1.9290e+02_wp, 1.8809e+02_wp, 1.8329e+02_wp, 1.7849e+02_wp, 1.7394e+02_wp, 1.7212e+02_wp /) - - ! read subroutines - END MODULE mo_rrtm_params diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_spec_sampling.f90 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_spec_sampling.f90 deleted file mode 100644 index 5cdee52320..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_spec_sampling.f90 +++ /dev/null @@ -1,149 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_spec_sampling.f90 -! Generated at: 2015-02-19 15:30:31 -! KGEN version: 0.4.4 - - - - MODULE mo_spec_sampling - USE mo_random_numbers, ONLY: get_random - USE mo_kind, ONLY: wp - IMPLICIT NONE - PRIVATE - ! - ! Team choices - Longwave - ! - ! - ! Team choices - Shortwave - ! - ! - ! Encapsulate the strategy - ! - TYPE spec_sampling_strategy - PRIVATE - INTEGER, dimension(:, :), pointer :: teams => null() - INTEGER :: num_gpts_ts ! How many g points at each time step - LOGICAL :: unique = .false. - END TYPE spec_sampling_strategy - PUBLIC spec_sampling_strategy, get_gpoint_set - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_integer_4_dim2_pointer - module procedure read_var_spec_sampling_strategy - end interface kgen_read_var - - CONTAINS - subroutine read_var_spec_sampling_strategy(var, kgen_unit) - integer, intent(in) :: kgen_unit - type(spec_sampling_strategy), intent(out) :: var - - call kgen_read_var(var%teams, kgen_unit, .true.) - READ(UNIT=kgen_unit) var%num_gpts_ts - READ(UNIT=kgen_unit) var%unique - end subroutine - - ! read subroutines - subroutine read_var_integer_4_dim2_pointer(var, kgen_unit, is_pointer) - integer, intent(in) :: kgen_unit - logical, intent(in) :: is_pointer - integer(kind=4), intent(out), dimension(:,:), pointer :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - ! ----------------------------------------------------------------------------------------------- - !> - !! @brief Sets a spectral sampling strategy - !! - !! @remarks: Choose a set of g-point teams to use. - !! Two end-member choices: - !! strategy = 1 : a single team comprising all g-points, i.e. broadband integration - !! strategy = 2 : ngpts teams of a single g-point each, i.e. a single randomly chosen g-point - !! This can be modified to choose m samples at each time step (with or without replacement, eventually) - !! Other strategies must combine n teams of m gpoints each such that m * n = ngpts - !! strategy 1 (broadband) is the default - !! - ! - - ! ----------------------------------------------------------------------------------------------- - ! ----------------------------------------------------------------------------------------------- - !> - !! @brief Sets a spectral sampling strategy - !! - !! @remarks: Choose a set of g-point teams to use. - !! Two end-member choices: - !! strategy = 1 : a single team comprising all g-points, i.e. broadband integration - !! strategy = 2 : ngpts teams of a single g-point each, i.e. a single randomly chosen g-point - !! This can be modified to choose m samples at each time step (with or without replacement, eventually) - !! Other strategies must combine n teams of m gpoints each such that m * n = ngpts - !! strategy 1 (broadband) is the default - !! - ! - - ! ----------------------------------------------------------------------------------------------- - !> - !! @brief Returns the number of g-points to compute at each time step - !! - - ! ----------------------------------------------------------------------------------------------- - !> - !! @brief Returns one set of g-points consistent with sampling strategy - !! - - FUNCTION get_gpoint_set(kproma, kbdim, strategy, seeds) - INTEGER, intent(in) :: kproma - INTEGER, intent(in) :: kbdim - TYPE(spec_sampling_strategy), intent(in) :: strategy - INTEGER, intent(inout) :: seeds(:,:) ! dimensions kbdim, rng seed_size - INTEGER, dimension(kproma, strategy%num_gpts_ts) :: get_gpoint_set - REAL(KIND=wp) :: rn(kbdim) - INTEGER :: team(kbdim) - INTEGER :: num_teams - INTEGER :: num_gpts_team - INTEGER :: jl - INTEGER :: it - ! -------- - num_teams = size(strategy%teams, 2) - num_gpts_team = size(strategy%teams, 1) - IF (num_teams == 1) THEN - ! - ! Broadband integration - ! - get_gpoint_set(1:kproma,:) = spread(strategy%teams(:, 1), dim = 1, ncopies = kproma) - ELSE IF (num_gpts_team > 1) THEN - ! - ! Mutiple g-points per team, including broadband integration - ! Return just one team - ! - CALL get_random(kproma, kbdim, seeds, rn) - team(1:kproma) = min(int(rn(1:kproma) * num_teams) + 1, num_teams) - DO jl = 1, kproma - get_gpoint_set(jl, :) = strategy%teams(:,team(jl)) - END DO - ELSE - ! - ! MCSI - return one or more individual points chosen randomly - ! Need to add option for sampling without replacement - ! - DO it = 1, strategy%num_gpts_ts - CALL get_random(kproma, kbdim, seeds, rn) - team(1:kproma) = min(int(rn(1:kproma) * num_teams) + 1, num_teams) - get_gpoint_set(1:kproma, it) = strategy%teams(1, team(1:kproma)) - END DO - END IF - END FUNCTION get_gpoint_set - ! ----------------------------------------------------------------------------------------------- - END MODULE mo_spec_sampling diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_taumol03.f90 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_taumol03.f90 deleted file mode 100644 index cbef6884b8..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_taumol03.f90 +++ /dev/null @@ -1,583 +0,0 @@ -! ====================================================================================================== -! This kernel represents a distillation of *part* of -! the taumol03 calculation in the gas optics part of the PSRAD -! atmospheric -! radiation code. -! -! It is meant to show conceptually how one might "SIMD-ize" swaths of -! the taumol03 code related to calculating the -! taug term, so that the impact of the conditional expression on -! specparm could be reduced and at least partial vectorization -! across columns could be achieved. -! -! I consider it at this point to be "compiling pseudo-code". -! -! By this I mean that the code as written compiles under ifort, but has -! not been tested -! for correctness, nor I have written a driver routine for it. It does -! not contain everything -! that is going on in the taug parent taumol03 code, but I don't claim -! to actually completely -! understand the physical meaning of all or even most of the inputs -! required to make it run. -! -! It has been written to vectorize, but apparently does not actually do -! that -! under the ifort V13 compiler with the -xHost -O3 level of -! optimization, even with !dir$ assume_aligned directives. -! I hypothesize that the compiler is baulking to do so for the indirect -! addressed calls into the absa -! look-up table, either that or 4 byte integers may be causing alignment -! issues relative to 8 byte reals. Anyway, -! it seems to complain about the key loop being too complex. -! ====================================================================================================== -MODULE mo_taumol03 - USE mo_kind, only:wp - USE mo_lrtm_setup, ONLY: nspa - USE mo_lrtm_setup, ONLY: nspb - USE rrlw_planck, ONLY: chi_mls - USE rrlw_kg03, ONLY: selfref - USE rrlw_kg03, ONLY: forref - USE rrlw_kg03, ONLY: ka_mn2o - USE rrlw_kg03, ONLY: absa - USE rrlw_kg03, ONLY: fracrefa - USE rrlw_kg03, ONLY: kb_mn2o - USE rrlw_kg03, ONLY: absb - USE rrlw_kg03, ONLY: fracrefb - IMPLICIT NONE - PRIVATE - PUBLIC taumol03_lwr,taumol03_upr - CONTAINS - SUBROUTINE taumol03_lwr(ncol, laytrop, nlayers, & - rat_h2oco2, colco2, colh2o, coln2o, coldry, & - fac0, fac1, minorfrac, & - selffac,selffrac,forfac,forfrac, & - jp, jt, ig, indself, & - indfor, indminor, & - taug, fracs) - IMPLICIT NONE - - real(kind=wp), PARAMETER :: oneminus = 1.0_wp - 1.0e-06_wp - integer, intent(in) :: ncol ! number of simd columns - integer, intent(in) :: laytrop ! number of layers forwer atmosphere kernel - integer, intent(in) :: nlayers ! total number of layers - real(kind=wp), intent(in), dimension(ncol,0:1,nlayers) :: rat_h2oco2,fac0,fac1 ! not sure of ncol depend - real(kind=wp), intent(in), dimension(ncol,nlayers) :: colco2,colh2o,coln2o,coldry ! these appear to be gas concentrations - - real(kind=wp), intent(in), dimension(ncol,nlayers) :: selffac,selffrac ! not sure of ncol depend - real(kind=wp), intent(in), dimension(ncol,nlayers) :: forfac,forfrac ! not sure of ncol depend - real(kind=wp), intent(in), dimension(ncol,nlayers) :: minorfrac ! not sure of ncol depend - - ! Look up tables and related lookup indices - ! I assume all lookup indices depend on 3D position - ! ================================================= - - integer, intent(in) :: jp(ncol,nlayers) ! I assume jp depends on ncol - integer, intent(in) :: jt(ncol,0:1,nlayers) ! likewise for jt - integer, intent(in) :: ig ! ig indexes into lookup tables - integer, intent(in) :: indself(ncol,nlayers) ! self index array - integer, intent(in) :: indfor(ncol,nlayers) ! for index array - integer, intent(in) :: indminor(ncol,nlayers) ! ka_mn2o index array - real(kind=wp), intent(out), dimension(ncol,nlayers) :: taug ! kernel result - real(kind=wp), intent(out), dimension(ncol,nlayers) :: fracs ! kernel result - - ! Local variable - ! ============== - - integer :: lay ! layer index - integer :: i ! specparm types index - integer :: icol ! column index - - ! vector temporaries - ! ==================== - - integer, dimension(1:3,1:3) :: caseTypeOperations - integer, dimension(ncol) :: caseType - real(kind=wp), dimension(ncol) :: p, p4, fs - real(kind=wp), dimension(ncol) :: fmn2o,fmn2omf - real(kind=wp), dimension(ncol) :: fpl - real(kind=wp), dimension(ncol) :: specmult, speccomb, specparm - real(kind=wp), dimension(ncol) :: specmult_mn2o, speccomb_mn2o,specparm_mn2o - real(kind=wp), dimension(ncol) :: specmult_planck, speccomb_planck,specparm_planck - real(kind=wp), dimension(ncol) :: n2om1,n2om2,absn2o,adjcoln2o,adjfac,chi_n2o,ratn2o - real(kind=wp), dimension(ncol,0:1) :: tau_major - real(kind=wp), dimension(ncol) :: taufor,tauself - integer, dimension(ncol) :: js, ind0, ind00, ind01, ind02, jmn2o, jpl - - ! Register temporaries - ! ==================== - - real(kind=wp) :: p2,fk0,fk1,fk2 - real(kind=wp) :: refrat_planck_a, refrat_planck_b - real(kind=wp) :: refrat_m_a, refrat_m_b - integer :: rrpk_counter=0 - - !dir$ assume_aligned jp:64 - !dir$ assume_aligned jt:64 - !dir$ assume_aligned rat_h2oco2:64 - !dir$ assume_aligned colco2:64 - !dir$ assume_aligned colh2o:64 - !dir$ assume_aligned fac0:64 - !dir$ assume_aligned fac1:64 - !dir$ assume_aligned taug:64 - - !dir$ assume_aligned p:64 - !dir$ assume_aligned p4:64 - !dir$ assume_aligned specmult:64 - !dir$ assume_aligned speccomb:64 - !dir$ assume_aligned specparm:64 - !dir$ assume_aligned specmult_mn2o:64 - !dir$ assume_aligned speccomb_mn2o:64 - !dir$ assume_aligned specparm_mn2o:64 - !dir$ assume_aligned specmult_planck:64 - !dir$ assume_aligned speccomb_planck:64 - !dir$ assume_aligned specparm_planck:64 - !dir$ assume_aligned indself:64 - !dir$ assume_aligned indfor:64 - !dir$ assume_aligned indminor:64 - !dir$ assume_aligned fs:64 - !dir$ assume_aligned tau_major:64 - - !dir$ assume_aligned js:64 - !dir$ assume_aligned ind0:64 - !dir$ assume_aligned ind00:64 - !dir$ assume_aligned ind01:64 - !dir$ assume_aligned ind02:64 - - !dir$ assume_aligned caseTypeOperations:64 - !dir$ assume_aligned caseType:64 - - ! Initialize Case type operations - !================================= - - caseTypeOperations(1:3,1) = (/0, 1, 2/) - caseTypeOperations(1:3,2) = (/1, 0,-1/) - caseTypeOperations(1:3,3) = (/0, 1, 1/) - - ! Minor gas mapping levels: - ! lower - n2o, p = 706.272 mbar, t = 278.94 k - ! upper - n2o, p = 95.58 mbar, t = 215.7 k - - ! P = 212.725 mb - refrat_planck_a = chi_mls(1,9)/chi_mls(2,9) - - ! P = 95.58 mb - refrat_planck_b = chi_mls(1,13)/chi_mls(2,13) - - ! P = 706.270mb - refrat_m_a = chi_mls(1,3)/chi_mls(2,3) - - ! P = 95.58 mb - refrat_m_b = chi_mls(1,13)/chi_mls(2,13) - - ! Lower atmosphere loop - ! ===================== - - DO lay = 1,laytrop ! loop over layers - - ! Compute tau_major term - ! ====================== - - DO i=0,1 ! loop over specparm types - - ! This loop should vectorize - ! ============================= - !dir$ SIMD - DO icol=1,ncol ! Vectorizes with dir - 14.0.2 - speccomb(icol) = colh2o(icol,lay) + rat_h2oco2(icol,i,lay)*colco2(icol,lay) - specparm(icol) = colh2o(icol,lay)/speccomb(icol) - IF (specparm(icol) .GE. oneminus) specparm(icol) = oneminus - specmult(icol) = 8._wp*(specparm(icol)) - js(icol) = 1 + INT(specmult(icol)) - fs(icol) = MOD(specmult(icol),1.0_wp) - END DO - - ! The only conditional loop - ! ========================= - - DO icol=1,ncol ! Vectorizes as is 14.0.2 - IF (specparm(icol) .LT. 0.125_wp) THEN - caseType(icol)=1 - p(icol) = fs(icol) - 1.0_wp - p2 = p(icol)*p(icol) - p4(icol) = p2*p2 - ELSE IF (specparm(icol) .GT. 0.875_wp) THEN - caseType(icol)=2 - p(icol) = -fs(icol) - p2 = p(icol)*p(icol) - p4(icol) = p2*p2 - ELSE - caseType(icol)=3 - ! SIMD way of writing fk0= 1-fs and fk1 = fs, fk2=zero - ! =========================================================== - - p4(icol) = 1.0_wp - fs(icol) - p(icol) = -p4(icol) ! complicated way of getting fk2 = zero for ELSE case - ENDIF - END DO - - ! Vector/SIMD index loop calculation - ! ================================== - - !dir$ SIMD - DO icol=1,ncol ! Vectorizes with dir 14.0.2 - ind0(icol) = ((jp(icol,lay)-(1*MOD(i+1,2)))*5+(jt(icol,i,lay)-1))*nspa(3) +js(icol) - ind00(icol) = ind0(icol) + caseTypeOperations(1,caseType(icol)) - ind01(icol) = ind0(icol) + caseTypeOperations(2,caseType(icol)) - ind02(icol) = ind0(icol) + caseTypeOperations(3,caseType(icol)) - END DO - - ! What we've been aiming for a nice flop intensive - ! SIMD/vectorizable loop! - ! 17 flops - ! - ! Albeit at the cost of a couple extra flops for the fk2 term - ! and a repeated lookup table access for the fk2 term in the - ! the ELSE case when specparm or specparm1 is (> .125 && < .875) - ! =============================================================== - - !dir$ SIMD - DO icol=1,ncol ! Vectorizes with dir 14.0.2 - - fk0 = p4(icol) - fk1 = 1.0_wp - p(icol) - 2.0_wp*p4(icol) - fk2 = p(icol) + p4(icol) - tau_major(icol,i) = speccomb(icol) * ( & - fac0(icol,i,lay)*(fk0*absa(ind00(icol),ig) + & - fk1*absa(ind01(icol),ig) + & - fk2*absa(ind02(icol),ig)) + & - fac1(icol,i,lay)*(fk0*absa(ind00(icol)+9,ig) + & - fk1*absa(ind01(icol)+9,ig) + & - fk2*absa(ind02(icol)+9,ig))) - END DO - - END DO ! end loop over specparm types for tau_major calculation - - ! Compute taufor and tauself terms: - ! Note the use of 1D bilinear interpolation of selfref and forref - ! lookup table values - ! =================================================================================== - - !dir$ SIMD - DO icol=1,ncol ! Vectorizes with dir 14.0.2 - tauself(icol) = selffac(icol,lay)*(selfref(indself(icol,lay),ig) +& - selffrac(icol,lay)*(selfref(indself(icol,lay)+1,ig)- selfref(indself(icol,lay),ig))) - taufor(icol) = forfac(icol,lay)*( forref(indfor(icol,lay),ig) +& - forfrac(icol,lay)*( forref(indfor(icol,lay)+1,ig) -forref(indfor(icol,lay),ig))) - END DO - - ! Compute absn2o term: - ! Note the use of 2D bilinear interpolation ka_mn2o lookup table - ! values - ! ===================================================================== - - !dir$ SIMD - DO icol=1,ncol !vectorizes with dir 14.0.2 - speccomb_mn2o(icol) = colh2o(icol,lay) +refrat_m_a*colco2(icol,lay) - specparm_mn2o(icol) = colh2o(icol,lay)/speccomb_mn2o(icol) - END DO - - do icol=1,ncol ! vectorizes as is 14.0.2 - IF (specparm_mn2o(icol) .GE. oneminus) specparm_mn2o(icol) =oneminus - end do - - !dir$ SIMD ! vectorizes with dir 14.0.2 - DO icol=1,ncol - specmult_mn2o(icol) = 8.0_wp*specparm_mn2o(icol) - jmn2o(icol) = 1 + INT(specmult_mn2o(icol)) - fmn2o(icol) = MOD(specmult_mn2o(icol),1.0_wp) - fmn2omf(icol) = minorfrac(icol,lay)*fmn2o(icol) - END DO - - ! - ! 2D bilinear interpolation - ! ========================= - - !dir$ SIMD - do icol=1,ncol ! vectorizes with dir 14.0.2 - n2om1(icol) = ka_mn2o(jmn2o(icol),indminor(icol,lay) ,ig) + & - fmn2o(icol)*(ka_mn2o(jmn2o(icol)+1,indminor(icol,lay),ig) - & - ka_mn2o(jmn2o(icol),indminor(icol,lay) ,ig)) - n2om2(icol) = ka_mn2o(jmn2o(icol),indminor(icol,lay)+1,ig) + & - fmn2o(icol)*(ka_mn2o(jmn2o(icol)+1,indminor(icol,lay)+1,ig)- & - ka_mn2o(jmn2o(icol),indminor(icol,lay)+1,ig)) - absn2o(icol) = n2om1(icol) + minorfrac(icol,lay)*(n2om2(icol) -n2om1(icol)) - end do - - ! In atmospheres where the amount of N2O is too great to be - ! considered - ! a minor species, adjust the column amount of N2O by an empirical - ! factor - ! to obtain the proper contribution. - ! ======================================================================== - - !dir$ SIMD - do icol=1,ncol ! vectorized with dir 14.0.2 - chi_n2o(icol) = coln2o(icol,lay)/coldry(icol,lay) - ratn2o(icol) = 1.e20*chi_n2o(icol)/chi_mls(4,jp(icol,lay)+1) - end do - - do icol=1,ncol ! vectorizes as is 14.0.2 - IF (ratn2o(icol) .GT. 1.5_wp) THEN - adjfac(icol) = 0.5_wp+(ratn2o(icol)-0.5_wp)**0.65_wp - adjcoln2o(icol) =adjfac(icol)*chi_mls(4,jp(icol,lay)+1)*coldry(icol,lay)*1.e-20_wp - ELSE - adjcoln2o(icol) = coln2o(icol,lay) - ENDIF - end do - - ! Compute taug, one of two terms returned by the lower atmosphere - ! kernel (the other is fracs) - ! This loop could be parallelized over specparm types (i) but might - ! produce - ! different results for different thread counts - ! =========================================================================================== - - !dir$ SIMD ! DOES NOT VECTORIZE even with SIMD dir 14.0.2 - DO icol=1,ncol - taug(icol,lay) = tau_major(icol,0) + tau_major(icol,1) +tauself(icol) + taufor(icol) + adjcoln2o(icol)*absn2o(icol) - END DO - - !dir$ SIMD ! vectorizes with dir 14.0.2 - DO icol=1,ncol - speccomb_planck(icol) = colh2o(icol,lay)+refrat_planck_a*colco2(icol,lay) - specparm_planck(icol) = colh2o(icol,lay)/speccomb_planck(icol) - END DO - - DO icol=1,ncol ! vectorizes as is 14.0.2 - IF (specparm_planck(icol) .GE. oneminus) specparm_planck(icol)=oneminus - END DO - - !dir$ SIMD - DO icol=1,ncol !vectorizes with dir 14.0.2 - specmult_planck(icol) = 8.0_wp*specparm_planck(icol) - jpl(icol)= 1 + INT(specmult_planck(icol)) - fpl(icol) = MOD(specmult_planck(icol),1.0_wp) - fracs(icol,lay) = fracrefa(ig,jpl(icol)) + fpl(icol)*(fracrefa(ig,jpl(icol)+1)-fracrefa(ig,jpl(icol))) - END DO - rrpk_counter=rrpk_counter+1 - END DO ! end lower atmosphere loop - END SUBROUTINE taumol03_lwr - - - SUBROUTINE taumol03_upr(ncol, laytrop, nlayers, & - rat_h2oco2, colco2, colh2o, coln2o, coldry, & - fac0, fac1, minorfrac, & - forfac,forfrac, & - jp, jt, ig, & - indfor, indminor, & - taug, fracs) - - use mo_kind, only : wp - USE mo_lrtm_setup, ONLY: nspa - USE mo_lrtm_setup, ONLY: nspb - USE rrlw_planck, ONLY: chi_mls - USE rrlw_kg03, ONLY: selfref - USE rrlw_kg03, ONLY: forref - USE rrlw_kg03, ONLY: ka_mn2o - USE rrlw_kg03, ONLY: absa - USE rrlw_kg03, ONLY: fracrefa - USE rrlw_kg03, ONLY: kb_mn2o - USE rrlw_kg03, ONLY: absb - USE rrlw_kg03, ONLY: fracrefb - - IMPLICIT NONE - - real(kind=wp), PARAMETER :: oneminus = 1.0_wp - 1.0e-06_wp - - integer, intent(in) :: ncol ! number of simd columns - integer, intent(in) :: laytrop ! number of layers for lower atmosphere kernel - integer, intent(in) :: nlayers ! total number of layers - real(kind=wp), intent(in), dimension(ncol,0:1,nlayers) :: rat_h2oco2,fac0,fac1 ! not sure of ncol depend - real(kind=wp), intent(in), dimension(ncol,nlayers) :: colco2,colh2o,coln2o,coldry ! these appear to be gas concentrations - real(kind=wp), intent(in), dimension(ncol,nlayers) :: forfac,forfrac ! not sure of ncol depend - real(kind=wp), intent(in), dimension(ncol,nlayers) :: minorfrac ! not sure of ncol depend - - ! Look up tables and related lookup indices - ! I assume all lookup indices depend on 3D position - ! ================================================= - - integer, intent(in) :: jp(ncol,nlayers) ! I assume jp depends on ncol - integer, intent(in) :: jt(ncol,0:1,nlayers) ! likewise for jt - integer, intent(in) :: ig ! ig indexes into lookup tables - integer, intent(in) :: indfor(ncol,nlayers) ! for index array - integer, intent(in) :: indminor(ncol,nlayers) ! ka_mn2o index array - real(kind=wp), intent(out), dimension(ncol,nlayers) :: taug ! kernel result - real(kind=wp), intent(out), dimension(ncol,nlayers) :: fracs ! kernel result - - ! Local variable - ! ============== - - integer :: lay ! layer index - integer :: i ! specparm types index - integer :: icol ! column index - - ! vector temporaries - ! ==================== - - real(kind=wp), dimension(ncol) :: fs - real(kind=wp), dimension(ncol) :: fmn2o,fmn2omf - real(kind=wp), dimension(ncol) :: fpl - real(kind=wp), dimension(ncol) :: specmult, speccomb, specparm - real(kind=wp), dimension(ncol) :: specmult_mn2o, speccomb_mn2o, specparm_mn2o - real(kind=wp), dimension(ncol) :: specmult_planck, speccomb_planck,specparm_planck - real(kind=wp), dimension(ncol) :: n2om1,n2om2,absn2o,adjcoln2o,adjfac,chi_n2o,ratn2o - real(kind=wp), dimension(ncol,0:1) :: tau_major - real(kind=wp), dimension(ncol) :: taufor,tauself - integer, dimension(ncol) :: js, ind0, jmn2o, jpl - - ! Register temporaries - ! ==================== - - real(kind=wp) :: p2,fk0,fk1,fk2 - real(kind=wp) :: refrat_planck_a, refrat_planck_b - real(kind=wp) :: refrat_m_a, refrat_m_b - - !dir$ assume_aligned jp:64 - !dir$ assume_aligned jt:64 - !dir$ assume_aligned rat_h2oco2:64 - !dir$ assume_aligned colco2:64 - !dir$ assume_aligned colh2o:64 - !dir$ assume_aligned fac0:64 - !dir$ assume_aligned fac1:64 - !dir$ assume_aligned taug:64 - - !dir$ assume_aligned specmult:64 - !dir$ assume_aligned speccomb:64 - !dir$ assume_aligned specparm:64 - !dir$ assume_aligned specmult_mn2o:64 - !dir$ assume_aligned speccomb_mn2o:64 - !dir$ assume_aligned specparm_mn2o:64 - !dir$ assume_aligned specmult_planck:64 - !dir$ assume_aligned speccomb_planck:64 - !dir$ assume_aligned specparm_planck:64 - !dir$ assume_aligned fs:64 - !dir$ assume_aligned tau_major:64 - !dir$ assume_aligned chi_n2o:64 - - !dir$ assume_aligned js:64 - !dir$ assume_aligned ind0:64 - !dir$ assume_aligned jpl:64 - !dir$ assume_aligned fpl:64 - - !dir$ assume_aligned absn2o:64 - !dir$ assume_aligned adjcoln2o:64 - !dir$ assume_aligned adjfac:64 - !dir$ assume_aligned ratn2o:64 - - ! Upper atmosphere loop - ! ======================== - refrat_planck_b = chi_mls(1,13)/chi_mls(2,13) - refrat_m_b = chi_mls(1,13)/chi_mls(2,13) - DO lay = laytrop+1, nlayers - - DO i=0,1 ! loop over specparm types - - ! This loop should vectorize - ! ============================= - - !dir$ SIMD - DO icol=1,ncol ! Vectorizes with dir 14.0.2 - speccomb(icol) = colh2o(icol,lay) + rat_h2oco2(icol,i,lay)*colco2(icol,lay) - specparm(icol) = colh2o(icol,lay)/speccomb(icol) - IF (specparm(icol) .ge. oneminus) specparm(icol) = oneminus - specmult(icol) = 4.0_wp*(specparm(icol)) - js(icol) = 1 + INT(specmult(icol)) - fs(icol) = MOD(specmult(icol),1.0_wp) - ind0(icol) = ((jp(icol,lay)-13+i)*5+(jt(icol,i,lay)-1))*nspb(3) +js(icol) - END DO - - !dir$ SIMD - DO icol=1,ncol ! Vectorizes with dir 14.0.2 - tau_major(icol,i) = speccomb(icol) * & - ((1.0_wp - fs(icol))*fac0(icol,i,lay)*absb(ind0(icol) ,ig) + & - fs(icol) *fac0(icol,i,lay)*absb(ind0(icol)+1,ig) + & - (1.0_wp - fs(icol))*fac1(icol,i,lay)*absb(ind0(icol)+5,ig) + & - fs(icol) *fac1(icol,i,lay)*absb(ind0(icol)+6,ig)) - END DO - - END DO ! end loop over specparm types for tau_major calculation - - ! Compute taufor terms - ! Note the use of 1D bilinear interpolation of selfref and forref lookup - ! table values - ! =================================================================================== - !dir$ SIMD - DO icol=1,ncol ! Vectorizes with dir 14.0.2 - taufor(icol) = forfac(icol,lay)*( forref(indfor(icol,lay),ig) + & - forfrac(icol,lay)*( forref(indfor(icol,lay)+1,ig) - forref(indfor(icol,lay),ig))) - END DO - - ! Compute absn2o term: - ! Note the use of 2D bilinear interpolation ka_mn2o lookup table values - ! ===================================================================== - !$DIR SIMD - DO icol=1,ncol ! Vectorizes with dir 14.0.2 - speccomb_mn2o(icol) = colh2o(icol,lay) + refrat_m_b*colco2(icol,lay) - specparm_mn2o(icol) = colh2o(icol,lay)/speccomb_mn2o(icol) - IF (specparm_mn2o(icol) .GE. oneminus) specparm_mn2o(icol) = oneminus - specmult_mn2o(icol) = 4.0_wp*specparm_mn2o(icol) - jmn2o(icol) = 1 + INT(specmult_mn2o(icol)) - fmn2o(icol) = MOD(specmult_mn2o(icol),1.0_wp) - fmn2omf(icol) = minorfrac(icol,lay)*fmn2o(icol) - END DO - - ! In atmospheres where the amount of N2O is too great to be considered - ! a minor species, adjust the column amount of N2O by an empirical factor - ! to obtain the proper contribution. - ! ======================================================================== - - !dir$ SIMD - DO icol=1,ncol ! loop vectorized with directive 14.0.2 - chi_n2o(icol) = coln2o(icol,lay)/coldry(icol,lay) - ratn2o(icol) = 1.e20*chi_n2o(icol)/chi_mls(4,jp(icol,lay)+1) - END DO - - DO icol=1,ncol ! Loop vectorized as is 14.0.2 - IF (ratn2o(icol) .GT. 1.5_wp) THEN - adjfac(icol) = 0.5_wp+(ratn2o(icol)-0.5_wp)**0.65_wp - adjcoln2o(icol) = adjfac(icol)*chi_mls(4,jp(icol,lay)+1)*coldry(icol,lay)*1.e-20_wp - ELSE - adjcoln2o(icol) = coln2o(icol,lay) - ENDIF - END DO - - ! - ! 2D bilinear interpolation - ! ========================= - - !dir$ SIMD - DO icol=1,ncol ! loop vectorizes with directive 14.0.2 - n2om1(icol) = kb_mn2o(jmn2o(icol),indminor(icol,lay) ,ig) + & - fmn2o(icol)*(kb_mn2o(jmn2o(icol)+1,indminor(icol,lay),ig) - & - kb_mn2o(jmn2o(icol) ,indminor(icol,lay) ,ig)) - n2om2(icol) = kb_mn2o(jmn2o(icol),indminor(icol,lay)+1,ig) + & - fmn2o(icol)*(kb_mn2o(jmn2o(icol)+1,indminor(icol,lay)+1,ig)- & - kb_mn2o(jmn2o(icol),indminor(icol,lay)+1,ig)) - absn2o(icol) = n2om1(icol) + minorfrac(icol,lay)*(n2om2(icol) -n2om1(icol)) - END DO - - !dir$ SIMD - DO icol=1,ncol ! loop vectorizes with directive 14.0.2 - taug(icol,lay) = tau_major(icol,0) + tau_major(icol,1) + taufor(icol) + adjcoln2o(icol)*absn2o(icol) - END DO - - !dir$ SIMD - DO icol=1,ncol ! loop vectorizes with directive 14.0.2 - speccomb_planck(icol) = colh2o(icol,lay)+refrat_planck_b*colco2(icol,lay) - specparm_planck(icol) = colh2o(icol,lay)/speccomb_planck(icol) - END DO - - !dir$ SIMD - DO icol=1,ncol ! loop vectorizes with directive 14.0.2 - IF (specparm_planck(icol) .GE. oneminus) specparm_planck(icol)=oneminus - specmult_planck(icol) = 4.0_wp*specparm_planck(icol) - jpl(icol)= 1 + INT(specmult_planck(icol)) - fpl(icol) = MOD(specmult_planck(icol),1.0_wp) - fracs(icol,lay) = fracrefb(ig,jpl(icol)) + fpl(icol)*(fracrefb(ig,jpl(icol)+1)-fracrefb(ig,jpl(icol))) - END DO - END DO ! nlayers loop - - END SUBROUTINE taumol03_upr - -END MODULE mo_taumol03 diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_taumol04.f90 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_taumol04.f90 deleted file mode 100644 index e250361db9..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_taumol04.f90 +++ /dev/null @@ -1,435 +0,0 @@ -! ====================================================================================================== -! This kernel represents a distillation of *part* of -! the taumol04 calculation in the gas optics part of the PSRAD -! atmospheric -! radiation code. -! -! It is meant to show conceptually how one might "SIMD-ize" swaths of -! the taumol04 code related to calculating the -! taug term, so that the impact of the conditional expression on -! specparm could be reduced and at least partial vectorization -! across columns could be achieved. -! -! I consider it at this point to be "compiling pseudo-code". -! -! By this I mean that the code as written compiles under ifort, but has -! not been tested -! for correctness, nor I have written a driver routine for it. It does -! not contain everything -! that is going on in the taug parent taumol04 code, but I don't claim -! to actually completely -! understand the physical meaning of all or even most of the inputs -! required to make it run. -! -! It has been written to vectorize, but apparently does not actually do -! that -! under the ifort V13 compiler with the -xHost -O3 level of -! optimization, even with !dir$ assume_aligned directives. -! I hypothesize that the compiler is baulking to do so for the indirect -! addressed calls into the absa -! look-up table, either that or 4 byte integers may be causing alignment -! issues relative to 8 byte reals. Anyway, -! it seems to complain about the key loop being too complex. -! ====================================================================================================== -MODULE mo_taumol04 - USE mo_kind, only:wp - USE mo_lrtm_setup, ONLY: nspa - USE mo_lrtm_setup, ONLY: nspb - USE mo_lrtm_setup, ONLY: ngc - USE rrlw_planck, ONLY: chi_mls - USE rrlw_kg04, ONLY: selfref - USE rrlw_kg04, ONLY: forref - USE rrlw_kg04, ONLY: absa - USE rrlw_kg04, ONLY: fracrefa - USE rrlw_kg04, ONLY: absb - USE rrlw_kg04, ONLY: fracrefb - IMPLICIT NONE - PRIVATE - PUBLIC taumol04_lwr,taumol04_upr - CONTAINS - SUBROUTINE taumol04_lwr(ncol, laytrop, nlayers, & - rat_h2oco2, colco2, colh2o, coldry, & - fac0, fac1, minorfrac, & - selffac,selffrac,forfac,forfrac, & - jp, jt, ig, indself, & - indfor, & - taug, fracs) - IMPLICIT NONE - - real(kind=wp), PARAMETER :: oneminus = 1.0_wp - 1.0e-06_wp - integer, intent(in) :: ncol ! number of simd columns - integer, intent(in) :: laytrop ! number of layers forwer atmosphere kernel - integer, intent(in) :: nlayers ! total number of layers - real(kind=wp), intent(in), dimension(ncol,0:1,nlayers) :: rat_h2oco2,fac0,fac1 ! not sure of ncol depend - real(kind=wp), intent(in), dimension(ncol,nlayers) :: colco2,colh2o,coldry ! these appear to be gas concentrations - - real(kind=wp), intent(in), dimension(ncol,nlayers) :: selffac,selffrac ! not sure of ncol depend - real(kind=wp), intent(in), dimension(ncol,nlayers) :: forfac,forfrac ! not sure of ncol depend - real(kind=wp), intent(in), dimension(ncol,nlayers) :: minorfrac ! not sure of ncol depend - - ! Look up tables and related lookup indices - ! I assume all lookup indices depend on 3D position - ! ================================================= - - integer, intent(in) :: jp(ncol,nlayers) ! I assume jp depends on ncol - integer, intent(in) :: jt(ncol,0:1,nlayers) ! likewise for jt - integer, intent(in) :: ig ! ig indexes into lookup tables - integer, intent(in) :: indself(ncol,nlayers) ! self index array - integer, intent(in) :: indfor(ncol,nlayers) ! for index array - real(kind=wp), intent(out), dimension(ncol,nlayers) :: taug ! kernel result - real(kind=wp), intent(out), dimension(ncol,nlayers) :: fracs ! kernel result - - ! Local variable - ! ============== - - integer :: lay ! layer index - integer :: i ! specparm types index - integer :: icol ! column index - - ! vector temporaries - ! ==================== - - integer, dimension(1:3,1:3) :: caseTypeOperations - integer, dimension(ncol) :: caseType - real(kind=wp), dimension(ncol) :: p, p4, fs - real(kind=wp), dimension(ncol) :: fpl - real(kind=wp), dimension(ncol) :: specmult, speccomb, specparm - real(kind=wp), dimension(ncol) :: specmult_planck, speccomb_planck,specparm_planck - real(kind=wp), dimension(ncol,0:1) :: tau_major - real(kind=wp), dimension(ncol) :: taufor,tauself - integer, dimension(ncol) :: js, ind0, ind00, ind01, ind02, jpl - - ! Register temporaries - ! ==================== - - real(kind=wp) :: p2,fk0,fk1,fk2 - real(kind=wp) :: refrat_planck_a, refrat_planck_b - - !dir$ assume_aligned jp:64 - !dir$ assume_aligned jt:64 - !dir$ assume_aligned rat_h2oco2:64 - !dir$ assume_aligned colco2:64 - !dir$ assume_aligned colh2o:64 - !dir$ assume_aligned fac0:64 - !dir$ assume_aligned fac1:64 - !dir$ assume_aligned taug:64 - - !dir$ assume_aligned p:64 - !dir$ assume_aligned p4:64 - !dir$ assume_aligned specmult:64 - !dir$ assume_aligned speccomb:64 - !dir$ assume_aligned specparm:64 - !dir$ assume_aligned specmult_planck:64 - !dir$ assume_aligned speccomb_planck:64 - !dir$ assume_aligned specparm_planck:64 - !dir$ assume_aligned indself:64 - !dir$ assume_aligned indfor:64 - !dir$ assume_aligned fs:64 - !dir$ assume_aligned tau_major:64 - - !dir$ assume_aligned js:64 - !dir$ assume_aligned ind0:64 - !dir$ assume_aligned ind00:64 - !dir$ assume_aligned ind01:64 - !dir$ assume_aligned ind02:64 - - !dir$ assume_aligned caseTypeOperations:64 - !dir$ assume_aligned caseType:64 - - ! Initialize Case type operations - !================================= - - caseTypeOperations(1:3,1) = (/0, 1, 2/) - caseTypeOperations(1:3,2) = (/1, 0,-1/) - caseTypeOperations(1:3,3) = (/0, 1, 1/) - - ! Minor gas mapping levels: - ! lower - n2o, p = 706.272 mbar, t = 278.94 k - ! upper - n2o, p = 95.58 mbar, t = 215.7 k - - ! P = 212.725 mb - refrat_planck_a = chi_mls(1,11)/chi_mls(2,11) - - ! P = 95.58 mb - refrat_planck_b = chi_mls(3,13)/chi_mls(2,13) - - - ! Lower atmosphere loop - ! ===================== - - DO lay = 1,laytrop ! loop over layers - - ! Compute tau_major term - ! ====================== - - DO i=0,1 ! loop over specparm types - - ! This loop should vectorize - ! ============================= - !dir$ SIMD - DO icol=1,ncol ! Vectorizes with dir - 14.0.2 - speccomb(icol) = colh2o(icol,lay) + rat_h2oco2(icol,i,lay)*colco2(icol,lay) - specparm(icol) = colh2o(icol,lay)/speccomb(icol) - IF (specparm(icol) .GE. oneminus) specparm(icol) = oneminus - specmult(icol) = 8._wp*(specparm(icol)) - js(icol) = 1 + INT(specmult(icol)) - fs(icol) = MOD(specmult(icol),1.0_wp) - END DO - - ! The only conditional loop - ! ========================= - - DO icol=1,ncol ! Vectorizes as is 14.0.2 - IF (specparm(icol) .LT. 0.125_wp) THEN - caseType(icol)=1 - p(icol) = fs(icol) - 1.0_wp - p2 = p(icol)*p(icol) - p4(icol) = p2*p2 - ELSE IF (specparm(icol) .GT. 0.875_wp) THEN - caseType(icol)=2 - p(icol) = -fs(icol) - p2 = p(icol)*p(icol) - p4(icol) = p2*p2 - ELSE - caseType(icol)=3 - ! SIMD way of writing fk0= 1-fs and fk1 = fs, fk2=zero - ! =========================================================== - - p4(icol) = 1.0_wp - fs(icol) - p(icol) = -p4(icol) ! complicated way of getting fk2 = zero for ELSE case - ENDIF - END DO - - ! Vector/SIMD index loop calculation - ! ================================== - - !dir$ SIMD - DO icol=1,ncol ! Vectorizes with dir 14.0.2 - ind0(icol) = ((jp(icol,lay)-(1*MOD(i+1,2)))*5+(jt(icol,i,lay)-1))*nspa(4) +js(icol) - ind00(icol) = ind0(icol) + caseTypeOperations(1,caseType(icol)) - ind01(icol) = ind0(icol) + caseTypeOperations(2,caseType(icol)) - ind02(icol) = ind0(icol) + caseTypeOperations(3,caseType(icol)) - END DO - - ! What we've been aiming for a nice flop intensive - ! SIMD/vectorizable loop! - ! 17 flops - ! - ! Albeit at the cost of a couple extra flops for the fk2 term - ! and a repeated lookup table access for the fk2 term in the - ! the ELSE case when specparm or specparm1 is (> .125 && < .875) - ! =============================================================== - - !dir$ SIMD - DO icol=1,ncol ! Vectorizes with dir 14.0.2 - - fk0 = p4(icol) - fk1 = 1.0_wp - p(icol) - 2.0_wp*p4(icol) - fk2 = p(icol) + p4(icol) - tau_major(icol,i) = speccomb(icol) * ( & - fac0(icol,i,lay)*(fk0*absa(ind00(icol),ig) + & - fk1*absa(ind01(icol),ig) + & - fk2*absa(ind02(icol),ig)) + & - fac1(icol,i,lay)*(fk0*absa(ind00(icol)+9,ig) + & - fk1*absa(ind01(icol)+9,ig) + & - fk2*absa(ind02(icol)+9,ig))) - END DO - - END DO ! end loop over specparm types for tau_major calculation - - ! Compute taufor and tauself terms: - ! Note the use of 1D bilinear interpolation of selfref and forref - ! lookup table values - ! =================================================================================== - - !dir$ SIMD - DO icol=1,ncol ! Vectorizes with dir 14.0.2 - tauself(icol) = selffac(icol,lay)*(selfref(indself(icol,lay),ig) +& - selffrac(icol,lay)*(selfref(indself(icol,lay)+1,ig)- selfref(indself(icol,lay),ig))) - taufor(icol) = forfac(icol,lay)*( forref(indfor(icol,lay),ig) +& - forfrac(icol,lay)*( forref(indfor(icol,lay)+1,ig) -forref(indfor(icol,lay),ig))) - END DO - - ! Compute taug, one of two terms returned by the lower atmosphere - ! kernel (the other is fracs) - ! This loop could be parallelized over specparm types (i) but might - ! produce - ! different results for different thread counts - ! =========================================================================================== - - !dir$ SIMD ! DOES NOT VECTORIZE even with SIMD dir 14.0.2 - DO icol=1,ncol - taug(icol,lay) = tau_major(icol,0) + tau_major(icol,1) +tauself(icol) + taufor(icol) - END DO - - !dir$ SIMD ! vectorizes with dir 14.0.2 - DO icol=1,ncol - speccomb_planck(icol) = colh2o(icol,lay)+refrat_planck_a*colco2(icol,lay) - specparm_planck(icol) = colh2o(icol,lay)/speccomb_planck(icol) - END DO - - DO icol=1,ncol ! vectorizes as is 14.0.2 - IF (specparm_planck(icol) .GE. oneminus) specparm_planck(icol)=oneminus - END DO - - !dir$ SIMD - DO icol=1,ncol !vectorizes with dir 14.0.2 - specmult_planck(icol) = 8.0_wp*specparm_planck(icol) - jpl(icol)= 1 + INT(specmult_planck(icol)) - fpl(icol) = MOD(specmult_planck(icol),1.0_wp) - fracs(icol,lay) = fracrefa(ig,jpl(icol)) + fpl(icol)*(fracrefa(ig,jpl(icol)+1)-fracrefa(ig,jpl(icol))) - END DO - END DO ! end lower atmosphere loop - END SUBROUTINE taumol04_lwr - - - SUBROUTINE taumol04_upr(ncol, laytrop, nlayers, & - rat_o3co2, colco2, colo3, coldry, & - fac0, fac1, minorfrac, & - forfac,forfrac, & - jp, jt, ig, & - indfor, & - taug, fracs) - - use mo_kind, only : wp - USE mo_lrtm_setup, ONLY: nspa - USE mo_lrtm_setup, ONLY: nspb - USE rrlw_planck, ONLY: chi_mls - USE rrlw_kg04, ONLY: selfref - USE rrlw_kg04, ONLY: forref - USE rrlw_kg04, ONLY: absb - USE rrlw_kg04, ONLY: fracrefb - - IMPLICIT NONE - - real(kind=wp), PARAMETER :: oneminus = 1.0_wp - 1.0e-06_wp - - integer, intent(in) :: ncol ! number of simd columns - integer, intent(in) :: laytrop ! number of layers for lower atmosphere kernel - integer, intent(in) :: nlayers ! total number of layers - real(kind=wp), intent(in), dimension(ncol,0:1,nlayers) :: rat_o3co2,fac0,fac1 ! not sure of ncol depend - real(kind=wp), intent(in), dimension(ncol,nlayers) :: colco2,colo3,coldry ! these appear to be gas concentrations - real(kind=wp), intent(in), dimension(ncol,nlayers) :: forfac,forfrac ! not sure of ncol depend - real(kind=wp), intent(in), dimension(ncol,nlayers) :: minorfrac ! not sure of ncol depend - - ! Look up tables and related lookup indices - ! I assume all lookup indices depend on 3D position - ! ================================================= - - integer, intent(in) :: jp(ncol,nlayers) ! I assume jp depends on ncol - integer, intent(in) :: jt(ncol,0:1,nlayers) ! likewise for jt - integer, intent(in) :: ig ! ig indexes into lookup tables - integer, intent(in) :: indfor(ncol,nlayers) ! for index array - real(kind=wp), intent(out), dimension(ncol,nlayers) :: taug ! kernel result - real(kind=wp), intent(out), dimension(ncol,nlayers) :: fracs ! kernel result - - ! Local variable - ! ============== - - integer :: lay ! layer index - integer :: i ! specparm types index - integer :: icol ! column index - - ! vector temporaries - ! ==================== - - real(kind=wp), dimension(ncol) :: fs - real(kind=wp), dimension(ncol) :: fpl - real(kind=wp), dimension(ncol) :: specmult, speccomb, specparm - real(kind=wp), dimension(ncol) :: specmult_planck, speccomb_planck,specparm_planck - real(kind=wp), dimension(ncol,0:1) :: tau_major - real(kind=wp), dimension(ncol) :: taufor,tauself - integer, dimension(ncol) :: js, ind0, jpl - - ! Register temporaries - ! ==================== - - real(kind=wp) :: p2,fk0,fk1,fk2 - real(kind=wp) :: refrat_planck_a, refrat_planck_b - REAL(KIND=wp), dimension(ngc(4)) :: stratcorrect = (/ 1., 1., 1., 1.,1., 1., 1., .92, .88, 1.07, 1.1, & - .99, .88, .943 /) - !dir$ assume_aligned jp:64 - !dir$ assume_aligned jt:64 - !dir$ assume_aligned rat_o3co2:64 - !dir$ assume_aligned colco2:64 - !dir$ assume_aligned colo3:64 - !dir$ assume_aligned fac0:64 - !dir$ assume_aligned fac1:64 - !dir$ assume_aligned taug:64 - - !dir$ assume_aligned specmult:64 - !dir$ assume_aligned speccomb:64 - !dir$ assume_aligned specparm:64 - !dir$ assume_aligned specmult_planck:64 - !dir$ assume_aligned speccomb_planck:64 - !dir$ assume_aligned specparm_planck:64 - !dir$ assume_aligned fs:64 - !dir$ assume_aligned tau_major:64 - - !dir$ assume_aligned js:64 - !dir$ assume_aligned ind0:64 - !dir$ assume_aligned jpl:64 - !dir$ assume_aligned fpl:64 - - - ! Upper atmosphere loop - ! ======================== - refrat_planck_b = chi_mls(3,13)/chi_mls(2,13) - DO lay = laytrop+1, nlayers - - DO i=0,1 ! loop over specparm types - - ! This loop should vectorize - ! ============================= - - !dir$ SIMD - DO icol=1,ncol ! Vectorizes with dir 14.0.2 - speccomb(icol) = colo3(icol,lay) + rat_o3co2(icol,i,lay)*colco2(icol,lay) - specparm(icol) = colo3(icol,lay)/speccomb(icol) - IF (specparm(icol) .ge. oneminus) specparm(icol) = oneminus - specmult(icol) = 4.0_wp*(specparm(icol)) - js(icol) = 1 + INT(specmult(icol)) - fs(icol) = MOD(specmult(icol),1.0_wp) - ind0(icol) = ((jp(icol,lay)-13+i)*5+(jt(icol,i,lay)-1))*nspb(4) +js(icol) - END DO - - !dir$ SIMD - DO icol=1,ncol ! Vectorizes with dir 14.0.2 - tau_major(icol,i) = speccomb(icol) * & - ((1.0_wp - fs(icol))*fac0(icol,i,lay)*absb(ind0(icol) ,ig) + & - fs(icol) *fac0(icol,i,lay)*absb(ind0(icol)+1,ig) + & - (1.0_wp - fs(icol))*fac1(icol,i,lay)*absb(ind0(icol)+5,ig) + & - fs(icol) *fac1(icol,i,lay)*absb(ind0(icol)+6,ig)) - END DO - - END DO ! end loop over specparm types for tau_major calculation - - ! Compute taufor terms - ! Note the use of 1D bilinear interpolation of selfref and forref lookup - ! table values - ! =================================================================================== - - !dir$ SIMD - DO icol=1,ncol ! loop vectorizes with directive 14.0.2 - taug(icol,lay) = (tau_major(icol,0) + tau_major(icol,1) ) * stratcorrect(ig) - END DO - - !dir$ SIMD - DO icol=1,ncol ! loop vectorizes with directive 14.0.2 - speccomb_planck(icol) = colo3(icol,lay)+refrat_planck_b*colco2(icol,lay) - specparm_planck(icol) = colo3(icol,lay)/speccomb_planck(icol) - END DO - - !dir$ SIMD - DO icol=1,ncol ! loop vectorizes with directive 14.0.2 - IF (specparm_planck(icol) .GE. oneminus) specparm_planck(icol)=oneminus - specmult_planck(icol) = 4.0_wp*specparm_planck(icol) - jpl(icol)= 1 + INT(specmult_planck(icol)) - fpl(icol) = MOD(specmult_planck(icol),1.0_wp) - fracs(icol,lay) = fracrefb(ig,jpl(icol)) + fpl(icol)*(fracrefb(ig,jpl(icol)+1)-fracrefb(ig,jpl(icol))) - END DO - END DO ! nlayers loop - - END SUBROUTINE taumol04_upr - -END MODULE mo_taumol04 diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/CESM_license.txt b/test/ncar_kernels/PSRAD_lrtm_codereview/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/README b/test/ncar_kernels/PSRAD_lrtm_codereview/README deleted file mode 100644 index d495b7eef2..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/README +++ /dev/null @@ -1,21 +0,0 @@ -* kernel and supporting files - - lrtm subroutine is located at line #61 of mo_lrtm_driver.f90 file - - program statement or subroutine call is on line #320 in mo_psrad_interface.f90 - - call_hierarchy.png is a diagram showing function call hierarchy in PSrad - - The other files are subset of PSrad source files that contain information to execute lrtm - -* compilation and execution - - Place all files in a directory - - Adjust FC and FFLAGS macros in Makefile to use a specific compiler. Default compiler is ifort - - run "make" - -* verification - - "make" command will run kernel and print verification output on screen - - Verification is considered as pass if it shows "PASSED" or "Normalized RMS of difference" is around machine-precision (apprx. 10e-15) - - Verification check is performed using three data files- lrtm.1, lrtm.10 and lrtm.50. The data files are generated from running PSrad using Intel 15.0 compiler with "-O3 -xHost" compiler flags - -* performance measurement - - The kernel prints elapsed time (in seconds) as the time taken to execute the kernel - - The elapsed time is printed three times for each kernel executed using the three data files - - diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/data/lrtm.1 b/test/ncar_kernels/PSRAD_lrtm_codereview/data/lrtm.1 deleted file mode 100644 index 180c3d36f2..0000000000 Binary files a/test/ncar_kernels/PSRAD_lrtm_codereview/data/lrtm.1 and /dev/null differ diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/data/lrtm.10 b/test/ncar_kernels/PSRAD_lrtm_codereview/data/lrtm.10 deleted file mode 100644 index 01775e3cc2..0000000000 Binary files a/test/ncar_kernels/PSRAD_lrtm_codereview/data/lrtm.10 and /dev/null differ diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/data/lrtm.50 b/test/ncar_kernels/PSRAD_lrtm_codereview/data/lrtm.50 deleted file mode 100644 index e1ce33ff53..0000000000 Binary files a/test/ncar_kernels/PSRAD_lrtm_codereview/data/lrtm.50 and /dev/null differ diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/inc/t1.mk b/test/ncar_kernels/PSRAD_lrtm_codereview/inc/t1.mk deleted file mode 100644 index 2345c22e5c..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/inc/t1.mk +++ /dev/null @@ -1,103 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# Makefile for KGEN-generated kernel - -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# Intel default flags -# -# FC_FLAGS := -O3 -xAVX -ftz -funroll-loops -ip -no-fp-port -fp-model fast -# -no-prec-div -no-prec-sqrt -override-limits -align array64byte -# -DCPRINTEL -mkl -# FC_FLAGS := -O3 -xHost -# - -FC_FLAGS := $(OPT) - -ALL_OBJS := kernel_driver.o mo_psrad_interface.o mo_lrtm_kgs.o mo_cld_sampling.o mo_lrtm_solver.o mo_rrtm_coeffs.o mo_exception_stub.o mo_physical_constants.o mo_radiation_parameters.o mo_kind.o mo_spec_sampling.o mo_random_numbers.o mo_lrtm_setup.o mo_math_constants.o mo_rrtm_params.o mo_rad_fastmath.o mo_taumol03.o mo_taumol04.o mo_lrtm_driver.o mo_lrtm_gas_optics.o - -all: build run verify - -verify: - @(grep "verification.FAIL" $(TEST).rslt && echo "FAILED") || (grep "verification.PASS" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 mo_psrad_interface.o mo_lrtm_kgs.o mo_cld_sampling.o mo_lrtm_solver.o mo_rrtm_coeffs.o mo_exception_stub.o mo_physical_constants.o mo_radiation_parameters.o mo_kind.o mo_spec_sampling.o mo_random_numbers.o mo_lrtm_setup.o mo_math_constants.o mo_rrtm_params.o mo_rad_fastmath.o mo_lrtm_driver.o mo_lrtm_gas_optics.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_psrad_interface.o: $(SRC_DIR)/mo_psrad_interface.f90 mo_lrtm_driver.o mo_rrtm_params.o mo_kind.o mo_spec_sampling.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_lrtm_kgs.o: $(SRC_DIR)/mo_lrtm_kgs.f90 mo_kind.o mo_rrtm_params.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_cld_sampling.o: $(SRC_DIR)/mo_cld_sampling.f90 mo_kind.o mo_random_numbers.o mo_exception_stub.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_lrtm_solver.o: $(SRC_DIR)/mo_lrtm_solver.f90 mo_kind.o mo_rrtm_params.o mo_rad_fastmath.o mo_math_constants.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_taumol03.o: $(SRC_DIR)/mo_taumol03.f90 mo_kind.o mo_lrtm_setup.o mo_lrtm_kgs.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_taumol04.o: $(SRC_DIR)/mo_taumol04.f90 mo_kind.o mo_lrtm_setup.o mo_lrtm_kgs.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_rrlw_planck.o: $(SRC_DIR)/mo_rrlw_planck.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_rrtm_coeffs.o: $(SRC_DIR)/mo_rrtm_coeffs.f90 mo_kind.o mo_rrtm_params.o mo_lrtm_kgs.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_exception_stub.o: $(SRC_DIR)/mo_exception_stub.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_physical_constants.o: $(SRC_DIR)/mo_physical_constants.f90 mo_kind.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_radiation_parameters.o: $(SRC_DIR)/mo_radiation_parameters.f90 mo_kind.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_kind.o: $(SRC_DIR)/mo_kind.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_spec_sampling.o: $(SRC_DIR)/mo_spec_sampling.f90 mo_kind.o mo_random_numbers.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_random_numbers.o: $(SRC_DIR)/mo_random_numbers.f90 mo_kind.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_lrtm_setup.o: $(SRC_DIR)/mo_lrtm_setup.f90 mo_rrtm_params.o mo_kind.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_math_constants.o: $(SRC_DIR)/mo_math_constants.f90 mo_kind.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_rrtm_params.o: $(SRC_DIR)/mo_rrtm_params.f90 mo_kind.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_rad_fastmath.o: $(SRC_DIR)/mo_rad_fastmath.f90 mo_kind.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_lrtm_driver.o: $(SRC_DIR)/mo_lrtm_driver.f90 mo_rrtm_params.o mo_kind.o mo_spec_sampling.o mo_radiation_parameters.o mo_lrtm_setup.o mo_cld_sampling.o mo_rrtm_coeffs.o mo_lrtm_gas_optics.o mo_taumol03.o mo_taumol04.o mo_lrtm_kgs.o mo_physical_constants.o mo_lrtm_solver.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_lrtm_gas_optics.o: $(SRC_DIR)/mo_lrtm_gas_optics.f90 mo_kind.o mo_lrtm_setup.o mo_lrtm_kgs.o mo_exception_stub.o - ${FC} ${FC_FLAGS} -c -o $@ $< - - -clean: - rm -f kernel.exe *.mod *.o *.oo *.rslt diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/lit/runmake b/test/ncar_kernels/PSRAD_lrtm_codereview/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/lit/t1.sh b/test/ncar_kernels/PSRAD_lrtm_codereview/lit/t1.sh deleted file mode 100644 index 33c953a156..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/lit/t1.sh +++ /dev/null @@ -1,9 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -# Shared lit script for each tests. Run bash commands that run tests with make. - -# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t -# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/makefile b/test/ncar_kernels/PSRAD_lrtm_codereview/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/src/kernel_driver.f90 b/test/ncar_kernels/PSRAD_lrtm_codereview/src/kernel_driver.f90 deleted file mode 100644 index f40e019a30..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/src/kernel_driver.f90 +++ /dev/null @@ -1,141 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-02-19 15:30:29 -! KGEN version: 0.4.4 - - -PROGRAM kernel_driver - USE mo_psrad_interface, only : psrad_interface - USE mo_kind, ONLY: wp - USE mo_psrad_interface, only : read_externs_mo_psrad_interface - USE mo_radiation_parameters, only : read_externs_mo_radiation_parameters - USE rrlw_kg12, only : read_externs_rrlw_kg12 - USE rrlw_kg13, only : read_externs_rrlw_kg13 - USE rrlw_planck, only : read_externs_rrlw_planck - USE rrlw_kg11, only : read_externs_rrlw_kg11 - USE rrlw_kg16, only : read_externs_rrlw_kg16 - USE rrlw_kg14, only : read_externs_rrlw_kg14 - USE rrlw_kg15, only : read_externs_rrlw_kg15 - USE rrlw_kg10, only : read_externs_rrlw_kg10 - USE rrlw_kg01, only : read_externs_rrlw_kg01 - USE rrlw_kg03, only : read_externs_rrlw_kg03 - USE rrlw_kg02, only : read_externs_rrlw_kg02 - USE rrlw_kg05, only : read_externs_rrlw_kg05 - USE rrlw_kg04, only : read_externs_rrlw_kg04 - USE rrlw_kg07, only : read_externs_rrlw_kg07 - USE rrlw_kg06, only : read_externs_rrlw_kg06 - USE rrlw_kg09, only : read_externs_rrlw_kg09 - USE rrlw_kg08, only : read_externs_rrlw_kg08 - USE mo_random_numbers, only : read_externs_mo_random_numbers - - IMPLICIT NONE - - ! read interface - !interface kgen_read_var - ! procedure read_var_real_wp_dim1 - !end interface kgen_read_var - - - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_counter_at = (/ 1, 10, 50 /) - CHARACTER(LEN=1024) :: kgen_filepath - INTEGER :: nb_sw - INTEGER :: klev - REAL(KIND=wp), allocatable :: tk_sfc(:) - INTEGER :: kproma - INTEGER :: kbdim - INTEGER :: ktrac - - DO kgen_repeat_counter = 0, 2 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_filepath = "../data/lrtm." // trim(adjustl(kgen_counter_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "************ Verification against '" // trim(adjustl(kgen_filepath)) // "' ************" - - call read_externs_mo_psrad_interface(kgen_unit) - call read_externs_mo_radiation_parameters(kgen_unit) - call read_externs_rrlw_kg12(kgen_unit) - call read_externs_rrlw_kg13(kgen_unit) - call read_externs_rrlw_planck(kgen_unit) - call read_externs_rrlw_kg11(kgen_unit) - call read_externs_rrlw_kg16(kgen_unit) - call read_externs_rrlw_kg14(kgen_unit) - call read_externs_rrlw_kg15(kgen_unit) - call read_externs_rrlw_kg10(kgen_unit) - call read_externs_rrlw_kg01(kgen_unit) - call read_externs_rrlw_kg03(kgen_unit) - call read_externs_rrlw_kg02(kgen_unit) - call read_externs_rrlw_kg05(kgen_unit) - call read_externs_rrlw_kg04(kgen_unit) - call read_externs_rrlw_kg07(kgen_unit) - call read_externs_rrlw_kg06(kgen_unit) - call read_externs_rrlw_kg09(kgen_unit) - call read_externs_rrlw_kg08(kgen_unit) - call read_externs_mo_random_numbers(kgen_unit) - - ! driver variables - READ(UNIT=kgen_unit) kbdim - READ(UNIT=kgen_unit) klev - READ(UNIT=kgen_unit) nb_sw - READ(UNIT=kgen_unit) kproma - READ(UNIT=kgen_unit) ktrac - !call kgen_read_var(tk_sfc, kgen_unit) - call read_var_real_wp_dim1(tk_sfc, kgen_unit) - call psrad_interface(kbdim, klev, nb_sw, kproma, ktrac, tk_sfc, kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_cld_sampling.f90 b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_cld_sampling.f90 deleted file mode 100644 index f85e2cdfc3..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_cld_sampling.f90 +++ /dev/null @@ -1,88 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_cld_sampling.f90 -! Generated at: 2015-02-19 15:30:32 -! KGEN version: 0.4.4 - - - - MODULE mo_cld_sampling - USE mo_kind, ONLY: wp - USE mo_exception, ONLY: finish - USE mo_random_numbers, ONLY: get_random - IMPLICIT NONE - PRIVATE - PUBLIC sample_cld_state - CONTAINS - - ! read subroutines - !----------------------------------------------------------------------------- - !> - !! @brief Returns a sample of the cloud state - !! - !! @remarks - ! - - SUBROUTINE sample_cld_state(kproma, kbdim, klev, ksamps, rnseeds, i_overlap, cld_frac, cldy) - INTEGER, intent(in) :: kbdim - INTEGER, intent(in) :: klev - INTEGER, intent(in) :: ksamps - INTEGER, intent(in) :: kproma !< numbers of columns, levels, samples - INTEGER, intent(inout) :: rnseeds(:, :) !< Seeds for random number generator (kbdim, :) - INTEGER, intent(in) :: i_overlap !< 1=max-ran, 2=maximum, 3=random - REAL(KIND=wp), intent(in) :: cld_frac(kbdim,klev) !< cloud fraction - LOGICAL, intent(out) :: cldy(kbdim,klev,ksamps) !< Logical: cloud present? - REAL(KIND=wp) :: rank(kbdim,klev,ksamps) - INTEGER :: js - INTEGER :: jk - ! Here cldy(:,:,1) indicates whether any cloud is present - ! - cldy(1:kproma,1:klev,1) = cld_frac(1:kproma,1:klev) > 0._wp - SELECT CASE ( i_overlap ) - CASE ( 1 ) - ! Maximum-random overlap - DO js = 1, ksamps - DO jk = 1, klev - ! mask means we compute random numbers only when cloud is present - CALL get_random(kproma, kbdim, rnseeds, cldy(:,jk,1), rank(:,jk,js)) - END DO - END DO - ! There may be a better way to structure this calculation... - DO jk = klev-1, 1, -1 - DO js = 1, ksamps - rank(1:kproma,jk,js) = merge(rank(1:kproma,jk+1,js), & - rank(1:kproma,jk,js) * (1._wp - cld_frac(1:kproma,jk+1)), & - rank(1:kproma,jk+1,js) > 1._wp - cld_frac(1:kproma,jk+1)) - ! Max overlap... - ! ... or random overlap in the clear sky portion, - ! depending on whether or not you have cloud in the layer above - END DO - END DO - CASE ( 2 ) - ! - ! Max overlap means every cell in a column is identical - ! - DO js = 1, ksamps - CALL get_random(kproma, kbdim, rnseeds, rank(:, 1, js)) - rank(1:kproma,2:klev,js) = spread(rank(1:kproma,1,js), dim=2, ncopies=(klev-1)) - END DO - CASE ( 3 ) - ! - ! Random overlap means every cell is independent - ! - DO js = 1, ksamps - DO jk = 1, klev - ! mask means we compute random numbers only when cloud is present - CALL get_random(kproma, kbdim, rnseeds, cldy(:,jk,1), rank(:,jk,js)) - END DO - END DO - CASE DEFAULT - CALL finish('In sample_cld_state: unknown overlap assumption') - END SELECT - ! Now cldy indicates whether the sample (ks) is cloudy or not. - DO js = 1, ksamps - cldy(1:kproma,1:klev,js) = rank(1:kproma,1:klev,js) > (1. - cld_frac(1:kproma,1:klev)) - END DO - END SUBROUTINE sample_cld_state - END MODULE mo_cld_sampling diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_exception_stub.f90 b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_exception_stub.f90 deleted file mode 100644 index 51a60be233..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_exception_stub.f90 +++ /dev/null @@ -1,45 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_exception_stub.f90 -! Generated at: 2015-02-19 15:30:31 -! KGEN version: 0.4.4 - - - - MODULE mo_exception - IMPLICIT NONE - PRIVATE - PUBLIC finish - ! normal message - ! informational message - ! warning message: number of warnings counted - ! error message: number of errors counted - ! report parameter value - ! debugging message - !++mgs - CONTAINS - - ! read subroutines - - SUBROUTINE finish(name, text, exit_no) - CHARACTER(LEN=*), intent(in) :: name - CHARACTER(LEN=*), intent(in), optional :: text - INTEGER, intent(in), optional :: exit_no - INTEGER :: ifile - IF (present(exit_no)) THEN - ifile = exit_no - ELSE - ifile = 6 - END IF - WRITE (ifile, '(/,80("*"),/)') - IF (present(text)) THEN - WRITE (ifile, '(1x,a,a,a)') trim(name), ': ', trim(text) - ELSE - WRITE (ifile, '(1x,a,a)') trim(name), ': ' - END IF - WRITE (ifile, '(/,80("-"),/,/)') - STOP - END SUBROUTINE finish - - END MODULE mo_exception diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_kind.f90 b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_kind.f90 deleted file mode 100644 index f10effef4c..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_kind.f90 +++ /dev/null @@ -1,43 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_kind.f90 -! Generated at: 2015-02-19 15:30:37 -! KGEN version: 0.4.4 - - - - MODULE mo_kind - ! L. Kornblueh, MPI, August 2001, added working precision and comments - IMPLICIT NONE - ! Number model from which the SELECTED_*_KIND are requested: - ! - ! 4 byte REAL 8 byte REAL - ! CRAY: - precision = 13 - ! exponent = 2465 - ! IEEE: precision = 6 precision = 15 - ! exponent = 37 exponent = 307 - ! - ! Most likely this are the only possible models. - ! Floating point section: - INTEGER, parameter :: pd = 12 - INTEGER, parameter :: rd = 307 - INTEGER, parameter :: pi8 = 14 - INTEGER, parameter :: dp = selected_real_kind(pd,rd) - ! Floating point working precision - INTEGER, parameter :: wp = dp - ! Integer section - INTEGER, parameter :: i8 = selected_int_kind(pi8) - ! Working precision for index variables - ! - ! predefined preprocessor macros: - ! - ! xlf __64BIT__ checked with P6 and AIX - ! gfortran __LP64__ checked with Darwin and Linux - ! Intel, PGI __x86_64__ checked with Linux - ! Sun __x86_64 checked with Linux - CONTAINS - - ! read subroutines - - END MODULE mo_kind diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_lrtm_driver.f90 b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_lrtm_driver.f90 deleted file mode 100644 index 4180708fe5..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_lrtm_driver.f90 +++ /dev/null @@ -1,510 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_lrtm_driver.f90 -! Generated at: 2015-02-19 15:30:29 -! KGEN version: 0.4.4 - - - - MODULE mo_lrtm_driver - USE mo_kind, ONLY: wp - USE mo_physical_constants, ONLY: amw - USE mo_physical_constants, ONLY: amd - USE mo_physical_constants, ONLY: grav - USE mo_rrtm_params, ONLY: nbndlw - USE mo_rrtm_params, ONLY: ngptlw - USE mo_radiation_parameters, ONLY: do_gpoint - USE mo_radiation_parameters, ONLY: i_overlap - USE mo_radiation_parameters, ONLY: l_do_sep_clear_sky - USE mo_radiation_parameters, ONLY: rad_undef - USE mo_lrtm_setup, ONLY: ngb - USE mo_lrtm_setup, ONLY: ngs - USE mo_lrtm_setup, ONLY: delwave - USE mo_lrtm_setup, ONLY: nspa - USE mo_lrtm_setup, ONLY: nspb - USE rrlw_planck, ONLY: totplanck - USE mo_rrtm_coeffs, ONLY: lrtm_coeffs - USE mo_lrtm_gas_optics, ONLY: gas_optics_lw - USE mo_lrtm_solver, ONLY: find_secdiff - USE mo_lrtm_solver, ONLY: lrtm_solver - USE mo_cld_sampling, ONLY: sample_cld_state - USE mo_spec_sampling, ONLY: spec_sampling_strategy - USE mo_spec_sampling, ONLY: get_gpoint_set - USE mo_taumol03, ONLY: taumol03_lwr,taumol03_upr - USE mo_taumol04, ONLY: taumol04_lwr,taumol04_upr - USE rrlw_planck, ONLY: chi_mls - USE rrlw_kg03, ONLY: selfref - USE rrlw_kg03, ONLY: forref - USE rrlw_kg03, ONLY: ka_mn2o - USE rrlw_kg03, ONLY: absa - USE rrlw_kg03, ONLY: fracrefa - USE rrlw_kg03, ONLY: kb_mn2o - USE rrlw_kg03, ONLY: absb - USE rrlw_kg03, ONLY: fracrefb - IMPLICIT NONE - PRIVATE - PUBLIC lrtm - CONTAINS - - ! read subroutines - !----------------------------------------------------------------------------- - !> - !! @brief Prepares information for radiation call - !! - !! @remarks: This program is the driver subroutine for the longwave radiative - !! transfer routine. This routine is adapted from the AER LW RRTMG_LW model - !! that itself has been adapted from RRTM_LW for improved efficiency. Our - !! routine does the spectral integration externally (the solver is explicitly - !! called for each g-point, so as to facilitate sampling of g-points - !! This routine: - !! 1) calls INATM to read in the atmospheric profile from GCM; - !! all layering in RRTMG is ordered from surface to toa. - !! 2) calls COEFFS to calculate various quantities needed for - !! the radiative transfer algorithm. This routine is called only once for - !! any given thermodynamic state, i.e., it does not change if clouds chanege - !! 3) calls TAUMOL to calculate gaseous optical depths for each - !! of the 16 spectral bands, this is updated band by band. - !! 4) calls SOLVER (for both clear and cloudy profiles) to perform the - !! radiative transfer calculation with a maximum-random cloud - !! overlap method, or calls RTRN to use random cloud overlap. - !! 5) passes the necessary fluxes and cooling rates back to GCM - !! - ! - - SUBROUTINE lrtm(kproma, kbdim, klev, play, psfc, tlay, tlev, tsfc, wkl, wx, coldry, emis, cldfr, taucld, tauaer, rnseeds, & - strategy, n_gpts_ts, uflx, dflx, uflxc, dflxc) - INTEGER, intent(in) :: klev - INTEGER, intent(in) :: kbdim - INTEGER, intent(in) :: kproma - !< Maximum block length - !< Number of horizontal columns - !< Number of model layers - REAL(KIND=wp), intent(in) :: wx(:,:,:) - REAL(KIND=wp), intent(in) :: cldfr(kbdim,klev) - REAL(KIND=wp), intent(in) :: taucld(kbdim,klev,nbndlw) - REAL(KIND=wp), intent(in) :: wkl(:,:,:) - REAL(KIND=wp), intent(in) :: coldry(kbdim,klev) - REAL(KIND=wp), intent(in) :: play(kbdim,klev) - REAL(KIND=wp), intent(in) :: tlay(kbdim,klev) - REAL(KIND=wp), intent(in) :: tauaer(kbdim,klev,nbndlw) - REAL(KIND=wp), intent(in) :: tlev(kbdim,klev+1) - REAL(KIND=wp), intent(in) :: tsfc(kbdim) - REAL(KIND=wp), intent(in) :: psfc(kbdim) - REAL(KIND=wp), intent(in) :: emis(kbdim,nbndlw) - !< Layer pressures [hPa, mb] (kbdim,klev) - !< Surface pressure [hPa, mb] (kbdim) - !< Layer temperatures [K] (kbdim,klev) - !< Interface temperatures [K] (kbdim,klev+1) - !< Surface temperature [K] (kbdim) - !< Gas volume mixing ratios - !< CFC type gas volume mixing ratios - !< Column dry amount - !< Surface emissivity (kbdim,nbndlw) - !< Cloud fraction (kbdim,klev) - !< Coud optical depth (kbdim,klev,nbndlw) - !< Aerosol optical depth (kbdim,klev,nbndlw) - ! Variables for sampling cloud state and spectral points - INTEGER, intent(inout) :: rnseeds(:, :) !< Seeds for random number generator (kbdim,:) - TYPE(spec_sampling_strategy), intent(in) :: strategy - INTEGER, intent(in ) :: n_gpts_ts - REAL(KIND=wp), intent(out) :: uflx (kbdim,0:klev) - REAL(KIND=wp), intent(out) :: dflx (kbdim,0:klev) - REAL(KIND=wp), intent(out) :: uflxc(kbdim,0:klev) - REAL(KIND=wp), intent(out) :: dflxc(kbdim,0:klev) - !< Tot sky longwave upward flux [W/m2], (kbdim,0:klev) - !< Tot sky longwave downward flux [W/m2], (kbdim,0:klev) - !< Clr sky longwave upward flux [W/m2], (kbdim,0:klev) - !< Clr sky longwave downward flux [W/m2], (kbdim,0:klev) - REAL(KIND=wp) :: taug(klev) !< Properties for one column at a time >! gas optical depth - REAL(KIND=wp) :: rrpk_taug03(kbdim,klev) - REAL(KIND=wp) :: rrpk_taug04(kbdim,klev) - REAL(KIND=wp) :: fracs(kbdim,klev,n_gpts_ts) - REAL(KIND=wp) :: taut (kbdim,klev,n_gpts_ts) - REAL(KIND=wp) :: tautot(kbdim,klev,n_gpts_ts) - REAL(KIND=wp) :: pwvcm(kbdim) - REAL(KIND=wp) :: secdiff(kbdim) - !< Planck fraction per g-point - !< precipitable water vapor [cm] - !< diffusivity angle for RT calculation - !< gaseous + aerosol optical depths for all columns - !< cloud + gaseous + aerosol optical depths for all columns - REAL(KIND=wp) :: planklay(kbdim, klev,nbndlw) - REAL(KIND=wp) :: planklev(kbdim,0:klev,nbndlw) - REAL(KIND=wp) :: plankbnd(kbdim, nbndlw) ! Properties for all bands - ! Planck function at mid-layer - ! Planck function at level interfaces - ! Planck function at surface - REAL(KIND=wp) :: layplnk(kbdim, klev) - REAL(KIND=wp) :: levplnk(kbdim,0:klev) - REAL(KIND=wp) :: bndplnk(kbdim) - REAL(KIND=wp) :: srfemis(kbdim) ! Properties for a single set of columns/g-points - ! Planck function at mid-layer - ! Planck function at level interfaces - ! Planck function at surface - ! Surface emission - REAL(KIND=wp) :: zgpfd(kbdim,0:klev) - REAL(KIND=wp) :: zgpfu(kbdim,0:klev) - REAL(KIND=wp) :: zgpcu(kbdim,0:klev) - REAL(KIND=wp) :: zgpcd(kbdim,0:klev) - ! < gpoint clearsky downward flux - ! < gpoint clearsky downward flux - ! < gpoint fullsky downward flux - ! < gpoint fullsky downward flux - ! ----------------- - ! Variables for gas optics calculations - INTEGER :: jt1 (kbdim,klev) - INTEGER :: indfor (kbdim,klev) - INTEGER :: indself (kbdim,klev) - INTEGER :: indminor(kbdim,klev) - INTEGER :: laytrop (kbdim ) - INTEGER :: jp (kbdim,klev) - INTEGER :: rrpk_jp (klev,kbdim) - INTEGER :: jt (kbdim,klev) - INTEGER :: rrpk_jt (kbdim,0:1,klev) - !< tropopause layer index - !< lookup table index - !< lookup table index - !< lookup table index - REAL(KIND=wp) :: wbrodl (kbdim,klev) - REAL(KIND=wp) :: selffac (kbdim,klev) - REAL(KIND=wp) :: colh2o (kbdim,klev) - REAL(KIND=wp) :: colo3 (kbdim,klev) - REAL(KIND=wp) :: coln2o (kbdim,klev) - REAL(KIND=wp) :: colco (kbdim,klev) - REAL(KIND=wp) :: selffrac (kbdim,klev) - REAL(KIND=wp) :: colch4 (kbdim,klev) - REAL(KIND=wp) :: colo2 (kbdim,klev) - REAL(KIND=wp) :: colbrd (kbdim,klev) - REAL(KIND=wp) :: minorfrac (kbdim,klev) - REAL(KIND=wp) :: scaleminorn2(kbdim,klev) - REAL(KIND=wp) :: scaleminor (kbdim,klev) - REAL(KIND=wp) :: forfac (kbdim,klev) - REAL(KIND=wp) :: colco2 (kbdim,klev) - REAL(KIND=wp) :: forfrac (kbdim,klev) - !< column amount (h2o) - !< column amount (co2) - !< column amount (o3) - !< column amount (n2o) - !< column amount (co) - !< column amount (ch4) - !< column amount (o2) - !< column amount (broadening gases) - REAL(KIND=wp) :: wx_loc(size(wx, 2), size(wx, 3)) - !< Normalized CFC amounts (molecules/cm^2) - REAL(KIND=wp) :: fac00(kbdim,klev) - REAL(KIND=wp) :: fac01(kbdim,klev) - REAL(KIND=wp) :: fac10(kbdim,klev) - REAL(KIND=wp) :: fac11(kbdim,klev) - REAL(KIND=wp) :: rrpk_fac0(kbdim,0:1,klev) - REAL(KIND=wp) :: rrpk_fac1(kbdim,0:1,klev) - REAL(KIND=wp) :: rat_n2oco2 (kbdim,klev) - REAL(KIND=wp) :: rat_o3co2 (kbdim,klev) - REAL(KIND=wp) :: rat_h2on2o (kbdim,klev) - REAL(KIND=wp) :: rat_n2oco2_1(kbdim,klev) - REAL(KIND=wp) :: rat_h2on2o_1(kbdim,klev) - REAL(KIND=wp) :: rat_h2oco2_1(kbdim,klev) - REAL(KIND=wp) :: rat_h2oo3 (kbdim,klev) - REAL(KIND=wp) :: rat_h2och4 (kbdim,klev) - REAL(KIND=wp) :: rat_h2oco2 (kbdim,klev) - REAL(KIND=wp) :: rrpk_rat_h2oco2 (kbdim,0:1,klev) - REAL(KIND=wp) :: rrpk_rat_o3co2 (kbdim,0:1,klev) - REAL(KIND=wp) :: rat_h2oo3_1 (kbdim,klev) - REAL(KIND=wp) :: rat_o3co2_1 (kbdim,klev) - REAL(KIND=wp) :: rat_h2och4_1(kbdim,klev) - ! ----------------- - INTEGER :: jl,jlBegin,simdStep=96 - INTEGER :: ig - INTEGER :: jk ! loop indicies - INTEGER :: igs(kbdim, n_gpts_ts) - INTEGER :: ibs(kbdim, n_gpts_ts) - INTEGER :: ib - INTEGER :: igpt - INTEGER*8 :: start_clock,stop_clock,rate_clock - REAL :: overall_time=0 - ! minimum val for clouds - ! Variables for sampling strategy - REAL(KIND=wp) :: gpt_scaling - REAL(KIND=wp) :: clrsky_scaling(1:kbdim) - REAL(KIND=wp) :: smp_tau(kbdim, klev, n_gpts_ts) - LOGICAL :: cldmask(kbdim, klev, n_gpts_ts) - LOGICAL :: colcldmask(kbdim, n_gpts_ts) !< cloud mask in each cell - !< cloud mask for each column - ! - ! -------------------------------- - ! - ! 1.0 Choose a set of g-points to do consistent with the spectral sampling strategy - ! - ! -------------------------------- - gpt_scaling = real(ngptlw,kind=wp)/real(n_gpts_ts,kind=wp) - ! Standalone logic - IF (do_gpoint == 0) THEN - igs(1:kproma,1:n_gpts_ts) = get_gpoint_set(kproma, kbdim, strategy, rnseeds) - ELSE IF (n_gpts_ts == 1) THEN ! Standalone logic - IF (do_gpoint > ngptlw) RETURN - igs(:, 1:n_gpts_ts) = do_gpoint - ELSE - PRINT *, "Asking for gpoint fluxes for too many gpoints!" - STOP - END IF - ! Save the band nunber associated with each gpoint - DO jl = 1, kproma - DO ig = 1, n_gpts_ts - ibs(jl, ig) = ngb(igs(jl, ig)) - END DO - END DO - ! - ! --- 2.0 Optical properties - ! - ! --- 2.1 Cloud optical properties. - ! -------------------------------- - ! Cloud optical depth is only saved for the band associated with this g-point - ! We sample clouds first because we may want to adjust water vapor based - ! on presence/absence of clouds - ! - CALL sample_cld_state(kproma, kbdim, klev, n_gpts_ts, rnseeds(:,:), i_overlap, cldfr(:,:), cldmask(:,:,:)) - !IBM* ASSERT(NODEPS) - DO ig = 1, n_gpts_ts - DO jl = 1, kproma - smp_tau(jl,:,ig) = merge(taucld(jl,1:klev,ibs(jl,ig)), 0._wp, cldmask(jl,:,ig)) - END DO - END DO ! Loop over samples - done with cloud optical depth calculations - ! - ! Cloud masks for sorting out clear skies - by cell and by column - ! - IF (.not. l_do_sep_clear_sky) THEN - ! - ! Are any layers cloudy? - ! - colcldmask(1:kproma, 1:n_gpts_ts) = any(cldmask(1:kproma,1:klev,1:n_gpts_ts), dim=2) - ! - ! Clear-sky scaling is gpt_scaling/frac_clr or 0 if all samples are cloudy - ! - clrsky_scaling(1:kproma) = gpt_scaling * & - merge(real(n_gpts_ts,kind=wp) / (real(n_gpts_ts - count(& - colcldmask(1:kproma,:),dim=2),kind=wp)), & - 0._wp, any(.not. colcldmask(1:kproma,:),dim=2)) - END IF - ! - ! --- 2.2. Gas optical depth calculations - ! - ! -------------------------------- - ! - ! 2.2.1 Calculate information needed by the radiative transfer routine - ! that is specific to this atmosphere, especially some of the - ! coefficients and indices needed to compute the optical depths - ! by interpolating data from stored reference atmospheres. - ! The coefficients are functions of temperature and pressure and remain the same - ! for all g-point samples. - ! If gas concentrations, temperatures, or pressures vary with sample (ig) - ! the coefficients need to be calculated inside the loop over samples - ! -------------------------------- - ! - ! Broadening gases -- the number of molecules per cm^2 of all gases not specified explicitly - ! (water is excluded) - wbrodl(1:kproma,1:klev) = coldry(1:kproma,1:klev) - sum(wkl(1:kproma,2:,1:klev), dim=2) - CALL lrtm_coeffs(kproma, kbdim, klev, play, tlay, coldry, wkl, wbrodl, laytrop, jp, jt, jt1, colh2o, colco2, colo3, & - coln2o, colco, colch4, colo2, colbrd, fac00, fac01, fac10, fac11, rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, & - rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, selffac, & - selffrac, indself, forfac, forfrac, indfor, minorfrac, scaleminor, scaleminorn2, indminor) - ! - ! 2.2.2 Loop over g-points calculating gas optical properties. - ! - ! -------------------------------- - !IBM* ASSERT(NODEPS) - !CALL system_clock(start_clock,rate_clock) - rrpk_rat_h2oco2(:,0,:) = rat_h2oco2 - rrpk_rat_h2oco2(:,1,:) = (rat_h2oco2_1) - rrpk_rat_o3co2(:,0,:) = rat_o3co2 - rrpk_rat_o3co2(:,1,:) = (rat_o3co2_1) - rrpk_fac0(:,0,:) = fac00 - rrpk_fac0(:,1,:) = fac01 - rrpk_fac1(:,0,:) = fac10 - rrpk_fac1(:,1,:) = fac11 - rrpk_jt(:,0,:) = jt - rrpk_jt(:,1,:) = jt1 - !CALL system_clock(stop_clock,rate_clock) - !overall_time=overall_time + (stop_clock-start_clock)/REAL(rate_clock) - !print *,n_gpts_ts - !print *,"===",kproma - DO ig = 1, n_gpts_ts - igpt=igs(1,ig) - IF(ngb(igpt) == 3) Then - CALL system_clock(start_clock, rate_clock) - jl=kproma - DO jlBegin = 1,kproma,simdStep - jl = jlBegin+simdStep-1 - call taumol03_lwr(jl,jlBegin,laytrop(1), klev, & - rrpk_rat_h2oco2(jlBegin:jl,:,:), colco2(jlBegin:jl,:), colh2o(jlBegin:jl,:), coln2o(jlBegin:jl,:), coldry(jlBegin:jl,:), & - rrpk_fac0(jlBegin:jl,:,:), rrpk_fac1(jlBegin:jl,:,:), minorfrac(jlBegin:jl,:), & - selffac(jlBegin:jl,:),selffrac(jlBegin:jl,:),forfac(jlBegin:jl,:),forfrac(jlBegin:jl,:), & - jp(jlBegin:jl,:), rrpk_jt(jlBegin:jl,:,:), (igpt-ngs(ngb(igpt)-1)), indself(jlBegin:jl,:), & - indfor(jlBegin:jl,:), indminor(jlBegin:jl,:), & - rrpk_taug03(jlBegin:jl,:),fracs(jlBegin:jl,:,ig)) - !print *,"Computing" - call taumol03_upr(jl,jlBegin,laytrop(1), klev, & - rrpk_rat_h2oco2(jlBegin:jl,:,:), colco2(jlBegin:jl,:), colh2o(jlBegin:jl,:), coln2o(jlBegin:jl,:), coldry(jlBegin:jl,:), & - rrpk_fac0(jlBegin:jl,:,:), rrpk_fac1(jlBegin:jl,:,:), minorfrac(jlBegin:jl,:), & - forfac(jlBegin:jl,:),forfrac(jlBegin:jl,:), & - jp(jlBegin:jl,:), rrpk_jt(jlBegin:jl,:,:), (igpt-ngs(ngb(igpt)-1)), & - indfor(jlBegin:jl,:), indminor(jlBegin:jl,:), & - rrpk_taug03(jlBegin:jl,:),fracs(jlBegin:jl,:,ig)) - !print *,"End Computing" - END DO - CALL system_clock(stop_clock, rate_clock) - overall_time=overall_time + (stop_clock-start_clock)/REAL(rate_clock) - ENDIF - IF(ngb(igpt) == 4) Then - !CALL system_clock(start_clock, rate_clock) - jl=kproma - call taumol04_lwr(jl,laytrop(1), klev, & - rrpk_rat_h2oco2(1:jl,:,:), colco2(1:jl,:), colh2o(1:jl,:), coldry(1:jl,:), & - rrpk_fac0(1:jl,:,:), rrpk_fac1(1:jl,:,:), minorfrac(1:jl,:), & - selffac(1:jl,:),selffrac(1:jl,:),forfac(1:jl,:),forfrac(1:jl,:), & - jp(1:jl,:), rrpk_jt(1:jl,:,:), (igpt-ngs(ngb(igpt)-1)), indself(1:jl,:), & - indfor(1:jl,:), & - rrpk_taug04(1:jl,:),fracs(1:jl,:,ig)) - call taumol04_upr(jl,laytrop(1), klev, & - rrpk_rat_o3co2(1:jl,:,:), colco2(1:jl,:), colo3(1:jl,:), coldry(1:jl,:), & - rrpk_fac0(1:jl,:,:), rrpk_fac1(1:jl,:,:), minorfrac(1:jl,:), & - forfac(1:jl,:),forfrac(1:jl,:), & - jp(1:jl,:), rrpk_jt(1:jl,:,:), (igpt-ngs(ngb(igpt)-1)), & - indfor(1:jl,:), & - rrpk_taug04(1:jl,:),fracs(1:jl,:,ig)) - !CALL system_clock(stop_clock, rate_clock) - !overall_time=overall_time + (stop_clock-start_clock)/REAL(rate_clock) - ENDIF - DO jl = 1, kproma - ib = ibs(jl, ig) - igpt = igs(jl, ig) - ! - ! Gas concentrations in colxx variables are normalized by 1.e-20_wp in lrtm_coeffs - ! CFC gas concentrations (wx) need the same normalization - ! Per Eli Mlawer the k values used in gas optics tables have been multiplied by 1e20 - wx_loc(:,:) = 1.e-20_wp * wx(jl,:,:) - IF (ngb(igpt) == 3) THEN - taug = rrpk_taug03(jl,:) - ELSEIF (ngb(igpt) == 4) THEN - taug = rrpk_taug04(jl,:) - ELSE - CALL gas_optics_lw(klev, igpt, play (jl,:), wx_loc (:,:), coldry (jl,:), laytrop (jl), jp & - (jl,:), jt (jl,:), jt1 (jl,:), colh2o (jl,:), colco2 (jl,:), colo3 (jl,:)& - , coln2o (jl,:), colco (jl,:), colch4 (jl,:), colo2 (jl,:), colbrd (jl,:), fac00 & - (jl,:), fac01 (jl,:), fac10 (jl,:), fac11 (jl,:), rat_h2oco2 (jl,:), rat_h2oco2_1(jl,:), & - rat_h2oo3 (jl,:), rat_h2oo3_1 (jl,:), rat_h2on2o (jl,:), rat_h2on2o_1(jl,:), rat_h2och4(jl,:), rat_h2och4_1(& - jl,:), rat_n2oco2 (jl,:), rat_n2oco2_1(jl,:), rat_o3co2 (jl,:), rat_o3co2_1 (jl,:), selffac (jl,:), & - selffrac (jl,:), indself (jl,:), forfac (jl,:), forfrac (jl,:), indfor (jl,:), minorfrac (& - jl,:), scaleminor (jl,:), scaleminorn2(jl,:), indminor (jl,:), fracs (jl,:,ig), taug ) - END IF - DO jk = 1, klev - taut(jl,jk,ig) = taug(jk) + tauaer(jl,jk,ib) - END DO - END DO ! Loop over columns - END DO ! Loop over g point samples - done with gas optical depth calculations - PRINT *, "Elapsed time (sec): ", overall_time - overall_time=0 - tautot(1:kproma,:,:) = taut(1:kproma,:,:) + smp_tau(1:kproma,:,:) ! All-sky optical depth. Mask for 0 cloud optical depth? - ! - ! --- 3.0 Compute radiative transfer. - ! -------------------------------- - ! - ! Initialize fluxes to zero - ! - uflx(1:kproma,0:klev) = 0.0_wp - dflx(1:kproma,0:klev) = 0.0_wp - uflxc(1:kproma,0:klev) = 0.0_wp - dflxc(1:kproma,0:klev) = 0.0_wp - ! - ! Planck function in each band at layers and boundaries - ! - !IBM* ASSERT(NODEPS) - DO ig = 1, nbndlw - planklay(1:kproma,1:klev,ig) = planckfunction(tlay(1:kproma,1:klev ),ig) - planklev(1:kproma,0:klev,ig) = planckfunction(tlev(1:kproma,1:klev+1),ig) - plankbnd(1:kproma, ig) = planckfunction(tsfc(1:kproma ),ig) - END DO - ! - ! Precipitable water vapor in each column - this can affect the integration angle secdiff - ! - pwvcm(1:kproma) = ((amw * sum(wkl(1:kproma,1,1:klev), dim=2)) / (amd * sum(coldry(1:kproma,& - 1:klev) + wkl(1:kproma,1,1:klev), dim=2))) * (1.e3_wp * psfc(1:kproma)) / (1.e2_wp * grav) - ! - ! Compute radiative transfer for each set of samples - ! - DO ig = 1, n_gpts_ts - secdiff(1:kproma) = find_secdiff(ibs(1:kproma, ig), pwvcm(1:kproma)) - !IBM* ASSERT(NODEPS) - DO jl = 1, kproma - ib = ibs(jl,ig) - layplnk(jl,1:klev) = planklay(jl,1:klev,ib) - levplnk(jl,0:klev) = planklev(jl,0:klev,ib) - bndplnk(jl) = plankbnd(jl, ib) - srfemis(jl) = emis (jl, ib) - END DO - ! - ! All sky fluxes - ! - CALL lrtm_solver(kproma, kbdim, klev, tautot(:,:,ig), layplnk, levplnk, fracs(:,:,ig), secdiff, bndplnk, srfemis, & - zgpfu, zgpfd) - uflx(1:kproma,0:klev) = uflx (1:kproma,0:klev) + zgpfu(1:kproma,0:klev) * gpt_scaling - dflx(1:kproma,0:klev) = dflx (1:kproma,0:klev) + zgpfd(1:kproma,0:klev) * gpt_scaling - ! - ! Clear-sky fluxes - ! - IF (l_do_sep_clear_sky) THEN - ! - ! Remove clouds and do second RT calculation - ! - CALL lrtm_solver(kproma, kbdim, klev, taut (:,:,ig), layplnk, levplnk, fracs(:,:,ig), secdiff, bndplnk, & - srfemis, zgpcu, zgpcd) - uflxc(1:kproma,0:klev) = uflxc(1:kproma,0:klev) + zgpcu(1:kproma,0:klev) * gpt_scaling - dflxc(1:kproma,0:klev) = dflxc(1:kproma,0:klev) + zgpcd(1:kproma,0:klev) * gpt_scaling - ELSE - ! - ! Accumulate fluxes by excluding cloudy subcolumns, weighting to account for smaller sample size - ! - !IBM* ASSERT(NODEPS) - DO jk = 0, klev - uflxc(1:kproma,jk) = uflxc(1:kproma,jk) & - + merge(0._wp, & - zgpfu(1:kproma,jk) * clrsky_scaling(1:kproma), & - colcldmask(1:kproma,ig)) - dflxc(1:kproma,jk) = dflxc(1:kproma,jk) & - + merge(0._wp, & - zgpfd(1:kproma,jk) * clrsky_scaling(1:kproma), & - colcldmask(1:kproma,ig)) - END DO - END IF - END DO ! Loop over samples - ! - ! --- 3.1 If computing clear-sky fluxes from samples, flag any columns where all samples were cloudy - ! - ! -------------------------------- - IF (.not. l_do_sep_clear_sky) THEN - !IBM* ASSERT(NODEPS) - DO jl = 1, kproma - IF (all(colcldmask(jl,:))) THEN - uflxc(jl,0:klev) = rad_undef - dflxc(jl,0:klev) = rad_undef - END IF - END DO - END IF - END SUBROUTINE lrtm - !---------------------------------------------------------------------------- - - elemental FUNCTION planckfunction(temp, band) - ! - ! Compute the blackbody emission in a given band as a function of temperature - ! - REAL(KIND=wp), intent(in) :: temp - INTEGER, intent(in) :: band - REAL(KIND=wp) :: planckfunction - INTEGER :: index - REAL(KIND=wp) :: fraction - index = min(max(1, int(temp - 159._wp)),180) - fraction = temp - 159._wp - float(index) - planckfunction = totplanck(index, band) + fraction * (totplanck(index+1, band) - totplanck(index, & - band)) - planckfunction = planckfunction * delwave(band) - END FUNCTION planckfunction - END MODULE mo_lrtm_driver diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_lrtm_gas_optics.f90 b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_lrtm_gas_optics.f90 deleted file mode 100644 index d2c0cf3f32..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_lrtm_gas_optics.f90 +++ /dev/null @@ -1,3006 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_lrtm_gas_optics.f90 -! Generated at: 2015-02-19 15:30:40 -! KGEN version: 0.4.4 - - - - MODULE mo_lrtm_gas_optics - ! -------------------------------------------------------------------------- - ! | | - ! | Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER). | - ! | This software may be used, copied, or redistributed as long as it is | - ! | not sold and this copyright notice is reproduced on each copy made. | - ! | This model is provided as is without any express or implied warranties. | - ! | (http://www.rtweb.aer.com/) | - ! | | - ! -------------------------------------------------------------------------- - ! ------- Modules ------- - USE mo_kind, ONLY: wp - USE mo_exception, ONLY: finish - USE mo_lrtm_setup, ONLY: ngb - USE mo_lrtm_setup, ONLY: ngs - USE mo_lrtm_setup, ONLY: nspa - USE mo_lrtm_setup, ONLY: nspb - USE mo_lrtm_setup, ONLY: ngc - USE rrlw_planck, ONLY: chi_mls - IMPLICIT NONE - REAL(KIND=wp), parameter :: oneminus = 1.0_wp - 1.0e-06_wp - CONTAINS - - ! read subroutines - !---------------------------------------------------------------------------- - - SUBROUTINE gas_optics_lw(nlayers, igg, pavel, wx, coldry, laytrop, jp, jt, jt1, colh2o, colco2, colo3, coln2o, colco, & - colch4, colo2, colbrd, fac00, fac01, fac10, fac11, rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, rat_h2on2o, & - rat_h2on2o_1, rat_h2och4, rat_h2och4_1, rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, selffac, selffrac, indself, & - forfac, forfrac, indfor, minorfrac, scaleminor, scaleminorn2, indminor, fracs, taug) - !---------------------------------------------------------------------------- - ! ******************************************************************************* - ! * * - ! * Optical depths developed for the * - ! * * - ! * RAPID RADIATIVE TRANSFER MODEL (RRTM) * - ! * * - ! * * - ! * ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC. * - ! * 131 HARTWELL AVENUE * - ! * LEXINGTON, MA 02421 * - ! * * - ! * * - ! * ELI J. MLAWER * - ! * JENNIFER DELAMERE * - ! * STEVEN J. TAUBMAN * - ! * SHEPARD A. CLOUGH * - ! * * - ! * * - ! * * - ! * * - ! * email: mlawer@aer.com * - ! * email: jdelamer@aer.com * - ! * * - ! * The authors wish to acknowledge the contributions of the * - ! * following people: Karen Cady-Pereira, Patrick D. Brown, * - ! * Michael J. Iacono, Ronald E. Farren, Luke Chen, Robert Bergstrom. * - ! * * - ! ******************************************************************************* - ! * * - ! * Revision for g-point reduction: Michael J. Iacono, AER, Inc. * - ! * * - ! ******************************************************************************* - ! * TAUMOL * - ! * * - ! * This file contains the subroutines TAUGBn (where n goes from * - ! * 1 to 16). TAUGBn calculates the optical depths and Planck fractions * - ! * per g-value and layer for band n. * - ! * * - ! * Output: optical depths (unitless) * - ! * fractions needed to compute Planck functions at every layer * - ! * and g-value * - ! * * - ! * COMMON /TAUGCOM/ TAUG(MXLAY,MG) * - ! * COMMON /PLANKG/ FRACS(MXLAY,MG) * - ! * * - ! * Input * - ! * * - ! * COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS) * - ! * COMMON /PRECISE/ ONEMINUS * - ! * COMMON /PROFILE/ NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY), * - ! * & PZ(0:MXLAY),TZ(0:MXLAY) * - ! * COMMON /PROFDATA/ LAYTROP, * - ! * & COLH2O(MXLAY),COLCO2(MXLAY),COLO3(MXLAY), * - ! * & COLN2O(MXLAY),COLCO(MXLAY),COLCH4(MXLAY), * - ! * & COLO2(MXLAY) - ! * COMMON /INTFAC/ FAC00(MXLAY),FAC01(MXLAY), * - ! * & FAC10(MXLAY),FAC11(MXLAY) * - ! * COMMON /INTIND/ JP(MXLAY),JT(MXLAY),JT1(MXLAY) * - ! * COMMON /SELF/ SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(MXLAY) * - ! * * - ! * Description: * - ! * NG(IBAND) - number of g-values in band IBAND * - ! * NSPA(IBAND) - for the lower atmosphere, the number of reference * - ! * atmospheres that are stored for band IBAND per * - ! * pressure level and temperature. Each of these * - ! * atmospheres has different relative amounts of the * - ! * key species for the band (i.e. different binary * - ! * species parameters). * - ! * NSPB(IBAND) - same for upper atmosphere * - ! * ONEMINUS - since problems are caused in some cases by interpolation * - ! * parameters equal to or greater than 1, for these cases * - ! * these parameters are set to this value, slightly < 1. * - ! * PAVEL - layer pressures (mb) * - ! * TAVEL - layer temperatures (degrees K) * - ! * PZ - level pressures (mb) * - ! * TZ - level temperatures (degrees K) * - ! * LAYTROP - layer at which switch is made from one combination of * - ! * key species to another * - ! * COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water * - ! * vapor,carbon dioxide, ozone, nitrous ozide, methane, * - ! * respectively (molecules/cm**2) * - ! * FACij(LAY) - for layer LAY, these are factors that are needed to * - ! * compute the interpolation factors that multiply the * - ! * appropriate reference k-values. A value of 0 (1) for * - ! * i,j indicates that the corresponding factor multiplies * - ! * reference k-value for the lower (higher) of the two * - ! * appropriate temperatures, and altitudes, respectively. * - ! * JP - the index of the lower (in altitude) of the two appropriate * - ! * reference pressure levels needed for interpolation * - ! * JT, JT1 - the indices of the lower of the two appropriate reference * - ! * temperatures needed for interpolation (for pressure * - ! * levels JP and JP+1, respectively) * - ! * SELFFAC - scale factor needed for water vapor self-continuum, equals * - ! * (water vapor density)/(atmospheric density at 296K and * - ! * 1013 mb) * - ! * SELFFRAC - factor needed for temperature interpolation of reference * - ! * water vapor self-continuum data * - ! * INDSELF - index of the lower of the two appropriate reference * - ! * temperatures needed for the self-continuum interpolation * - ! * FORFAC - scale factor needed for water vapor foreign-continuum. * - ! * FORFRAC - factor needed for temperature interpolation of reference * - ! * water vapor foreign-continuum data * - ! * INDFOR - index of the lower of the two appropriate reference * - ! * temperatures needed for the foreign-continuum interpolation * - ! * * - ! * Data input * - ! * COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG),* - ! * FORREF(4,MG), KA_M'MGAS', KB_M'MGAS' * - ! * (note: n is the band number,'MGAS' is the species name of the minor * - ! * gas) * - ! * * - ! * Description: * - ! * KA - k-values for low reference atmospheres (key-species only) * - ! * (units: cm**2/molecule) * - ! * KB - k-values for high reference atmospheres (key-species only) * - ! * (units: cm**2/molecule) * - ! * KA_M'MGAS' - k-values for low reference atmosphere minor species * - ! * (units: cm**2/molecule) * - ! * KB_M'MGAS' - k-values for high reference atmosphere minor species * - ! * (units: cm**2/molecule) * - ! * SELFREF - k-values for water vapor self-continuum for reference * - ! * atmospheres (used below LAYTROP) * - ! * (units: cm**2/molecule) * - ! * FORREF - k-values for water vapor foreign-continuum for reference * - ! * atmospheres (used below/above LAYTROP) * - ! * (units: cm**2/molecule) * - ! * * - ! * DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG) * - ! * EQUIVALENCE (KA,ABSA),(KB,ABSB) * - ! * * - !******************************************************************************* - ! ------- Declarations ------- - ! ----- Input ----- - INTEGER, intent(in) :: igg ! g-point to process - INTEGER, intent(in) :: nlayers ! total number of layers - REAL(KIND=wp), intent(in) :: pavel(:) ! layer pressures (mb) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: wx(:,:) ! cross-section amounts (mol/cm2) - ! Dimensions: (maxxsec,nlayers) - REAL(KIND=wp), intent(in) :: coldry(:) ! column amount (dry air) - ! Dimensions: (nlayers) - INTEGER, intent(in) :: laytrop ! tropopause layer index - INTEGER, intent(in) :: jp(:) ! - ! Dimensions: (nlayers) - INTEGER, intent(in) :: jt(:) ! - ! Dimensions: (nlayers) - INTEGER, intent(in) :: jt1(:) ! - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: colh2o(:) ! column amount (h2o) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: colco2(:) ! column amount (co2) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: colo3(:) ! column amount (o3) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: coln2o(:) ! column amount (n2o) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: colco(:) ! column amount (co) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: colch4(:) ! column amount (ch4) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: colo2(:) ! column amount (o2) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: colbrd(:) ! column amount (broadening gases) - ! Dimensions: (nlayers) - INTEGER, intent(in) :: indself(:) - ! Dimensions: (nlayers) - INTEGER, intent(in) :: indfor(:) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: selffac(:) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: selffrac(:) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: forfac(:) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: forfrac(:) - ! Dimensions: (nlayers) - INTEGER, intent(in) :: indminor(:) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: minorfrac(:) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: scaleminor(:) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: scaleminorn2(:) - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: fac11(:) - REAL(KIND=wp), intent(in) :: fac01(:) - REAL(KIND=wp), intent(in) :: fac00(:) - REAL(KIND=wp), intent(in) :: fac10(:) ! - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(in) :: rat_h2oco2(:) - REAL(KIND=wp), intent(in) :: rat_h2oco2_1(:) - REAL(KIND=wp), intent(in) :: rat_o3co2(:) - REAL(KIND=wp), intent(in) :: rat_o3co2_1(:) - REAL(KIND=wp), intent(in) :: rat_h2oo3(:) - REAL(KIND=wp), intent(in) :: rat_h2oo3_1(:) - REAL(KIND=wp), intent(in) :: rat_h2och4(:) - REAL(KIND=wp), intent(in) :: rat_h2och4_1(:) - REAL(KIND=wp), intent(in) :: rat_h2on2o(:) - REAL(KIND=wp), intent(in) :: rat_h2on2o_1(:) - REAL(KIND=wp), intent(in) :: rat_n2oco2(:) - REAL(KIND=wp), intent(in) :: rat_n2oco2_1(:) ! - ! Dimensions: (nlayers) - ! ----- Output ----- - REAL(KIND=wp), intent(out) :: fracs(:) ! planck fractions - ! Dimensions: (nlayers) - REAL(KIND=wp), intent(out) :: taug(:) ! gaseous optical depth - ! Dimensions: (nlayers) - !REAL, intent(inout) :: overall_time - INTEGER*8 :: start_clock,stop_clock,rate_clock - INTEGER :: ig - ! Calculate gaseous optical depth and planck fractions for each spectral band. - ! Local (within band) g-point - IF (ngb(igg) == 1) THEN - ig = igg - ELSE - ig = igg - ngs(ngb(igg) - 1) - END IF - SELECT CASE ( ngb(igg) ) - CASE ( 1 ) - CALL taumol01 - CASE ( 2 ) - CALL taumol02 - CASE ( 3 ) - !CALL system_clock(start_clock, rate_clock) - CALL taumol03 - !CALL system_clock(stop_clock, rate_clock) - !overall_time = overall_time + (stop_clock-start_clock)/REAL(rate_clock) - CASE ( 4 ) - !CALL system_clock(start_clock, rate_clock) - CALL taumol04 - !CALL system_clock(stop_clock, rate_clock) - !overall_time = overall_time + (stop_clock-start_clock)/REAL(rate_clock) - CASE ( 5 ) - CALL taumol05 - CASE ( 6 ) - CALL taumol06 - CASE ( 7 ) - CALL taumol07 - CASE ( 8 ) - CALL taumol08 - CASE ( 9 ) - CALL taumol09 - CASE ( 10 ) - CALL taumol10 - CASE ( 11 ) - CALL taumol11 - CASE ( 12 ) - CALL taumol12 - CASE ( 13 ) - CALL taumol13 - CASE ( 14 ) - CALL taumol14 - CASE ( 15 ) - CALL taumol15 - CASE ( 16 ) - CALL taumol16 - CASE DEFAULT - CALL finish('gas_optics_sw', 'Chosen band out of range') - END SELECT - CONTAINS - !---------------------------------------------------------------------------- - - SUBROUTINE taumol01() - !---------------------------------------------------------------------------- - ! ------- Modifications ------- - ! Written by Eli J. Mlawer, Atmospheric & Environmental Research. - ! Revised by Michael J. Iacono, Atmospheric & Environmental Research. - ! - ! band 1: 10-350 cm-1 (low key - h2o; low minor - n2) - ! (high key - h2o; high minor - n2) - ! - ! note: previous versions of rrtm band 1: - ! 10-250 cm-1 (low - h2o; high - h2o) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg01, ONLY: selfref - USE rrlw_kg01, ONLY: forref - USE rrlw_kg01, ONLY: ka_mn2 - USE rrlw_kg01, ONLY: absa - USE rrlw_kg01, ONLY: fracrefa - USE rrlw_kg01, ONLY: kb_mn2 - USE rrlw_kg01, ONLY: absb - USE rrlw_kg01, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - REAL(KIND=wp) :: pp - REAL(KIND=wp) :: corradj - REAL(KIND=wp) :: scalen2 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: taun2 - ! Minor gas mapping levels: - ! lower - n2, p = 142.5490 mbar, t = 215.70 k - ! upper - n2, p = 142.5490 mbar, t = 215.70 k - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature. Below laytrop, the water vapor self-continuum and - ! foreign continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(1) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(1) + 1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - pp = pavel(lay) - corradj = 1. - IF (pp .lt. 250._wp) THEN - corradj = 1._wp - 0.15_wp * (250._wp-pp) / 154.4_wp - END IF - scalen2 = colbrd(lay) * scaleminorn2(lay) - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - & - forref(indf,ig))) - taun2 = scalen2*(ka_mn2(indm,ig) + minorfrac(lay) * (ka_mn2(indm+1,ig) - ka_mn2(indm,& - ig))) - taug(lay) = corradj * (colh2o(lay) * (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) + tauself + taufor + taun2) - fracs(lay) = fracrefa(ig) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(1) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(1) + 1 - indf = indfor(lay) - indm = indminor(lay) - pp = pavel(lay) - corradj = 1._wp - 0.15_wp * (pp / 95.6_wp) - scalen2 = colbrd(lay) * scaleminorn2(lay) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - taun2 = scalen2*(kb_mn2(indm,ig) + minorfrac(lay) * (kb_mn2(indm+1,ig) - kb_mn2(indm,& - ig))) - taug(lay) = corradj * (colh2o(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) + taufor + taun2) - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol01 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol02() - !---------------------------------------------------------------------------- - ! - ! band 2: 350-500 cm-1 (low key - h2o; high key - h2o) - ! - ! note: previous version of rrtm band 2: - ! 250 - 500 cm-1 (low - h2o; high - h2o) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg02, ONLY: selfref - USE rrlw_kg02, ONLY: forref - USE rrlw_kg02, ONLY: absa - USE rrlw_kg02, ONLY: fracrefa - USE rrlw_kg02, ONLY: absb - USE rrlw_kg02, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - REAL(KIND=wp) :: pp - REAL(KIND=wp) :: corradj - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature. Below laytrop, the water vapor self-continuum and - ! foreign continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(2) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(2) + 1 - inds = indself(lay) - indf = indfor(lay) - pp = pavel(lay) - corradj = 1._wp - .05_wp * (pp - 100._wp) / 900._wp - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - taug(lay) = corradj * (colh2o(lay) * (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) + tauself + taufor) - fracs(lay) = fracrefa(ig) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(2) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(2) + 1 - indf = indfor(lay) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - taug(lay) = colh2o(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) + taufor - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol02 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol03() - !---------------------------------------------------------------------------- - ! - ! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o) - ! (high key - h2o,co2; high minor - n2o) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg03, ONLY: selfref - USE rrlw_kg03, ONLY: forref - USE rrlw_kg03, ONLY: ka_mn2o - USE rrlw_kg03, ONLY: absa - USE rrlw_kg03, ONLY: fracrefa - USE rrlw_kg03, ONLY: kb_mn2o - USE rrlw_kg03, ONLY: absb - USE rrlw_kg03, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: js - INTEGER :: js1 - INTEGER :: jmn2o - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_mn2o - REAL(KIND=wp) :: specparm_mn2o - REAL(KIND=wp) :: specmult_mn2o - REAL(KIND=wp) :: fmn2o - REAL(KIND=wp) :: fmn2omf - REAL(KIND=wp) :: chi_n2o - REAL(KIND=wp) :: ratn2o - REAL(KIND=wp) :: adjfac - REAL(KIND=wp) :: adjcoln2o - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: n2om1 - REAL(KIND=wp) :: n2om2 - REAL(KIND=wp) :: absn2o - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: refrat_planck_b - REAL(KIND=wp) :: refrat_m_a - REAL(KIND=wp) :: refrat_m_b - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - INTEGER :: rrpk_counter=0 - ! Minor gas mapping levels: - ! lower - n2o, p = 706.272 mbar, t = 278.94 k - ! upper - n2o, p = 95.58 mbar, t = 215.7 k - ! P = 212.725 mb - refrat_planck_a = chi_mls(1,9)/chi_mls(2,9) - ! P = 95.58 mb - refrat_planck_b = chi_mls(1,13)/chi_mls(2,13) - ! P = 706.270mb - refrat_m_a = chi_mls(1,3)/chi_mls(2,3) - ! P = 95.58 mb - refrat_m_b = chi_mls(1,13)/chi_mls(2,13) - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature, and appropriate species. Below laytrop, the water vapor - ! self-continuum and foreign continuum is interpolated (in temperature) - ! separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_mn2o = colh2o(lay) + refrat_m_a*colco2(lay) - specparm_mn2o = colh2o(lay)/speccomb_mn2o - IF (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus - specmult_mn2o = 8._wp*specparm_mn2o - jmn2o = 1 + int(specmult_mn2o) - fmn2o = mod(specmult_mn2o,1.0_wp) - fmn2omf = minorfrac(lay)*fmn2o - ! In atmospheres where the amount of N2O is too great to be considered - ! a minor species, adjust the column amount of N2O by an empirical factor - ! to obtain the proper contribution. - chi_n2o = coln2o(lay)/coldry(lay) - ratn2o = 1.e20_wp*chi_n2o/chi_mls(4,jp(lay)+1) - IF (ratn2o .gt. 1.5_wp) THEN - adjfac = 0.5_wp+(ratn2o-0.5_wp)**0.65_wp - adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_wp - ELSE - adjcoln2o = coln2o(lay) - END IF - speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(3) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(3) + js1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o * (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,& - indm,ig)) - n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o * (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(& - jmn2o,indm+1,ig)) - absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor + adjcoln2o*absn2o - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - rrpk_counter=rrpk_counter+1 - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 4._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 4._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - speccomb_mn2o = colh2o(lay) + refrat_m_b*colco2(lay) - specparm_mn2o = colh2o(lay)/speccomb_mn2o - IF (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus - specmult_mn2o = 4._wp*specparm_mn2o - jmn2o = 1 + int(specmult_mn2o) - fmn2o = mod(specmult_mn2o,1.0_wp) - fmn2omf = minorfrac(lay)*fmn2o - ! In atmospheres where the amount of N2O is too great to be considered - ! a minor species, adjust the column amount of N2O by an empirical factor - ! to obtain the proper contribution. - chi_n2o = coln2o(lay)/coldry(lay) - ratn2o = 1.e20*chi_n2o/chi_mls(4,jp(lay)+1) - IF (ratn2o .gt. 1.5_wp) THEN - adjfac = 0.5_wp+(ratn2o-0.5_wp)**0.65_wp - adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_wp - ELSE - adjcoln2o = coln2o(lay) - END IF - speccomb_planck = colh2o(lay)+refrat_planck_b*colco2(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 4._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(3) + js - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(3) + js1 - indf = indfor(lay) - indm = indminor(lay) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - n2om1 = kb_mn2o(jmn2o,indm,ig) + fmn2o * (kb_mn2o(jmn2o+1,indm,ig)-kb_mn2o(jmn2o,& - indm,ig)) - n2om2 = kb_mn2o(jmn2o,indm+1,ig) + fmn2o * (kb_mn2o(jmn2o+1,indm+1,ig)-kb_mn2o(jmn2o,& - indm+1,ig)) - absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1) - taug(lay) = speccomb * (fac000 * absb(ind0,ig) + fac100 * & - absb(ind0+1,ig) + fac010 * absb(ind0+5,ig) + fac110 * absb(& - ind0+6,ig)) + speccomb1 * (fac001 * absb(ind1,ig) + & - fac101 * absb(ind1+1,ig) + fac011 * absb(ind1+5,ig) + & - fac111 * absb(ind1+6,ig)) + taufor + adjcoln2o*absn2o - fracs(lay) = fracrefb(ig,jpl) + fpl * (fracrefb(ig,jpl+1)-fracrefb(ig,jpl)) - END DO - END SUBROUTINE taumol03 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol04() - !---------------------------------------------------------------------------- - ! - ! band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg04, ONLY: selfref - USE rrlw_kg04, ONLY: forref - USE rrlw_kg04, ONLY: absa - USE rrlw_kg04, ONLY: fracrefa - USE rrlw_kg04, ONLY: absb - USE rrlw_kg04, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: js - INTEGER :: js1 - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: refrat_planck_b - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - REAL(KIND=wp), dimension(ngc(4)), parameter :: stratcorrect = (/ 1., 1., 1., 1., 1., 1., 1., .92, .88, 1.07, 1.1, & - .99, .88, .943 /) - ! P = 142.5940 mb - refrat_planck_a = chi_mls(1,11)/chi_mls(2,11) - ! P = 95.58350 mb - refrat_planck_b = chi_mls(3,13)/chi_mls(2,13) - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature, and appropriate species. Below laytrop, the water - ! vapor self-continuum and foreign continuum is interpolated (in temperature) - ! separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(4) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(4) + js1 - inds = indself(lay) - indf = indfor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - speccomb = colo3(lay) + rat_o3co2(lay)*colco2(lay) - specparm = colo3(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 4._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colo3(lay) + rat_o3co2_1(lay)*colco2(lay) - specparm1 = colo3(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 4._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - speccomb_planck = colo3(lay)+refrat_planck_b*colco2(lay) - specparm_planck = colo3(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 4._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(4) + js - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(4) + js1 - taug(lay) = speccomb * (fac000 * absb(ind0,ig) + fac100 * & - absb(ind0+1,ig) + fac010 * absb(ind0+5,ig) + fac110 * absb(& - ind0+6,ig)) + speccomb1 * (fac001 * absb(ind1,ig) + & - fac101 * absb(ind1+1,ig) + fac011 * absb(ind1+5,ig) + & - fac111 * absb(ind1+6,ig)) - fracs(lay) = fracrefb(ig,jpl) + fpl * (fracrefb(ig,jpl+1)-fracrefb(ig,jpl)) - ! Empirical modification to code to improve stratospheric cooling rates - ! for co2. Revised to apply weighting for g-point reduction in this band. - ! taug(lay,ngs3+8)=taug(lay,ngs3+8)*0.92 - ! taug(lay,ngs3+9)=taug(lay,ngs3+9)*0.88 - ! taug(lay,ngs3+10)=taug(lay,ngs3+10)*1.07 - ! taug(lay,ngs3+11)=taug(lay,ngs3+11)*1.1 - ! taug(lay,ngs3+12)=taug(lay,ngs3+12)*0.99 - ! taug(lay,ngs3+13)=taug(lay,ngs3+13)*0.88 - ! taug(lay,ngs3+14)=taug(lay,ngs3+14)*0.943 - END DO - taug(laytrop+1:nlayers) = taug(laytrop+1:nlayers) * stratcorrect(ig) - END SUBROUTINE taumol04 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol05() - !---------------------------------------------------------------------------- - ! - ! band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4) - ! (high key - o3,co2) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg05, ONLY: selfref - USE rrlw_kg05, ONLY: forref - USE rrlw_kg05, ONLY: ka_mo3 - USE rrlw_kg05, ONLY: absa - USE rrlw_kg05, ONLY: ccl4 - USE rrlw_kg05, ONLY: fracrefa - USE rrlw_kg05, ONLY: absb - USE rrlw_kg05, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: js - INTEGER :: js1 - INTEGER :: jmo3 - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_mo3 - REAL(KIND=wp) :: specparm_mo3 - REAL(KIND=wp) :: specmult_mo3 - REAL(KIND=wp) :: fmo3 - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: o3m1 - REAL(KIND=wp) :: o3m2 - REAL(KIND=wp) :: abso3 - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: refrat_planck_b - REAL(KIND=wp) :: refrat_m_a - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - ! Minor gas mapping level : - ! lower - o3, p = 317.34 mbar, t = 240.77 k - ! lower - ccl4 - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower/upper atmosphere. - ! P = 473.420 mb - refrat_planck_a = chi_mls(1,5)/chi_mls(2,5) - ! P = 0.2369 mb - refrat_planck_b = chi_mls(3,43)/chi_mls(2,43) - ! P = 317.3480 - refrat_m_a = chi_mls(1,7)/chi_mls(2,7) - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature, and appropriate species. Below laytrop, the - ! water vapor self-continuum and foreign continuum is - ! interpolated (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_mo3 = colh2o(lay) + refrat_m_a*colco2(lay) - specparm_mo3 = colh2o(lay)/speccomb_mo3 - IF (specparm_mo3 .ge. oneminus) specparm_mo3 = oneminus - specmult_mo3 = 8._wp*specparm_mo3 - jmo3 = 1 + int(specmult_mo3) - fmo3 = mod(specmult_mo3,1.0_wp) - speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(5) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(5) + js1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - o3m1 = ka_mo3(jmo3,indm,ig) + fmo3 * (ka_mo3(jmo3+1,indm,ig)-ka_mo3(jmo3,indm,ig)) - o3m2 = ka_mo3(jmo3,indm+1,ig) + fmo3 * (ka_mo3(jmo3+1,indm+1,ig)-ka_mo3(jmo3,indm+1,& - ig)) - abso3 = o3m1 + minorfrac(lay)*(o3m2-o3m1) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor + & - abso3*colo3(lay) + wx(1,lay) * ccl4(ig) - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - speccomb = colo3(lay) + rat_o3co2(lay)*colco2(lay) - specparm = colo3(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 4._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colo3(lay) + rat_o3co2_1(lay)*colco2(lay) - specparm1 = colo3(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 4._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - speccomb_planck = colo3(lay)+refrat_planck_b*colco2(lay) - specparm_planck = colo3(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 4._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(5) + js - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(5) + js1 - taug(lay) = speccomb * (fac000 * absb(ind0,ig) + fac100 * & - absb(ind0+1,ig) + fac010 * absb(ind0+5,ig) + fac110 * absb(& - ind0+6,ig)) + speccomb1 * (fac001 * absb(ind1,ig) + & - fac101 * absb(ind1+1,ig) + fac011 * absb(ind1+5,ig) + & - fac111 * absb(ind1+6,ig)) + wx(1,lay) * ccl4(ig) - fracs(lay) = fracrefb(ig,jpl) + fpl * (fracrefb(ig,jpl+1)-fracrefb(ig,jpl)) - END DO - END SUBROUTINE taumol05 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol06() - !---------------------------------------------------------------------------- - ! - ! band 6: 820-980 cm-1 (low key - h2o; low minor - co2) - ! (high key - nothing; high minor - cfc11, cfc12) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg06, ONLY: selfref - USE rrlw_kg06, ONLY: forref - USE rrlw_kg06, ONLY: ka_mco2 - USE rrlw_kg06, ONLY: cfc12 - USE rrlw_kg06, ONLY: absa - USE rrlw_kg06, ONLY: cfc11adj - USE rrlw_kg06, ONLY: fracrefa - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - REAL(KIND=wp) :: chi_co2 - REAL(KIND=wp) :: ratco2 - REAL(KIND=wp) :: adjfac - REAL(KIND=wp) :: adjcolco2 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: absco2 - ! Minor gas mapping level: - ! lower - co2, p = 706.2720 mb, t = 294.2 k - ! upper - cfc11, cfc12 - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature. The water vapor self-continuum and foreign continuum - ! is interpolated (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - ! In atmospheres where the amount of CO2 is too great to be considered - ! a minor species, adjust the column amount of CO2 by an empirical factor - ! to obtain the proper contribution. - chi_co2 = colco2(lay)/(coldry(lay)) - ratco2 = 1.e20_wp*chi_co2/chi_mls(2,jp(lay)+1) - IF (ratco2 .gt. 3.0_wp) THEN - adjfac = 2.0_wp+(ratco2-2.0_wp)**0.77_wp - adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_wp - ELSE - adjcolco2 = colco2(lay) - END IF - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(6) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(6) + 1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - absco2 = (ka_mco2(indm,ig) + minorfrac(lay) * (ka_mco2(indm+1,ig) - ka_mco2(indm,ig))& - ) - taug(lay) = colh2o(lay) * (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) + tauself + taufor + & - adjcolco2 * absco2 + wx(2,lay) * cfc11adj(ig) + wx(3,lay) * & - cfc12(ig) - fracs(lay) = fracrefa(ig) - END DO - ! Upper atmosphere loop - ! Nothing important goes on above laytrop in this band. - DO lay = laytrop+1, nlayers - taug(lay) = 0.0_wp + wx(2,lay) * cfc11adj(ig) + wx(3,lay) * & - cfc12(ig) - fracs(lay) = fracrefa(ig) - END DO - END SUBROUTINE taumol06 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol07() - !---------------------------------------------------------------------------- - ! - ! band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2) - ! (high key - o3; high minor - co2) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg07, ONLY: selfref - USE rrlw_kg07, ONLY: forref - USE rrlw_kg07, ONLY: ka_mco2 - USE rrlw_kg07, ONLY: absa - USE rrlw_kg07, ONLY: fracrefa - USE rrlw_kg07, ONLY: kb_mco2 - USE rrlw_kg07, ONLY: absb - USE rrlw_kg07, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: js - INTEGER :: js1 - INTEGER :: jmco2 - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_mco2 - REAL(KIND=wp) :: specparm_mco2 - REAL(KIND=wp) :: specmult_mco2 - REAL(KIND=wp) :: fmco2 - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: co2m1 - REAL(KIND=wp) :: co2m2 - REAL(KIND=wp) :: absco2 - REAL(KIND=wp) :: chi_co2 - REAL(KIND=wp) :: ratco2 - REAL(KIND=wp) :: adjfac - REAL(KIND=wp) :: adjcolco2 - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: refrat_m_a - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - REAL(KIND=wp), dimension(ngc(7)), parameter :: stratcorrect = (/ 1., 1., 1., 1., 1., .92, .88, 1.07, 1.1, .99, & - .855, 1. /) - ! Minor gas mapping level : - ! lower - co2, p = 706.2620 mbar, t= 278.94 k - ! upper - co2, p = 12.9350 mbar, t = 234.01 k - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower atmosphere. - ! P = 706.2620 mb - refrat_planck_a = chi_mls(1,3)/chi_mls(3,3) - ! P = 706.2720 mb - refrat_m_a = chi_mls(1,3)/chi_mls(3,3) - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below laytrop, the water - ! vapor self-continuum and foreign continuum is interpolated - ! (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2oo3(lay)*colo3(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2oo3_1(lay)*colo3(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_mco2 = colh2o(lay) + refrat_m_a*colo3(lay) - specparm_mco2 = colh2o(lay)/speccomb_mco2 - IF (specparm_mco2 .ge. oneminus) specparm_mco2 = oneminus - specmult_mco2 = 8._wp*specparm_mco2 - jmco2 = 1 + int(specmult_mco2) - fmco2 = mod(specmult_mco2,1.0_wp) - ! In atmospheres where the amount of CO2 is too great to be considered - ! a minor species, adjust the column amount of CO2 by an empirical factor - ! to obtain the proper contribution. - chi_co2 = colco2(lay)/(coldry(lay)) - ratco2 = 1.e20*chi_co2/chi_mls(2,jp(lay)+1) - IF (ratco2 .gt. 3.0_wp) THEN - adjfac = 3.0_wp+(ratco2-3.0_wp)**0.79_wp - adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_wp - ELSE - adjcolco2 = colco2(lay) - END IF - speccomb_planck = colh2o(lay)+refrat_planck_a*colo3(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(7) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(7) + js1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 * (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,& - indm,ig)) - co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 * (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(& - jmco2,indm+1,ig)) - absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor + adjcolco2*absco2 - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ! In atmospheres where the amount of CO2 is too great to be considered - ! a minor species, adjust the column amount of CO2 by an empirical factor - ! to obtain the proper contribution. - chi_co2 = colco2(lay)/(coldry(lay)) - ratco2 = 1.e20*chi_co2/chi_mls(2,jp(lay)+1) - IF (ratco2 .gt. 3.0_wp) THEN - adjfac = 2.0_wp+(ratco2-2.0_wp)**0.79_wp - adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_wp - ELSE - adjcolco2 = colco2(lay) - END IF - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(7) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(7) + 1 - indm = indminor(lay) - absco2 = kb_mco2(indm,ig) + minorfrac(lay) * (kb_mco2(indm+1,ig) - kb_mco2(indm,ig)) - taug(lay) = colo3(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) + adjcolco2 * absco2 - fracs(lay) = fracrefb(ig) - ! Empirical modification to code to improve stratospheric cooling rates - ! for o3. Revised to apply weighting for g-point reduction in this band. - ! taug(lay,ngs6+6)=taug(lay,ngs6+6)*0.92_wp - ! taug(lay,ngs6+7)=taug(lay,ngs6+7)*0.88_wp - ! taug(lay,ngs6+8)=taug(lay,ngs6+8)*1.07_wp - ! taug(lay,ngs6+9)=taug(lay,ngs6+9)*1.1_wp - ! taug(lay,ngs6+10)=taug(lay,ngs6+10)*0.99_wp - ! taug(lay,ngs6+11)=taug(lay,ngs6+11)*0.855_wp - END DO - taug(laytrop+1:nlayers) = taug(laytrop+1:nlayers) * stratcorrect(ig) - END SUBROUTINE taumol07 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol08() - !---------------------------------------------------------------------------- - ! - ! band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o) - ! (high key - o3; high minor - co2, n2o) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg08, ONLY: selfref - USE rrlw_kg08, ONLY: forref - USE rrlw_kg08, ONLY: ka_mco2 - USE rrlw_kg08, ONLY: ka_mo3 - USE rrlw_kg08, ONLY: ka_mn2o - USE rrlw_kg08, ONLY: absa - USE rrlw_kg08, ONLY: cfc22adj - USE rrlw_kg08, ONLY: cfc12 - USE rrlw_kg08, ONLY: fracrefa - USE rrlw_kg08, ONLY: kb_mco2 - USE rrlw_kg08, ONLY: kb_mn2o - USE rrlw_kg08, ONLY: absb - USE rrlw_kg08, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: absco2 - REAL(KIND=wp) :: abso3 - REAL(KIND=wp) :: absn2o - REAL(KIND=wp) :: chi_co2 - REAL(KIND=wp) :: ratco2 - REAL(KIND=wp) :: adjfac - REAL(KIND=wp) :: adjcolco2 - ! Minor gas mapping level: - ! lower - co2, p = 1053.63 mb, t = 294.2 k - ! lower - o3, p = 317.348 mb, t = 240.77 k - ! lower - n2o, p = 706.2720 mb, t= 278.94 k - ! lower - cfc12,cfc11 - ! upper - co2, p = 35.1632 mb, t = 223.28 k - ! upper - n2o, p = 8.716e-2 mb, t = 226.03 k - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature, and appropriate species. Below laytrop, the water vapor - ! self-continuum and foreign continuum is interpolated (in temperature) - ! separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - ! In atmospheres where the amount of CO2 is too great to be considered - ! a minor species, adjust the column amount of CO2 by an empirical factor - ! to obtain the proper contribution. - chi_co2 = colco2(lay)/(coldry(lay)) - ratco2 = 1.e20_wp*chi_co2/chi_mls(2,jp(lay)+1) - IF (ratco2 .gt. 3.0_wp) THEN - adjfac = 2.0_wp+(ratco2-2.0_wp)**0.65_wp - adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_wp - ELSE - adjcolco2 = colco2(lay) - END IF - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(8) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(8) + 1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - absco2 = (ka_mco2(indm,ig) + minorfrac(lay) * (ka_mco2(indm+1,ig) - ka_mco2(indm,ig))& - ) - abso3 = (ka_mo3(indm,ig) + minorfrac(lay) * (ka_mo3(indm+1,ig) - ka_mo3(indm,ig))) - absn2o = (ka_mn2o(indm,ig) + minorfrac(lay) * (ka_mn2o(indm+1,ig) - ka_mn2o(indm,ig))& - ) - taug(lay) = colh2o(lay) * (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) + tauself + taufor + & - adjcolco2*absco2 + colo3(lay) * abso3 + coln2o(lay) * & - absn2o + wx(3,lay) * cfc12(ig) + wx(4,lay) * cfc22adj(ig) - fracs(lay) = fracrefa(ig) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ! In atmospheres where the amount of CO2 is too great to be considered - ! a minor species, adjust the column amount of CO2 by an empirical factor - ! to obtain the proper contribution. - chi_co2 = colco2(lay)/coldry(lay) - ratco2 = 1.e20_wp*chi_co2/chi_mls(2,jp(lay)+1) - IF (ratco2 .gt. 3.0_wp) THEN - adjfac = 2.0_wp+(ratco2-2.0_wp)**0.65_wp - adjcolco2 = adjfac*chi_mls(2,jp(lay)+1) * coldry(lay)*1.e-20_wp - ELSE - adjcolco2 = colco2(lay) - END IF - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(8) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(8) + 1 - indm = indminor(lay) - absco2 = (kb_mco2(indm,ig) + minorfrac(lay) * (kb_mco2(indm+1,ig) - kb_mco2(indm,ig))& - ) - absn2o = (kb_mn2o(indm,ig) + minorfrac(lay) * (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig))& - ) - taug(lay) = colo3(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) + adjcolco2*absco2 + coln2o(& - lay)*absn2o + wx(3,lay) * cfc12(ig) + wx(4,lay) * cfc22adj(& - ig) - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol08 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol09() - !---------------------------------------------------------------------------- - ! - ! band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o) - ! (high key - ch4; high minor - n2o) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg09, ONLY: selfref - USE rrlw_kg09, ONLY: forref - USE rrlw_kg09, ONLY: ka_mn2o - USE rrlw_kg09, ONLY: absa - USE rrlw_kg09, ONLY: fracrefa - USE rrlw_kg09, ONLY: kb_mn2o - USE rrlw_kg09, ONLY: absb - USE rrlw_kg09, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: js - INTEGER :: js1 - INTEGER :: jmn2o - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_mn2o - REAL(KIND=wp) :: specparm_mn2o - REAL(KIND=wp) :: specmult_mn2o - REAL(KIND=wp) :: fmn2o - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: n2om1 - REAL(KIND=wp) :: n2om2 - REAL(KIND=wp) :: absn2o - REAL(KIND=wp) :: chi_n2o - REAL(KIND=wp) :: ratn2o - REAL(KIND=wp) :: adjfac - REAL(KIND=wp) :: adjcoln2o - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: refrat_m_a - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - ! Minor gas mapping level : - ! lower - n2o, p = 706.272 mbar, t = 278.94 k - ! upper - n2o, p = 95.58 mbar, t = 215.7 k - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower/upper atmosphere. - ! P = 212 mb - refrat_planck_a = chi_mls(1,9)/chi_mls(6,9) - ! P = 706.272 mb - refrat_m_a = chi_mls(1,3)/chi_mls(6,3) - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below laytrop, the water - ! vapor self-continuum and foreign continuum is interpolated - ! (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2och4(lay)*colch4(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2och4_1(lay)*colch4(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_mn2o = colh2o(lay) + refrat_m_a*colch4(lay) - specparm_mn2o = colh2o(lay)/speccomb_mn2o - IF (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus - specmult_mn2o = 8._wp*specparm_mn2o - jmn2o = 1 + int(specmult_mn2o) - fmn2o = mod(specmult_mn2o,1.0_wp) - ! In atmospheres where the amount of N2O is too great to be considered - ! a minor species, adjust the column amount of N2O by an empirical factor - ! to obtain the proper contribution. - chi_n2o = coln2o(lay)/(coldry(lay)) - ratn2o = 1.e20_wp*chi_n2o/chi_mls(4,jp(lay)+1) - IF (ratn2o .gt. 1.5_wp) THEN - adjfac = 0.5_wp+(ratn2o-0.5_wp)**0.65_wp - adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_wp - ELSE - adjcoln2o = coln2o(lay) - END IF - speccomb_planck = colh2o(lay)+refrat_planck_a*colch4(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(9) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(9) + js1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o * (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,& - indm,ig)) - n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o * (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(& - jmn2o,indm+1,ig)) - absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor + adjcoln2o*absn2o - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ! In atmospheres where the amount of N2O is too great to be considered - ! a minor species, adjust the column amount of N2O by an empirical factor - ! to obtain the proper contribution. - chi_n2o = coln2o(lay)/(coldry(lay)) - ratn2o = 1.e20_wp*chi_n2o/chi_mls(4,jp(lay)+1) - IF (ratn2o .gt. 1.5_wp) THEN - adjfac = 0.5_wp+(ratn2o-0.5_wp)**0.65_wp - adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_wp - ELSE - adjcoln2o = coln2o(lay) - END IF - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(9) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(9) + 1 - indm = indminor(lay) - absn2o = kb_mn2o(indm,ig) + minorfrac(lay) * (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig)) - taug(lay) = colch4(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) + adjcoln2o*absn2o - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol09 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol10() - !---------------------------------------------------------------------------- - ! - ! band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg10, ONLY: selfref - USE rrlw_kg10, ONLY: forref - USE rrlw_kg10, ONLY: absa - USE rrlw_kg10, ONLY: fracrefa - USE rrlw_kg10, ONLY: absb - USE rrlw_kg10, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature. Below laytrop, the water vapor self-continuum and - ! foreign continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(10) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(10) + 1 - inds = indself(lay) - indf = indfor(lay) - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - taug(lay) = colh2o(lay) * (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) + tauself + taufor - fracs(lay) = fracrefa(ig) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(10) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(10) + 1 - indf = indfor(lay) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - taug(lay) = colh2o(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) + taufor - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol10 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol11() - !---------------------------------------------------------------------------- - ! - ! band 11: 1480-1800 cm-1 (low - h2o; low minor - o2) - ! (high key - h2o; high minor - o2) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg11, ONLY: selfref - USE rrlw_kg11, ONLY: forref - USE rrlw_kg11, ONLY: ka_mo2 - USE rrlw_kg11, ONLY: absa - USE rrlw_kg11, ONLY: fracrefa - USE rrlw_kg11, ONLY: kb_mo2 - USE rrlw_kg11, ONLY: absb - USE rrlw_kg11, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - REAL(KIND=wp) :: scaleo2 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: tauo2 - ! Minor gas mapping level : - ! lower - o2, p = 706.2720 mbar, t = 278.94 k - ! upper - o2, p = 4.758820 mbarm t = 250.85 k - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature. Below laytrop, the water vapor self-continuum and - ! foreign continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(11) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(11) + 1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - scaleo2 = colo2(lay)*scaleminor(lay) - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - tauo2 = scaleo2 * (ka_mo2(indm,ig) + minorfrac(lay) * (ka_mo2(indm+1,ig) - ka_mo2(& - indm,ig))) - taug(lay) = colh2o(lay) * (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) + tauself + taufor + tauo2 - fracs(lay) = fracrefa(ig) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(11) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(11) + 1 - indf = indfor(lay) - indm = indminor(lay) - scaleo2 = colo2(lay)*scaleminor(lay) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - tauo2 = scaleo2 * (kb_mo2(indm,ig) + minorfrac(lay) * (kb_mo2(indm+1,ig) - kb_mo2(& - indm,ig))) - taug(lay) = colh2o(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) + taufor + tauo2 - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol11 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol12() - !---------------------------------------------------------------------------- - ! - ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg12, ONLY: selfref - USE rrlw_kg12, ONLY: forref - USE rrlw_kg12, ONLY: absa - USE rrlw_kg12, ONLY: fracrefa - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: js - INTEGER :: js1 - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower/upper atmosphere. - ! P = 174.164 mb - refrat_planck_a = chi_mls(1,10)/chi_mls(2,10) - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below laytrop, the water - ! vapor self-continuum adn foreign continuum is interpolated - ! (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(12) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(12) + js1 - inds = indself(lay) - indf = indfor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - taug(lay) = 0.0_wp - fracs(lay) = 0.0_wp - END DO - END SUBROUTINE taumol12 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol13() - !---------------------------------------------------------------------------- - ! - ! band 13: 2080-2250 cm-1 (low key - h2o,n2o; high minor - o3 minor) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg13, ONLY: selfref - USE rrlw_kg13, ONLY: forref - USE rrlw_kg13, ONLY: ka_mco2 - USE rrlw_kg13, ONLY: ka_mco - USE rrlw_kg13, ONLY: absa - USE rrlw_kg13, ONLY: fracrefa - USE rrlw_kg13, ONLY: kb_mo3 - USE rrlw_kg13, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: js - INTEGER :: js1 - INTEGER :: jmco2 - INTEGER :: jmco - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_mco2 - REAL(KIND=wp) :: specparm_mco2 - REAL(KIND=wp) :: specmult_mco2 - REAL(KIND=wp) :: fmco2 - REAL(KIND=wp) :: speccomb_mco - REAL(KIND=wp) :: specparm_mco - REAL(KIND=wp) :: specmult_mco - REAL(KIND=wp) :: fmco - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: co2m1 - REAL(KIND=wp) :: co2m2 - REAL(KIND=wp) :: absco2 - REAL(KIND=wp) :: com1 - REAL(KIND=wp) :: com2 - REAL(KIND=wp) :: absco - REAL(KIND=wp) :: abso3 - REAL(KIND=wp) :: chi_co2 - REAL(KIND=wp) :: ratco2 - REAL(KIND=wp) :: adjfac - REAL(KIND=wp) :: adjcolco2 - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: refrat_m_a - REAL(KIND=wp) :: refrat_m_a3 - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - ! Minor gas mapping levels : - ! lower - co2, p = 1053.63 mb, t = 294.2 k - ! lower - co, p = 706 mb, t = 278.94 k - ! upper - o3, p = 95.5835 mb, t = 215.7 k - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower/upper atmosphere. - ! P = 473.420 mb (Level 5) - refrat_planck_a = chi_mls(1,5)/chi_mls(4,5) - ! P = 1053. (Level 1) - refrat_m_a = chi_mls(1,1)/chi_mls(4,1) - ! P = 706. (Level 3) - refrat_m_a3 = chi_mls(1,3)/chi_mls(4,3) - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below laytrop, the water - ! vapor self-continuum and foreign continuum is interpolated - ! (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2on2o(lay)*coln2o(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2on2o_1(lay)*coln2o(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_mco2 = colh2o(lay) + refrat_m_a*coln2o(lay) - specparm_mco2 = colh2o(lay)/speccomb_mco2 - IF (specparm_mco2 .ge. oneminus) specparm_mco2 = oneminus - specmult_mco2 = 8._wp*specparm_mco2 - jmco2 = 1 + int(specmult_mco2) - fmco2 = mod(specmult_mco2,1.0_wp) - ! In atmospheres where the amount of CO2 is too great to be considered - ! a minor species, adjust the column amount of CO2 by an empirical factor - ! to obtain the proper contribution. - chi_co2 = colco2(lay)/(coldry(lay)) - ratco2 = 1.e20_wp*chi_co2/3.55e-4_wp - IF (ratco2 .gt. 3.0_wp) THEN - adjfac = 2.0_wp+(ratco2-2.0_wp)**0.68_wp - adjcolco2 = adjfac*3.55e-4*coldry(lay)*1.e-20_wp - ELSE - adjcolco2 = colco2(lay) - END IF - speccomb_mco = colh2o(lay) + refrat_m_a3*coln2o(lay) - specparm_mco = colh2o(lay)/speccomb_mco - IF (specparm_mco .ge. oneminus) specparm_mco = oneminus - specmult_mco = 8._wp*specparm_mco - jmco = 1 + int(specmult_mco) - fmco = mod(specmult_mco,1.0_wp) - speccomb_planck = colh2o(lay)+refrat_planck_a*coln2o(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(13) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(13) + js1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 * (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,& - indm,ig)) - co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 * (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(& - jmco2,indm+1,ig)) - absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1) - com1 = ka_mco(jmco,indm,ig) + fmco * (ka_mco(jmco+1,indm,ig) - ka_mco(jmco,indm,ig)) - com2 = ka_mco(jmco,indm+1,ig) + fmco * (ka_mco(jmco+1,indm+1,ig) - ka_mco(jmco,& - indm+1,ig)) - absco = com1 + minorfrac(lay) * (com2 - com1) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor + & - adjcolco2*absco2 + colco(lay)*absco - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - indm = indminor(lay) - abso3 = kb_mo3(indm,ig) + minorfrac(lay) * (kb_mo3(indm+1,ig) - kb_mo3(indm,ig)) - taug(lay) = colo3(lay)*abso3 - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol13 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol14() - !---------------------------------------------------------------------------- - ! - ! band 14: 2250-2380 cm-1 (low - co2; high - co2) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg14, ONLY: selfref - USE rrlw_kg14, ONLY: forref - USE rrlw_kg14, ONLY: absa - USE rrlw_kg14, ONLY: fracrefa - USE rrlw_kg14, ONLY: absb - USE rrlw_kg14, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - ! Compute the optical depth by interpolating in ln(pressure) and - ! temperature. Below laytrop, the water vapor self-continuum - ! and foreign continuum is interpolated (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(14) + 1 - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(14) + 1 - inds = indself(lay) - indf = indfor(lay) - tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - taug(lay) = colco2(lay) * (fac00(lay) * absa(ind0,ig) + & - fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & - fac11(lay) * absa(ind1+1,ig)) + tauself + taufor - fracs(lay) = fracrefa(ig) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(14) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(14) + 1 - taug(lay) = colco2(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol14 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol15() - !---------------------------------------------------------------------------- - ! - ! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2) - ! (high - nothing) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg15, ONLY: selfref - USE rrlw_kg15, ONLY: forref - USE rrlw_kg15, ONLY: ka_mn2 - USE rrlw_kg15, ONLY: absa - USE rrlw_kg15, ONLY: fracrefa - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: indm - INTEGER :: js - INTEGER :: js1 - INTEGER :: jmn2 - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_mn2 - REAL(KIND=wp) :: specparm_mn2 - REAL(KIND=wp) :: specmult_mn2 - REAL(KIND=wp) :: fmn2 - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: scalen2 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: n2m1 - REAL(KIND=wp) :: n2m2 - REAL(KIND=wp) :: taun2 - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: refrat_m_a - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - ! Minor gas mapping level : - ! Lower - Nitrogen Continuum, P = 1053., T = 294. - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower atmosphere. - ! P = 1053. mb (Level 1) - refrat_planck_a = chi_mls(4,1)/chi_mls(2,1) - ! P = 1053. - refrat_m_a = chi_mls(4,1)/chi_mls(2,1) - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature, and appropriate species. Below laytrop, the water - ! vapor self-continuum and foreign continuum is interpolated - ! (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = coln2o(lay) + rat_n2oco2(lay)*colco2(lay) - specparm = coln2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = coln2o(lay) + rat_n2oco2_1(lay)*colco2(lay) - specparm1 = coln2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_mn2 = coln2o(lay) + refrat_m_a*colco2(lay) - specparm_mn2 = coln2o(lay)/speccomb_mn2 - IF (specparm_mn2 .ge. oneminus) specparm_mn2 = oneminus - specmult_mn2 = 8._wp*specparm_mn2 - jmn2 = 1 + int(specmult_mn2) - fmn2 = mod(specmult_mn2,1.0_wp) - speccomb_planck = coln2o(lay)+refrat_planck_a*colco2(lay) - specparm_planck = coln2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(15) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(15) + js1 - inds = indself(lay) - indf = indfor(lay) - indm = indminor(lay) - scalen2 = colbrd(lay)*scaleminor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - n2m1 = ka_mn2(jmn2,indm,ig) + fmn2 * (ka_mn2(jmn2+1,indm,ig) - ka_mn2(jmn2,indm,ig)) - n2m2 = ka_mn2(jmn2,indm+1,ig) + fmn2 * (ka_mn2(jmn2+1,indm+1,ig) - ka_mn2(jmn2,& - indm+1,ig)) - taun2 = scalen2 * (n2m1 + minorfrac(lay) * (n2m2 - n2m1)) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor + taun2 - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - taug(lay) = 0.0_wp - fracs(lay) = 0.0_wp - END DO - END SUBROUTINE taumol15 - !---------------------------------------------------------------------------- - - SUBROUTINE taumol16() - !---------------------------------------------------------------------------- - ! - ! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4) - !---------------------------------------------------------------------------- - ! ------- Modules ------- - USE rrlw_kg16, ONLY: selfref - USE rrlw_kg16, ONLY: forref - USE rrlw_kg16, ONLY: absa - USE rrlw_kg16, ONLY: fracrefa - USE rrlw_kg16, ONLY: absb - USE rrlw_kg16, ONLY: fracrefb - ! ------- Declarations ------- - ! Local - INTEGER :: lay - INTEGER :: ind0 - INTEGER :: ind1 - INTEGER :: inds - INTEGER :: indf - INTEGER :: js - INTEGER :: js1 - INTEGER :: jpl - REAL(KIND=wp) :: speccomb - REAL(KIND=wp) :: specparm - REAL(KIND=wp) :: specmult - REAL(KIND=wp) :: fs - REAL(KIND=wp) :: speccomb1 - REAL(KIND=wp) :: specparm1 - REAL(KIND=wp) :: specmult1 - REAL(KIND=wp) :: fs1 - REAL(KIND=wp) :: speccomb_planck - REAL(KIND=wp) :: specparm_planck - REAL(KIND=wp) :: specmult_planck - REAL(KIND=wp) :: fpl - REAL(KIND=wp) :: p - REAL(KIND=wp) :: p4 - REAL(KIND=wp) :: fk0 - REAL(KIND=wp) :: fk1 - REAL(KIND=wp) :: fk2 - REAL(KIND=wp) :: fac000 - REAL(KIND=wp) :: fac100 - REAL(KIND=wp) :: fac200 - REAL(KIND=wp) :: fac010 - REAL(KIND=wp) :: fac110 - REAL(KIND=wp) :: fac210 - REAL(KIND=wp) :: fac001 - REAL(KIND=wp) :: fac101 - REAL(KIND=wp) :: fac201 - REAL(KIND=wp) :: fac011 - REAL(KIND=wp) :: fac111 - REAL(KIND=wp) :: fac211 - REAL(KIND=wp) :: tauself - REAL(KIND=wp) :: taufor - REAL(KIND=wp) :: refrat_planck_a - REAL(KIND=wp) :: tau_major - REAL(KIND=wp) :: tau_major1 - ! Calculate reference ratio to be used in calculation of Planck - ! fraction in lower atmosphere. - ! P = 387. mb (Level 6) - refrat_planck_a = chi_mls(1,6)/chi_mls(6,6) - ! Compute the optical depth by interpolating in ln(pressure), - ! temperature,and appropriate species. Below laytrop, the water - ! vapor self-continuum and foreign continuum is interpolated - ! (in temperature) separately. - ! Lower atmosphere loop - DO lay = 1, laytrop - speccomb = colh2o(lay) + rat_h2och4(lay)*colch4(lay) - specparm = colh2o(lay)/speccomb - IF (specparm .ge. oneminus) specparm = oneminus - specmult = 8._wp*(specparm) - js = 1 + int(specmult) - fs = mod(specmult,1.0_wp) - speccomb1 = colh2o(lay) + rat_h2och4_1(lay)*colch4(lay) - specparm1 = colh2o(lay)/speccomb1 - IF (specparm1 .ge. oneminus) specparm1 = oneminus - specmult1 = 8._wp*(specparm1) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1,1.0_wp) - speccomb_planck = colh2o(lay)+refrat_planck_a*colch4(lay) - specparm_planck = colh2o(lay)/speccomb_planck - IF (specparm_planck .ge. oneminus) specparm_planck = oneminus - specmult_planck = 8._wp*specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck,1.0_wp) - ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(16) + js - ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(16) + js1 - inds = indself(lay) - indf = indfor(lay) - IF (specparm .lt. 0.125_wp) THEN - p = fs - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE IF (specparm .gt. 0.875_wp) THEN - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac000 = fk0*fac00(lay) - fac100 = fk1*fac00(lay) - fac200 = fk2*fac00(lay) - fac010 = fk0*fac10(lay) - fac110 = fk1*fac10(lay) - fac210 = fk2*fac10(lay) - ELSE - fac000 = (1._wp - fs) * fac00(lay) - fac010 = (1._wp - fs) * fac10(lay) - fac100 = fs * fac00(lay) - fac110 = fs * fac10(lay) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - p = fs1 - 1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = 1 - p - 2.0_wp*p4 - fk2 = p + p4 - fac001 = fk0*fac01(lay) - fac101 = fk1*fac01(lay) - fac201 = fk2*fac01(lay) - fac011 = fk0*fac11(lay) - fac111 = fk1*fac11(lay) - fac211 = fk2*fac11(lay) - ELSE - fac001 = (1._wp - fs1) * fac01(lay) - fac011 = (1._wp - fs1) * fac11(lay) - fac101 = fs1 * fac01(lay) - fac111 = fs1 * fac11(lay) - END IF - tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & - selfref(inds,ig))) - taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& - indf,ig))) - IF (specparm .lt. 0.125_wp) THEN - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & - fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & - fac210 * absa(ind0+11,ig)) - ELSE IF (specparm .gt. 0.875_wp) THEN - tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & - fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & - fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & - fac010 * absa(ind0+10,ig)) - ELSE - tau_major = speccomb * (fac000 * absa(ind0,ig) + & - fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & - fac110 * absa(ind0+10,ig)) - END IF - IF (specparm1 .lt. 0.125_wp) THEN - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & - fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & - fac211 * absa(ind1+11,ig)) - ELSE IF (specparm1 .gt. 0.875_wp) THEN - tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & - fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & - fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & - fac011 * absa(ind1+10,ig)) - ELSE - tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & - fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & - fac111 * absa(ind1+10,ig)) - END IF - taug(lay) = tau_major + tau_major1 + tauself + taufor - fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) - END DO - ! Upper atmosphere loop - DO lay = laytrop+1, nlayers - ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(16) + 1 - ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(16) + 1 - taug(lay) = colch4(lay) * (fac00(lay) * absb(ind0,ig) + & - fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & - fac11(lay) * absb(ind1+1,ig)) - fracs(lay) = fracrefb(ig) - END DO - END SUBROUTINE taumol16 - END SUBROUTINE gas_optics_lw - END MODULE mo_lrtm_gas_optics diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_lrtm_kgs.f90 b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_lrtm_kgs.f90 deleted file mode 100644 index 4a142f95b9..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_lrtm_kgs.f90 +++ /dev/null @@ -1,1217 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_lrtm_kgs.f90 -! Generated at: 2015-02-19 15:30:31 -! KGEN version: 0.4.4 - - - - MODULE rrlw_planck - USE mo_kind, ONLY: wp - USE mo_rrtm_params, ONLY: nbndlw - REAL(KIND=wp) :: chi_mls(7,59) - REAL(KIND=wp) :: totplanck(181,nbndlw) !< planck function for each band - !< for band 16 - PUBLIC read_externs_rrlw_planck - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_planck(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) chi_mls - READ(UNIT=kgen_unit) totplanck - END SUBROUTINE read_externs_rrlw_planck - - - ! read subroutines - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_planck - - MODULE rrlw_kg01 - USE mo_kind, ONLY: wp - IMPLICIT NONE - !< original abs coefficients - INTEGER, parameter :: ng1 = 10 !< combined abs. coefficients - REAL(KIND=wp) :: fracrefa(ng1) - REAL(KIND=wp) :: fracrefb(ng1) - REAL(KIND=wp) :: absa(65,ng1) - REAL(KIND=wp) :: absb(235,ng1) - REAL(KIND=wp) :: ka_mn2(19,ng1) - REAL(KIND=wp) :: kb_mn2(19,ng1) - REAL(KIND=wp) :: selfref(10,ng1) - REAL(KIND=wp) :: forref(4,ng1) - PUBLIC read_externs_rrlw_kg01 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg01(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mn2 - READ(UNIT=kgen_unit) kb_mn2 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg01 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg01 - - MODULE rrlw_kg02 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng2 = 12 - REAL(KIND=wp) :: fracrefa(ng2) - REAL(KIND=wp) :: fracrefb(ng2) - REAL(KIND=wp) :: absa(65,ng2) - REAL(KIND=wp) :: absb(235,ng2) - REAL(KIND=wp) :: selfref(10,ng2) - REAL(KIND=wp) :: forref(4,ng2) - PUBLIC read_externs_rrlw_kg02 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg02(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg02 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg02 - - MODULE rrlw_kg03 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng3 = 16 - REAL(KIND=wp) :: fracrefa(ng3,9) - REAL(KIND=wp) :: fracrefb(ng3,5) - REAL(KIND=wp) :: absa(585,ng3) - REAL(KIND=wp) :: absb(1175,ng3) - REAL(KIND=wp) :: ka_mn2o(9,19,ng3) - REAL(KIND=wp) :: kb_mn2o(5,19,ng3) - REAL(KIND=wp) :: selfref(10,ng3) - REAL(KIND=wp) :: forref(4,ng3) - PUBLIC read_externs_rrlw_kg03 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim2 - module procedure read_var_real_wp_dim3 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg03(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mn2o - READ(UNIT=kgen_unit) kb_mn2o - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg03 - - - ! read subroutines - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim3(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:,:), allocatable :: var - integer, dimension(2,3) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg03 - - MODULE rrlw_kg04 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng4 = 14 - REAL(KIND=wp) :: fracrefa(ng4,9) - REAL(KIND=wp) :: fracrefb(ng4,5) - REAL(KIND=wp) :: absa(585,ng4) - REAL(KIND=wp) :: absb(1175,ng4) - REAL(KIND=wp) :: selfref(10,ng4) - REAL(KIND=wp) :: forref(4,ng4) - PUBLIC read_externs_rrlw_kg04 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg04(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg04 - - - ! read subroutines - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg04 - - MODULE rrlw_kg05 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng5 = 16 - REAL(KIND=wp) :: fracrefa(ng5,9) - REAL(KIND=wp) :: fracrefb(ng5,5) - REAL(KIND=wp) :: absa(585,ng5) - REAL(KIND=wp) :: absb(1175,ng5) - REAL(KIND=wp) :: ka_mo3(9,19,ng5) - REAL(KIND=wp) :: selfref(10,ng5) - REAL(KIND=wp) :: forref(4,ng5) - REAL(KIND=wp) :: ccl4(ng5) - PUBLIC read_externs_rrlw_kg05 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim2 - module procedure read_var_real_wp_dim3 - module procedure read_var_real_wp_dim1 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg05(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mo3 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) ccl4 - END SUBROUTINE read_externs_rrlw_kg05 - - - ! read subroutines - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim3(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:,:), allocatable :: var - integer, dimension(2,3) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg05 - - MODULE rrlw_kg06 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng6 = 8 - REAL(KIND=wp), dimension(ng6) :: fracrefa - REAL(KIND=wp) :: absa(65,ng6) - REAL(KIND=wp) :: ka_mco2(19,ng6) - REAL(KIND=wp) :: selfref(10,ng6) - REAL(KIND=wp) :: forref(4,ng6) - REAL(KIND=wp), dimension(ng6) :: cfc11adj - REAL(KIND=wp), dimension(ng6) :: cfc12 - PUBLIC read_externs_rrlw_kg06 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg06(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) ka_mco2 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - READ(UNIT=kgen_unit) cfc11adj - READ(UNIT=kgen_unit) cfc12 - END SUBROUTINE read_externs_rrlw_kg06 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg06 - - MODULE rrlw_kg07 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng7 = 12 - REAL(KIND=wp), dimension(ng7) :: fracrefb - REAL(KIND=wp) :: fracrefa(ng7,9) - REAL(KIND=wp) :: absa(585,ng7) - REAL(KIND=wp) :: absb(235,ng7) - REAL(KIND=wp) :: ka_mco2(9,19,ng7) - REAL(KIND=wp) :: kb_mco2(19,ng7) - REAL(KIND=wp) :: selfref(10,ng7) - REAL(KIND=wp) :: forref(4,ng7) - PUBLIC read_externs_rrlw_kg07 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - module procedure read_var_real_wp_dim3 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg07(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mco2 - READ(UNIT=kgen_unit) kb_mco2 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg07 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim3(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:,:), allocatable :: var - integer, dimension(2,3) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg07 - - MODULE rrlw_kg08 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng8 = 8 - REAL(KIND=wp), dimension(ng8) :: fracrefa - REAL(KIND=wp), dimension(ng8) :: fracrefb - REAL(KIND=wp), dimension(ng8) :: cfc12 - REAL(KIND=wp), dimension(ng8) :: cfc22adj - REAL(KIND=wp) :: absa(65,ng8) - REAL(KIND=wp) :: absb(235,ng8) - REAL(KIND=wp) :: ka_mco2(19,ng8) - REAL(KIND=wp) :: ka_mn2o(19,ng8) - REAL(KIND=wp) :: ka_mo3(19,ng8) - REAL(KIND=wp) :: kb_mco2(19,ng8) - REAL(KIND=wp) :: kb_mn2o(19,ng8) - REAL(KIND=wp) :: selfref(10,ng8) - REAL(KIND=wp) :: forref(4,ng8) - PUBLIC read_externs_rrlw_kg08 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg08(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) cfc12 - READ(UNIT=kgen_unit) cfc22adj - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mco2 - READ(UNIT=kgen_unit) ka_mn2o - READ(UNIT=kgen_unit) ka_mo3 - READ(UNIT=kgen_unit) kb_mco2 - READ(UNIT=kgen_unit) kb_mn2o - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg08 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg08 - - MODULE rrlw_kg09 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng9 = 12 - REAL(KIND=wp), dimension(ng9) :: fracrefb - REAL(KIND=wp) :: fracrefa(ng9,9) - REAL(KIND=wp) :: absa(585,ng9) - REAL(KIND=wp) :: absb(235,ng9) - REAL(KIND=wp) :: ka_mn2o(9,19,ng9) - REAL(KIND=wp) :: kb_mn2o(19,ng9) - REAL(KIND=wp) :: selfref(10,ng9) - REAL(KIND=wp) :: forref(4,ng9) - PUBLIC read_externs_rrlw_kg09 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - module procedure read_var_real_wp_dim3 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg09(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mn2o - READ(UNIT=kgen_unit) kb_mn2o - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg09 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim3(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:,:), allocatable :: var - integer, dimension(2,3) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg09 - - MODULE rrlw_kg10 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng10 = 6 - REAL(KIND=wp), dimension(ng10) :: fracrefa - REAL(KIND=wp), dimension(ng10) :: fracrefb - REAL(KIND=wp) :: absa(65,ng10) - REAL(KIND=wp) :: absb(235,ng10) - REAL(KIND=wp) :: selfref(10,ng10) - REAL(KIND=wp) :: forref(4,ng10) - PUBLIC read_externs_rrlw_kg10 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg10(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg10 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg10 - - MODULE rrlw_kg11 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng11 = 8 - REAL(KIND=wp), dimension(ng11) :: fracrefa - REAL(KIND=wp), dimension(ng11) :: fracrefb - REAL(KIND=wp) :: absa(65,ng11) - REAL(KIND=wp) :: absb(235,ng11) - REAL(KIND=wp) :: ka_mo2(19,ng11) - REAL(KIND=wp) :: kb_mo2(19,ng11) - REAL(KIND=wp) :: selfref(10,ng11) - REAL(KIND=wp) :: forref(4,ng11) - PUBLIC read_externs_rrlw_kg11 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg11(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) ka_mo2 - READ(UNIT=kgen_unit) kb_mo2 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg11 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg11 - - MODULE rrlw_kg12 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng12 = 8 - REAL(KIND=wp) :: fracrefa(ng12,9) - REAL(KIND=wp) :: absa(585,ng12) - REAL(KIND=wp) :: selfref(10,ng12) - REAL(KIND=wp) :: forref(4,ng12) - PUBLIC read_externs_rrlw_kg12 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg12(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg12 - - - ! read subroutines - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg12 - - MODULE rrlw_kg13 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng13 = 4 - REAL(KIND=wp), dimension(ng13) :: fracrefb - REAL(KIND=wp) :: fracrefa(ng13,9) - REAL(KIND=wp) :: absa(585,ng13) - REAL(KIND=wp) :: ka_mco2(9,19,ng13) - REAL(KIND=wp) :: ka_mco(9,19,ng13) - REAL(KIND=wp) :: kb_mo3(19,ng13) - REAL(KIND=wp) :: selfref(10,ng13) - REAL(KIND=wp) :: forref(4,ng13) - PUBLIC read_externs_rrlw_kg13 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - module procedure read_var_real_wp_dim3 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg13(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) ka_mco2 - READ(UNIT=kgen_unit) ka_mco - READ(UNIT=kgen_unit) kb_mo3 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg13 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim3(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:,:), allocatable :: var - integer, dimension(2,3) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg13 - - MODULE rrlw_kg14 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng14 = 2 - REAL(KIND=wp), dimension(ng14) :: fracrefa - REAL(KIND=wp), dimension(ng14) :: fracrefb - REAL(KIND=wp) :: absa(65,ng14) - REAL(KIND=wp) :: absb(235,ng14) - REAL(KIND=wp) :: selfref(10,ng14) - REAL(KIND=wp) :: forref(4,ng14) - PUBLIC read_externs_rrlw_kg14 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg14(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg14 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg14 - - MODULE rrlw_kg15 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng15 = 2 - REAL(KIND=wp) :: fracrefa(ng15,9) - REAL(KIND=wp) :: absa(585,ng15) - REAL(KIND=wp) :: ka_mn2(9,19,ng15) - REAL(KIND=wp) :: selfref(10,ng15) - REAL(KIND=wp) :: forref(4,ng15) - PUBLIC read_externs_rrlw_kg15 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim2 - module procedure read_var_real_wp_dim3 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg15(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) ka_mn2 - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg15 - - - ! read subroutines - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim3(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:,:), allocatable :: var - integer, dimension(2,3) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg15 - - MODULE rrlw_kg16 - USE mo_kind, ONLY: wp - IMPLICIT NONE - INTEGER, parameter :: ng16 = 2 - REAL(KIND=wp), dimension(ng16) :: fracrefb - REAL(KIND=wp) :: fracrefa(ng16,9) - REAL(KIND=wp) :: absa(585,ng16) - REAL(KIND=wp) :: absb(235,ng16) - REAL(KIND=wp) :: selfref(10,ng16) - REAL(KIND=wp) :: forref(4,ng16) - PUBLIC read_externs_rrlw_kg16 - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_real_wp_dim1 - module procedure read_var_real_wp_dim2 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_rrlw_kg16(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) fracrefb - READ(UNIT=kgen_unit) fracrefa - READ(UNIT=kgen_unit) absa - READ(UNIT=kgen_unit) absb - READ(UNIT=kgen_unit) selfref - READ(UNIT=kgen_unit) forref - END SUBROUTINE read_externs_rrlw_kg16 - - - ! read subroutines - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - END MODULE rrlw_kg16 diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_lrtm_setup.f90 b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_lrtm_setup.f90 deleted file mode 100644 index d5159218ee..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_lrtm_setup.f90 +++ /dev/null @@ -1,123 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_lrtm_setup.f90 -! Generated at: 2015-02-19 15:30:32 -! KGEN version: 0.4.4 - - - - MODULE mo_lrtm_setup - USE mo_kind, ONLY: wp - USE mo_rrtm_params, ONLY: ngptlw - USE mo_rrtm_params, ONLY: nbndlw - IMPLICIT NONE - ! - ! spectra information that is entered at run time - ! - !< Weights for combining original gpts into reduced gpts - !< Number of cross-section molecules - !< Flag for active cross-sections in calculation - INTEGER, parameter :: ngc(nbndlw) = (/ 10,12,16,14,16,8,12,8,12,6,8,8,4,2,2,2/) !< The number of new g-intervals in each band - INTEGER, parameter :: ngs(nbndlw) = (/ 10,22,38,52,68,76,88,96,108,114,122,130,134,136,138,140/) !< The cumulative sum of new g-intervals for each band - !< The index of each new gpt relative to the orignal - ! band 1 - ! band 2 - ! band 3 - ! band 4 - ! band 5 - ! band 6 - ! band 7 - ! band 8 - ! band 9 - ! band 10 - ! band 11 - ! band 12 - ! band 13 - ! band 14 - ! band 15 - ! band 16 - !< The number of original gs combined to make new pts - ! band 1 - ! band 2 - ! band 3 - ! band 4 - ! band 5 - ! band 6 - ! band 7 - ! band 8 - ! band 9 - ! band 10 - ! band 11 - ! band 12 - ! band 13 - ! band 14 - ! band 15 - ! band 16 - INTEGER, parameter :: ngb(ngptlw) = (/ 1,1,1,1,1,1,1,1,1,1, 2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,& - 3,3,3,3,3,3,3,3, 4,4,4,4,4,4,4,4,4,4,4,4,4,4, 5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5, 6,6,6,6,6,6,6,6, & - 7,7,7,7,7,7,7,7,7,7,7,7, 8,8,8,8,8,8,8,8, 9,9,9,9,9,9,9,9,9,9,9,9, 10,10,10,10,10,10, 11,11,& - 11,11,11,11,11,11, 12,12,12,12,12,12,12,12, 13,13,13,13, 14,14, 15,15, 16,16/) !< The band index for each new g-interval - ! band 1 - ! band 2 - ! band 3 - ! band 4 - ! band 5 - ! band 6 - ! band 7 - ! band 8 - ! band 9 - ! band 10 - ! band 11 - ! band 12 - ! band 13 - ! band 14 - ! band 15 - ! band 16 - !< RRTM weights for the original 16 g-intervals - INTEGER, parameter :: nspa(nbndlw) = (/ 1,1,9,9,9,1,9,1,9,1,1,9,9,1,9,9/) !< Number of reference atmospheres for lower atmosphere - INTEGER, parameter :: nspb(nbndlw) = (/ 1,1,5,5,5,0,1,1,1,1,1,0,0,1,0,0/) !< Number of reference atmospheres for upper atmosphere - ! < Number of g intervals in each band - !< Spectral band lower boundary in wavenumbers - !< Spectral band upper boundary in wavenumbers - REAL(KIND=wp), parameter :: delwave(nbndlw) = (/ 340._wp, 150._wp, 130._wp, 70._wp, 120._wp, 160._wp, & - 100._wp, 100._wp, 210._wp, 90._wp, 320._wp, 280._wp, 170._wp, 130._wp, 220._wp, 650._wp/) !< Spectral band width in wavenumbers - CONTAINS - - ! read subroutines - ! ************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - - !*************************************************************************** - END MODULE mo_lrtm_setup diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_lrtm_solver.f90 b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_lrtm_solver.f90 deleted file mode 100644 index 841db2d6b8..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_lrtm_solver.f90 +++ /dev/null @@ -1,161 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_lrtm_solver.f90 -! Generated at: 2015-02-19 15:30:36 -! KGEN version: 0.4.4 - - - - MODULE mo_lrtm_solver - USE mo_kind, ONLY: wp - USE mo_math_constants, ONLY: pi - USE mo_rrtm_params, ONLY: nbndlw - USE mo_rad_fastmath, ONLY: tautrans - USE mo_rad_fastmath, ONLY: transmit - IMPLICIT NONE - REAL(KIND=wp), parameter :: fluxfac = 2.0e+04_wp * pi - CONTAINS - - ! read subroutines - ! ------------------------------------------------------------------------------- - - SUBROUTINE lrtm_solver(kproma, kbdim, klev, tau, layplnk, levplnk, weights, secdiff, surfplanck, surfemis, fluxup, fluxdn) - ! - ! Compute IR (no scattering) radiative transfer for a set of columns - ! Based on AER code RRTMG_LW_RTNMC, including approximations used there - ! Layers are ordered from botton to top (i.e. tau(1) is tau in lowest layer) - ! Computes all-sky RT given a total optical thickness in each layer - ! - INTEGER, intent(in) :: kbdim - INTEGER, intent(in) :: klev - INTEGER, intent(in) :: kproma - !< Number of columns - !< Maximum number of columns as declared in calling (sub)program - !< number of layers (one fewer than levels) - REAL(KIND=wp), intent(in) :: tau(kbdim,klev) - REAL(KIND=wp), intent(in) :: layplnk(kbdim,klev) - REAL(KIND=wp), intent(in) :: weights(kbdim,klev) !< dimension (kbdim, klev) - !< Longwave optical thickness - !< Planck function at layer centers - !< Fraction of total Planck function for this g-point - REAL(KIND=wp), intent(in) :: levplnk(kbdim, 0:klev) - !< Planck function at layer edges, level i is the top of layer i - REAL(KIND=wp), intent(in) :: secdiff(kbdim) - REAL(KIND=wp), intent(in) :: surfemis(kbdim) - REAL(KIND=wp), intent(in) :: surfplanck(kbdim) !< dimension (kbdim) - !< Planck function at surface - !< Surface emissivity - !< secant of integration angle - depends on band, column water vapor - REAL(KIND=wp), intent(out) :: fluxup(kbdim, 0:klev) - REAL(KIND=wp), intent(out) :: fluxdn(kbdim, 0:klev) !< dimension (kbdim, 0:klev) - !< Fluxes at the interfaces - ! ----------- - INTEGER :: jk - !< Loop index for layers - REAL(KIND=wp) :: odepth(kbdim,klev) - REAL(KIND=wp) :: tfn(kbdim) - REAL(KIND=wp) :: dplnkup(kbdim,klev) - REAL(KIND=wp) :: dplnkdn(kbdim,klev) - REAL(KIND=wp) :: bbup(kbdim,klev) - REAL(KIND=wp) :: bbdn(kbdim,klev) - REAL(KIND=wp) :: trans(kbdim,klev) - !< Layer transmissivity - !< TFN_TBL - !< Tau transition function; i.e. the transition of the Planck - !< function from that for the mean layer temperature to that for - !< the layer boundary temperature as a function of optical depth. - !< The "linear in tau" method is used to make the table. - !< Upward derivative of Planck function - !< Downward derivative of Planck function - !< Interpolated downward emission - !< Interpolated upward emission - !< Effective IR optical depth of layer - REAL(KIND=wp) :: rad_dn(kbdim,0:klev) - REAL(KIND=wp) :: rad_up(kbdim,0:klev) - !< Radiance down at propagation angle - !< Radiance down at propagation angle - ! This secant and weight corresponds to the standard diffusivity - ! angle. The angle is redefined for some bands. - REAL(KIND=wp), parameter :: wtdiff = 0.5_wp - ! ----------- - ! - ! 1.0 Initial preparations - ! Weight optical depth by 1/cos(diffusivity angle), which depends on band - ! This will be used to compute layer transmittance - ! ----- - !IBM* ASSERT(NODEPS) - DO jk = 1, klev - odepth(1:kproma,jk) = max(0._wp, secdiff(1:kproma) * tau(1:kproma,jk)) - END DO - ! - ! 2.0 Radiative transfer - ! - ! ----- - ! - ! Plank function derivatives and total emission for linear-in-tau approximation - ! - !IBM* ASSERT(NODEPS) - DO jk = 1, klev - tfn(1:kproma) = tautrans(odepth(:,jk), kproma) - dplnkup(1:kproma,jk) = levplnk(1:kproma,jk) - layplnk(1:kproma,jk) - dplnkdn(1:kproma,jk) = levplnk(1:kproma,jk-1) - layplnk(1:kproma,jk) - bbup(1:kproma,jk) = weights(1:kproma,jk) * (layplnk(1:kproma,jk) + dplnkup(1:kproma,jk) * tfn(1:kproma)) - bbdn(1:kproma,jk) = weights(1:kproma,jk) * (layplnk(1:kproma,jk) + dplnkdn(1:kproma,jk) * tfn(1:kproma)) - END DO - ! ----- - ! 2.1 Downward radiative transfer - ! - ! Level 0 is closest to the ground - ! - rad_dn(:, klev) = 0. ! Upper boundary condition - no downwelling IR - DO jk = klev, 1, -1 - trans(1:kproma,jk) = transmit(odepth(:,jk), kproma) - ! RHS is a rearrangment of rad_dn(:,jk) * (1._wp - trans(:,jk)) + trans(:,jk) * bbdn(:) - rad_dn(1:kproma,jk-1) = rad_dn(1:kproma,jk) + (bbdn(1:kproma,jk) - rad_dn(1:kproma,jk)) * trans(1:kproma,jk) - END DO - ! - ! 2.2 Surface contribution, including reflection - ! - rad_up(1:kproma, 0) = weights(1:kproma, 1) * surfemis(1:kproma) * surfplanck(1:kproma) + (1._wp - & - surfemis(1:kproma)) * rad_dn(1:kproma, 0) - ! - ! 2.3 Upward radiative transfer - ! - DO jk = 1, klev - rad_up(1:kproma,jk) = rad_up(1:kproma,jk-1) * (1._wp - trans(1:kproma,jk)) + trans(1:kproma,jk) * bbup(1:kproma,& - jk) - END DO - ! - ! 3.0 Covert intensities at diffusivity angles to fluxes - ! - ! ----- - fluxup(1:kproma, 0:klev) = rad_up(1:kproma,:) * wtdiff * fluxfac - fluxdn(1:kproma, 0:klev) = rad_dn(1:kproma,:) * wtdiff * fluxfac - END SUBROUTINE lrtm_solver - ! ------------------------------------------------------------------------------- - - elemental FUNCTION find_secdiff(iband, pwvcm) - INTEGER, intent(in) :: iband - !< RRTMG LW band number - REAL(KIND=wp), intent(in) :: pwvcm - !< Precipitable water vapor (cm) - REAL(KIND=wp) :: find_secdiff - ! Compute diffusivity angle for Bands 2-3 and 5-9 to vary (between 1.50 - ! and 1.80) as a function of total column water vapor. The function - ! has been defined to minimize flux and cooling rate errors in these bands - ! over a wide range of precipitable water values. - REAL(KIND=wp), dimension(nbndlw), parameter :: a0 = (/ 1.66_wp, 1.55_wp, 1.58_wp, 1.66_wp, 1.54_wp, 1.454_wp, & - 1.89_wp, 1.33_wp, 1.668_wp, 1.66_wp, 1.66_wp, 1.66_wp, 1.66_wp, 1.66_wp, 1.66_wp, 1.66_wp /) - REAL(KIND=wp), dimension(nbndlw), parameter :: a1 = (/ 0.00_wp, 0.25_wp, 0.22_wp, 0.00_wp, 0.13_wp, 0.446_wp, & - -0.10_wp, 0.40_wp, -0.006_wp, 0.00_wp, 0.00_wp, 0.00_wp, 0.00_wp, 0.00_wp, 0.00_wp, 0.00_wp /) - REAL(KIND=wp), dimension(nbndlw), parameter :: a2 = (/ 0.00_wp, -12.0_wp, -11.7_wp, 0.00_wp, -0.72_wp,-0.243_wp, & - 0.19_wp,-0.062_wp, 0.414_wp, 0.00_wp, 0.00_wp, 0.00_wp, 0.00_wp, 0.00_wp, 0.00_wp, 0.00_wp /) - IF (iband == 1 .or. iband == 4 .or. iband >= 10) THEN - find_secdiff = 1.66_wp - ELSE - find_secdiff = max(min(a0(iband) + a1(iband) * exp(a2(iband)*pwvcm), 1.8_wp), 1.5_wp) - END IF - END FUNCTION find_secdiff - ! ------------------------------------------------------------------------------- - END MODULE mo_lrtm_solver diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_math_constants.f90 b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_math_constants.f90 deleted file mode 100644 index 792ef885ed..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_math_constants.f90 +++ /dev/null @@ -1,48 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_math_constants.f90 -! Generated at: 2015-02-19 15:30:32 -! KGEN version: 0.4.4 - - - - MODULE mo_math_constants - USE mo_kind, ONLY: wp - IMPLICIT NONE - PUBLIC - ! Mathematical constants defined: - ! - !-------------------------------------------------------------- - ! Fortran name | C name | meaning | - !-------------------------------------------------------------- - ! euler | M_E | e | - ! log2e | M_LOG2E | log2(e) | - ! log10e | M_LOG10E | log10(e) | - ! ln2 | M_LN2 | ln(2) | - ! ln10 | M_LN10 | ln(10) | - ! pi | M_PI | pi | - ! pi_2 | M_PI_2 | pi/2 | - ! pi_4 | M_PI_4 | pi/4 | - ! rpi | M_1_PI | 1/pi | - ! rpi_2 | M_2_PI | 2/pi | - ! rsqrtpi_2 | M_2_SQRTPI | 2/(sqrt(pi)) | - ! sqrt2 | M_SQRT2 | sqrt(2) | - ! sqrt1_2 | M_SQRT1_2 | 1/sqrt(2) | - ! sqrt3 | | sqrt(3) | - ! sqrt1_3 | | 1/sqrt(3) | - ! half angle of pentagon | - ! pi_5 | | pi/5 | - ! latitude of the lowest major triangle corner | - ! and latitude of the major hexagonal faces centers | - ! phi0 | | pi/2 -2acos(1/(2*sin(pi/5))) | - ! conversion factor from radians to degree | - ! rad2deg | | 180/pi | - ! conversion factor from degree to radians | - ! deg2rad | | pi/180 | - ! one_third | | 1/3 | - !-------------------------------------------------------------| - REAL(KIND=wp), parameter :: pi = 3.14159265358979323846264338327950288419717_wp - - ! read subroutines - END MODULE mo_math_constants diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_physical_constants.f90 b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_physical_constants.f90 deleted file mode 100644 index 926757551a..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_physical_constants.f90 +++ /dev/null @@ -1,199 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_physical_constants.f90 -! Generated at: 2015-02-19 15:30:36 -! KGEN version: 0.4.4 - - - - MODULE mo_physical_constants - USE mo_kind, ONLY: wp - IMPLICIT NONE - PUBLIC - ! Natural constants - ! ----------------- - ! - ! WMO/SI values - !> [1/mo] Avogadro constant - !! [J/K] Boltzmann constant - !! [J/K/mol] molar/universal/ideal gas constant - !! [W/m2/K4] Stephan-Boltzmann constant - ! - !> Molar weights - !! ------------- - !! - !! Pure species - !>[g/mol] CO2 (National Institute for - !! Standards and Technology (NIST)) - !! [g/mol] CH4 - !! [g/mol] O3 - !! [g/mol] O2 - !! [g/mol] N2O - !! [g/mol] CFC11 - !! [g/mol] CFC12 - REAL(KIND=wp), parameter :: amw = 18.0154_wp !! [g/mol] H2O - ! - !> Mixed species - REAL(KIND=wp), parameter :: amd = 28.970_wp !> [g/mol] dry air - ! - !> Auxiliary constants - ! ppmv2gg converts ozone from volume mixing ratio in ppmv - ! to mass mixing ratio in g/g - ! - !> Earth and Earth orbit constants - !! ------------------------------- - !! - !! [m] average radius - !! [1/m] - !! [1/s] angular velocity - ! - ! WMO/SI value - REAL(KIND=wp), parameter :: grav = 9.80665_wp !> [m/s2] av. gravitational acceleration - !! [s2/m] - ! - !> [m/m] ratio of atm. scale height - ! !! to Earth radius - ! seconds per day - ! - !> Thermodynamic constants for the dry and moist atmosphere - !! -------------------------------------------------------- - ! - !> Dry air - !> [J/K/kg] gas constant - !! [J/K/kg] specific heat at constant pressure - !! [J/K/kg] specific heat at constant volume - !! [m^2/s] kinematic viscosity of dry air - !! [m^2/s] scalar conductivity of dry air - !! [J/m/s/K]thermal conductivity of dry air - !! [N*s/m2] dyn viscosity of dry air at tmelt - ! - !> H2O - !! - gas - !> [J/K/kg] gas constant for water vapor - !! [J/K/kg] specific heat at constant pressure - !! [J/K/kg] specific heat at constant volume - !! [m^2/s] diff coeff of H2O vapor in dry air at tmelt - !> - liquid / water - !> [kg/m3] density of liquid water - !> H2O related constants (liquid, ice, snow), phase change constants - ! echam values - ! density of sea water in kg/m3 - ! density of ice in kg/m3 - ! density of snow in kg/m3 - ! density ratio (ice/water) - ! specific heat for liquid water J/K/kg - ! specific heat for sea water J/K/kg - ! specific heat for ice J/K/kg - ! specific heat for snow J/K/kg - ! thermal conductivity of ice in W/K/m - ! thermal conductivity of snow in W/K/m - ! echam values end - ! - !REAL(wp), PARAMETER :: clw = 4186.84_wp !! [J/K/kg] specific heat of water - ! !! see below - !> - phase changes - !> [J/kg] latent heat for vaporisation - !! [J/kg] latent heat for sublimation - !! [J/kg] latent heat for fusion - !! [K] melting temperature of ice/snow - ! - !> Auxiliary constants - !> [ ] - ! the next 2 values not as parameters due to ECHAM-dyn - !! [ ] - !! [ ] - !! [ ] - !! [K] - !! [K] - !! [K*kg/J] - !! [K*kg/J] - !! cp_d / cp_l - 1 - ! - !> specific heat capacity of liquid water - ! - !> [ ] - !! [ ] - !! [ ] - ! - !> [Pa] reference pressure for Exner function - !> Auxiliary constants used in ECHAM - ! Constants used for computation of saturation mixing ratio - ! over liquid water (*c_les*) or ice(*c_ies*) - ! - ! - ! - ! - ! - ! - ! - !> Variables for computing cloud cover in RH scheme - ! - !> vertical profile parameters (vpp) of CH4 and N2O - ! - !> constants for radiation module - !> lw sfc default emissivity factor - ! - !--------------------------- - ! Specifications, thresholds, and derived constants for the following subroutines: - ! s_lake, s_licetemp, s_sicetemp, meltpond, meltpond_ice, update_albedo_ice_meltpond - ! - ! mixed-layer depth of lakes in m - ! mixed-layer depth of ocean in m - ! minimum ice thickness in m - ! minimum ice thickness of pond ice in m - ! threshold ice thickness for pond closing in m - ! minimum pond depth for pond fraction in m - ! albedo of pond ice - ! - ! heat capacity of lake mixed layer - ! ! in J/K/m2 - ! heat capacity of upper ice layer - ! heat capacity of upper pond ice layer - ! - ! [J/m3] - ! [J/m3] - ! [m/K] - ! [K/m] - ! cooling below tmelt required to form dice - !--------------------------- - ! - !------------below are parameters for ocean model--------------- - ! coefficients in linear EOS - ! thermal expansion coefficient (kg/m3/K) - ! haline contraction coefficient (kg/m3/psu) - ! - ! density reference values, to be constant in Boussinesq ocean models - ! reference density [kg/m^3] - ! inverse reference density [m^3/kg] - ! reference salinity [psu] - ! - !Conversion from pressure [p] to pressure [bar] - ! !used in ocean thermodynamics - ! - ! [Pa] sea level pressure - ! - !----------below are parameters for sea-ice model--------------- - ! heat conductivity snow [J / (m s K)] - ! heat conductivity ice [J / (m s K)] - ! density of sea ice [kg / m3] - ! density of snow [kg / m3] - ! Heat capacity of ice [J / (kg K)] - ! Temperature ice bottom [C] - ! Sea-ice bulk salinity [ppt] - ! Constant in linear freezing- - ! ! point relationship [C/ppt] - ! = - (sea-ice liquidus - ! ! (aka melting) temperature) [C] - !REAL(wp), PARAMETER :: muS = -(-0.0575 + 1.710523E-3*Sqrt(Sice) - 2.154996E-4*Sice) * Sice - ! Albedo of snow (not melting) - ! Albedo of snow (melting) - ! Albedo of ice (not melting) - ! Albedo of ice (melting) - ! albedo of the ocean - !REAL(wp), PARAMETER :: I_0 = 0.3 ! Ice-surface penetrating shortwave fraction - ! Ice-surface penetrating shortwave fraction - !------------------------------------------------------------ - - ! read subroutines - END MODULE mo_physical_constants diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_psrad_interface.f90 b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_psrad_interface.f90 deleted file mode 100644 index 354f412aa2..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_psrad_interface.f90 +++ /dev/null @@ -1,770 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_psrad_interface.f90 -! Generated at: 2015-02-19 15:30:28 -! KGEN version: 0.4.4 - - - - MODULE mo_psrad_interface - USE mo_spec_sampling, only : read_var_mod5 => kgen_read_var - USE mo_kind, ONLY: wp - USE mo_rrtm_params, ONLY: nbndlw - USE mo_rrtm_params, ONLY: maxinpx - USE mo_rrtm_params, ONLY: maxxsec - USE mo_lrtm_driver, ONLY: lrtm - USE mo_spec_sampling, ONLY: spec_sampling_strategy - IMPLICIT NONE - PUBLIC lw_strat - PUBLIC read_externs_mo_psrad_interface - INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - PUBLIC psrad_interface - type, public :: check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - end type check_t - TYPE(spec_sampling_strategy), save :: lw_strat - !< Spectral sampling strategies for longwave, shortwave - INTEGER, parameter :: rng_seed_size = 4 - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_mo_psrad_interface(kgen_unit) - integer, intent(in) :: kgen_unit - call read_var_mod5(lw_strat, kgen_unit) - END SUBROUTINE read_externs_mo_psrad_interface - - subroutine kgen_init_check(check,tolerance) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.E-14 - endif - end subroutine kgen_init_check - subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif - end subroutine kgen_print_check - !--------------------------------------------------------------------------- - !> - !! @brief Sets up (initializes) radation routines - !! - !! @remarks - !! Modify preset variables of module MO_RADIATION which control the - !! configuration of the radiation scheme. - ! - - !----------------------------------------------------------------------------- - !> - !! @brief arranges input and calls rrtm sw and lw routines - !! - !! @par Revision History - !! Original Source Rewritten and renamed by B. Stevens (2009-08) - !! - !! @remarks - !! Because the RRTM indexes vertical levels differently than ECHAM a chief - !! function of thise routine is to reorder the input in the vertical. In - !! addition some cloud physical properties are prescribed, which are - !! required to derive cloud optical properties - !! - !! @par The gases are passed into RRTM via two multi-constituent arrays: - !! zwkl and wx_r. zwkl has maxinpx species and wx_r has maxxsec species - !! The species are identifed as follows. - !! ZWKL [#/cm2] WX_R [#/cm2] - !! index = 1 => H20 index = 1 => n/a - !! index = 2 => CO2 index = 2 => CFC11 - !! index = 3 => O3 index = 3 => CFC12 - !! index = 4 => N2O index = 4 => n/a - !! index = 5 => n/a - !! index = 6 => CH4 - !! index = 7 => O2 - ! - - SUBROUTINE psrad_interface(kbdim, klev, nb_sw, kproma, ktrac, tk_sfc, kgen_unit) - integer, intent(in) :: kgen_unit - - ! read interface - !interface kgen_read_var - ! procedure read_var_real_wp_dim2 - ! procedure read_var_real_wp_dim1 - ! procedure read_var_real_wp_dim3 - ! procedure read_var_integer_4_dim2 - !end interface kgen_read_var - - - - ! verification interface - !interface kgen_verify_var - ! procedure verify_var_logical - ! procedure verify_var_integer - ! procedure verify_var_real - ! procedure verify_var_character - ! procedure verify_var_real_wp_dim2 - ! procedure verify_var_real_wp_dim1 - ! procedure verify_var_real_wp_dim3 - ! procedure verify_var_integer_4_dim2 - !end interface kgen_verify_var - - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - INTEGER, intent(in) :: kbdim - INTEGER, intent(in) :: klev - INTEGER, intent(in) :: nb_sw - INTEGER, intent(in) :: kproma - INTEGER, intent(in) :: ktrac - !< aerosol control - !< number of longitudes - !< first dimension of 2-d arrays - !< first dimension of 2-d arrays - !< number of levels - !< number of tracers - !< type of convection - !< number of shortwave bands - !< land sea mask, land=.true. - !< glacier mask, glacier=.true. - REAL(KIND=wp), intent(in) :: tk_sfc(kbdim) - !< surface emissivity - !< mu0 for solar zenith angle - !< geopotential above ground - !< surface albedo for vis range and dir light - !< surface albedo for NIR range and dir light - !< surface albedo for vis range and dif light - !< surface albedo for NIR range and dif light - !< full level pressure in Pa - !< half level pressure in Pa - !< surface pressure in Pa - !< full level temperature in K - !< half level temperature in K - !< surface temperature in K - !< specific humidity in g/g - !< specific liquid water content - !< specific ice content in g/g - !< cloud nuclei concentration - !< fractional cloud cover - !< total cloud cover in m2/m2 - !< o3 mass mixing ratio - !< co2 mass mixing ratio - !< ch4 mass mixing ratio - !< n2o mass mixing ratio - !< cfc volume mixing ratio - !< o2 mass mixing ratio - !< tracer mass mixing ratios - !< upward LW flux profile, all sky - !< upward LW flux profile, clear sky - !< downward LW flux profile, all sky - !< downward LW flux profile, clear sky - !< upward SW flux profile, all sky - !< upward SW flux profile, clear sky - !< downward SW flux profile, all sky - !< downward SW flux profile, clear sky - !< Visible (250-680) fraction of net surface radiation - !< Downward Photosynthetically Active Radiation (PAR) at surface - !< Diffuse fraction of downward surface near-infrared radiation - !< Diffuse fraction of downward surface visible radiation - !< Diffuse fraction of downward surface PAR - ! ------------------------------------------------------------------------------------- - !< loop indicies - !< index for clear or cloudy - REAL(KIND=wp) :: zsemiss (kbdim,nbndlw) - REAL(KIND=wp) :: pm_sfc (kbdim) - !< LW surface emissivity by band - !< pressure thickness in Pa - !< surface pressure in mb - !< pressure thickness - !< scratch array - ! - ! --- vertically reversed _vr variables - ! - REAL(KIND=wp) :: cld_frc_vr(kbdim,klev) - REAL(KIND=wp) :: aer_tau_lw_vr(kbdim,klev,nbndlw) - REAL(KIND=wp) :: pm_fl_vr (kbdim,klev) - REAL(KIND=wp) :: tk_fl_vr (kbdim,klev) - REAL(KIND=wp) :: tk_hl_vr (kbdim,klev+1) - REAL(KIND=wp) :: cld_tau_lw_vr(kbdim,klev,nbndlw) - REAL(KIND=wp) :: wkl_vr (kbdim,maxinpx,klev) - REAL(KIND=wp) :: wx_vr (kbdim,maxxsec,klev) - REAL(KIND=wp) :: col_dry_vr(kbdim,klev) - !< number of molecules/cm2 of - !< full level pressure [mb] - !< half level pressure [mb] - !< full level temperature [K] - !< half level temperature [K] - !< cloud nuclei concentration - !< secure cloud fraction - !< specific ice water content - !< ice water content per volume - !< ice water path in g/m2 - !< specific liquid water content - !< liquid water path in g/m2 - !< liquid water content per - !< effective radius of liquid - !< effective radius of ice - !< number of molecules/cm2 of - !< number of molecules/cm2 of - !< LW optical thickness of clouds - !< extincion - !< asymmetry factor - !< single scattering albedo - !< LW optical thickness of aerosols - !< aerosol optical thickness - !< aerosol asymmetry factor - !< aerosol single scattering albedo - REAL(KIND=wp) :: flx_uplw_vr(kbdim,klev+1) - REAL(KIND=wp), allocatable :: ref_flx_uplw_vr(:,:) - REAL(KIND=wp) :: flx_uplw_clr_vr(kbdim,klev+1) - REAL(KIND=wp), allocatable :: ref_flx_uplw_clr_vr(:,:) - REAL(KIND=wp) :: flx_dnlw_clr_vr(kbdim,klev+1) - REAL(KIND=wp), allocatable :: ref_flx_dnlw_clr_vr(:,:) - REAL(KIND=wp) :: flx_dnlw_vr(kbdim,klev+1) - REAL(KIND=wp), allocatable :: ref_flx_dnlw_vr(:,:) - !< upward flux, total sky - !< upward flux, clear sky - !< downward flux, total sky - !< downward flux, clear sky - ! - ! Random seeds for sampling. Needs to get somewhere upstream - ! - INTEGER :: rnseeds(kbdim,rng_seed_size) - INTEGER, allocatable :: ref_rnseeds(:,:) - ! - ! Number of g-points per time step. Determine here to allow automatic array allocation in - ! lrtm, srtm subroutines. - ! - INTEGER :: n_gpts_ts - ! 1.0 Constituent properties - !-------------------------------- - !IBM* ASSERT(NODEPS) - ! - ! --- control for zero, infintesimal or negative cloud fractions - ! - ! - ! --- main constituent reordering - ! - !IBM* ASSERT(NODEPS) - !IBM* ASSERT(NODEPS) - !IBM* ASSERT(NODEPS) - ! - ! --- CFCs are in volume mixing ratio - ! - !IBM* ASSERT(NODEPS) - ! - ! -- Convert to molecules/cm^2 - ! - ! - ! 2.0 Surface Properties - ! -------------------------------- - ! - ! 3.0 Particulate Optical Properties - ! -------------------------------- - ! - ! 3.5 Interface for submodels that provide aerosol and/or cloud radiative properties: - ! ----------------------------------------------------------------------------------- - ! - ! 4.0 Radiative Transfer Routines - ! -------------------------------- - ! - ! Seeds for random numbers come from least significant digits of pressure field - ! - tolerance = 1.E-12 - CALL kgen_init_check(check_status, tolerance) - READ(UNIT=kgen_unit) zsemiss - READ(UNIT=kgen_unit) pm_sfc - READ(UNIT=kgen_unit) cld_frc_vr - READ(UNIT=kgen_unit) aer_tau_lw_vr - READ(UNIT=kgen_unit) pm_fl_vr - READ(UNIT=kgen_unit) tk_fl_vr - READ(UNIT=kgen_unit) tk_hl_vr - READ(UNIT=kgen_unit) cld_tau_lw_vr - READ(UNIT=kgen_unit) wkl_vr - READ(UNIT=kgen_unit) wx_vr - READ(UNIT=kgen_unit) col_dry_vr - READ(UNIT=kgen_unit) flx_uplw_vr - READ(UNIT=kgen_unit) flx_uplw_clr_vr - READ(UNIT=kgen_unit) flx_dnlw_clr_vr - READ(UNIT=kgen_unit) flx_dnlw_vr - READ(UNIT=kgen_unit) rnseeds - READ(UNIT=kgen_unit) n_gpts_ts - - !call kgen_read_var(ref_flx_uplw_vr, kgen_unit) - !call kgen_read_var(ref_flx_uplw_clr_vr, kgen_unit) - !call kgen_read_var(ref_flx_dnlw_clr_vr, kgen_unit) - !call kgen_read_var(ref_flx_dnlw_vr, kgen_unit) - !call kgen_read_var(ref_rnseeds, kgen_unit) - call read_var_real_wp_dim2(ref_flx_uplw_vr, kgen_unit) - call read_var_real_wp_dim2(ref_flx_uplw_clr_vr, kgen_unit) - call read_var_real_wp_dim2(ref_flx_dnlw_clr_vr, kgen_unit) - call read_var_real_wp_dim2(ref_flx_dnlw_vr, kgen_unit) - call read_var_integer_4_dim2(ref_rnseeds, kgen_unit) - - ! call to kernel - CALL lrtm(kproma, kbdim, klev, pm_fl_vr, pm_sfc, tk_fl_vr, tk_hl_vr, tk_sfc, wkl_vr, wx_vr, col_dry_vr, zsemiss, cld_frc_vr, cld_tau_lw_vr, aer_tau_lw_vr, rnseeds, lw_strat, n_gpts_ts, flx_uplw_vr, flx_dnlw_vr, flx_uplw_clr_vr, flx_dnlw_clr_vr) - ! kernel verification for output variables - call verify_var_real_wp_dim2("flx_uplw_vr", check_status, flx_uplw_vr, ref_flx_uplw_vr) - call verify_var_real_wp_dim2("flx_uplw_clr_vr", check_status, flx_uplw_clr_vr, ref_flx_uplw_clr_vr) - call verify_var_real_wp_dim2("flx_dnlw_clr_vr", check_status, flx_dnlw_clr_vr, ref_flx_dnlw_clr_vr) - call verify_var_real_wp_dim2("flx_dnlw_vr", check_status, flx_dnlw_vr, ref_flx_dnlw_vr) - call verify_var_integer_4_dim2("rnseeds", check_status, rnseeds, ref_rnseeds) - CALL kgen_print_check("lrtm", check_status) - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,100 - CALL lrtm(kproma, kbdim, klev, pm_fl_vr, pm_sfc, tk_fl_vr, tk_hl_vr, tk_sfc, wkl_vr, wx_vr, col_dry_vr, zsemiss, cld_frc_vr, cld_tau_lw_vr, aer_tau_lw_vr, rnseeds, lw_strat, n_gpts_ts, flx_uplw_vr, flx_dnlw_vr, flx_uplw_clr_vr, flx_dnlw_clr_vr) - END DO - CALL system_clock(stop_clock, rate_clock) - WRITE(*,*) - !PRINT *, "Elapsed time (sec): ", (stop_clock - start_clock)/REAL(rate_clock*100) - ! - ! Reset random seeds so SW doesn't depend on what's happened in LW but is also independent - ! - ! - ! Potential pitfall - we're passing every argument but some may not be present - ! - ! - ! 5.0 Post Processing - ! -------------------------------- - ! - ! Lw fluxes are vertically revered but SW fluxes are not - ! - ! - ! 6.0 Interface for submodel diagnosics after radiation calculation: - ! ------------------------------------------------------------------ - CONTAINS - - ! read subroutines - subroutine read_var_real_wp_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_real_wp_dim3(var, kgen_unit) - integer, intent(in) :: kgen_unit - real(kind=wp), intent(out), dimension(:,:,:), allocatable :: var - integer, dimension(2,3) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - subroutine read_var_integer_4_dim2(var, kgen_unit) - integer, intent(in) :: kgen_unit - integer(kind=4), intent(out), dimension(:,:), allocatable :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - - subroutine verify_var_logical(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - logical, intent(in) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - IF ( var .eqv. ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - endif - endif - check_status%numFatal = check_status%numFatal + 1 - END IF - end subroutine - - subroutine verify_var_integer(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer, intent(in) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - endif - endif - check_status%numFatal = check_status%numFatal + 1 - END IF - end subroutine - - subroutine verify_var_real(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real, intent(in) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - endif - endif - check_status%numFatal = check_status%numFatal + 1 - END IF - end subroutine - - subroutine verify_var_character(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - character(*), intent(in) :: var, ref_var - - check_status%numTotal = check_status%numTotal + 1 - IF ( var == ref_var ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." - endif - ELSE - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - if(check_status%verboseLevel > 2) then - WRITE(*,*) "KERNEL: ", var - WRITE(*,*) "REF. : ", ref_var - end if - end if - check_status%numFatal = check_status%numFatal + 1 - END IF - end subroutine - - subroutine verify_var_real_wp_dim2(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(kind=wp), intent(in), dimension(:,:) :: var - real(kind=wp), intent(in), allocatable, dimension(:,:) :: ref_var - real(kind=wp) :: nrmsdiff, rmsdiff - real(kind=wp), allocatable :: temp(:,:), temp2(:,:) - integer :: n - - - IF ( ALLOCATED(ref_var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - IF ( ALL( var == ref_var ) ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - n = count(var/=ref_var) - where(ref_var .NE. 0) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - END IF - deallocate(temp,temp2) - END IF - end subroutine - - subroutine verify_var_real_wp_dim1(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(kind=wp), intent(in), dimension(:) :: var - real(kind=wp), intent(in), allocatable, dimension(:) :: ref_var - real(kind=wp) :: nrmsdiff, rmsdiff - real(kind=wp), allocatable :: temp(:), temp2(:) - integer :: n - - - IF ( ALLOCATED(ref_var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - allocate(temp(SIZE(var,dim=1))) - allocate(temp2(SIZE(var,dim=1))) - IF ( ALL( var == ref_var ) ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - n = count(var/=ref_var) - where(ref_var .NE. 0) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - END IF - deallocate(temp,temp2) - END IF - end subroutine - - subroutine verify_var_real_wp_dim3(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(kind=wp), intent(in), dimension(:,:,:) :: var - real(kind=wp), intent(in), allocatable, dimension(:,:,:) :: ref_var - real(kind=wp) :: nrmsdiff, rmsdiff - real(kind=wp), allocatable :: temp(:,:,:), temp2(:,:,:) - integer :: n - - - IF ( ALLOCATED(ref_var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - IF ( ALL( var == ref_var ) ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - n = count(var/=ref_var) - where(ref_var .NE. 0) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - END IF - deallocate(temp,temp2) - END IF - end subroutine - - subroutine verify_var_integer_4_dim2(varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - integer(kind=4), intent(in), dimension(:,:) :: var - integer(kind=4), intent(in), allocatable, dimension(:,:) :: ref_var - integer(kind=4) :: nrmsdiff, rmsdiff - integer(kind=4), allocatable :: temp(:,:), temp2(:,:) - integer :: n - - - IF ( ALLOCATED(ref_var) ) THEN - check_status%numTotal = check_status%numTotal + 1 - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - IF ( ALL( var == ref_var ) ) THEN - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - n = count(var/=ref_var) - where(ref_var .NE. 0) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - END IF - deallocate(temp,temp2) - END IF - end subroutine - - END SUBROUTINE psrad_interface - END MODULE mo_psrad_interface diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_rad_fastmath.f90 b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_rad_fastmath.f90 deleted file mode 100644 index 0df00ac882..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_rad_fastmath.f90 +++ /dev/null @@ -1,84 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_rad_fastmath.f90 -! Generated at: 2015-02-19 15:30:32 -! KGEN version: 0.4.4 - - - - MODULE mo_rad_fastmath - USE mo_kind, ONLY: dp - USE mo_kind, ONLY: wp - IMPLICIT NONE - PRIVATE - PUBLIC tautrans, inv_expon, transmit - !< Optical depth - !< Exponential lookup table (EXP(-tau)) - !< Tau transition function - ! i.e. the transition of the Planck function from that for the mean layer temperature - ! to that for the layer boundary temperature as a function of optical depth. - ! The "linear in tau" method is used to make the table. - !< Value of tau below which expansion is used - !< Smallest value for exponential table - !< Pade approximation constant - REAL(KIND=wp), parameter :: rec_6 = 1._wp/6._wp - ! - ! The RRTMG tables are indexed with INT(tblint * x(i)/(bpade + x(i)) + 0.5_wp) - ! But these yield unstable values in the SW solver for some parameter sets, so - ! we'll remove this option (though the tables are initialized if people want them). - ! RRTMG table lookups are approximated second-order Taylor series expansion - ! (e.g. exp(-x) = 1._wp - x(1:n) + 0.5_wp * x(1:n)**2, tautrans = x/6._wp) for x < od_lo - ! - CONTAINS - - ! read subroutines - ! ------------------------------------------------------------ - - ! ------------------------------------------------------------ - - ! ------------------------------------------------------------ - - FUNCTION inv_expon(x, n) - ! - ! Compute EXP(-x) - but do it fast - ! - INTEGER, intent(in) :: n - REAL(KIND=dp), intent(in) :: x(n) - REAL(KIND=dp) :: inv_expon(n) - inv_expon(1:n) = exp(-x(1:n)) - END FUNCTION inv_expon - ! ------------------------------------------------------------ - - FUNCTION transmit(x, n) - ! - ! Compute transmittance 1 - EXP(-x) - ! - INTEGER, intent(in) :: n - REAL(KIND=dp), intent(in) :: x(n) - REAL(KIND=dp) :: transmit(n) - ! - ! MASS and MKL libraries have exp(x) - 1 functions; we could - ! use those here - ! - transmit(1:n) = 1._wp - inv_expon(x,n) - END FUNCTION transmit - ! ------------------------------------------------------------ - - FUNCTION tautrans(x, n) - ! - ! Compute "tau transition" using linear-in-tau approximation - ! - INTEGER, intent(in) :: n - REAL(KIND=dp), intent(in) :: x(n) - REAL(KIND=dp) :: tautrans(n) - REAL(KIND=dp) :: y(n) - ! - ! Default calculation is unstable (NaN) for the very lowest value of tau (3.6e-4) - ! - y(:) = inv_expon(x,n) - tautrans(:) = merge(1._wp - 2._wp*(1._wp/x(1:n) - y(:)/(1._wp-y(:))), x * rec_6, & - x > 1.e-3_wp) - END FUNCTION tautrans - ! ------------------------------------------------------------ - END MODULE mo_rad_fastmath diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_radiation_parameters.f90 b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_radiation_parameters.f90 deleted file mode 100644 index dc08eb4811..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_radiation_parameters.f90 +++ /dev/null @@ -1,115 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_radiation_parameters.f90 -! Generated at: 2015-02-19 15:30:29 -! KGEN version: 0.4.4 - - - - MODULE mo_radiation_parameters - USE mo_kind, ONLY: wp - IMPLICIT NONE - PRIVATE - PUBLIC i_overlap, l_do_sep_clear_sky - PUBLIC rad_undef - ! Standalone radiative transfer parameters - PUBLIC do_gpoint ! Standalone use only - ! 1.0 NAMELIST global variables and parameters - ! -------------------------------- - !< diurnal cycle - !< &! switch on/off diagnostic - !of instantaneous aerosol solar (lradforcing(1)) and - !thermal (lradforcing(2)) radiation forcing - !< switch to specify perpetual vsop87 year - !< year if (lyr_perp == .TRUE.) - !< 0=annual cycle; 1-12 for perpetual month - ! nmonth currently works for zonal mean ozone and the orbit (year 1987) only - !< mode of solar constant calculation - !< default is rrtm solar constant - !< number of shortwave bands, set in setup - ! Spectral sampling - ! 1 is broadband, 2 is MCSI, 3 and up are teams - ! Number of g-points per time step using MCSI - ! Integer for perturbing random number seeds - ! Use unique spectral samples under MCSI? Not yet implemented - INTEGER :: do_gpoint = 0 ! Standalone use only - specify gpoint to use - ! Radiation driver - LOGICAL :: l_do_sep_clear_sky = .true. ! Compute clear-sky fluxes by removing clouds - INTEGER :: i_overlap = 1 ! 1 = max-ran, 2 = max, 3 = ran - ! Use separate water vapor amounts in clear, cloudy skies - ! - ! --- Switches for radiative agents - ! - !< water vapor, clouds and ice for radiation - !< carbon dioxide - !< methane - !< ozone - !< molecular oxygen - !< nitrous oxide - !< cfc11 and cfc12 - !< greenhouse gase scenario - !< aerosol model - !< factor for external co2 scenario (ico2=4) - ! - ! --- Default gas volume mixing ratios - 1990 values (CMIP5) - ! - !< CO2 - !< CH4 - !< O2 - !< N20 - !< CFC 11 and CFC 12 - ! - ! 2.0 Non NAMELIST global variables and parameters - ! -------------------------------- - ! - ! --- radiative transfer parameters - ! - !< LW Emissivity Factor - !< LW Diffusivity Factor - REAL(KIND=wp), parameter :: rad_undef = -999._wp - ! - ! - !< default solar constant [W/m2] for - ! AMIP-type CMIP5 simulation - !++hs - !< local (orbit relative and possibly - ! time dependent) solar constant - !< orbit and time dependent solar constant for radiation time step - !< fraction of TSI in the 14 RRTM SW bands - !--hs - !< solar declination at current time step - ! - ! 3.0 Variables computed by routines in mo_radiation (export to submodels) - ! -------------------------------- - ! - ! setup_radiation - PUBLIC read_externs_mo_radiation_parameters - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_mo_radiation_parameters(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) do_gpoint - READ(UNIT=kgen_unit) l_do_sep_clear_sky - READ(UNIT=kgen_unit) i_overlap - END SUBROUTINE read_externs_mo_radiation_parameters - - - ! read subroutines - !--------------------------------------------------------------------------- - !> - !! @brief Scans a block and fills with solar parameters - !! - !! @remarks: This routine calculates the solar zenith angle for each - !! point in a block of data. For simulations with no dirunal cycle - !! the cosine of the zenith angle is set to its average value (assuming - !! negatives to be zero and for a day divided into nds intervals). - !! Additionally a field is set indicating the fraction of the day over - !! which the solar zenith angle is greater than zero. Otherwise the field - !! is set to 1 or 0 depending on whether the zenith angle is greater or - !! less than 1. - ! - - END MODULE mo_radiation_parameters diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_random_numbers.f90 b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_random_numbers.f90 deleted file mode 100644 index cf0916b327..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_random_numbers.f90 +++ /dev/null @@ -1,141 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_random_numbers.f90 -! Generated at: 2015-02-19 15:30:29 -! KGEN version: 0.4.4 - - - - MODULE mo_random_numbers - USE mo_kind, ONLY: dp - USE mo_kind, ONLY: i8 - IMPLICIT NONE - LOGICAL, parameter :: big_endian = (transfer(1_i8, 1) == 0) - INTEGER, parameter :: state_size = 4 - INTEGER :: global_seed(state_size) = (/123456789,362436069,21288629,14921776/) - PRIVATE - PUBLIC get_random - - INTERFACE get_random - MODULE PROCEDURE kisssca, kiss_global, kissvec, kissvec_all, kissvec_global - END INTERFACE get_random - PUBLIC read_externs_mo_random_numbers - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_integer_4_dim1 - end interface kgen_read_var - - CONTAINS - - ! module extern variables - - SUBROUTINE read_externs_mo_random_numbers(kgen_unit) - integer, intent(in) :: kgen_unit - READ(UNIT=kgen_unit) global_seed - END SUBROUTINE read_externs_mo_random_numbers - - - ! read subroutines - subroutine read_var_integer_4_dim1(var, kgen_unit) - integer, intent(in) :: kgen_unit - integer(kind=4), intent(out), dimension(:), allocatable :: var - integer, dimension(2,1) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - ! ----------------------------------------------- - - ! ----------------------------------------------- - - ! ----------------------------------------------- - - SUBROUTINE kissvec_all(kproma, kbdim, seed, harvest) - INTEGER, intent(in ) :: kbdim - INTEGER, intent(in ) :: kproma - INTEGER, intent(inout) :: seed(:,:) ! Dimension nproma, seed_size - REAL(KIND=dp), intent( out) :: harvest(:) ! Dimension nproma - LOGICAL :: mask(kbdim) - mask(:) = .true. - CALL kissvec(kproma, kbdim, seed, mask, harvest) - END SUBROUTINE kissvec_all - ! ----------------------------------------------- - - SUBROUTINE kissvec(kproma, kbdim, seed, mask, harvest) - INTEGER, intent(in ) :: kbdim - INTEGER, intent(in ) :: kproma - INTEGER, intent(inout) :: seed(:,:) ! Dimension kbdim, seed_size or bigger - LOGICAL, intent(in ) :: mask(kbdim) - REAL(KIND=dp), intent( out) :: harvest(kbdim) - INTEGER(KIND=i8) :: kiss(kproma) - INTEGER :: jk - DO jk = 1, kproma - IF (mask(jk)) THEN - kiss(jk) = 69069_i8 * seed(jk,1) + 1327217885 - seed(jk,1) = low_byte(kiss(jk)) - seed(jk,2) = m (m (m (seed(jk,2), 13), - 17), 5) - seed(jk,3) = 18000 * iand (seed(jk,3), 65535) + ishft (seed(jk,3), - 16) - seed(jk,4) = 30903 * iand (seed(jk,4), 65535) + ishft (seed(jk,4), - 16) - kiss(jk) = int(seed(jk,1), i8) + seed(jk,2) + ishft (seed(jk,3), 16) + seed(jk,4) - harvest(jk) = low_byte(kiss(jk))*2.328306e-10_dp + 0.5_dp - ELSE - harvest(jk) = 0._dp - END IF - END DO - END SUBROUTINE kissvec - ! ----------------------------------------------- - - SUBROUTINE kisssca(seed, harvest) - INTEGER, intent(inout) :: seed(:) - REAL(KIND=dp), intent( out) :: harvest - INTEGER(KIND=i8) :: kiss - kiss = 69069_i8 * seed(1) + 1327217885 - seed(1) = low_byte(kiss) - seed(2) = m (m (m (seed(2), 13), - 17), 5) - seed(3) = 18000 * iand (seed(3), 65535) + ishft (seed(3), - 16) - seed(4) = 30903 * iand (seed(4), 65535) + ishft (seed(4), - 16) - kiss = int(seed(1), i8) + seed(2) + ishft (seed(3), 16) + seed(4) - harvest = low_byte(kiss)*2.328306e-10_dp + 0.5_dp - END SUBROUTINE kisssca - ! ----------------------------------------------- - - SUBROUTINE kiss_global(harvest) - REAL(KIND=dp), intent(inout) :: harvest - CALL kisssca(global_seed, harvest) - END SUBROUTINE kiss_global - ! ----------------------------------------------- - - SUBROUTINE kissvec_global(harvest) - REAL(KIND=dp), intent(inout) :: harvest(:) - INTEGER :: i - DO i = 1, size(harvest) - CALL kisssca(global_seed, harvest(i)) - END DO - END SUBROUTINE kissvec_global - ! ----------------------------------------------- - - elemental integer FUNCTION m(k, n) - INTEGER, intent(in) :: k - INTEGER, intent(in) :: n - m = ieor (k, ishft (k, n)) ! UNRESOLVED: m - END FUNCTION m - ! ----------------------------------------------- - - elemental integer FUNCTION low_byte(i) - INTEGER(KIND=i8), intent(in) :: i - IF (big_endian) THEN - low_byte = transfer(ishft(i,bit_size(1)),1) ! UNRESOLVED: low_byte - ELSE - low_byte = transfer(i,1) ! UNRESOLVED: low_byte - END IF - END FUNCTION low_byte - END MODULE mo_random_numbers diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_rrtm_coeffs.f90 b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_rrtm_coeffs.f90 deleted file mode 100644 index 6ce71ad64b..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_rrtm_coeffs.f90 +++ /dev/null @@ -1,314 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_rrtm_coeffs.f90 -! Generated at: 2015-02-19 15:30:32 -! KGEN version: 0.4.4 - - - - MODULE mo_rrtm_coeffs - USE mo_kind, ONLY: wp - USE mo_rrtm_params, ONLY: preflog - USE mo_rrtm_params, ONLY: tref - USE rrlw_planck, ONLY: chi_mls - IMPLICIT NONE - REAL(KIND=wp), parameter :: stpfac = 296._wp/1013._wp - CONTAINS - - ! read subroutines - ! -------------------------------------------------------------------------------------------- - - SUBROUTINE lrtm_coeffs(kproma, kbdim, klev, play, tlay, coldry, wkl, wbroad, laytrop, jp, jt, jt1, colh2o, colco2, colo3, & - coln2o, colco, colch4, colo2, colbrd, fac00, fac01, fac10, fac11, rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, & - rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, selffac, selffrac, & - indself, forfac, forfrac, indfor, minorfrac, scaleminor, scaleminorn2, indminor) - INTEGER, intent(in) :: kbdim - INTEGER, intent(in) :: klev - INTEGER, intent(in) :: kproma - ! number of columns - ! maximum number of column as first dim is declared in calling (sub)prog. - ! total number of layers - REAL(KIND=wp), intent(in) :: wkl(:,:,:) - REAL(KIND=wp), intent(in) :: play(kbdim,klev) - REAL(KIND=wp), intent(in) :: tlay(kbdim,klev) - REAL(KIND=wp), intent(in) :: coldry(kbdim,klev) - REAL(KIND=wp), intent(in) :: wbroad(kbdim,klev) - ! layer pressures (mb) - ! layer temperatures (K) - ! dry air column density (mol/cm2) - ! broadening gas column density (mol/cm2) - !< molecular amounts (mol/cm-2) (mxmol,klev) - ! - ! Output Dimensions kproma, klev unless otherwise specified - ! - INTEGER, intent(out) :: laytrop(kbdim) - INTEGER, intent(out) :: jp(kbdim,klev) - INTEGER, intent(out) :: jt(kbdim,klev) - INTEGER, intent(out) :: jt1(kbdim,klev) - INTEGER, intent(out) :: indfor(kbdim,klev) - INTEGER, intent(out) :: indself(kbdim,klev) - INTEGER, intent(out) :: indminor(kbdim,klev) - !< tropopause layer index - ! - ! - ! - ! - ! - ! - REAL(KIND=wp), intent(out) :: forfac(kbdim,klev) - REAL(KIND=wp), intent(out) :: colch4(kbdim,klev) - REAL(KIND=wp), intent(out) :: colco2(kbdim,klev) - REAL(KIND=wp), intent(out) :: colh2o(kbdim,klev) - REAL(KIND=wp), intent(out) :: coln2o(kbdim,klev) - REAL(KIND=wp), intent(out) :: forfrac(kbdim,klev) - REAL(KIND=wp), intent(out) :: selffrac(kbdim,klev) - REAL(KIND=wp), intent(out) :: colo3(kbdim,klev) - REAL(KIND=wp), intent(out) :: fac00(kbdim,klev) - REAL(KIND=wp), intent(out) :: colo2(kbdim,klev) - REAL(KIND=wp), intent(out) :: fac01(kbdim,klev) - REAL(KIND=wp), intent(out) :: fac10(kbdim,klev) - REAL(KIND=wp), intent(out) :: fac11(kbdim,klev) - REAL(KIND=wp), intent(out) :: selffac(kbdim,klev) - REAL(KIND=wp), intent(out) :: colbrd(kbdim,klev) - REAL(KIND=wp), intent(out) :: colco(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_h2oco2(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_h2oco2_1(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_h2oo3(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_h2oo3_1(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_h2on2o(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_h2on2o_1(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_h2och4(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_h2och4_1(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_n2oco2(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_n2oco2_1(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_o3co2(kbdim,klev) - REAL(KIND=wp), intent(out) :: rat_o3co2_1(kbdim,klev) - REAL(KIND=wp), intent(out) :: scaleminor(kbdim,klev) - REAL(KIND=wp), intent(out) :: scaleminorn2(kbdim,klev) - REAL(KIND=wp), intent(out) :: minorfrac(kbdim,klev) - !< column amount (h2o) - !< column amount (co2) - !< column amount (o3) - !< column amount (n2o) - !< column amount (co) - !< column amount (ch4) - !< column amount (o2) - !< column amount (broadening gases) - !< - !< - !< - !< - !< - INTEGER :: jk - REAL(KIND=wp) :: colmol(kbdim,klev) - REAL(KIND=wp) :: factor(kbdim,klev) - ! ------------------------------------------------ - CALL srtm_coeffs(kproma, kbdim, klev, play, tlay, coldry, wkl, laytrop, jp, jt, jt1, colch4, colco2, colh2o, colmol, & - coln2o, colo2, colo3, fac00, fac01, fac10, fac11, selffac, selffrac, indself, forfac, forfrac, indfor) - colbrd(1:kproma,1:klev) = 1.e-20_wp * wbroad(1:kproma,1:klev) - colco(1:kproma,1:klev) = merge(1.e-20_wp * wkl(1:kproma,5,1:klev), 1.e-32_wp * & - coldry(1:kproma,1:klev), wkl(1:kproma,5,1:klev) > 0._wp) - ! - ! Water vapor continuum broadening factors are used differently in LW and SW? - ! - forfac(1:kproma,1:klev) = forfac(1:kproma,1:klev) * colh2o(1:kproma,1:klev) - selffac(1:kproma,1:klev) = selffac(1:kproma,1:klev) * colh2o(1:kproma,1:klev) - ! - ! Setup reference ratio to be used in calculation of binary species parameter. - ! - DO jk = 1, klev - rat_h2oco2(1:kproma, jk) = chi_mls(1,jp(1:kproma, jk))/chi_mls(2,jp(1:kproma, jk)) - rat_h2oco2_1(1:kproma, jk) = chi_mls(1,jp(1:kproma, jk)+1)/chi_mls(2,jp(1:kproma, jk)+1) - ! - ! Needed only in lower atmos (plog > 4.56_wp) - ! - rat_h2oo3(1:kproma, jk) = chi_mls(1,jp(1:kproma, jk))/chi_mls(3,jp(1:kproma, jk)) - rat_h2oo3_1(1:kproma, jk) = chi_mls(1,jp(1:kproma, jk)+1)/chi_mls(3,jp(1:kproma, jk)+1) - rat_h2on2o(1:kproma, jk) = chi_mls(1,jp(1:kproma, jk))/chi_mls(4,jp(1:kproma, jk)) - rat_h2on2o_1(1:kproma, jk) = chi_mls(1,jp(1:kproma, jk)+1)/chi_mls(4,jp(1:kproma, jk)+1) - rat_h2och4(1:kproma, jk) = chi_mls(1,jp(1:kproma, jk))/chi_mls(6,jp(1:kproma, jk)) - rat_h2och4_1(1:kproma, jk) = chi_mls(1,jp(1:kproma, jk)+1)/chi_mls(6,jp(1:kproma, jk)+1) - rat_n2oco2(1:kproma, jk) = chi_mls(4,jp(1:kproma, jk))/chi_mls(2,jp(1:kproma, jk)) - rat_n2oco2_1(1:kproma, jk) = chi_mls(4,jp(1:kproma, jk)+1)/chi_mls(2,jp(1:kproma, jk)+1) - ! - ! Needed only in upper atmos (plog <= 4.56_wp) - ! - rat_o3co2(1:kproma, jk) = chi_mls(3,jp(1:kproma, jk))/chi_mls(2,jp(1:kproma, jk)) - rat_o3co2_1(1:kproma, jk) = chi_mls(3,jp(1:kproma, jk)+1)/chi_mls(2,jp(1:kproma, jk)+1) - END DO - ! - ! Set up factors needed to separately include the minor gases - ! in the calculation of absorption coefficient - ! - scaleminor(1:kproma,1:klev) = play(1:kproma,1:klev)/tlay(1:kproma,1:klev) - scaleminorn2(1:kproma,1:klev) = scaleminor(1:kproma,1:klev) * (wbroad(1:kproma,1:klev)/(& - coldry(1:kproma,1:klev)+wkl(1:kproma,1,1:klev))) - factor(1:kproma,1:klev) = (tlay(1:kproma,1:klev)-180.8_wp)/7.2_wp - indminor(1:kproma,1:klev) = min(18, max(1, int(factor(1:kproma,1:klev)))) - minorfrac(1:kproma,1:klev) = (tlay(1:kproma,1:klev)-180.8_wp)/7.2_wp - float(indminor(1:kproma,1:klev)) - END SUBROUTINE lrtm_coeffs - ! -------------------------------------------------------------------------------------------- - - SUBROUTINE srtm_coeffs(kproma, kbdim, klev, play, tlay, coldry, wkl, laytrop, jp, jt, jt1, colch4, colco2, colh2o, colmol,& - coln2o, colo2, colo3, fac00, fac01, fac10, fac11, selffac, selffrac, indself, forfac, forfrac, indfor) - INTEGER, intent(in) :: kbdim - INTEGER, intent(in) :: klev - INTEGER, intent(in) :: kproma - ! number of columns - ! maximum number of col. as declared in calling (sub)programs - ! total number of layers - REAL(KIND=wp), intent(in) :: play(kbdim,klev) - REAL(KIND=wp), intent(in) :: tlay(kbdim,klev) - REAL(KIND=wp), intent(in) :: wkl(:,:,:) - REAL(KIND=wp), intent(in) :: coldry(kbdim,klev) - ! layer pressures (mb) - ! layer temperatures (K) - ! dry air column density (mol/cm2) - !< molecular amounts (mol/cm-2) (mxmol,klev) - ! - ! Output Dimensions kproma, klev unless otherwise specified - ! - INTEGER, intent(out) :: jp(kbdim,klev) - INTEGER, intent(out) :: jt(kbdim,klev) - INTEGER, intent(out) :: jt1(kbdim,klev) - INTEGER, intent(out) :: laytrop(kbdim) - INTEGER, intent(out) :: indfor(kbdim,klev) - INTEGER, intent(out) :: indself(kbdim,klev) - !< tropopause layer index - ! - ! - ! - ! - REAL(KIND=wp), intent(out) :: fac10(kbdim,klev) - REAL(KIND=wp), intent(out) :: fac00(kbdim,klev) - REAL(KIND=wp), intent(out) :: fac11(kbdim,klev) - REAL(KIND=wp), intent(out) :: fac01(kbdim,klev) - REAL(KIND=wp), intent(out) :: colh2o(kbdim,klev) - REAL(KIND=wp), intent(out) :: colco2(kbdim,klev) - REAL(KIND=wp), intent(out) :: colo3(kbdim,klev) - REAL(KIND=wp), intent(out) :: coln2o(kbdim,klev) - REAL(KIND=wp), intent(out) :: colch4(kbdim,klev) - REAL(KIND=wp), intent(out) :: colo2(kbdim,klev) - REAL(KIND=wp), intent(out) :: colmol(kbdim,klev) - REAL(KIND=wp), intent(out) :: forfac(kbdim,klev) - REAL(KIND=wp), intent(out) :: selffac(kbdim,klev) - REAL(KIND=wp), intent(out) :: forfrac(kbdim,klev) - REAL(KIND=wp), intent(out) :: selffrac(kbdim,klev) - !< column amount (h2o) - !< column amount (co2) - !< column amount (o3) - !< column amount (n2o) - !< column amount (ch4) - !< column amount (o2) - !< - !< - !< - !< - !< - INTEGER :: jp1(kbdim,klev) - INTEGER :: jk - REAL(KIND=wp) :: plog (kbdim,klev) - REAL(KIND=wp) :: fp (kbdim,klev) - REAL(KIND=wp) :: ft (kbdim,klev) - REAL(KIND=wp) :: ft1 (kbdim,klev) - REAL(KIND=wp) :: water (kbdim,klev) - REAL(KIND=wp) :: scalefac(kbdim,klev) - REAL(KIND=wp) :: compfp(kbdim,klev) - REAL(KIND=wp) :: factor (kbdim,klev) - ! ------------------------------------------------------------------------- - ! - ! Find the two reference pressures on either side of the - ! layer pressure. Store them in JP and JP1. Store in FP the - ! fraction of the difference (in ln(pressure)) between these - ! two values that the layer pressure lies. - ! - plog(1:kproma,1:klev) = log(play(1:kproma,1:klev)) - jp(1:kproma,1:klev) = min(58,max(1,int(36._wp - 5*(plog(1:kproma,1:klev)+0.04_wp)))) - jp1(1:kproma,1:klev) = jp(1:kproma,1:klev) + 1 - DO jk = 1, klev - fp(1:kproma,jk) = 5._wp *(preflog(jp(1:kproma,jk)) - plog(1:kproma,jk)) - END DO - ! - ! Determine, for each reference pressure (JP and JP1), which - ! reference temperature (these are different for each - ! reference pressure) is nearest the layer temperature but does - ! not exceed it. Store these indices in JT and JT1, resp. - ! Store in FT (resp. FT1) the fraction of the way between JT - ! (JT1) and the next highest reference temperature that the - ! layer temperature falls. - ! - DO jk = 1, klev - jt(1:kproma,jk) = min(4,max(1,int(3._wp + (tlay(1:kproma,jk) - tref(& - jp (1:kproma,jk)))/15._wp))) - jt1(1:kproma,jk) = min(4,max(1,int(3._wp + (tlay(1:kproma,jk) - & - tref(jp1(1:kproma,jk)))/15._wp))) - END DO - DO jk = 1, klev - ft(1:kproma,jk) = ((tlay(1:kproma,jk)-tref(jp (1:kproma,jk)))/15._wp) - float(jt (& - 1:kproma,jk)-3) - ft1(1:kproma,jk) = ((tlay(1:kproma,jk)-tref(jp1(1:kproma,jk)))/15._wp) - float(jt1(& - 1:kproma,jk)-3) - END DO - water(1:kproma,1:klev) = wkl(1:kproma,1,1:klev)/coldry(1:kproma,1:klev) - scalefac(1:kproma,1:klev) = play(1:kproma,1:klev) * stpfac / tlay(1:kproma,1:klev) - ! - ! We have now isolated the layer ln pressure and temperature, - ! between two reference pressures and two reference temperatures - ! (for each reference pressure). We multiply the pressure - ! fraction FP with the appropriate temperature fractions to get - ! the factors that will be needed for the interpolation that yields - ! the optical depths (performed in routines TAUGBn for band n).` - ! - compfp(1:kproma,1:klev) = 1. - fp(1:kproma,1:klev) - fac10(1:kproma,1:klev) = compfp(1:kproma,1:klev) * ft(1:kproma,1:klev) - fac00(1:kproma,1:klev) = compfp(1:kproma,1:klev) * (1._wp - ft(1:kproma,1:klev)) - fac11(1:kproma,1:klev) = fp(1:kproma,1:klev) * ft1(1:kproma,1:klev) - fac01(1:kproma,1:klev) = fp(1:kproma,1:klev) * (1._wp - ft1(1:kproma,1:klev)) - ! Tropopause defined in terms of pressure (~100 hPa) - ! We're looking for the first layer (counted from the bottom) at which the pressure reaches - ! or falls below this value - ! - laytrop(1:kproma) = count(plog(1:kproma,1:klev) > 4.56_wp, dim = 2) - ! - ! Calculate needed column amounts. - ! Only a few ratios are used in the upper atmosphere but masking may be less efficient - ! - colh2o(1:kproma,1:klev) = merge(1.e-20_wp * wkl(1:kproma,1,1:klev), 1.e-32_wp * & - coldry(1:kproma,1:klev), wkl(1:kproma,1,1:klev) > 0._wp) - colco2(1:kproma,1:klev) = merge(1.e-20_wp * wkl(1:kproma,2,1:klev), 1.e-32_wp * & - coldry(1:kproma,1:klev), wkl(1:kproma,2,1:klev) > 0._wp) - colo3(1:kproma,1:klev) = merge(1.e-20_wp * wkl(1:kproma,3,1:klev), 1.e-32_wp * & - coldry(1:kproma,1:klev), wkl(1:kproma,3,1:klev) > 0._wp) - coln2o(1:kproma,1:klev) = merge(1.e-20_wp * wkl(1:kproma,4,1:klev), 1.e-32_wp * & - coldry(1:kproma,1:klev), wkl(1:kproma,4,1:klev) > 0._wp) - colch4(1:kproma,1:klev) = merge(1.e-20_wp * wkl(1:kproma,6,1:klev), 1.e-32_wp * & - coldry(1:kproma,1:klev), wkl(1:kproma,6,1:klev) > 0._wp) - colo2(1:kproma,1:klev) = merge(1.e-20_wp * wkl(1:kproma,7,1:klev), 1.e-32_wp * & - coldry(1:kproma,1:klev), wkl(1:kproma,7,1:klev) > 0._wp) - colmol(1:kproma,1:klev) = 1.e-20_wp * coldry(1:kproma,1:klev) + colh2o(1:kproma,1:klev) - ! ------------------------------------------ - ! Interpolation coefficients - ! - forfac(1:kproma,1:klev) = scalefac(1:kproma,1:klev) / (1._wp+water(1:kproma,1:klev)) - ! - ! Set up factors needed to separately include the water vapor - ! self-continuum in the calculation of absorption coefficient. - ! - selffac(1:kproma,1:klev) = water(1:kproma,1:klev) * forfac(1:kproma,1:klev) - ! - ! If the pressure is less than ~100mb, perform a different set of species - ! interpolations. - ! - factor(1:kproma,1:klev) = (332.0_wp-tlay(1:kproma,1:klev))/36.0_wp - indfor(1:kproma,1:klev) = merge(3, min(2, max(1, int(factor(1:kproma,& - 1:klev)))), plog(1:kproma,1:klev) <= 4.56_wp) - forfrac(1:kproma,1:klev) = merge((tlay(1:kproma,1:klev)-188.0_wp)/36.0_wp - 1.0_wp, factor(1:kproma,& - 1:klev) - float(indfor(1:kproma,1:klev)), plog(1:kproma,1:klev) <= 4.56_wp) - ! In RRTMG code, this calculation is done only in the lower atmosphere (plog > 4.56) - ! - factor(1:kproma,1:klev) = (tlay(1:kproma,1:klev)-188.0_wp)/7.2_wp - indself(1:kproma,1:klev) = min(9, max(1, int(factor(1:kproma,1:klev))-7)) - selffrac(1:kproma,1:klev) = factor(1:kproma,1:klev) - float(indself(1:kproma,1:klev) + 7) - END SUBROUTINE srtm_coeffs - END MODULE mo_rrtm_coeffs diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_rrtm_params.f90 b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_rrtm_params.f90 deleted file mode 100644 index fac2c9c41a..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_rrtm_params.f90 +++ /dev/null @@ -1,56 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_rrtm_params.f90 -! Generated at: 2015-02-19 15:30:37 -! KGEN version: 0.4.4 - - - - MODULE mo_rrtm_params - USE mo_kind, ONLY: wp - IMPLICIT NONE - PUBLIC - !! ----------------------------------------------------------------------------------------- - !! - !! Shared parameters - !! - !< number of original g-intervals per spectral band - INTEGER, parameter :: maxxsec= 4 !< maximum number of cross-section molecules (cfcs) - INTEGER, parameter :: maxinpx= 38 - !< number of last band (lw and sw share band 16) - !< number of spectral bands in sw model - !< total number of gpts - !< first band in sw - !< last band in sw - INTEGER, parameter :: nbndlw = 16 !< number of spectral bands in lw model - INTEGER, parameter :: ngptlw = 140 !< total number of reduced g-intervals for rrtmg_lw - ! - ! These pressures are chosen such that the ln of the first pressure - ! has only a few non-zero digits (i.e. ln(PREF(1)) = 6.96000) and - ! each subsequent ln(pressure) differs from the previous one by 0.2. - ! - REAL(KIND=wp), parameter :: preflog(59) = (/ 6.9600e+00_wp, 6.7600e+00_wp, 6.5600e+00_wp, 6.3600e+00_wp, & - 6.1600e+00_wp, 5.9600e+00_wp, 5.7600e+00_wp, 5.5600e+00_wp, 5.3600e+00_wp, 5.1600e+00_wp, 4.9600e+00_wp, & - 4.7600e+00_wp, 4.5600e+00_wp, 4.3600e+00_wp, 4.1600e+00_wp, 3.9600e+00_wp, 3.7600e+00_wp, 3.5600e+00_wp, & - 3.3600e+00_wp, 3.1600e+00_wp, 2.9600e+00_wp, 2.7600e+00_wp, 2.5600e+00_wp, 2.3600e+00_wp, 2.1600e+00_wp, & - 1.9600e+00_wp, 1.7600e+00_wp, 1.5600e+00_wp, 1.3600e+00_wp, 1.1600e+00_wp, 9.6000e-01_wp, 7.6000e-01_wp, & - 5.6000e-01_wp, 3.6000e-01_wp, 1.6000e-01_wp, -4.0000e-02_wp,-2.4000e-01_wp,-4.4000e-01_wp,-6.4000e-01_wp,& - -8.4000e-01_wp, -1.0400e+00_wp,-1.2400e+00_wp,-1.4400e+00_wp,-1.6400e+00_wp,-1.8400e+00_wp, -2.0400e+00_wp,& - -2.2400e+00_wp,-2.4400e+00_wp,-2.6400e+00_wp,-2.8400e+00_wp, -3.0400e+00_wp,-3.2400e+00_wp,-3.4400e+00_wp,& - -3.6400e+00_wp,-3.8400e+00_wp, -4.0400e+00_wp,-4.2400e+00_wp,-4.4400e+00_wp,-4.6400e+00_wp /) - ! - ! These are the temperatures associated with the respective pressures - ! - REAL(KIND=wp), parameter :: tref(59) = (/ 2.9420e+02_wp, 2.8799e+02_wp, 2.7894e+02_wp, 2.6925e+02_wp, & - 2.5983e+02_wp, 2.5017e+02_wp, 2.4077e+02_wp, 2.3179e+02_wp, 2.2306e+02_wp, 2.1578e+02_wp, 2.1570e+02_wp, & - 2.1570e+02_wp, 2.1570e+02_wp, 2.1706e+02_wp, 2.1858e+02_wp, 2.2018e+02_wp, 2.2174e+02_wp, 2.2328e+02_wp, & - 2.2479e+02_wp, 2.2655e+02_wp, 2.2834e+02_wp, 2.3113e+02_wp, 2.3401e+02_wp, 2.3703e+02_wp, 2.4022e+02_wp, & - 2.4371e+02_wp, 2.4726e+02_wp, 2.5085e+02_wp, 2.5457e+02_wp, 2.5832e+02_wp, 2.6216e+02_wp, 2.6606e+02_wp, & - 2.6999e+02_wp, 2.7340e+02_wp, 2.7536e+02_wp, 2.7568e+02_wp, 2.7372e+02_wp, 2.7163e+02_wp, 2.6955e+02_wp, & - 2.6593e+02_wp, 2.6211e+02_wp, 2.5828e+02_wp, 2.5360e+02_wp, 2.4854e+02_wp, 2.4348e+02_wp, 2.3809e+02_wp, & - 2.3206e+02_wp, 2.2603e+02_wp, 2.2000e+02_wp, 2.1435e+02_wp, 2.0887e+02_wp, 2.0340e+02_wp, 1.9792e+02_wp, & - 1.9290e+02_wp, 1.8809e+02_wp, 1.8329e+02_wp, 1.7849e+02_wp, 1.7394e+02_wp, 1.7212e+02_wp /) - - ! read subroutines - END MODULE mo_rrtm_params diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_spec_sampling.f90 b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_spec_sampling.f90 deleted file mode 100644 index 5cdee52320..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_spec_sampling.f90 +++ /dev/null @@ -1,149 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_spec_sampling.f90 -! Generated at: 2015-02-19 15:30:31 -! KGEN version: 0.4.4 - - - - MODULE mo_spec_sampling - USE mo_random_numbers, ONLY: get_random - USE mo_kind, ONLY: wp - IMPLICIT NONE - PRIVATE - ! - ! Team choices - Longwave - ! - ! - ! Team choices - Shortwave - ! - ! - ! Encapsulate the strategy - ! - TYPE spec_sampling_strategy - PRIVATE - INTEGER, dimension(:, :), pointer :: teams => null() - INTEGER :: num_gpts_ts ! How many g points at each time step - LOGICAL :: unique = .false. - END TYPE spec_sampling_strategy - PUBLIC spec_sampling_strategy, get_gpoint_set - - ! read interface - PUBLIC kgen_read_var - interface kgen_read_var - module procedure read_var_integer_4_dim2_pointer - module procedure read_var_spec_sampling_strategy - end interface kgen_read_var - - CONTAINS - subroutine read_var_spec_sampling_strategy(var, kgen_unit) - integer, intent(in) :: kgen_unit - type(spec_sampling_strategy), intent(out) :: var - - call kgen_read_var(var%teams, kgen_unit, .true.) - READ(UNIT=kgen_unit) var%num_gpts_ts - READ(UNIT=kgen_unit) var%unique - end subroutine - - ! read subroutines - subroutine read_var_integer_4_dim2_pointer(var, kgen_unit, is_pointer) - integer, intent(in) :: kgen_unit - logical, intent(in) :: is_pointer - integer(kind=4), intent(out), dimension(:,:), pointer :: var - integer, dimension(2,2) :: kgen_bound - logical is_save - - READ(UNIT = kgen_unit) is_save - if ( is_save ) then - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - end if - end subroutine - ! ----------------------------------------------------------------------------------------------- - !> - !! @brief Sets a spectral sampling strategy - !! - !! @remarks: Choose a set of g-point teams to use. - !! Two end-member choices: - !! strategy = 1 : a single team comprising all g-points, i.e. broadband integration - !! strategy = 2 : ngpts teams of a single g-point each, i.e. a single randomly chosen g-point - !! This can be modified to choose m samples at each time step (with or without replacement, eventually) - !! Other strategies must combine n teams of m gpoints each such that m * n = ngpts - !! strategy 1 (broadband) is the default - !! - ! - - ! ----------------------------------------------------------------------------------------------- - ! ----------------------------------------------------------------------------------------------- - !> - !! @brief Sets a spectral sampling strategy - !! - !! @remarks: Choose a set of g-point teams to use. - !! Two end-member choices: - !! strategy = 1 : a single team comprising all g-points, i.e. broadband integration - !! strategy = 2 : ngpts teams of a single g-point each, i.e. a single randomly chosen g-point - !! This can be modified to choose m samples at each time step (with or without replacement, eventually) - !! Other strategies must combine n teams of m gpoints each such that m * n = ngpts - !! strategy 1 (broadband) is the default - !! - ! - - ! ----------------------------------------------------------------------------------------------- - !> - !! @brief Returns the number of g-points to compute at each time step - !! - - ! ----------------------------------------------------------------------------------------------- - !> - !! @brief Returns one set of g-points consistent with sampling strategy - !! - - FUNCTION get_gpoint_set(kproma, kbdim, strategy, seeds) - INTEGER, intent(in) :: kproma - INTEGER, intent(in) :: kbdim - TYPE(spec_sampling_strategy), intent(in) :: strategy - INTEGER, intent(inout) :: seeds(:,:) ! dimensions kbdim, rng seed_size - INTEGER, dimension(kproma, strategy%num_gpts_ts) :: get_gpoint_set - REAL(KIND=wp) :: rn(kbdim) - INTEGER :: team(kbdim) - INTEGER :: num_teams - INTEGER :: num_gpts_team - INTEGER :: jl - INTEGER :: it - ! -------- - num_teams = size(strategy%teams, 2) - num_gpts_team = size(strategy%teams, 1) - IF (num_teams == 1) THEN - ! - ! Broadband integration - ! - get_gpoint_set(1:kproma,:) = spread(strategy%teams(:, 1), dim = 1, ncopies = kproma) - ELSE IF (num_gpts_team > 1) THEN - ! - ! Mutiple g-points per team, including broadband integration - ! Return just one team - ! - CALL get_random(kproma, kbdim, seeds, rn) - team(1:kproma) = min(int(rn(1:kproma) * num_teams) + 1, num_teams) - DO jl = 1, kproma - get_gpoint_set(jl, :) = strategy%teams(:,team(jl)) - END DO - ELSE - ! - ! MCSI - return one or more individual points chosen randomly - ! Need to add option for sampling without replacement - ! - DO it = 1, strategy%num_gpts_ts - CALL get_random(kproma, kbdim, seeds, rn) - team(1:kproma) = min(int(rn(1:kproma) * num_teams) + 1, num_teams) - get_gpoint_set(1:kproma, it) = strategy%teams(1, team(1:kproma)) - END DO - END IF - END FUNCTION get_gpoint_set - ! ----------------------------------------------------------------------------------------------- - END MODULE mo_spec_sampling diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_taumol03.f90 b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_taumol03.f90 deleted file mode 100644 index a9b71a8913..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_taumol03.f90 +++ /dev/null @@ -1,584 +0,0 @@ -! ====================================================================================================== -! This kernel represents a distillation of *part* of -! the taumol03 calculation in the gas optics part of the PSRAD -! atmospheric -! radiation code. -! -! It is meant to show conceptually how one might "SIMD-ize" swaths of -! the taumol03 code related to calculating the -! taug term, so that the impact of the conditional expression on -! specparm could be reduced and at least partial vectorization -! across columns could be achieved. -! -! I consider it at this point to be "compiling pseudo-code". -! -! By this I mean that the code as written compiles under ifort, but has -! not been tested -! for correctness, nor I have written a driver routine for it. It does -! not contain everything -! that is going on in the taug parent taumol03 code, but I don't claim -! to actually completely -! understand the physical meaning of all or even most of the inputs -! required to make it run. -! -! It has been written to vectorize, but apparently does not actually do -! that -! under the ifort V13 compiler with the -xHost -O3 level of -! optimization, even with !dir$ assume_aligned directives. -! I hypothesize that the compiler is baulking to do so for the indirect -! addressed calls into the absa -! look-up table, either that or 4 byte integers may be causing alignment -! issues relative to 8 byte reals. Anyway, -! it seems to complain about the key loop being too complex. -! ====================================================================================================== -MODULE mo_taumol03 - USE mo_kind, only:wp - USE mo_lrtm_setup, ONLY: nspa - USE mo_lrtm_setup, ONLY: nspb - USE rrlw_planck, ONLY: chi_mls - USE rrlw_kg03, ONLY: selfref - USE rrlw_kg03, ONLY: forref - USE rrlw_kg03, ONLY: ka_mn2o - USE rrlw_kg03, ONLY: absa - USE rrlw_kg03, ONLY: fracrefa - USE rrlw_kg03, ONLY: kb_mn2o - USE rrlw_kg03, ONLY: absb - USE rrlw_kg03, ONLY: fracrefb - IMPLICIT NONE - PRIVATE - PUBLIC taumol03_lwr,taumol03_upr - CONTAINS - SUBROUTINE taumol03_lwr(ncol, startCol, laytrop, nlayers, & - rat_h2oco2, colco2, colh2o, coln2o, coldry, & - fac0, fac1, minorfrac, & - selffac,selffrac,forfac,forfrac, & - jp, jt, ig, indself, & - indfor, indminor, & - taug, fracs) - IMPLICIT NONE - - real(kind=wp), PARAMETER :: oneminus = 1.0_wp - 1.0e-06_wp - integer, intent(in) :: ncol ! number of simd columns - integer, intent(in) :: startCol !starting index column - integer, intent(in) :: laytrop ! number of layers forwer atmosphere kernel - integer, intent(in) :: nlayers ! total number of layers - real(kind=wp), intent(in), dimension(startCol:ncol,0:1,nlayers) :: rat_h2oco2,fac0,fac1 ! not sure of ncol depend - real(kind=wp), intent(in), dimension(startCol:ncol,nlayers) :: colco2,colh2o,coln2o,coldry ! these appear to be gas concentrations - - real(kind=wp), intent(in), dimension(startCol:ncol,nlayers) :: selffac,selffrac ! not sure of ncol depend - real(kind=wp), intent(in), dimension(startCol:ncol,nlayers) :: forfac,forfrac ! not sure of ncol depend - real(kind=wp), intent(in), dimension(startCol:ncol,nlayers) :: minorfrac ! not sure of ncol depend - - ! Look up tables and related lookup indices - ! I assume all lookup indices depend on 3D position - ! ================================================= - - integer, intent(in) :: jp(startCol:ncol,nlayers) ! I assume jp depends on ncol - integer, intent(in) :: jt(startCol:ncol,0:1,nlayers) ! likewise for jt - integer, intent(in) :: ig ! ig indexes into lookup tables - integer, intent(in) :: indself(startCol:ncol,nlayers) ! self index array - integer, intent(in) :: indfor(startCol:ncol,nlayers) ! for index array - integer, intent(in) :: indminor(startCol:ncol,nlayers) ! ka_mn2o index array - real(kind=wp), intent(out), dimension(startCol:ncol,nlayers) :: taug ! kernel result - real(kind=wp), intent(out), dimension(startCol:ncol,nlayers) :: fracs ! kernel result - - ! Local variable - ! ============== - - integer :: lay ! layer index - integer :: i ! specparm types index - integer :: icol ! column index - ! vector temporaries - ! ==================== - - integer, dimension(1:3,1:3) :: caseTypeOperations - integer, dimension(startCol:ncol) :: caseType - real(kind=wp), dimension(startCol:ncol) :: p, p4, fs - real(kind=wp), dimension(startCol:ncol) :: fmn2o,fmn2omf - real(kind=wp), dimension(startCol:ncol) :: fpl - real(kind=wp), dimension(startCol:ncol) :: specmult, speccomb, specparm - real(kind=wp), dimension(startCol:ncol) :: specmult_mn2o, speccomb_mn2o,specparm_mn2o - real(kind=wp), dimension(startCol:ncol) :: specmult_planck, speccomb_planck,specparm_planck - real(kind=wp), dimension(startCol:ncol) :: n2om1,n2om2,absn2o,adjcoln2o,adjfac,chi_n2o,ratn2o - real(kind=wp), dimension(startCol:ncol,0:1) :: tau_major - real(kind=wp), dimension(startCol:ncol) :: taufor,tauself - integer, dimension(startCol:ncol) :: js, ind0, ind00, ind01, ind02, jmn2o, jpl - - ! Register temporaries - ! ==================== - - real(kind=wp) :: p2,fk0,fk1,fk2 - real(kind=wp) :: refrat_planck_a, refrat_planck_b - real(kind=wp) :: refrat_m_a, refrat_m_b - integer :: rrpk_counter=0 - - !dir$ assume_aligned jp:64 - !dir$ assume_aligned jt:64 - !dir$ assume_aligned rat_h2oco2:64 - !dir$ assume_aligned colco2:64 - !dir$ assume_aligned colh2o:64 - !dir$ assume_aligned fac0:64 - !dir$ assume_aligned fac1:64 - !dir$ assume_aligned taug:64 - - !dir$ assume_aligned p:64 - !dir$ assume_aligned p4:64 - !dir$ assume_aligned specmult:64 - !dir$ assume_aligned speccomb:64 - !dir$ assume_aligned specparm:64 - !dir$ assume_aligned specmult_mn2o:64 - !dir$ assume_aligned speccomb_mn2o:64 - !dir$ assume_aligned specparm_mn2o:64 - !dir$ assume_aligned specmult_planck:64 - !dir$ assume_aligned speccomb_planck:64 - !dir$ assume_aligned specparm_planck:64 - !dir$ assume_aligned indself:64 - !dir$ assume_aligned indfor:64 - !dir$ assume_aligned indminor:64 - !dir$ assume_aligned fs:64 - !dir$ assume_aligned tau_major:64 - - !dir$ assume_aligned js:64 - !dir$ assume_aligned ind0:64 - !dir$ assume_aligned ind00:64 - !dir$ assume_aligned ind01:64 - !dir$ assume_aligned ind02:64 - - !dir$ assume_aligned caseTypeOperations:64 - !dir$ assume_aligned caseType:64 - - ! Initialize Case type operations - !================================= - - caseTypeOperations(1:3,1) = (/0, 1, 2/) - caseTypeOperations(1:3,2) = (/1, 0,-1/) - caseTypeOperations(1:3,3) = (/0, 1, 1/) - - ! Minor gas mapping levels: - ! lower - n2o, p = 706.272 mbar, t = 278.94 k - ! upper - n2o, p = 95.58 mbar, t = 215.7 k - - ! P = 212.725 mb - refrat_planck_a = chi_mls(1,9)/chi_mls(2,9) - - ! P = 95.58 mb - refrat_planck_b = chi_mls(1,13)/chi_mls(2,13) - - ! P = 706.270mb - refrat_m_a = chi_mls(1,3)/chi_mls(2,3) - - ! P = 95.58 mb - refrat_m_b = chi_mls(1,13)/chi_mls(2,13) - - ! Lower atmosphere loop - ! ===================== - - DO lay = 1,laytrop ! loop over layers - - ! Compute tau_major term - ! ====================== - - DO i=0,1 ! loop over specparm types - - ! This loop should vectorize - ! ============================= - !dir$ SIMD - DO icol=startCol,ncol ! Vectorizes with dir - 14.0.2 - speccomb(icol) = colh2o(icol,lay) + rat_h2oco2(icol,i,lay)*colco2(icol,lay) - specparm(icol) = colh2o(icol,lay)/speccomb(icol) - IF (specparm(icol) .GE. oneminus) specparm(icol) = oneminus - specmult(icol) = 8._wp*(specparm(icol)) - js(icol) = 1 + INT(specmult(icol)) - fs(icol) = MOD(specmult(icol),1.0_wp) - END DO - - ! The only conditional loop - ! ========================= - - DO icol=startCol,ncol ! Vectorizes as is 14.0.2 - IF (specparm(icol) .LT. 0.125_wp) THEN - caseType(icol)=1 - p(icol) = fs(icol) - 1.0_wp - p2 = p(icol)*p(icol) - p4(icol) = p2*p2 - ELSE IF (specparm(icol) .GT. 0.875_wp) THEN - caseType(icol)=2 - p(icol) = -fs(icol) - p2 = p(icol)*p(icol) - p4(icol) = p2*p2 - ELSE - caseType(icol)=3 - ! SIMD way of writing fk0= 1-fs and fk1 = fs, fk2=zero - ! =========================================================== - - p4(icol) = 1.0_wp - fs(icol) - p(icol) = -p4(icol) ! complicated way of getting fk2 = zero for ELSE case - ENDIF - END DO - - ! Vector/SIMD index loop calculation - ! ================================== - - !dir$ SIMD - DO icol=startCol,ncol ! Vectorizes with dir 14.0.2 - ind0(icol) = ((jp(icol,lay)-(1*MOD(i+1,2)))*5+(jt(icol,i,lay)-1))*nspa(3) +js(icol) - ind00(icol) = ind0(icol) + caseTypeOperations(1,caseType(icol)) - ind01(icol) = ind0(icol) + caseTypeOperations(2,caseType(icol)) - ind02(icol) = ind0(icol) + caseTypeOperations(3,caseType(icol)) - END DO - - ! What we've been aiming for a nice flop intensive - ! SIMD/vectorizable loop! - ! 17 flops - ! - ! Albeit at the cost of a couple extra flops for the fk2 term - ! and a repeated lookup table access for the fk2 term in the - ! the ELSE case when specparm or specparm1 is (> .125 && < .875) - ! =============================================================== - - !dir$ SIMD - DO icol=startCol,ncol ! Vectorizes with dir 14.0.2 - - fk0 = p4(icol) - fk1 = 1.0_wp - p(icol) - 2.0_wp*p4(icol) - fk2 = p(icol) + p4(icol) - tau_major(icol,i) = speccomb(icol) * ( & - fac0(icol,i,lay)*(fk0*absa(ind00(icol),ig) + & - fk1*absa(ind01(icol),ig) + & - fk2*absa(ind02(icol),ig)) + & - fac1(icol,i,lay)*(fk0*absa(ind00(icol)+9,ig) + & - fk1*absa(ind01(icol)+9,ig) + & - fk2*absa(ind02(icol)+9,ig))) - END DO - - END DO ! end loop over specparm types for tau_major calculation - - ! Compute taufor and tauself terms: - ! Note the use of 1D bilinear interpolation of selfref and forref - ! lookup table values - ! =================================================================================== - - !dir$ SIMD - DO icol=startCol,ncol ! Vectorizes with dir 14.0.2 - tauself(icol) = selffac(icol,lay)*(selfref(indself(icol,lay),ig) +& - selffrac(icol,lay)*(selfref(indself(icol,lay)+1,ig)- selfref(indself(icol,lay),ig))) - taufor(icol) = forfac(icol,lay)*( forref(indfor(icol,lay),ig) +& - forfrac(icol,lay)*( forref(indfor(icol,lay)+1,ig) -forref(indfor(icol,lay),ig))) - END DO - - ! Compute absn2o term: - ! Note the use of 2D bilinear interpolation ka_mn2o lookup table - ! values - ! ===================================================================== - - !dir$ SIMD - DO icol=startCol,ncol !vectorizes with dir 14.0.2 - speccomb_mn2o(icol) = colh2o(icol,lay) +refrat_m_a*colco2(icol,lay) - specparm_mn2o(icol) = colh2o(icol,lay)/speccomb_mn2o(icol) - END DO - - do icol=startCol,ncol ! vectorizes as is 14.0.2 - IF (specparm_mn2o(icol) .GE. oneminus) specparm_mn2o(icol) =oneminus - end do - - !dir$ SIMD ! vectorizes with dir 14.0.2 - DO icol=startCol,ncol - specmult_mn2o(icol) = 8.0_wp*specparm_mn2o(icol) - jmn2o(icol) = 1 + INT(specmult_mn2o(icol)) - fmn2o(icol) = MOD(specmult_mn2o(icol),1.0_wp) - fmn2omf(icol) = minorfrac(icol,lay)*fmn2o(icol) - END DO - - ! - ! 2D bilinear interpolation - ! ========================= - - !dir$ SIMD - do icol=startCol,ncol ! vectorizes with dir 14.0.2 - n2om1(icol) = ka_mn2o(jmn2o(icol),indminor(icol,lay) ,ig) + & - fmn2o(icol)*(ka_mn2o(jmn2o(icol)+1,indminor(icol,lay),ig) - & - ka_mn2o(jmn2o(icol),indminor(icol,lay) ,ig)) - n2om2(icol) = ka_mn2o(jmn2o(icol),indminor(icol,lay)+1,ig) + & - fmn2o(icol)*(ka_mn2o(jmn2o(icol)+1,indminor(icol,lay)+1,ig)- & - ka_mn2o(jmn2o(icol),indminor(icol,lay)+1,ig)) - absn2o(icol) = n2om1(icol) + minorfrac(icol,lay)*(n2om2(icol) -n2om1(icol)) - end do - - ! In atmospheres where the amount of N2O is too great to be - ! considered - ! a minor species, adjust the column amount of N2O by an empirical - ! factor - ! to obtain the proper contribution. - ! ======================================================================== - - !dir$ SIMD - do icol=startCol,ncol ! vectorized with dir 14.0.2 - chi_n2o(icol) = coln2o(icol,lay)/coldry(icol,lay) - ratn2o(icol) = 1.e20*chi_n2o(icol)/chi_mls(4,jp(icol,lay)+1) - end do - - do icol=startCol,ncol ! vectorizes as is 14.0.2 - IF (ratn2o(icol) .GT. 1.5_wp) THEN - adjfac(icol) = 0.5_wp+(ratn2o(icol)-0.5_wp)**0.65_wp - adjcoln2o(icol) =adjfac(icol)*chi_mls(4,jp(icol,lay)+1)*coldry(icol,lay)*1.e-20_wp - ELSE - adjcoln2o(icol) = coln2o(icol,lay) - ENDIF - end do - - ! Compute taug, one of two terms returned by the lower atmosphere - ! kernel (the other is fracs) - ! This loop could be parallelized over specparm types (i) but might - ! produce - ! different results for different thread counts - ! =========================================================================================== - - !dir$ SIMD ! DOES NOT VECTORIZE even with SIMD dir 14.0.2 - DO icol=startCol,ncol - taug(icol,lay) = tau_major(icol,0) + tau_major(icol,1) +tauself(icol) + taufor(icol) + adjcoln2o(icol)*absn2o(icol) - END DO - - !dir$ SIMD ! vectorizes with dir 14.0.2 - DO icol=startCol,ncol - speccomb_planck(icol) = colh2o(icol,lay)+refrat_planck_a*colco2(icol,lay) - specparm_planck(icol) = colh2o(icol,lay)/speccomb_planck(icol) - END DO - - DO icol=startCol,ncol ! vectorizes as is 14.0.2 - IF (specparm_planck(icol) .GE. oneminus) specparm_planck(icol)=oneminus - END DO - - !dir$ SIMD - DO icol=startCol,ncol !vectorizes with dir 14.0.2 - specmult_planck(icol) = 8.0_wp*specparm_planck(icol) - jpl(icol)= 1 + INT(specmult_planck(icol)) - fpl(icol) = MOD(specmult_planck(icol),1.0_wp) - fracs(icol,lay) = fracrefa(ig,jpl(icol)) + fpl(icol)*(fracrefa(ig,jpl(icol)+1)-fracrefa(ig,jpl(icol))) - END DO - rrpk_counter=rrpk_counter+1 - END DO ! end lower atmosphere loop - END SUBROUTINE taumol03_lwr - - - SUBROUTINE taumol03_upr(ncol, startCol, laytrop, nlayers, & - rat_h2oco2, colco2, colh2o, coln2o, coldry, & - fac0, fac1, minorfrac, & - forfac,forfrac, & - jp, jt, ig, & - indfor, indminor, & - taug, fracs) - - use mo_kind, only : wp - USE mo_lrtm_setup, ONLY: nspa - USE mo_lrtm_setup, ONLY: nspb - USE rrlw_planck, ONLY: chi_mls - USE rrlw_kg03, ONLY: selfref - USE rrlw_kg03, ONLY: forref - USE rrlw_kg03, ONLY: ka_mn2o - USE rrlw_kg03, ONLY: absa - USE rrlw_kg03, ONLY: fracrefa - USE rrlw_kg03, ONLY: kb_mn2o - USE rrlw_kg03, ONLY: absb - USE rrlw_kg03, ONLY: fracrefb - - IMPLICIT NONE - - real(kind=wp), PARAMETER :: oneminus = 1.0_wp - 1.0e-06_wp - - integer, intent(in) :: ncol ! number of simd columns - integer, intent(in) :: startCol ! starting index for iterations in order to support parallelization across architectures - integer, intent(in) :: laytrop ! number of layers for lower atmosphere kernel - integer, intent(in) :: nlayers ! total number of layers - real(kind=wp), intent(in), dimension(startCol:ncol,0:1,nlayers) :: rat_h2oco2,fac0,fac1 ! not sure of ncol depend - real(kind=wp), intent(in), dimension(startCol:ncol,nlayers) :: colco2,colh2o,coln2o,coldry ! these appear to be gas concentrations - real(kind=wp), intent(in), dimension(startCol:ncol,nlayers) :: forfac,forfrac ! not sure of ncol depend - real(kind=wp), intent(in), dimension(startCol:ncol,nlayers) :: minorfrac ! not sure of ncol depend - - ! Look up tables and related lookup indices - ! I assume all lookup indices depend on 3D position - ! ================================================= - - integer, intent(in) :: jp(startCol:ncol,nlayers) ! I assume jp depends on ncol - integer, intent(in) :: jt(startCol:ncol,0:1,nlayers) ! likewise for jt - integer, intent(in) :: ig ! ig indexes into lookup tables - integer, intent(in) :: indfor(startCol:ncol,nlayers) ! for index array - integer, intent(in) :: indminor(startCol:ncol,nlayers) ! ka_mn2o index array - real(kind=wp), intent(out), dimension(startCol:ncol,nlayers) :: taug ! kernel result - real(kind=wp), intent(out), dimension(startCol:ncol,nlayers) :: fracs ! kernel result - - ! Local variable - ! ============== - - integer :: lay ! layer index - integer :: i ! specparm types index - integer :: icol ! column index - - ! vector temporaries - ! ==================== - - real(kind=wp), dimension(startCol:ncol) :: fs - real(kind=wp), dimension(startCol:ncol) :: fmn2o,fmn2omf - real(kind=wp), dimension(startCol:ncol) :: fpl - real(kind=wp), dimension(startCol:ncol) :: specmult, speccomb, specparm - real(kind=wp), dimension(startCol:ncol) :: specmult_mn2o, speccomb_mn2o, specparm_mn2o - real(kind=wp), dimension(startCol:ncol) :: specmult_planck, speccomb_planck,specparm_planck - real(kind=wp), dimension(startCol:ncol) :: n2om1,n2om2,absn2o,adjcoln2o,adjfac,chi_n2o,ratn2o - real(kind=wp), dimension(startCol:ncol,0:1) :: tau_major - real(kind=wp), dimension(startCol:ncol) :: taufor,tauself - integer, dimension(startCol:ncol) :: js, ind0, jmn2o, jpl - - ! Register temporaries - ! ==================== - - real(kind=wp) :: p2,fk0,fk1,fk2 - real(kind=wp) :: refrat_planck_a, refrat_planck_b - real(kind=wp) :: refrat_m_a, refrat_m_b - - !dir$ assume_aligned jp:64 - !dir$ assume_aligned jt:64 - !dir$ assume_aligned rat_h2oco2:64 - !dir$ assume_aligned colco2:64 - !dir$ assume_aligned colh2o:64 - !dir$ assume_aligned fac0:64 - !dir$ assume_aligned fac1:64 - !dir$ assume_aligned taug:64 - - !dir$ assume_aligned specmult:64 - !dir$ assume_aligned speccomb:64 - !dir$ assume_aligned specparm:64 - !dir$ assume_aligned specmult_mn2o:64 - !dir$ assume_aligned speccomb_mn2o:64 - !dir$ assume_aligned specparm_mn2o:64 - !dir$ assume_aligned specmult_planck:64 - !dir$ assume_aligned speccomb_planck:64 - !dir$ assume_aligned specparm_planck:64 - !dir$ assume_aligned fs:64 - !dir$ assume_aligned tau_major:64 - !dir$ assume_aligned chi_n2o:64 - - !dir$ assume_aligned js:64 - !dir$ assume_aligned ind0:64 - !dir$ assume_aligned jpl:64 - !dir$ assume_aligned fpl:64 - - !dir$ assume_aligned absn2o:64 - !dir$ assume_aligned adjcoln2o:64 - !dir$ assume_aligned adjfac:64 - !dir$ assume_aligned ratn2o:64 - - ! Upper atmosphere loop - ! ======================== - refrat_planck_b = chi_mls(1,13)/chi_mls(2,13) - refrat_m_b = chi_mls(1,13)/chi_mls(2,13) - DO lay = laytrop+1, nlayers - - DO i=0,1 ! loop over specparm types - - ! This loop should vectorize - ! ============================= - - !dir$ SIMD - DO icol=startCol,ncol ! Vectorizes with dir 14.0.2 - speccomb(icol) = colh2o(icol,lay) + rat_h2oco2(icol,i,lay)*colco2(icol,lay) - specparm(icol) = colh2o(icol,lay)/speccomb(icol) - IF (specparm(icol) .ge. oneminus) specparm(icol) = oneminus - specmult(icol) = 4.0_wp*(specparm(icol)) - js(icol) = 1 + INT(specmult(icol)) - fs(icol) = MOD(specmult(icol),1.0_wp) - ind0(icol) = ((jp(icol,lay)-13+i)*5+(jt(icol,i,lay)-1))*nspb(3) +js(icol) - END DO - - !dir$ SIMD - DO icol=startCol,ncol ! Vectorizes with dir 14.0.2 - tau_major(icol,i) = speccomb(icol) * & - ((1.0_wp - fs(icol))*fac0(icol,i,lay)*absb(ind0(icol) ,ig) + & - fs(icol) *fac0(icol,i,lay)*absb(ind0(icol)+1,ig) + & - (1.0_wp - fs(icol))*fac1(icol,i,lay)*absb(ind0(icol)+5,ig) + & - fs(icol) *fac1(icol,i,lay)*absb(ind0(icol)+6,ig)) - END DO - - END DO ! end loop over specparm types for tau_major calculation - - ! Compute taufor terms - ! Note the use of 1D bilinear interpolation of selfref and forref lookup - ! table values - ! =================================================================================== - !dir$ SIMD - DO icol=startCol,ncol ! Vectorizes with dir 14.0.2 - taufor(icol) = forfac(icol,lay)*( forref(indfor(icol,lay),ig) + & - forfrac(icol,lay)*( forref(indfor(icol,lay)+1,ig) - forref(indfor(icol,lay),ig))) - END DO - - ! Compute absn2o term: - ! Note the use of 2D bilinear interpolation ka_mn2o lookup table values - ! ===================================================================== - !$DIR SIMD - DO icol=startCol,ncol ! Vectorizes with dir 14.0.2 - speccomb_mn2o(icol) = colh2o(icol,lay) + refrat_m_b*colco2(icol,lay) - specparm_mn2o(icol) = colh2o(icol,lay)/speccomb_mn2o(icol) - IF (specparm_mn2o(icol) .GE. oneminus) specparm_mn2o(icol) = oneminus - specmult_mn2o(icol) = 4.0_wp*specparm_mn2o(icol) - jmn2o(icol) = 1 + INT(specmult_mn2o(icol)) - fmn2o(icol) = MOD(specmult_mn2o(icol),1.0_wp) - fmn2omf(icol) = minorfrac(icol,lay)*fmn2o(icol) - END DO - - ! In atmospheres where the amount of N2O is too great to be considered - ! a minor species, adjust the column amount of N2O by an empirical factor - ! to obtain the proper contribution. - ! ======================================================================== - - !dir$ SIMD - DO icol=startCol,ncol ! loop vectorized with directive 14.0.2 - chi_n2o(icol) = coln2o(icol,lay)/coldry(icol,lay) - ratn2o(icol) = 1.e20*chi_n2o(icol)/chi_mls(4,jp(icol,lay)+1) - END DO - - DO icol=startCol,ncol ! Loop vectorized as is 14.0.2 - IF (ratn2o(icol) .GT. 1.5_wp) THEN - adjfac(icol) = 0.5_wp+(ratn2o(icol)-0.5_wp)**0.65_wp - adjcoln2o(icol) = adjfac(icol)*chi_mls(4,jp(icol,lay)+1)*coldry(icol,lay)*1.e-20_wp - ELSE - adjcoln2o(icol) = coln2o(icol,lay) - ENDIF - END DO - - ! - ! 2D bilinear interpolation - ! ========================= - - !dir$ SIMD - DO icol=startCol,ncol ! loop vectorizes with directive 14.0.2 - n2om1(icol) = kb_mn2o(jmn2o(icol),indminor(icol,lay) ,ig) + & - fmn2o(icol)*(kb_mn2o(jmn2o(icol)+1,indminor(icol,lay),ig) - & - kb_mn2o(jmn2o(icol) ,indminor(icol,lay) ,ig)) - n2om2(icol) = kb_mn2o(jmn2o(icol),indminor(icol,lay)+1,ig) + & - fmn2o(icol)*(kb_mn2o(jmn2o(icol)+1,indminor(icol,lay)+1,ig)- & - kb_mn2o(jmn2o(icol),indminor(icol,lay)+1,ig)) - absn2o(icol) = n2om1(icol) + minorfrac(icol,lay)*(n2om2(icol) -n2om1(icol)) - END DO - - !dir$ SIMD - DO icol=startCol,ncol ! loop vectorizes with directive 14.0.2 - taug(icol,lay) = tau_major(icol,0) + tau_major(icol,1) + taufor(icol) + adjcoln2o(icol)*absn2o(icol) - END DO - - !dir$ SIMD - DO icol=startCol,ncol ! loop vectorizes with directive 14.0.2 - speccomb_planck(icol) = colh2o(icol,lay)+refrat_planck_b*colco2(icol,lay) - specparm_planck(icol) = colh2o(icol,lay)/speccomb_planck(icol) - END DO - - !dir$ SIMD - DO icol=startCol,ncol ! loop vectorizes with directive 14.0.2 - IF (specparm_planck(icol) .GE. oneminus) specparm_planck(icol)=oneminus - specmult_planck(icol) = 4.0_wp*specparm_planck(icol) - jpl(icol)= 1 + INT(specmult_planck(icol)) - fpl(icol) = MOD(specmult_planck(icol),1.0_wp) - fracs(icol,lay) = fracrefb(ig,jpl(icol)) + fpl(icol)*(fracrefb(ig,jpl(icol)+1)-fracrefb(ig,jpl(icol))) - END DO - END DO ! nlayers loop - - END SUBROUTINE taumol03_upr - -END MODULE mo_taumol03 diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_taumol04.f90 b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_taumol04.f90 deleted file mode 100644 index e250361db9..0000000000 --- a/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_taumol04.f90 +++ /dev/null @@ -1,435 +0,0 @@ -! ====================================================================================================== -! This kernel represents a distillation of *part* of -! the taumol04 calculation in the gas optics part of the PSRAD -! atmospheric -! radiation code. -! -! It is meant to show conceptually how one might "SIMD-ize" swaths of -! the taumol04 code related to calculating the -! taug term, so that the impact of the conditional expression on -! specparm could be reduced and at least partial vectorization -! across columns could be achieved. -! -! I consider it at this point to be "compiling pseudo-code". -! -! By this I mean that the code as written compiles under ifort, but has -! not been tested -! for correctness, nor I have written a driver routine for it. It does -! not contain everything -! that is going on in the taug parent taumol04 code, but I don't claim -! to actually completely -! understand the physical meaning of all or even most of the inputs -! required to make it run. -! -! It has been written to vectorize, but apparently does not actually do -! that -! under the ifort V13 compiler with the -xHost -O3 level of -! optimization, even with !dir$ assume_aligned directives. -! I hypothesize that the compiler is baulking to do so for the indirect -! addressed calls into the absa -! look-up table, either that or 4 byte integers may be causing alignment -! issues relative to 8 byte reals. Anyway, -! it seems to complain about the key loop being too complex. -! ====================================================================================================== -MODULE mo_taumol04 - USE mo_kind, only:wp - USE mo_lrtm_setup, ONLY: nspa - USE mo_lrtm_setup, ONLY: nspb - USE mo_lrtm_setup, ONLY: ngc - USE rrlw_planck, ONLY: chi_mls - USE rrlw_kg04, ONLY: selfref - USE rrlw_kg04, ONLY: forref - USE rrlw_kg04, ONLY: absa - USE rrlw_kg04, ONLY: fracrefa - USE rrlw_kg04, ONLY: absb - USE rrlw_kg04, ONLY: fracrefb - IMPLICIT NONE - PRIVATE - PUBLIC taumol04_lwr,taumol04_upr - CONTAINS - SUBROUTINE taumol04_lwr(ncol, laytrop, nlayers, & - rat_h2oco2, colco2, colh2o, coldry, & - fac0, fac1, minorfrac, & - selffac,selffrac,forfac,forfrac, & - jp, jt, ig, indself, & - indfor, & - taug, fracs) - IMPLICIT NONE - - real(kind=wp), PARAMETER :: oneminus = 1.0_wp - 1.0e-06_wp - integer, intent(in) :: ncol ! number of simd columns - integer, intent(in) :: laytrop ! number of layers forwer atmosphere kernel - integer, intent(in) :: nlayers ! total number of layers - real(kind=wp), intent(in), dimension(ncol,0:1,nlayers) :: rat_h2oco2,fac0,fac1 ! not sure of ncol depend - real(kind=wp), intent(in), dimension(ncol,nlayers) :: colco2,colh2o,coldry ! these appear to be gas concentrations - - real(kind=wp), intent(in), dimension(ncol,nlayers) :: selffac,selffrac ! not sure of ncol depend - real(kind=wp), intent(in), dimension(ncol,nlayers) :: forfac,forfrac ! not sure of ncol depend - real(kind=wp), intent(in), dimension(ncol,nlayers) :: minorfrac ! not sure of ncol depend - - ! Look up tables and related lookup indices - ! I assume all lookup indices depend on 3D position - ! ================================================= - - integer, intent(in) :: jp(ncol,nlayers) ! I assume jp depends on ncol - integer, intent(in) :: jt(ncol,0:1,nlayers) ! likewise for jt - integer, intent(in) :: ig ! ig indexes into lookup tables - integer, intent(in) :: indself(ncol,nlayers) ! self index array - integer, intent(in) :: indfor(ncol,nlayers) ! for index array - real(kind=wp), intent(out), dimension(ncol,nlayers) :: taug ! kernel result - real(kind=wp), intent(out), dimension(ncol,nlayers) :: fracs ! kernel result - - ! Local variable - ! ============== - - integer :: lay ! layer index - integer :: i ! specparm types index - integer :: icol ! column index - - ! vector temporaries - ! ==================== - - integer, dimension(1:3,1:3) :: caseTypeOperations - integer, dimension(ncol) :: caseType - real(kind=wp), dimension(ncol) :: p, p4, fs - real(kind=wp), dimension(ncol) :: fpl - real(kind=wp), dimension(ncol) :: specmult, speccomb, specparm - real(kind=wp), dimension(ncol) :: specmult_planck, speccomb_planck,specparm_planck - real(kind=wp), dimension(ncol,0:1) :: tau_major - real(kind=wp), dimension(ncol) :: taufor,tauself - integer, dimension(ncol) :: js, ind0, ind00, ind01, ind02, jpl - - ! Register temporaries - ! ==================== - - real(kind=wp) :: p2,fk0,fk1,fk2 - real(kind=wp) :: refrat_planck_a, refrat_planck_b - - !dir$ assume_aligned jp:64 - !dir$ assume_aligned jt:64 - !dir$ assume_aligned rat_h2oco2:64 - !dir$ assume_aligned colco2:64 - !dir$ assume_aligned colh2o:64 - !dir$ assume_aligned fac0:64 - !dir$ assume_aligned fac1:64 - !dir$ assume_aligned taug:64 - - !dir$ assume_aligned p:64 - !dir$ assume_aligned p4:64 - !dir$ assume_aligned specmult:64 - !dir$ assume_aligned speccomb:64 - !dir$ assume_aligned specparm:64 - !dir$ assume_aligned specmult_planck:64 - !dir$ assume_aligned speccomb_planck:64 - !dir$ assume_aligned specparm_planck:64 - !dir$ assume_aligned indself:64 - !dir$ assume_aligned indfor:64 - !dir$ assume_aligned fs:64 - !dir$ assume_aligned tau_major:64 - - !dir$ assume_aligned js:64 - !dir$ assume_aligned ind0:64 - !dir$ assume_aligned ind00:64 - !dir$ assume_aligned ind01:64 - !dir$ assume_aligned ind02:64 - - !dir$ assume_aligned caseTypeOperations:64 - !dir$ assume_aligned caseType:64 - - ! Initialize Case type operations - !================================= - - caseTypeOperations(1:3,1) = (/0, 1, 2/) - caseTypeOperations(1:3,2) = (/1, 0,-1/) - caseTypeOperations(1:3,3) = (/0, 1, 1/) - - ! Minor gas mapping levels: - ! lower - n2o, p = 706.272 mbar, t = 278.94 k - ! upper - n2o, p = 95.58 mbar, t = 215.7 k - - ! P = 212.725 mb - refrat_planck_a = chi_mls(1,11)/chi_mls(2,11) - - ! P = 95.58 mb - refrat_planck_b = chi_mls(3,13)/chi_mls(2,13) - - - ! Lower atmosphere loop - ! ===================== - - DO lay = 1,laytrop ! loop over layers - - ! Compute tau_major term - ! ====================== - - DO i=0,1 ! loop over specparm types - - ! This loop should vectorize - ! ============================= - !dir$ SIMD - DO icol=1,ncol ! Vectorizes with dir - 14.0.2 - speccomb(icol) = colh2o(icol,lay) + rat_h2oco2(icol,i,lay)*colco2(icol,lay) - specparm(icol) = colh2o(icol,lay)/speccomb(icol) - IF (specparm(icol) .GE. oneminus) specparm(icol) = oneminus - specmult(icol) = 8._wp*(specparm(icol)) - js(icol) = 1 + INT(specmult(icol)) - fs(icol) = MOD(specmult(icol),1.0_wp) - END DO - - ! The only conditional loop - ! ========================= - - DO icol=1,ncol ! Vectorizes as is 14.0.2 - IF (specparm(icol) .LT. 0.125_wp) THEN - caseType(icol)=1 - p(icol) = fs(icol) - 1.0_wp - p2 = p(icol)*p(icol) - p4(icol) = p2*p2 - ELSE IF (specparm(icol) .GT. 0.875_wp) THEN - caseType(icol)=2 - p(icol) = -fs(icol) - p2 = p(icol)*p(icol) - p4(icol) = p2*p2 - ELSE - caseType(icol)=3 - ! SIMD way of writing fk0= 1-fs and fk1 = fs, fk2=zero - ! =========================================================== - - p4(icol) = 1.0_wp - fs(icol) - p(icol) = -p4(icol) ! complicated way of getting fk2 = zero for ELSE case - ENDIF - END DO - - ! Vector/SIMD index loop calculation - ! ================================== - - !dir$ SIMD - DO icol=1,ncol ! Vectorizes with dir 14.0.2 - ind0(icol) = ((jp(icol,lay)-(1*MOD(i+1,2)))*5+(jt(icol,i,lay)-1))*nspa(4) +js(icol) - ind00(icol) = ind0(icol) + caseTypeOperations(1,caseType(icol)) - ind01(icol) = ind0(icol) + caseTypeOperations(2,caseType(icol)) - ind02(icol) = ind0(icol) + caseTypeOperations(3,caseType(icol)) - END DO - - ! What we've been aiming for a nice flop intensive - ! SIMD/vectorizable loop! - ! 17 flops - ! - ! Albeit at the cost of a couple extra flops for the fk2 term - ! and a repeated lookup table access for the fk2 term in the - ! the ELSE case when specparm or specparm1 is (> .125 && < .875) - ! =============================================================== - - !dir$ SIMD - DO icol=1,ncol ! Vectorizes with dir 14.0.2 - - fk0 = p4(icol) - fk1 = 1.0_wp - p(icol) - 2.0_wp*p4(icol) - fk2 = p(icol) + p4(icol) - tau_major(icol,i) = speccomb(icol) * ( & - fac0(icol,i,lay)*(fk0*absa(ind00(icol),ig) + & - fk1*absa(ind01(icol),ig) + & - fk2*absa(ind02(icol),ig)) + & - fac1(icol,i,lay)*(fk0*absa(ind00(icol)+9,ig) + & - fk1*absa(ind01(icol)+9,ig) + & - fk2*absa(ind02(icol)+9,ig))) - END DO - - END DO ! end loop over specparm types for tau_major calculation - - ! Compute taufor and tauself terms: - ! Note the use of 1D bilinear interpolation of selfref and forref - ! lookup table values - ! =================================================================================== - - !dir$ SIMD - DO icol=1,ncol ! Vectorizes with dir 14.0.2 - tauself(icol) = selffac(icol,lay)*(selfref(indself(icol,lay),ig) +& - selffrac(icol,lay)*(selfref(indself(icol,lay)+1,ig)- selfref(indself(icol,lay),ig))) - taufor(icol) = forfac(icol,lay)*( forref(indfor(icol,lay),ig) +& - forfrac(icol,lay)*( forref(indfor(icol,lay)+1,ig) -forref(indfor(icol,lay),ig))) - END DO - - ! Compute taug, one of two terms returned by the lower atmosphere - ! kernel (the other is fracs) - ! This loop could be parallelized over specparm types (i) but might - ! produce - ! different results for different thread counts - ! =========================================================================================== - - !dir$ SIMD ! DOES NOT VECTORIZE even with SIMD dir 14.0.2 - DO icol=1,ncol - taug(icol,lay) = tau_major(icol,0) + tau_major(icol,1) +tauself(icol) + taufor(icol) - END DO - - !dir$ SIMD ! vectorizes with dir 14.0.2 - DO icol=1,ncol - speccomb_planck(icol) = colh2o(icol,lay)+refrat_planck_a*colco2(icol,lay) - specparm_planck(icol) = colh2o(icol,lay)/speccomb_planck(icol) - END DO - - DO icol=1,ncol ! vectorizes as is 14.0.2 - IF (specparm_planck(icol) .GE. oneminus) specparm_planck(icol)=oneminus - END DO - - !dir$ SIMD - DO icol=1,ncol !vectorizes with dir 14.0.2 - specmult_planck(icol) = 8.0_wp*specparm_planck(icol) - jpl(icol)= 1 + INT(specmult_planck(icol)) - fpl(icol) = MOD(specmult_planck(icol),1.0_wp) - fracs(icol,lay) = fracrefa(ig,jpl(icol)) + fpl(icol)*(fracrefa(ig,jpl(icol)+1)-fracrefa(ig,jpl(icol))) - END DO - END DO ! end lower atmosphere loop - END SUBROUTINE taumol04_lwr - - - SUBROUTINE taumol04_upr(ncol, laytrop, nlayers, & - rat_o3co2, colco2, colo3, coldry, & - fac0, fac1, minorfrac, & - forfac,forfrac, & - jp, jt, ig, & - indfor, & - taug, fracs) - - use mo_kind, only : wp - USE mo_lrtm_setup, ONLY: nspa - USE mo_lrtm_setup, ONLY: nspb - USE rrlw_planck, ONLY: chi_mls - USE rrlw_kg04, ONLY: selfref - USE rrlw_kg04, ONLY: forref - USE rrlw_kg04, ONLY: absb - USE rrlw_kg04, ONLY: fracrefb - - IMPLICIT NONE - - real(kind=wp), PARAMETER :: oneminus = 1.0_wp - 1.0e-06_wp - - integer, intent(in) :: ncol ! number of simd columns - integer, intent(in) :: laytrop ! number of layers for lower atmosphere kernel - integer, intent(in) :: nlayers ! total number of layers - real(kind=wp), intent(in), dimension(ncol,0:1,nlayers) :: rat_o3co2,fac0,fac1 ! not sure of ncol depend - real(kind=wp), intent(in), dimension(ncol,nlayers) :: colco2,colo3,coldry ! these appear to be gas concentrations - real(kind=wp), intent(in), dimension(ncol,nlayers) :: forfac,forfrac ! not sure of ncol depend - real(kind=wp), intent(in), dimension(ncol,nlayers) :: minorfrac ! not sure of ncol depend - - ! Look up tables and related lookup indices - ! I assume all lookup indices depend on 3D position - ! ================================================= - - integer, intent(in) :: jp(ncol,nlayers) ! I assume jp depends on ncol - integer, intent(in) :: jt(ncol,0:1,nlayers) ! likewise for jt - integer, intent(in) :: ig ! ig indexes into lookup tables - integer, intent(in) :: indfor(ncol,nlayers) ! for index array - real(kind=wp), intent(out), dimension(ncol,nlayers) :: taug ! kernel result - real(kind=wp), intent(out), dimension(ncol,nlayers) :: fracs ! kernel result - - ! Local variable - ! ============== - - integer :: lay ! layer index - integer :: i ! specparm types index - integer :: icol ! column index - - ! vector temporaries - ! ==================== - - real(kind=wp), dimension(ncol) :: fs - real(kind=wp), dimension(ncol) :: fpl - real(kind=wp), dimension(ncol) :: specmult, speccomb, specparm - real(kind=wp), dimension(ncol) :: specmult_planck, speccomb_planck,specparm_planck - real(kind=wp), dimension(ncol,0:1) :: tau_major - real(kind=wp), dimension(ncol) :: taufor,tauself - integer, dimension(ncol) :: js, ind0, jpl - - ! Register temporaries - ! ==================== - - real(kind=wp) :: p2,fk0,fk1,fk2 - real(kind=wp) :: refrat_planck_a, refrat_planck_b - REAL(KIND=wp), dimension(ngc(4)) :: stratcorrect = (/ 1., 1., 1., 1.,1., 1., 1., .92, .88, 1.07, 1.1, & - .99, .88, .943 /) - !dir$ assume_aligned jp:64 - !dir$ assume_aligned jt:64 - !dir$ assume_aligned rat_o3co2:64 - !dir$ assume_aligned colco2:64 - !dir$ assume_aligned colo3:64 - !dir$ assume_aligned fac0:64 - !dir$ assume_aligned fac1:64 - !dir$ assume_aligned taug:64 - - !dir$ assume_aligned specmult:64 - !dir$ assume_aligned speccomb:64 - !dir$ assume_aligned specparm:64 - !dir$ assume_aligned specmult_planck:64 - !dir$ assume_aligned speccomb_planck:64 - !dir$ assume_aligned specparm_planck:64 - !dir$ assume_aligned fs:64 - !dir$ assume_aligned tau_major:64 - - !dir$ assume_aligned js:64 - !dir$ assume_aligned ind0:64 - !dir$ assume_aligned jpl:64 - !dir$ assume_aligned fpl:64 - - - ! Upper atmosphere loop - ! ======================== - refrat_planck_b = chi_mls(3,13)/chi_mls(2,13) - DO lay = laytrop+1, nlayers - - DO i=0,1 ! loop over specparm types - - ! This loop should vectorize - ! ============================= - - !dir$ SIMD - DO icol=1,ncol ! Vectorizes with dir 14.0.2 - speccomb(icol) = colo3(icol,lay) + rat_o3co2(icol,i,lay)*colco2(icol,lay) - specparm(icol) = colo3(icol,lay)/speccomb(icol) - IF (specparm(icol) .ge. oneminus) specparm(icol) = oneminus - specmult(icol) = 4.0_wp*(specparm(icol)) - js(icol) = 1 + INT(specmult(icol)) - fs(icol) = MOD(specmult(icol),1.0_wp) - ind0(icol) = ((jp(icol,lay)-13+i)*5+(jt(icol,i,lay)-1))*nspb(4) +js(icol) - END DO - - !dir$ SIMD - DO icol=1,ncol ! Vectorizes with dir 14.0.2 - tau_major(icol,i) = speccomb(icol) * & - ((1.0_wp - fs(icol))*fac0(icol,i,lay)*absb(ind0(icol) ,ig) + & - fs(icol) *fac0(icol,i,lay)*absb(ind0(icol)+1,ig) + & - (1.0_wp - fs(icol))*fac1(icol,i,lay)*absb(ind0(icol)+5,ig) + & - fs(icol) *fac1(icol,i,lay)*absb(ind0(icol)+6,ig)) - END DO - - END DO ! end loop over specparm types for tau_major calculation - - ! Compute taufor terms - ! Note the use of 1D bilinear interpolation of selfref and forref lookup - ! table values - ! =================================================================================== - - !dir$ SIMD - DO icol=1,ncol ! loop vectorizes with directive 14.0.2 - taug(icol,lay) = (tau_major(icol,0) + tau_major(icol,1) ) * stratcorrect(ig) - END DO - - !dir$ SIMD - DO icol=1,ncol ! loop vectorizes with directive 14.0.2 - speccomb_planck(icol) = colo3(icol,lay)+refrat_planck_b*colco2(icol,lay) - specparm_planck(icol) = colo3(icol,lay)/speccomb_planck(icol) - END DO - - !dir$ SIMD - DO icol=1,ncol ! loop vectorizes with directive 14.0.2 - IF (specparm_planck(icol) .GE. oneminus) specparm_planck(icol)=oneminus - specmult_planck(icol) = 4.0_wp*specparm_planck(icol) - jpl(icol)= 1 + INT(specmult_planck(icol)) - fpl(icol) = MOD(specmult_planck(icol),1.0_wp) - fracs(icol,lay) = fracrefb(ig,jpl(icol)) + fpl(icol)*(fracrefb(ig,jpl(icol)+1)-fracrefb(ig,jpl(icol))) - END DO - END DO ! nlayers loop - - END SUBROUTINE taumol04_upr - -END MODULE mo_taumol04 diff --git a/test/ncar_kernels/WACCM_imp_sol/CESM_license.txt b/test/ncar_kernels/WACCM_imp_sol/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/WACCM_imp_sol/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/WACCM_imp_sol/README b/test/ncar_kernels/WACCM_imp_sol/README deleted file mode 100644 index cc28105398..0000000000 --- a/test/ncar_kernels/WACCM_imp_sol/README +++ /dev/null @@ -1,8 +0,0 @@ -WACCM imp_sol kernel - -This version of WACCM imp_sol is generated from rev. 70637 of https://svn-ccsm-models.cgd.ucar.edu/cam1/branch_tags/WACCM_short_lived_not_advected_tags/WACCM_short_lived_not_advected_n01_cam5_3_82 using Intel compiler. - -To build and execute the kernel, run "make" in this directory. - -Please contact Youngsung Kim(youngsun@ucar.edu) for any questions concerning this kernel. - diff --git a/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.10.0 b/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.10.0 deleted file mode 100644 index 969f28b6e6..0000000000 Binary files a/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.10.0 and /dev/null differ diff --git a/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.10.100 b/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.10.100 deleted file mode 100644 index 832d34a04f..0000000000 Binary files a/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.10.100 and /dev/null differ diff --git a/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.10.300 b/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.10.300 deleted file mode 100644 index 8a05247717..0000000000 Binary files a/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.10.300 and /dev/null differ diff --git a/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.100.0 b/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.100.0 deleted file mode 100644 index 5ded6c7a62..0000000000 Binary files a/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.100.0 and /dev/null differ diff --git a/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.100.100 b/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.100.100 deleted file mode 100644 index 473cedaa2f..0000000000 Binary files a/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.100.100 and /dev/null differ diff --git a/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.100.300 b/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.100.300 deleted file mode 100644 index 5d9b36d344..0000000000 Binary files a/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.100.300 and /dev/null differ diff --git a/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.50.0 b/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.50.0 deleted file mode 100644 index e1c10cd8a0..0000000000 Binary files a/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.50.0 and /dev/null differ diff --git a/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.50.100 b/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.50.100 deleted file mode 100644 index 76682e9997..0000000000 Binary files a/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.50.100 and /dev/null differ diff --git a/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.50.300 b/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.50.300 deleted file mode 100644 index ef9a2859ff..0000000000 Binary files a/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.50.300 and /dev/null differ diff --git a/test/ncar_kernels/WACCM_imp_sol/inc/t1.mk b/test/ncar_kernels/WACCM_imp_sol/inc/t1.mk deleted file mode 100644 index a9bfcd52f2..0000000000 --- a/test/ncar_kernels/WACCM_imp_sol/inc/t1.mk +++ /dev/null @@ -1,78 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# Makefile for KGEN-generated kernel - -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# Intel default flags -# -# FC_FLAGS := -no-opt-dynamic-align -convert big_endian -assume byterecl -ftz -traceback -assume realloc_lhs -fp-model source -xHost -O2 -# - -FC_FLAGS := $(OPT) - -ALL_OBJS := kernel_driver.o mo_gas_phase_chemdr.o kgen_utils.o mo_tracname.o mo_nln_matrix.o mo_lu_solve.o chem_mods.o mo_prod_loss.o mo_lin_matrix.o ppgrid.o mo_imp_sol.o shr_kind_mod.o mo_lu_factor.o mo_indprd.o - -all: build run verify - -verify: - @(grep "verification.FAIL" $(TEST).rslt && echo "FAILED") || (grep "verification.PASS" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 mo_gas_phase_chemdr.o kgen_utils.o mo_tracname.o mo_nln_matrix.o mo_lu_solve.o chem_mods.o mo_prod_loss.o mo_lin_matrix.o ppgrid.o mo_imp_sol.o shr_kind_mod.o mo_lu_factor.o mo_indprd.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_gas_phase_chemdr.o: $(SRC_DIR)/mo_gas_phase_chemdr.F90 kgen_utils.o mo_imp_sol.o shr_kind_mod.o ppgrid.o chem_mods.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_tracname.o: $(SRC_DIR)/mo_tracname.F90 kgen_utils.o chem_mods.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_nln_matrix.o: $(SRC_DIR)/mo_nln_matrix.F90 kgen_utils.o shr_kind_mod.o chem_mods.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_lu_solve.o: $(SRC_DIR)/mo_lu_solve.F90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -chem_mods.o: $(SRC_DIR)/chem_mods.F90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_prod_loss.o: $(SRC_DIR)/mo_prod_loss.F90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_lin_matrix.o: $(SRC_DIR)/mo_lin_matrix.F90 kgen_utils.o shr_kind_mod.o chem_mods.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -ppgrid.o: $(SRC_DIR)/ppgrid.F90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_imp_sol.o: $(SRC_DIR)/mo_imp_sol.F90 kgen_utils.o ppgrid.o chem_mods.o shr_kind_mod.o mo_indprd.o mo_lin_matrix.o mo_nln_matrix.o mo_lu_factor.o mo_prod_loss.o mo_lu_solve.o mo_tracname.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_kind_mod.o: $(SRC_DIR)/shr_kind_mod.F90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_lu_factor.o: $(SRC_DIR)/mo_lu_factor.F90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_indprd.o: $(SRC_DIR)/mo_indprd.F90 kgen_utils.o shr_kind_mod.o ppgrid.o chem_mods.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -kgen_utils.o: $(SRC_DIR)/kgen_utils.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.oo *.rslt diff --git a/test/ncar_kernels/WACCM_imp_sol/lit/runmake b/test/ncar_kernels/WACCM_imp_sol/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/WACCM_imp_sol/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/WACCM_imp_sol/lit/t1.sh b/test/ncar_kernels/WACCM_imp_sol/lit/t1.sh deleted file mode 100644 index 33c953a156..0000000000 --- a/test/ncar_kernels/WACCM_imp_sol/lit/t1.sh +++ /dev/null @@ -1,9 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -# Shared lit script for each tests. Run bash commands that run tests with make. - -# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t -# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/WACCM_imp_sol/makefile b/test/ncar_kernels/WACCM_imp_sol/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/WACCM_imp_sol/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/WACCM_imp_sol/src/chem_mods.F90 b/test/ncar_kernels/WACCM_imp_sol/src/chem_mods.F90 deleted file mode 100644 index ee29ec447d..0000000000 --- a/test/ncar_kernels/WACCM_imp_sol/src/chem_mods.F90 +++ /dev/null @@ -1,57 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : chem_mods.F90 -! Generated at: 2015-05-13 11:02:22 -! KGEN version: 0.4.10 - - - - MODULE chem_mods - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !-------------------------------------------------------------- - ! ... Basic chemistry parameters and arrays - !-------------------------------------------------------------- - IMPLICIT NONE - INTEGER, parameter :: extcnt = 18 - INTEGER, parameter :: gas_pcnst = 158 - INTEGER, parameter :: rxntot = 449 - INTEGER, parameter :: clscnt4 = 135 - INTEGER, parameter :: nzcnt = 1509 - INTEGER, parameter :: nfs = 2 - INTEGER, parameter :: indexm = 1 ! number of photolysis reactions - ! number of total reactions - ! number of gas phase reactions - ! number of absorbing column densities - ! number of "gas phase" species - ! number of "fixed" species - ! number of relationship species - ! number of group members - ! number of non-zero matrix entries - ! number of species with external forcing - ! number of species in explicit class - ! number of species in hov class - ! number of species in ebi class - ! number of species in implicit class - ! number of species in rodas class - ! index of total atm density in invariant array - ! index of water vapor density - ! loop length for implicit chemistry - INTEGER :: cls_rxt_cnt(4,5) = 0 - INTEGER :: clsmap(gas_pcnst,5) = 0 - INTEGER :: permute(gas_pcnst,5) = 0 - PUBLIC kgen_read_externs_chem_mods - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_chem_mods(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) cls_rxt_cnt - READ(UNIT=kgen_unit) clsmap - READ(UNIT=kgen_unit) permute - END SUBROUTINE kgen_read_externs_chem_mods - - END MODULE chem_mods diff --git a/test/ncar_kernels/WACCM_imp_sol/src/kernel_driver.f90 b/test/ncar_kernels/WACCM_imp_sol/src/kernel_driver.f90 deleted file mode 100644 index f2fdd86b51..0000000000 --- a/test/ncar_kernels/WACCM_imp_sol/src/kernel_driver.f90 +++ /dev/null @@ -1,88 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-05-13 11:02:21 -! KGEN version: 0.4.10 - - -PROGRAM kernel_driver - USE mo_gas_phase_chemdr, ONLY : gas_phase_chemdr - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - USE mo_imp_sol, ONLY : kgen_read_externs_mo_imp_sol - USE chem_mods, ONLY : kgen_read_externs_chem_mods - USE mo_tracname, ONLY : kgen_read_externs_mo_tracname - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - - IMPLICIT NONE - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_mpi_rank_at = (/ 0, 100, 300 /) - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_counter_at = (/ 10, 100, 50 /) - CHARACTER(LEN=1024) :: kgen_filepath - INTEGER :: lchnk - INTEGER :: ncol - REAL(KIND=r8) :: delt - - DO kgen_repeat_counter = 0, 8 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - kgen_filepath = "../data/imp_sol." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "** Verification against '" // trim(adjustl(kgen_filepath)) // "' **" - - CALL kgen_read_externs_mo_imp_sol(kgen_unit) - CALL kgen_read_externs_chem_mods(kgen_unit) - CALL kgen_read_externs_mo_tracname(kgen_unit) - - ! driver variables - READ(UNIT=kgen_unit) lchnk - READ(UNIT=kgen_unit) ncol - READ(UNIT=kgen_unit) delt - - call gas_phase_chemdr(lchnk, ncol, delt, kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! write subroutines - ! No subroutines - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/WACCM_imp_sol/src/kgen_utils.f90 b/test/ncar_kernels/WACCM_imp_sol/src/kgen_utils.f90 deleted file mode 100644 index cfa8d114e0..0000000000 --- a/test/ncar_kernels/WACCM_imp_sol/src/kgen_utils.f90 +++ /dev/null @@ -1,61 +0,0 @@ -module kgen_utils_mod - -INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - -type check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - real(kind=kgen_dp) :: minvalue -end type check_t - -public kgen_dp, check_t, kgen_init_check, kgen_print_check - -contains - -subroutine kgen_init_check(check, tolerance, minvalue) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - real(kind=kgen_dp), intent(in), optional :: minvalue - - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.0D-15 - endif - if(present(minvalue)) then - check%minvalue = minvalue - else - check%minvalue = 1.0D-15 - endif -end subroutine kgen_init_check - -subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif -end subroutine kgen_print_check - -end module diff --git a/test/ncar_kernels/WACCM_imp_sol/src/mo_gas_phase_chemdr.F90 b/test/ncar_kernels/WACCM_imp_sol/src/mo_gas_phase_chemdr.F90 deleted file mode 100644 index f4f1439621..0000000000 --- a/test/ncar_kernels/WACCM_imp_sol/src/mo_gas_phase_chemdr.F90 +++ /dev/null @@ -1,503 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_gas_phase_chemdr.F90 -! Generated at: 2015-05-13 11:02:21 -! KGEN version: 0.4.10 - - - - MODULE mo_gas_phase_chemdr - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - USE chem_mods, ONLY: gas_pcnst - USE chem_mods, ONLY: rxntot - USE chem_mods, ONLY: extcnt - USE ppgrid, ONLY: pver - USE ppgrid, ONLY: pcols - IMPLICIT NONE - PUBLIC gas_phase_chemdr - PRIVATE - ! index map to/from chemistry/constituents list - ! - ! CCMI - ! - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - - SUBROUTINE gas_phase_chemdr(lchnk, ncol, delt, kgen_unit) - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !----------------------------------------------------------------------- - ! ... Chem_solver advances the volumetric mixing ratio - ! forward one time step via a combination of explicit, - ! ebi, hov, fully implicit, and/or rodas algorithms. - !----------------------------------------------------------------------- - USE chem_mods, ONLY: nfs - USE chem_mods, ONLY: indexm - USE mo_imp_sol, ONLY: imp_sol - ! - ! LINOZ - ! - ! - ! for aqueous chemistry and aerosol growth - ! - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy arguments - !----------------------------------------------------------------------- - integer, intent(in) :: kgen_unit - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - INTEGER, intent(in) :: lchnk ! chunk index - INTEGER, intent(in) :: ncol ! number columns in chunk - ! gas phase start index in q - REAL(KIND=r8), intent(in) :: delt ! timestep (s) - ! day of year - ! surface pressure - ! surface geopotential - ! midpoint temperature (K) - ! midpoint pressures (Pa) - ! pressure delta about midpoints (Pa) - ! zonal velocity (m/s) - ! meridional velocity (m/s) - ! cloud water (kg/kg) - ! droplet number concentration (#/kg) - ! midpoint geopotential height above the surface (m) - ! interface geopotential height above the surface (m) - ! interface pressures (Pa) - ! species concentrations (kg/kg) - ! longwave down at sfc - ! sea-ice areal fraction - ! ocean areal fraction - ! albedo: shortwave, direct - ! sfc temp (merged w/ocean if coupled) - ! - ! - ! - ! species tendencies (kg/kg/s) - ! constituent surface flux (kg/m^2/s) - ! dry deposition flux (kg/m^2/s) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - ! chunk lat indicies - ! chunk lon indicies - REAL(KIND=r8) :: invariants(ncol,pver,nfs) - ! column densities (molecules/cm^2) - ! layer column densities (molecules/cm^2) - REAL(KIND=r8) :: extfrc(ncol,pver,max(1,extcnt)) - REAL(KIND=r8) :: vmr(ncol,pver,gas_pcnst) - REAL(KIND=r8) :: ref_vmr(ncol,pver,gas_pcnst) ! xported species (vmr) - REAL(KIND=r8) :: reaction_rates(ncol,pver,max(1,rxntot)) ! reaction rates - ! dry deposition velocity (cm/s) - REAL(KIND=r8) :: het_rates(ncol,pver,max(1,gas_pcnst)) ! washout rate (1/s) - ! water vapor volume mixing ratio - ! mean wet atmospheric mass ( amu ) - ! midpoint geopotential in km - ! midpoint geopotential in km realitive to surf - ! trop sulfate aerosols - ! pressure at midpoints ( hPa ) - ! cloud water mass mixing ratio (kg/kg) - ! interface geopotential in km realitive to surf - ! interface geopotential in km - ! solar zenith angles - ! surface height (m) - ! chunk latitudes and longitudes (radians) - ! solar zenith angles (degrees) - ! radians to degrees conversion factor - ! relative humidity - ! wrk array for relative humidity - ! wrk array for relative humidity - INTEGER :: ltrop_sol(pcols) ! tropopause vertical index used in chem solvers - ! stratospheric sad (1/cm) - ! total trop. sad (cm^2/cm^3) - ! surface wind speed (m/s) - ! od diagnostics - ! fraction of day - ! o2 concentration (kg/kg) - ! o concentration (kg/kg) - ! chem working concentrations (kg/kg) - ! chem working concentrations (kg/kg) - ! hno3 gas phase concentration (mol/mol) - ! hno3 condensed phase concentration (mol/mol) - ! hcl gas phase concentration (mol/mol) - ! hcl condensed phase concentration (mol/mol) - ! h2o gas phase concentration (mol/mol) - ! h2o condensed phase concentration (mol/mol) - ! cloud water "ice" (kg/kg) - ! radius of sulfate, nat, & ice ( cm ) - ! surf area density of sulfate, nat, & ice ( cm^2/cm^3 ) - ! chemistry species tendencies (kg/kg/s) - ! specific humidity (kg/kg) - ! for aerosol formation.... - ! - ! CCMI - ! - REAL(KIND=r8), dimension(ncol,pver) :: o3s_loss - REAL(KIND=r8) :: ref_o3s_loss(ncol,pver) ! tropospheric ozone loss for o3s - ! - ! jfl - ! - ! - ! aerosol reaction diagnostics - ! initialize to NaN to hopefully catch user defined rxts that go unset - !----------------------------------------------------------------------- - ! ... Get chunck latitudes and longitudes - !----------------------------------------------------------------------- - ! convert to degrees - !----------------------------------------------------------------------- - ! ... Calculate cosine of zenith angle - ! then cast back to angle (radians) - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... Xform geopotential height from m to km - ! and pressure from Pa to mb - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... map incoming concentrations to working array - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... Set atmosphere mean mass - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... Xform from mmr to vmr - !----------------------------------------------------------------------- - ! - ! CCMI - ! - ! reset STE tracer to specific vmr of 200 ppbv - ! - ! - ! reset AOA_NH, NH_5, NH_50, NH_50W surface mixing ratios between 30N and 50N - ! - !----------------------------------------------------------------------- - ! ... force ion/electron balance - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... Set the "invariants" - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... stratosphere aerosol surface area - !----------------------------------------------------------------------- - ! NOTE: For gas-phase solver only. - ! ratecon_sfstrat needs total hcl. - !----------------------------------------------------------------------- - ! ... Set the column densities at the upper boundary - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... Set rates for "tabular" and user specified reactions - !----------------------------------------------------------------------- - !----------------------------------------------------------------- - ! ... zero out sulfate above tropopause - !----------------------------------------------------------------- - !----------------------------------------------------------------- - ! ... compute the relative humidity - !----------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... Compute the photolysis rates at time = t(n+1) - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... Set the column densities - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... Calculate the photodissociation rates - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... Adjust the photodissociation rates - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... Compute the extraneous frcing at time = t(n+1) - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... Compute the extraneous frcing at time = t(n+1) - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... Form the washout rates - !----------------------------------------------------------------------- - ! - ! CCMI - ! - ! set loss to below the tropopause only - ! - ! - ! save h2so4 before gas phase chem (for later new particle nucleation) - ! mixing ratios before chemistry changes - !======================================================================= - ! ... Call the class solution algorithms - !======================================================================= - !----------------------------------------------------------------------- - ! ... Solve for "Explicit" species - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... Solve for "Implicit" species - !----------------------------------------------------------------------- - ! - tolerance = 1.E-14 - CALL kgen_init_check(check_status, tolerance) - READ(UNIT=kgen_unit) invariants - READ(UNIT=kgen_unit) extfrc - READ(UNIT=kgen_unit) vmr - READ(UNIT=kgen_unit) reaction_rates - READ(UNIT=kgen_unit) het_rates - READ(UNIT=kgen_unit) ltrop_sol - READ(UNIT=kgen_unit) o3s_loss - - READ(UNIT=kgen_unit) ref_vmr - READ(UNIT=kgen_unit) ref_o3s_loss - - !Uncomment following call(s) to generate perturbed input(s) - !CALL kgen_perturb_real_r8_dim3( vmr ) - - ! call to kernel - CALL imp_sol(vmr, reaction_rates, het_rates, extfrc, delt, invariants(1,1,indexm), ncol, lchnk, ltrop_sol(:ncol), & - o3s_loss=o3s_loss) - ! kernel verification for output variables - CALL kgen_verify_real_r8_dim3( "vmr", check_status, vmr, ref_vmr) - CALL kgen_verify_real_r8_dim2( "o3s_loss", check_status, o3s_loss, ref_o3s_loss) - CALL kgen_print_check("imp_sol", check_status) - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,10 - CALL imp_sol(vmr, reaction_rates, het_rates, extfrc, delt, invariants(1, 1, indexm), ncol, lchnk, ltrop_sol(: ncol), o3s_loss = o3s_loss) - END DO - CALL system_clock(stop_clock, rate_clock) - WRITE(*,*) - PRINT *, "Elapsed time (sec): ", (stop_clock - start_clock)/REAL(rate_clock*10) - ! - ! jfl : CCMI : implement O3S here because mo_fstrat is not called - ! - ! save h2so4 change by gas phase chem (for later new particle nucleation) - ! - ! Aerosol processes ... - ! - ! - ! LINOZ - ! - !----------------------------------------------------------------------- - ! ... Check for negative values and reset to zero - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... Set upper boundary mmr values - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... Set fixed lower boundary mmr values - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! set NOy UBC - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... Xform from vmr to mmr - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... Form the tendencies - !----------------------------------------------------------------------- - ! - ! jfl - ! - ! surface vmr - ! - ! - ! - ! - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_r8_dim3(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2,idx3 - INTEGER, DIMENSION(2,3) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - READ(UNIT = kgen_unit) kgen_bound(1, 3) - READ(UNIT = kgen_unit) kgen_bound(2, 3) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1, kgen_bound(2, 3) - kgen_bound(1, 3) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim3 - - SUBROUTINE kgen_read_real_r8_dim2(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:) :: var - LOGICAL :: is_true - INTEGER :: idx1,idx2 - INTEGER, DIMENSION(2,2) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - READ(UNIT = kgen_unit) kgen_bound(1, 2) - READ(UNIT = kgen_unit) kgen_bound(2, 2) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1, kgen_bound(2, 2) - kgen_bound(1, 2) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim2 - - - ! verify subroutines - SUBROUTINE kgen_verify_real_r8_dim3( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim3 - - SUBROUTINE kgen_verify_real_r8_dim2( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:,:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:,:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) - allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim2 - - subroutine kgen_perturb_real_r8_dim3( var ) - real(kind=r8), intent(inout), dimension(:,:,:) :: var - integer, allocatable :: rndm_seed(:) - integer :: rndm_seed_sz - real(kind=r8) :: pertval - real(kind=r8) :: pertlim = 10e-15 - integer :: idx1,idx2,idx3 - - call random_seed(size=rndm_seed_sz) - allocate(rndm_seed(rndm_seed_sz)) - rndm_seed = 121869 - call random_seed(put=rndm_seed) - do idx1=1,size(var, dim=1) - do idx2=1,size(var, dim=2) - do idx3=1,size(var, dim=3) - call random_number(pertval) - pertval = 2.0_r8*pertlim*(0.5_r8 - pertval) - var(idx1,idx2,idx3) = var(idx1,idx2,idx3)*(1.0_r8 + pertval) - end do - end do - end do - deallocate(rndm_seed) - end subroutine - END SUBROUTINE gas_phase_chemdr - END MODULE mo_gas_phase_chemdr diff --git a/test/ncar_kernels/WACCM_imp_sol/src/mo_imp_sol.F90 b/test/ncar_kernels/WACCM_imp_sol/src/mo_imp_sol.F90 deleted file mode 100644 index 5d8eacfa1e..0000000000 --- a/test/ncar_kernels/WACCM_imp_sol/src/mo_imp_sol.F90 +++ /dev/null @@ -1,594 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_imp_sol.F90 -! Generated at: 2015-05-13 11:02:22 -! KGEN version: 0.4.10 - - - - MODULE mo_imp_sol - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - USE chem_mods, ONLY: gas_pcnst - USE chem_mods, ONLY: clscnt4 - USE chem_mods, ONLY: clsmap - IMPLICIT NONE - PRIVATE - PUBLIC imp_sol - !----------------------------------------------------------------------- - ! Newton-Raphson iteration limits - !----------------------------------------------------------------------- - INTEGER, parameter :: itermax = 11 - INTEGER, parameter :: cut_limit = 5 - REAL(KIND=r8) :: small - REAL(KIND=r8) :: epsilon(clscnt4) - LOGICAL :: factor(itermax) - INTEGER :: ox_ndx - INTEGER :: o1d_ndx = -1 - INTEGER :: h2o_ndx = -1 - INTEGER :: ch3co3_ndx - INTEGER :: ho2_ndx - INTEGER :: ch3o2_ndx - INTEGER :: po2_ndx - INTEGER :: oh_ndx - INTEGER :: macro2_ndx - INTEGER :: mco3_ndx - INTEGER :: c2h5o2_ndx - INTEGER :: c3h7o2_ndx - INTEGER :: isopo2_ndx - INTEGER :: xo2_ndx - INTEGER :: ro2_ndx - INTEGER :: no2_ndx - INTEGER :: n2o5_ndx - INTEGER :: no3_ndx - INTEGER :: no_ndx - INTEGER :: mvk_ndx - INTEGER :: c2h4_ndx - INTEGER :: c3h6_ndx - INTEGER :: isop_ndx - INTEGER :: c10h16_ndx - INTEGER :: ox_p2_ndx - INTEGER :: ox_p5_ndx - INTEGER :: ox_p1_ndx - INTEGER :: ox_p3_ndx - INTEGER :: ox_p4_ndx - INTEGER :: ox_p7_ndx - INTEGER :: ox_p8_ndx - INTEGER :: ox_p9_ndx - INTEGER :: ox_p6_ndx - INTEGER :: ox_p10_ndx - INTEGER :: ox_p11_ndx - INTEGER :: ox_l1_ndx - INTEGER :: ox_l3_ndx - INTEGER :: ox_l4_ndx - INTEGER :: ox_l5_ndx - INTEGER :: ox_l2_ndx - INTEGER :: ox_l7_ndx - INTEGER :: ox_l8_ndx - INTEGER :: ox_l9_ndx - INTEGER :: ox_l6_ndx - INTEGER :: usr4_ndx - INTEGER :: c2o3_ndx - INTEGER :: ole_ndx - INTEGER :: usr16_ndx - INTEGER :: usr17_ndx - INTEGER :: eneo2_ndx - INTEGER :: meko2_ndx - INTEGER :: eo2_ndx - INTEGER :: terpo2_ndx - INTEGER :: alko2_ndx - INTEGER :: tolo2_ndx - INTEGER :: ox_p17_ndx - INTEGER :: ox_p12_ndx - INTEGER :: ox_p14_ndx - INTEGER :: ox_p13_ndx - INTEGER :: ox_p16_ndx - INTEGER :: ox_p15_ndx - LOGICAL :: full_ozone_chem = .false. - LOGICAL :: middle_atm_chem = .false. - LOGICAL :: reduced_ozone_chem = .false. - ! for xnox ozone chemistry diagnostics - INTEGER :: o3a_ndx - INTEGER :: o1da_ndx - INTEGER :: xno2no3_ndx - INTEGER :: xno2_ndx - INTEGER :: xno3_ndx - INTEGER :: no2xno3_ndx - INTEGER :: xno_ndx - INTEGER :: usr16b_ndx - INTEGER :: usr4a_ndx - INTEGER :: usr16a_ndx - INTEGER :: usr17b_ndx - PUBLIC kgen_read_externs_mo_imp_sol - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_mo_imp_sol(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) small - READ(UNIT=kgen_unit) epsilon - READ(UNIT=kgen_unit) factor - READ(UNIT=kgen_unit) ox_ndx - READ(UNIT=kgen_unit) o1d_ndx - READ(UNIT=kgen_unit) h2o_ndx - READ(UNIT=kgen_unit) ch3co3_ndx - READ(UNIT=kgen_unit) ho2_ndx - READ(UNIT=kgen_unit) ch3o2_ndx - READ(UNIT=kgen_unit) po2_ndx - READ(UNIT=kgen_unit) oh_ndx - READ(UNIT=kgen_unit) macro2_ndx - READ(UNIT=kgen_unit) mco3_ndx - READ(UNIT=kgen_unit) c2h5o2_ndx - READ(UNIT=kgen_unit) c3h7o2_ndx - READ(UNIT=kgen_unit) isopo2_ndx - READ(UNIT=kgen_unit) xo2_ndx - READ(UNIT=kgen_unit) ro2_ndx - READ(UNIT=kgen_unit) no2_ndx - READ(UNIT=kgen_unit) n2o5_ndx - READ(UNIT=kgen_unit) no3_ndx - READ(UNIT=kgen_unit) no_ndx - READ(UNIT=kgen_unit) mvk_ndx - READ(UNIT=kgen_unit) c2h4_ndx - READ(UNIT=kgen_unit) c3h6_ndx - READ(UNIT=kgen_unit) isop_ndx - READ(UNIT=kgen_unit) c10h16_ndx - READ(UNIT=kgen_unit) ox_p2_ndx - READ(UNIT=kgen_unit) ox_p5_ndx - READ(UNIT=kgen_unit) ox_p1_ndx - READ(UNIT=kgen_unit) ox_p3_ndx - READ(UNIT=kgen_unit) ox_p4_ndx - READ(UNIT=kgen_unit) ox_p7_ndx - READ(UNIT=kgen_unit) ox_p8_ndx - READ(UNIT=kgen_unit) ox_p9_ndx - READ(UNIT=kgen_unit) ox_p6_ndx - READ(UNIT=kgen_unit) ox_p10_ndx - READ(UNIT=kgen_unit) ox_p11_ndx - READ(UNIT=kgen_unit) ox_l1_ndx - READ(UNIT=kgen_unit) ox_l3_ndx - READ(UNIT=kgen_unit) ox_l4_ndx - READ(UNIT=kgen_unit) ox_l5_ndx - READ(UNIT=kgen_unit) ox_l2_ndx - READ(UNIT=kgen_unit) ox_l7_ndx - READ(UNIT=kgen_unit) ox_l8_ndx - READ(UNIT=kgen_unit) ox_l9_ndx - READ(UNIT=kgen_unit) ox_l6_ndx - READ(UNIT=kgen_unit) usr4_ndx - READ(UNIT=kgen_unit) c2o3_ndx - READ(UNIT=kgen_unit) ole_ndx - READ(UNIT=kgen_unit) usr16_ndx - READ(UNIT=kgen_unit) usr17_ndx - READ(UNIT=kgen_unit) eneo2_ndx - READ(UNIT=kgen_unit) meko2_ndx - READ(UNIT=kgen_unit) eo2_ndx - READ(UNIT=kgen_unit) terpo2_ndx - READ(UNIT=kgen_unit) alko2_ndx - READ(UNIT=kgen_unit) tolo2_ndx - READ(UNIT=kgen_unit) ox_p17_ndx - READ(UNIT=kgen_unit) ox_p12_ndx - READ(UNIT=kgen_unit) ox_p14_ndx - READ(UNIT=kgen_unit) ox_p13_ndx - READ(UNIT=kgen_unit) ox_p16_ndx - READ(UNIT=kgen_unit) ox_p15_ndx - READ(UNIT=kgen_unit) full_ozone_chem - READ(UNIT=kgen_unit) middle_atm_chem - READ(UNIT=kgen_unit) reduced_ozone_chem - READ(UNIT=kgen_unit) o3a_ndx - READ(UNIT=kgen_unit) o1da_ndx - READ(UNIT=kgen_unit) xno2no3_ndx - READ(UNIT=kgen_unit) xno2_ndx - READ(UNIT=kgen_unit) xno3_ndx - READ(UNIT=kgen_unit) no2xno3_ndx - READ(UNIT=kgen_unit) xno_ndx - READ(UNIT=kgen_unit) usr16b_ndx - READ(UNIT=kgen_unit) usr4a_ndx - READ(UNIT=kgen_unit) usr16a_ndx - READ(UNIT=kgen_unit) usr17b_ndx - END SUBROUTINE kgen_read_externs_mo_imp_sol - - - - SUBROUTINE imp_sol(base_sol, reaction_rates, het_rates, extfrc, delt, xhnm, ncol, lchnk, ltrop, o3s_loss) - !----------------------------------------------------------------------- - ! ... imp_sol advances the volumetric mixing ratio - ! forward one time step via the fully implicit euler scheme. - ! this source is meant for small l1 cache machines such as - ! the intel pentium and itanium cpus - !----------------------------------------------------------------------- - USE chem_mods, ONLY: extcnt - USE chem_mods, ONLY: rxntot - USE chem_mods, ONLY: nzcnt - USE chem_mods, ONLY: cls_rxt_cnt - USE chem_mods, ONLY: permute - USE mo_tracname, ONLY: solsym - USE ppgrid, ONLY: pver - USE mo_lin_matrix, ONLY: linmat - USE mo_nln_matrix, ONLY: nlnmat - USE mo_lu_factor, ONLY: lu_fac - USE mo_lu_solve, ONLY: lu_slv - USE mo_prod_loss, ONLY: imp_prod_loss - USE mo_indprd, ONLY: indprd - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - INTEGER, intent(in) :: ncol ! columns in chunck - INTEGER, intent(in) :: lchnk ! chunk id - REAL(KIND=r8), intent(in) :: delt ! time step (s) - REAL(KIND=r8), intent(in) :: reaction_rates(ncol,pver,max(1,rxntot)) - REAL(KIND=r8), intent(in) :: extfrc(ncol,pver,max(1,extcnt)) - REAL(KIND=r8), intent(in) :: het_rates(ncol,pver,max(1,gas_pcnst)) ! rxt rates (1/cm^3/s) - ! external in-situ forcing (1/cm^3/s) - ! washout rates (1/s) - REAL(KIND=r8), intent(inout) :: base_sol(ncol,pver,gas_pcnst) ! species mixing ratios (vmr) - REAL(KIND=r8), intent(in) :: xhnm(ncol,pver) - INTEGER, intent(in) :: ltrop(ncol) ! chemistry troposphere boundary (index) - REAL(KIND=r8), optional, intent(out) :: o3s_loss(ncol,pver) - !----------------------------------------------------------------------- - ! ... local variables - !----------------------------------------------------------------------- - INTEGER :: m - INTEGER :: lev - INTEGER :: i - INTEGER :: k - INTEGER :: j - INTEGER :: nr_iter - INTEGER :: cut_cnt - INTEGER :: fail_cnt - INTEGER :: stp_con_cnt - INTEGER :: nstep - REAL(KIND=r8) :: dt - REAL(KIND=r8) :: interval_done - REAL(KIND=r8) :: dti - REAL(KIND=r8) :: max_delta(max(1,clscnt4)) - REAL(KIND=r8) :: sys_jac(max(1,nzcnt)) - REAL(KIND=r8) :: lin_jac(max(1,nzcnt)) - REAL(KIND=r8), dimension(max(1,clscnt4)) :: solution - REAL(KIND=r8), dimension(max(1,clscnt4)) :: iter_invariant - REAL(KIND=r8), dimension(max(1,clscnt4)) :: prod - REAL(KIND=r8), dimension(max(1,clscnt4)) :: loss - REAL(KIND=r8), dimension(max(1,clscnt4)) :: forcing - REAL(KIND=r8) :: lrxt(max(1,rxntot)) - REAL(KIND=r8) :: lsol(max(1,gas_pcnst)) - REAL(KIND=r8) :: lhet(max(1,gas_pcnst)) - REAL(KIND=r8), dimension(ncol,pver,max(1,clscnt4)) :: ind_prd - LOGICAL :: convergence - LOGICAL :: frc_mask - LOGICAL :: converged(max(1,clscnt4)) - REAL(KIND=r8), dimension(ncol,pver,max(1,clscnt4)) :: prod_out - REAL(KIND=r8), dimension(ncol,pver,max(1,clscnt4)) :: loss_out - REAL(KIND=r8), dimension(ncol,pver) :: prod_hydrogen_peroxides_out - IF (present(o3s_loss)) THEN - o3s_loss(:,:) = 0._r8 - END IF - prod_out(:,:,:) = 0._r8 - loss_out(:,:,:) = 0._r8 - prod_hydrogen_peroxides_out(:,:) = 0._r8 - solution(:) = 0._r8 - !----------------------------------------------------------------------- - ! ... class independent forcing - !----------------------------------------------------------------------- - IF (cls_rxt_cnt(1,4) > 0 .or. extcnt > 0) THEN - CALL indprd(4, ind_prd, clscnt4, base_sol, extfrc, reaction_rates, ncol) - ELSE - DO m = 1,max(1,clscnt4) - ind_prd(:,:,m) = 0._r8 - END DO - END IF - level_loop: DO lev = 1,pver - column_loop: DO i = 1,ncol - IF (lev <= ltrop(i)) CYCLE column_loop - !----------------------------------------------------------------------- - ! ... transfer from base to local work arrays - !----------------------------------------------------------------------- - DO m = 1,rxntot - lrxt(m) = reaction_rates(i,lev,m) - END DO - IF (gas_pcnst > 0) THEN - DO m = 1,gas_pcnst - lhet(m) = het_rates(i,lev,m) - END DO - END IF - !----------------------------------------------------------------------- - ! ... time step loop - !----------------------------------------------------------------------- - dt = delt - cut_cnt = 0 - fail_cnt = 0 - stp_con_cnt = 0 - interval_done = 0._r8 - time_step_loop: DO - dti = 1._r8 / dt - !----------------------------------------------------------------------- - ! ... transfer from base to local work arrays - !----------------------------------------------------------------------- - DO m = 1,gas_pcnst - lsol(m) = base_sol(i,lev,m) - END DO - !----------------------------------------------------------------------- - ! ... transfer from base to class array - !----------------------------------------------------------------------- - DO k = 1,clscnt4 - j = clsmap(k,4) - m = permute(k,4) - solution(m) = lsol(j) - END DO - !----------------------------------------------------------------------- - ! ... set the iteration invariant part of the function f(y) - !----------------------------------------------------------------------- - IF (cls_rxt_cnt(1,4) > 0 .or. extcnt > 0) THEN - DO m = 1,clscnt4 - iter_invariant(m) = dti * solution(m) + ind_prd(i,lev,m) - END DO - ELSE - DO m = 1,clscnt4 - iter_invariant(m) = dti * solution(m) - END DO - END IF - !----------------------------------------------------------------------- - ! ... the linear component - !----------------------------------------------------------------------- - !if( cls_rxt_cnt(2,4) > 0 ) then - CALL linmat(lin_jac, lsol, lrxt, lhet) - !end if - !======================================================================= - ! the newton-raphson iteration for f(y) = 0 - !======================================================================= - iter_loop: DO nr_iter = 1,itermax - !----------------------------------------------------------------------- - ! ... the non-linear component - !----------------------------------------------------------------------- - IF (factor(nr_iter)) THEN - CALL nlnmat(sys_jac, lsol, lrxt, lin_jac, dti) - !----------------------------------------------------------------------- - ! ... factor the "system" matrix - !----------------------------------------------------------------------- - CALL lu_fac(sys_jac) - END IF - !----------------------------------------------------------------------- - ! ... form f(y) - !----------------------------------------------------------------------- - CALL imp_prod_loss(prod, loss, lsol, lrxt, lhet) - DO m = 1,clscnt4 - forcing(m) = solution(m)*dti - (iter_invariant(m) + prod(m) - loss(m)) - END DO - !----------------------------------------------------------------------- - ! ... solve for the mixing ratio at t(n+1) - !----------------------------------------------------------------------- - CALL lu_slv(sys_jac, forcing) - DO m = 1,clscnt4 - solution(m) = solution(m) + forcing(m) - END DO - !----------------------------------------------------------------------- - ! ... convergence measures - !----------------------------------------------------------------------- - IF (nr_iter > 1) THEN - DO k = 1,clscnt4 - m = permute(k,4) - IF (abs(solution(m)) > 1.e-20_r8) THEN - max_delta(k) = abs(forcing(m)/solution(m)) - ELSE - max_delta(k) = 0._r8 - END IF - END DO - END IF - !----------------------------------------------------------------------- - ! ... limit iterate - !----------------------------------------------------------------------- - WHERE ( solution(:) < 0._r8 ) - solution(:) = 0._r8 - END WHERE - !----------------------------------------------------------------------- - ! ... transfer latest solution back to work array - !----------------------------------------------------------------------- - DO k = 1,clscnt4 - j = clsmap(k,4) - m = permute(k,4) - lsol(j) = solution(m) - END DO - !----------------------------------------------------------------------- - ! ... check for convergence - !----------------------------------------------------------------------- - converged(:) = .true. - IF (nr_iter > 1) THEN - DO k = 1,clscnt4 - m = permute(k,4) - frc_mask = abs(forcing(m)) > small - IF (frc_mask) THEN - converged(k) = abs(forcing(m)) <= epsilon(k)*abs(solution(m)) - ELSE - converged(k) = .true. - END IF - END DO - convergence = all(converged(:)) - IF (convergence) THEN - EXIT - END IF - END IF - END DO iter_loop - !----------------------------------------------------------------------- - ! ... check for newton-raphson convergence - !----------------------------------------------------------------------- - IF (.not. convergence) THEN - !----------------------------------------------------------------------- - ! ... non-convergence - !----------------------------------------------------------------------- - fail_cnt = fail_cnt + 1 - !kgen_excluded nstep = get_nstep() - !kgen_excluded WRITE (iulog, '('' IMP_SOL: TIME STEP '',1P,E21.13,'' FAILED TO CONVERGE @ (LCHNK,LEV, - ! COL,NSTEP) = '',4i6)') dt, lchnk, lev, i, nstep - stp_con_cnt = 0 - IF (cut_cnt < cut_limit) THEN - cut_cnt = cut_cnt + 1 - IF (cut_cnt < cut_limit) THEN - dt = .5_r8 * dt - ELSE - dt = .1_r8 * dt - END IF - CYCLE time_step_loop - ELSE - !kgen_excluded WRITE (iulog, '('' IMP_SOL: FAILED TO CONVERGE @ (LCHNK,LEV,COL,NSTEP,DT,TIME) = '' - ! ,4i6,1p,2e21.13)') lchnk, lev, i, nstep, dt, interval_done+dt - DO m = 1,clscnt4 - IF (.not. converged(m)) THEN - !kgen_excluded WRITE (iulog, '(1x,a8,1x,1pe10.3)') solsym(clsmap(m,4)), max_delta(m) - END IF - END DO - END IF - END IF - !----------------------------------------------------------------------- - ! ... check for interval done - !----------------------------------------------------------------------- - interval_done = interval_done + dt - IF (abs( delt - interval_done ) <= .0001_r8) THEN - IF (fail_cnt > 0) THEN - !kgen_excluded WRITE (iulog, *) 'imp_sol : @ (lchnk,lev,col) = ', lchnk, lev, i, ' failed ', fail_cnt, ' times' - END IF - EXIT time_step_loop - ELSE - !----------------------------------------------------------------------- - ! ... transfer latest solution back to base array - !----------------------------------------------------------------------- - IF (convergence) THEN - stp_con_cnt = stp_con_cnt + 1 - END IF - DO m = 1,gas_pcnst - base_sol(i,lev,m) = lsol(m) - END DO - IF (stp_con_cnt >= 2) THEN - dt = 2._r8*dt - stp_con_cnt = 0 - END IF - dt = min(dt,delt-interval_done) - ! write(iulog,'('' imp_sol: New time step '',1p,e21.13)') dt - END IF - END DO time_step_loop - !----------------------------------------------------------------------- - ! ... Transfer latest solution back to base array - !----------------------------------------------------------------------- - cls_loop: DO k = 1,clscnt4 - j = clsmap(k,4) - m = permute(k,4) - base_sol(i,lev,j) = solution(m) - END DO cls_loop - !----------------------------------------------------------------------- - ! ... Prod/Loss history buffers... - !----------------------------------------------------------------------- - cls_loop2: DO k = 1,clscnt4 - j = clsmap(k,4) - m = permute(k,4) - has_o3_chem: IF (( full_ozone_chem .or. reduced_ozone_chem .or. middle_atm_chem ) .and. & - (j == ox_ndx .or. j == o3a_ndx )) THEN - IF (o1d_ndx < 1) THEN - loss_out(i,lev,k) = reaction_rates(i,lev,ox_l1_ndx) - ELSE - IF (j == ox_ndx) loss_out(i,lev,k) = reaction_rates(i,lev,ox_l1_ndx) * base_sol(i,lev,o1d_ndx) & - / base_sol(i,lev,ox_ndx) - IF (j == o3a_ndx) loss_out(i,lev,k) = reaction_rates(i,lev,ox_l1_ndx) * base_sol(i,lev,o1da_ndx) & - / base_sol(i,lev,o3a_ndx) - IF (h2o_ndx > 0) loss_out(i,lev,k) = loss_out(i,lev,k) * base_sol(i,lev,h2o_ndx) - END IF - IF (full_ozone_chem) THEN - prod_out(i,lev,k) = reaction_rates(i,lev,ox_p1_ndx) * base_sol(i,lev,ho2_ndx) & - + reaction_rates(i,lev,ox_p2_ndx) * base_sol(i,lev,ch3o2_ndx) + & - reaction_rates(i,lev,ox_p3_ndx) * base_sol(i,lev,po2_ndx) + & - reaction_rates(i,lev,ox_p4_ndx) * base_sol(i,lev,ch3co3_ndx) + & - reaction_rates(i,lev,ox_p5_ndx) * base_sol(i,lev,c2h5o2_ndx) + .92_r8* & - reaction_rates(i,lev,ox_p6_ndx) * base_sol(i,lev,isopo2_ndx) + & - reaction_rates(i,lev,ox_p7_ndx) * base_sol(i,lev,macro2_ndx) + & - reaction_rates(i,lev,ox_p8_ndx) * base_sol(i,lev,mco3_ndx) + & - reaction_rates(i,lev,ox_p9_ndx) * base_sol(i,lev,c3h7o2_ndx) + & - reaction_rates(i,lev,ox_p10_ndx)* base_sol(i,lev,ro2_ndx) + & - reaction_rates(i,lev,ox_p11_ndx)* base_sol(i,lev,xo2_ndx) + & - .9_r8*reaction_rates(i,lev,ox_p12_ndx)*base_sol(i,lev,tolo2_ndx) + & - reaction_rates(i,lev,ox_p13_ndx)*base_sol(i,lev,terpo2_ndx) + & - .9_r8*reaction_rates(i,lev,ox_p14_ndx)*base_sol(i,lev,alko2_ndx) + & - reaction_rates(i,lev,ox_p15_ndx)*base_sol(i,lev,eneo2_ndx) + & - reaction_rates(i,lev,ox_p16_ndx)*base_sol(i,lev,eo2_ndx) + reaction_rates(& - i,lev,ox_p17_ndx)*base_sol(i,lev,meko2_ndx) - loss_out(i,lev,k) = loss_out(i,lev,k) + reaction_rates(i,lev,ox_l2_ndx) * & - base_sol(i,lev,oh_ndx) + reaction_rates(i,lev,ox_l3_ndx) * base_sol(i,lev,& - ho2_ndx) + reaction_rates(i,lev,ox_l6_ndx) * base_sol(i,lev,c2h4_ndx) & - + reaction_rates(i,lev,ox_l4_ndx) * base_sol(i,lev,c3h6_ndx) & - + .9_r8* reaction_rates(i,lev,ox_l5_ndx) * base_sol(i,lev,isop_ndx) & - + .8_r8*(reaction_rates(i,lev,ox_l7_ndx) * base_sol(i,lev,mvk_ndx) + & - reaction_rates(i,lev,ox_l8_ndx) * base_sol(i,lev,macro2_ndx)) + & - .235_r8*reaction_rates(i,lev,ox_l9_ndx) * base_sol(i,lev,c10h16_ndx) - ELSE IF ( reduced_ozone_chem ) THEN - prod_out(i,lev,k) = reaction_rates(i,lev,ox_p1_ndx) * base_sol(i,lev,ho2_ndx) & - + reaction_rates(i,lev,ox_p2_ndx) * base_sol(i,lev,ch3o2_ndx) + & - reaction_rates(i,lev,ox_p3_ndx) * base_sol(i,lev,c2o3_ndx) + & - reaction_rates(i,lev,ox_p11_ndx) * base_sol(i,lev,xo2_ndx) - loss_out(i,lev,k) = loss_out(i,lev,k) + reaction_rates(i,lev,ox_l2_ndx) * & - base_sol(i,lev,oh_ndx) + reaction_rates(i,lev,ox_l3_ndx) * base_sol(i,lev,& - ho2_ndx) + .9_r8* reaction_rates(i,lev,ox_l5_ndx) * base_sol(i,lev,& - isop_ndx) + reaction_rates(i,lev,ox_l6_ndx) * base_sol(i,lev,c2h4_ndx) & - + reaction_rates(i,lev,ox_l7_ndx) * base_sol(i,lev,ole_ndx) - ELSE IF ( middle_atm_chem ) THEN - loss_out(i,lev,k) = loss_out(i,lev,k) + reaction_rates(i,lev,ox_l2_ndx) * & - base_sol(i,lev,oh_ndx) + reaction_rates(i,lev,ox_l3_ndx) * base_sol(i,lev,& - ho2_ndx) - END IF - IF (j == ox_ndx) THEN - IF (.not. middle_atm_chem) THEN - loss_out(i,lev,k) = loss_out(i,lev,k) + (reaction_rates(i,lev,& - usr4_ndx) * base_sol(i,lev,no2_ndx) * base_sol(i,lev,oh_ndx) + & - 3._r8 * reaction_rates(i,lev,usr16_ndx) * base_sol(i,lev,n2o5_ndx) & - + 2._r8 * reaction_rates(i,lev,usr17_ndx) * base_sol(i,lev,no3_ndx)) & - / max(base_sol(i,lev,ox_ndx),1.e-20_r8) - END IF - IF (present(o3s_loss)) THEN - o3s_loss(i,lev) = loss_out(i,lev,k) - END IF - loss_out(i,lev,k) = loss_out(i,lev,k) * base_sol(i,lev,ox_ndx) - prod_out(i,lev,k) = prod_out(i,lev,k) * base_sol(i,lev,no_ndx) - ELSE IF (j == o3a_ndx) THEN - loss_out(i,lev,k) = loss_out(i,lev,k) + (reaction_rates(i,lev,usr4a_ndx) & - * base_sol(i,lev,xno2_ndx) * base_sol(i,lev,oh_ndx) + 1._r8 * & - reaction_rates(i,lev,usr16a_ndx) * base_sol(i,lev,xno2no3_ndx) + 2._r8 * & - reaction_rates(i,lev,usr16b_ndx) * base_sol(i,lev,no2xno3_ndx) + 2._r8 * & - reaction_rates(i,lev,usr17b_ndx) * base_sol(i,lev,xno3_ndx)) / max(& - base_sol(i,lev,o3a_ndx),1.e-20_r8) - loss_out(i,lev,k) = loss_out(i,lev,k) * base_sol(i,lev,o3a_ndx) - prod_out(i,lev,k) = prod_out(i,lev,k) * base_sol(i,lev,xno_ndx) - END IF - ELSE - prod_out(i,lev,k) = prod(m) + ind_prd(i,lev,m) - loss_out(i,lev,k) = loss(m) - END IF has_o3_chem - END DO cls_loop2 - END DO column_loop - END DO level_loop - DO i = 1,clscnt4 - j = clsmap(i,4) - prod_out(:,:,i) = prod_out(:,:,i)*xhnm - loss_out(:,:,i) = loss_out(:,:,i)*xhnm - !kgen_excluded CALL outfld(trim(solsym(j))//'_CHMP', prod_out(:,:,i), ncol, lchnk) - !kgen_excluded CALL outfld(trim(solsym(j))//'_CHML', loss_out(:,:,i), ncol, lchnk) - ! - ! added code for ROOH production !PJY not "RO2 production" - ! - IF (trim(solsym(j)) == 'ALKOOH' .or.trim(solsym(j)) == 'C2H5OOH' .or.trim(solsym(j)) == 'CH3OOH' & - .or.trim(solsym(j)) == 'CH3COOH' .or.trim(solsym(j)) == 'CH3COOOH' .or.trim(solsym(j)) == & - 'C3H7OOH' .or.trim(solsym(j)) == 'EOOH' .or.trim(solsym(j)) == 'ISOPOOH' .or.trim(solsym(& - j)) == 'MACROOH' .or.trim(solsym(j)) == 'MEKOOH' .or.trim(solsym(j)) == 'POOH' .or.trim(& - solsym(j)) == 'ROOH' .or.trim(solsym(j)) == 'TERPOOH' .or.trim(solsym(j)) == 'TOLOOH' & - &.or.trim(solsym(j)) == 'XOOH') THEN - !PJY added this - !PJY corrected this (from CH3H7OOH) - ! .or.trim(solsym(j)) == 'H2O2' & !PJY removed as H2O2 production asked for separately (as I read 4.2.3, point 7) - ! .or.trim(solsym(j)) == 'HCOOH' & !PJY removed this as this is formic acid HC(O)OH - i.e. not H-C-O-O-H - ! - prod_hydrogen_peroxides_out(:,:) = prod_hydrogen_peroxides_out(:,:) + prod_out(:,:,i) - ! - END IF - ! - END DO - ! - !kgen_excluded CALL outfld('H_PEROX_CHMP', prod_hydrogen_peroxides_out(:,:), ncol, lchnk) - ! - END SUBROUTINE imp_sol - END MODULE mo_imp_sol diff --git a/test/ncar_kernels/WACCM_imp_sol/src/mo_indprd.F90 b/test/ncar_kernels/WACCM_imp_sol/src/mo_indprd.F90 deleted file mode 100644 index af63b81aea..0000000000 --- a/test/ncar_kernels/WACCM_imp_sol/src/mo_indprd.F90 +++ /dev/null @@ -1,222 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_indprd.F90 -! Generated at: 2015-05-13 11:02:23 -! KGEN version: 0.4.10 - - - - MODULE mo_indprd - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - PRIVATE - PUBLIC indprd - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - - SUBROUTINE indprd(class, prod, nprod, y, extfrc, rxt, ncol) - USE chem_mods, ONLY: gas_pcnst - USE chem_mods, ONLY: extcnt - USE chem_mods, ONLY: rxntot - USE ppgrid, ONLY: pver - IMPLICIT NONE - !-------------------------------------------------------------------- - ! ... dummy arguments - !-------------------------------------------------------------------- - INTEGER, intent(in) :: class - INTEGER, intent(in) :: ncol - INTEGER, intent(in) :: nprod - REAL(KIND=r8), intent(in) :: y(ncol,pver,gas_pcnst) - REAL(KIND=r8), intent(in) :: rxt(ncol,pver,rxntot) - REAL(KIND=r8), intent(in) :: extfrc(ncol,pver,extcnt) - REAL(KIND=r8), intent(inout) :: prod(ncol,pver,nprod) - !-------------------------------------------------------------------- - ! ... "independent" production for Explicit species - !-------------------------------------------------------------------- - IF (class == 1) THEN - prod(:,:,1) = .080_r8*rxt(:,:,314)*y(:,:,48)*y(:,:,1) - prod(:,:,2) = rxt(:,:,187)*y(:,:,7)*y(:,:,5) - prod(:,:,3) = 0._r8 - prod(:,:,4) = 0._r8 - prod(:,:,5) = 0._r8 - prod(:,:,6) = 0._r8 - prod(:,:,7) = 0._r8 - prod(:,:,8) = 0._r8 - prod(:,:,9) = 0._r8 - prod(:,:,10) = 0._r8 - prod(:,:,11) = 0._r8 - prod(:,:,12) = 0._r8 - prod(:,:,13) = 0._r8 - prod(:,:,14) = 0._r8 - prod(:,:,15) = 0._r8 - prod(:,:,16) = 0._r8 - prod(:,:,17) = 0._r8 - prod(:,:,18) = 0._r8 - prod(:,:,19) = 0._r8 - prod(:,:,20) = 0._r8 - prod(:,:,21) = (rxt(:,:,267)*y(:,:,17) +rxt(:,:,268)*y(:,:,17) + rxt(:,:,279)*y(:,:,99) +rxt(:,:,& - 294)*y(:,:,40) + .500_r8*rxt(:,:,307)*y(:,:,45) +.800_r8*rxt(:,:,308)*y(:,:,43) + & - rxt(:,:,309)*y(:,:,44) +.500_r8*rxt(:,:,358)*y(:,:,63))*y(:,:,129) + (rxt(:,:,302)*y(:,:,6) & - +.900_r8*rxt(:,:,305)*y(:,:,13) + 2.000_r8*rxt(:,:,306)*y(:,:,133) +2.000_r8*rxt(:,:,354)*y(:,:,& - 141) + rxt(:,:,382)*y(:,:,145))*y(:,:,133) + (rxt(:,:,353)*y(:,:,13) + & - 2.000_r8*rxt(:,:,355)*y(:,:,141))*y(:,:,141) +rxt(:,:,63)*y(:,:,45) +.400_r8*rxt(:,:,64)*y(:,:,& - 47) - prod(:,:,22) = 0._r8 - prod(:,:,23) = 0._r8 - !-------------------------------------------------------------------- - ! ... "independent" production for Implicit species - !-------------------------------------------------------------------- - ELSE IF (class == 4) THEN - prod(:,:,123) = 0._r8 - prod(:,:,121) = (rxt(:,:,58) +rxt(:,:,117))*y(:,:,97) +.180_r8*rxt(:,:,60) *y(:,:,12) - prod(:,:,122) = rxt(:,:,5)*y(:,:,4) - prod(:,:,120) = 0._r8 - prod(:,:,28) = 0._r8 - prod(:,:,27) = 0._r8 - prod(:,:,108) = 1.440_r8*rxt(:,:,60)*y(:,:,12) - prod(:,:,103) = (rxt(:,:,58) +rxt(:,:,117))*y(:,:,97) +.380_r8*rxt(:,:,60) *y(:,:,12) + extfrc(:,& - :,3) - prod(:,:,92) = (rxt(:,:,101) +.800_r8*rxt(:,:,104) +rxt(:,:,113) + .800_r8*rxt(:,:,116)) + & - extfrc(:,:,16) - prod(:,:,129) = + extfrc(:,:,1) - prod(:,:,130) = + extfrc(:,:,2) - prod(:,:,131) = .660_r8*rxt(:,:,60)*y(:,:,12) + extfrc(:,:,18) - prod(:,:,132) = 0._r8 - prod(:,:,133) = 0._r8 - prod(:,:,60) = 0._r8 - prod(:,:,40) = 0._r8 - prod(:,:,119) = rxt(:,:,59)*y(:,:,12) +rxt(:,:,37)*y(:,:,79) +rxt(:,:,48) *y(:,:,80) - prod(:,:,50) = 0._r8 - prod(:,:,30) = 0._r8 - prod(:,:,17) = 0._r8 - prod(:,:,135) = .180_r8*rxt(:,:,60)*y(:,:,12) - prod(:,:,127) = rxt(:,:,59)*y(:,:,12) - prod(:,:,125) = 0._r8 - prod(:,:,74) = 0._r8 - prod(:,:,134) = .050_r8*rxt(:,:,60)*y(:,:,12) - prod(:,:,126) = rxt(:,:,37)*y(:,:,79) +2.000_r8*rxt(:,:,40)*y(:,:,81) +2.000_r8*rxt(:,:,41)*y(:,& - :,82) +2.000_r8*rxt(:,:,42)*y(:,:,83) +rxt(:,:,45)*y(:,:,84) +4.000_r8*rxt(:,:,38)*y(:,:,85) & - +3.000_r8*rxt(:,:,39)*y(:,:,86) +rxt(:,:,50)*y(:,:,88) +rxt(:,:,46) *y(:,:,89) & - +rxt(:,:,47)*y(:,:,90) +2.000_r8*rxt(:,:,43)*y(:,:,91) +rxt(:,:,44)*y(:,:,92) - prod(:,:,29) = 0._r8 - prod(:,:,124) = 0._r8 - prod(:,:,46) = 0._r8 - prod(:,:,18) = 0._r8 - prod(:,:,117) = 0._r8 - prod(:,:,93) = 0._r8 - prod(:,:,100) = 0._r8 - prod(:,:,33) = 0._r8 - prod(:,:,118) = rxt(:,:,48)*y(:,:,80) +rxt(:,:,49)*y(:,:,87) +rxt(:,:,50) *y(:,:,88) & - +2.000_r8*rxt(:,:,53)*y(:,:,93) +2.000_r8*rxt(:,:,54) *y(:,:,94) +3.000_r8*rxt(:,:,51)*y(:,:,95) & - +2.000_r8*rxt(:,:,52) *y(:,:,96) - prod(:,:,128) = 0._r8 - prod(:,:,90) = 0._r8 - prod(:,:,84) = 0._r8 - prod(:,:,70) = 0._r8 - prod(:,:,78) = (rxt(:,:,97) +rxt(:,:,109)) + extfrc(:,:,14) - prod(:,:,85) = + extfrc(:,:,12) - prod(:,:,58) = (rxt(:,:,101) +rxt(:,:,102) +rxt(:,:,113) +rxt(:,:,114)) + extfrc(:,:,13) - prod(:,:,72) = + extfrc(:,:,11) - prod(:,:,86) = 0._r8 - prod(:,:,61) = (rxt(:,:,102) +1.200_r8*rxt(:,:,104) +rxt(:,:,114) + 1.200_r8*rxt(:,:,116)) + & - extfrc(:,:,15) - prod(:,:,87) = (rxt(:,:,97) +rxt(:,:,101) +rxt(:,:,102) +rxt(:,:,109) + rxt(:,:,113) +rxt(:,:,& - 114)) + extfrc(:,:,17) - prod(:,:,102) = 0._r8 - prod(:,:,94) = 0._r8 - prod(:,:,89) = 0._r8 - prod(:,:,104) = 0._r8 - prod(:,:,75) = 0._r8 - prod(:,:,67) = 0._r8 - prod(:,:,115) = 0._r8 - prod(:,:,62) = 0._r8 - prod(:,:,57) = 0._r8 - prod(:,:,49) = 0._r8 - prod(:,:,37) = 0._r8 - prod(:,:,63) = 0._r8 - prod(:,:,19) = 0._r8 - prod(:,:,71) = 0._r8 - prod(:,:,20) = 0._r8 - prod(:,:,41) = 0._r8 - prod(:,:,79) = 0._r8 - prod(:,:,76) = 0._r8 - prod(:,:,55) = 0._r8 - prod(:,:,77) = 0._r8 - prod(:,:,42) = 0._r8 - prod(:,:,22) = 0._r8 - prod(:,:,23) = 0._r8 - prod(:,:,65) = 0._r8 - prod(:,:,51) = 0._r8 - prod(:,:,31) = 0._r8 - prod(:,:,98) = 0._r8 - prod(:,:,59) = 0._r8 - prod(:,:,66) = 0._r8 - prod(:,:,81) = 0._r8 - prod(:,:,111) = 0._r8 - prod(:,:,113) = 0._r8 - prod(:,:,107) = 0._r8 - prod(:,:,112) = 0._r8 - prod(:,:,43) = 0._r8 - prod(:,:,114) = 0._r8 - prod(:,:,91) = 0._r8 - prod(:,:,44) = 0._r8 - prod(:,:,73) = 0._r8 - prod(:,:,21) = 0._r8 - prod(:,:,96) = 0._r8 - prod(:,:,52) = 0._r8 - prod(:,:,80) = 0._r8 - prod(:,:,53) = 0._r8 - prod(:,:,68) = 0._r8 - prod(:,:,35) = 0._r8 - prod(:,:,95) = 0._r8 - prod(:,:,105) = 0._r8 - prod(:,:,83) = 0._r8 - prod(:,:,56) = 0._r8 - prod(:,:,24) = 0._r8 - prod(:,:,47) = 0._r8 - prod(:,:,106) = 0._r8 - prod(:,:,109) = 0._r8 - prod(:,:,101) = 0._r8 - prod(:,:,97) = 0._r8 - prod(:,:,110) = 0._r8 - prod(:,:,45) = 0._r8 - prod(:,:,69) = 0._r8 - prod(:,:,38) = 0._r8 - prod(:,:,64) = 0._r8 - prod(:,:,54) = 0._r8 - prod(:,:,25) = rxt(:,:,41)*y(:,:,82) +rxt(:,:,42)*y(:,:,83) +rxt(:,:,45) *y(:,:,84) +rxt(:,:,49)& - *y(:,:,87) +rxt(:,:,50)*y(:,:,88) +rxt(:,:,47) *y(:,:,90) +2.000_r8*rxt(:,:,43)*y(:,:,91) & - +2.000_r8*rxt(:,:,44) *y(:,:,92) +rxt(:,:,53)*y(:,:,93) +2.000_r8*rxt(:,:,54)*y(:,:,94) - prod(:,:,32) = rxt(:,:,40)*y(:,:,81) +rxt(:,:,42)*y(:,:,83) +rxt(:,:,46) *y(:,:,89) - prod(:,:,34) = 0._r8 - prod(:,:,88) = rxt(:,:,49)*y(:,:,87) +rxt(:,:,44)*y(:,:,92) - prod(:,:,99) = + extfrc(:,:,4) - prod(:,:,39) = 0._r8 - prod(:,:,48) = 0._r8 - prod(:,:,82) = 0._r8 - prod(:,:,116) = 0._r8 - prod(:,:,36) = 0._r8 - prod(:,:,26) = 0._r8 - prod(:,:,1) = 0._r8 - prod(:,:,2) = + extfrc(:,:,5) - prod(:,:,3) = + extfrc(:,:,7) - prod(:,:,4) = 0._r8 - prod(:,:,5) = + extfrc(:,:,8) - prod(:,:,6) = 0._r8 - prod(:,:,7) = 0._r8 - prod(:,:,8) = + extfrc(:,:,9) - prod(:,:,9) = + extfrc(:,:,6) - prod(:,:,10) = 0._r8 - prod(:,:,11) = 0._r8 - prod(:,:,12) = + extfrc(:,:,10) - prod(:,:,13) = 0._r8 - prod(:,:,14) = 0._r8 - prod(:,:,15) = 0._r8 - prod(:,:,16) = 0._r8 - END IF - END SUBROUTINE indprd - END MODULE mo_indprd diff --git a/test/ncar_kernels/WACCM_imp_sol/src/mo_lin_matrix.F90 b/test/ncar_kernels/WACCM_imp_sol/src/mo_lin_matrix.F90 deleted file mode 100644 index e33a91cfa2..0000000000 --- a/test/ncar_kernels/WACCM_imp_sol/src/mo_lin_matrix.F90 +++ /dev/null @@ -1,446 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_lin_matrix.F90 -! Generated at: 2015-05-13 11:02:22 -! KGEN version: 0.4.10 - - - - MODULE mo_lin_matrix - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - PRIVATE - PUBLIC linmat - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - - SUBROUTINE linmat01(mat, y, rxt, het_rates) - !---------------------------------------------- - ! ... linear matrix entries for implicit species - !---------------------------------------------- - USE chem_mods, ONLY: nzcnt - USE chem_mods, ONLY: gas_pcnst - USE chem_mods, ONLY: rxntot - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !---------------------------------------------- - ! ... dummy arguments - !---------------------------------------------- - REAL(KIND=r8), intent(in) :: y(gas_pcnst) - REAL(KIND=r8), intent(in) :: rxt(rxntot) - REAL(KIND=r8), intent(in) :: het_rates(max(1,gas_pcnst)) - REAL(KIND=r8), intent(inout) :: mat(nzcnt) - mat(1016) = -(rxt(3) + rxt(4) + het_rates(1)) - mat(943) = -(rxt(92) + rxt(93) + rxt(94) + rxt(105) + rxt(106) + rxt(107) + het_rates(2)) - mat(904) = rxt(1) + 2.000_r8*rxt(2) + rxt(98) + rxt(99) + rxt(100) + 2.000_r8*rxt(103) + rxt(& - 110) + rxt(111) + rxt(112) + 2.000_r8*rxt(115) - mat(1014) = rxt(4) - mat(1244) = rxt(6) - mat(1281) = rxt(8) - mat(103) = rxt(10) - mat(1423) = rxt(12) - mat(1471) = rxt(21) - mat(1041) = rxt(24) - mat(137) = rxt(25) - mat(1189) = rxt(32) - mat(554) = rxt(88) - mat(82) = rxt(89) - mat(808) = rxt(91) - mat(969) = rxt(131) - mat(970) = -(rxt(131) + rxt(135)*y(4) + rxt(136)*y(4) + rxt(138)*y(81) + rxt(139)*y(82) + rxt(& - 140)*y(83) + rxt(141)*y(91) + rxt(142)*y(92) + rxt(143)*y(84) + rxt(144)*y(89) + rxt(145)*y(90) & - + rxt(146)*y(85) + rxt(147)*y(80) + rxt(148)*y(88) + rxt(149)*y(87) + rxt(150)*y(93) & - + rxt(151)*y(94) + rxt(152)*y(95) + rxt(153)*y(96) + rxt(156)*y(12) + rxt(157)*y(12) & - + rxt(158)*y(12) + het_rates(157)) - mat(905) = rxt(1) - mat(1015) = rxt(3) - mat(1472) = rxt(20) - mat(903) = -(rxt(1) + rxt(2) + rxt(96) + rxt(98) + rxt(99) + rxt(100) + rxt(103) + rxt(108) + & - rxt(110) + rxt(111) + rxt(112) + rxt(115) + het_rates(3)) - mat(1013) = rxt(4) - mat(1422) = rxt(13) - mat(54) = rxt(126) - mat(51) = rxt(129) + rxt(130) - mat(968) = rxt(136)*y(4) - mat(53) = -(rxt(123) + rxt(126) + rxt(125)*y(97) + het_rates(155)) - mat(50) = -(rxt(129) + rxt(130) + het_rates(156)) - mat(984) = rxt(3) - mat(52) = rxt(123) + rxt(125)*y(97) - mat(650) = -(het_rates(18)) - mat(1490) = rxt(18) - mat(1465) = rxt(20) - mat(964) = rxt(158)*y(12) - mat(602) = -(het_rates(17)) - mat(1489) = rxt(17) + rxt(18) - mat(606) = rxt(61) - mat(636) = 1.340_r8*rxt(67) - mat(735) = .700_r8*rxt(68) - mat(661) = rxt(74) - mat(531) = rxt(76) - mat(511) = rxt(79) - mat(256) = .450_r8*rxt(81) - mat(376) = 2.000_r8*rxt(82) - mat(145) = rxt(90) - mat(1137) = rxt(254)*y(79) - mat(300) = rxt(439)*y(97) - mat(476) = -(rxt(95) + het_rates(5)) - mat(1223) = rxt(6) - mat(299) = rxt(436) - mat(1252) = -(rxt(6) + rxt(7) + het_rates(6)) - mat(1289) = rxt(8) + .500_r8*rxt(399) - mat(104) = rxt(10) - mat(1431) = rxt(13) - mat(412) = rxt(446) - mat(977) = 2.000_r8*rxt(135)*y(4) - mat(1290) = -(rxt(8) + rxt(399) + het_rates(7)) - mat(105) = rxt(9) + rxt(197) - mat(1454) = rxt(11) - mat(1432) = rxt(12) - mat(218) = rxt(15) + rxt(206) - mat(565) = rxt(30) - mat(285) = rxt(36) - mat(197) = .600_r8*rxt(64) + rxt(311) - mat(292) = rxt(65) + rxt(357) - mat(534) = rxt(76) - mat(1389) = -(rxt(255)*y(79) + rxt(256)*y(86) + rxt(257)*y(84) + rxt(258)*y(80) + rxt(260)*y(89)& - + rxt(261)*y(90) + rxt(262)*y(96) + rxt(263)*y(95) + rxt(266)*y(12) + het_rates(129)) - mat(1455) = rxt(11) - mat(219) = rxt(14) - mat(157) = rxt(16) - mat(1481) = rxt(19) - mat(317) = 2.000_r8*rxt(22) - mat(491) = rxt(27) - mat(403) = rxt(33) - mat(265) = rxt(62) - mat(230) = rxt(63) - mat(129) = rxt(69) - mat(43) = rxt(70) - mat(170) = rxt(71) - mat(175) = rxt(72) - mat(132) = rxt(75) - mat(332) = rxt(83) - mat(119) = rxt(84) - mat(165) = rxt(85) - mat(214) = rxt(86) - mat(1291) = .500_r8*rxt(399) - mat(979) = rxt(156)*y(12) - mat(1434) = -(rxt(12) + rxt(13) + rxt(398) + het_rates(8)) - mat(106) = rxt(9) + rxt(10) + rxt(197) - mat(220) = rxt(14) - mat(567) = rxt(29) - mat(286) = rxt(35) - mat(199) = .400_r8*rxt(64) - mat(1457) = -(rxt(11) + het_rates(9)) - mat(107) = 2.000_r8*rxt(397) + 2.000_r8*rxt(418) + 2.000_r8*rxt(424) + 2.000_r8*rxt(429) - mat(1435) = rxt(398) - mat(1293) = .500_r8*rxt(399) - mat(568) = rxt(419) + rxt(425) + rxt(430) - mat(287) = rxt(420) + rxt(428) + rxt(431) - mat(215) = -(rxt(14) + rxt(15) + rxt(206) + het_rates(10)) - mat(102) = -(rxt(9) + rxt(10) + rxt(197) + rxt(397) + rxt(418) + rxt(424) + rxt(429) + & - het_rates(11)) - mat(872) = -(het_rates(13)) - mat(609) = rxt(61) - mat(229) = rxt(63) - mat(196) = .400_r8*rxt(64) - mat(743) = .300_r8*rxt(68) - mat(372) = rxt(73) - mat(967) = rxt(156)*y(12) - mat(1143) = rxt(213)*y(12) - mat(435) = rxt(252)*y(12) - mat(1377) = rxt(266)*y(12) - mat(154) = -(rxt(16) + het_rates(14)) - mat(57) = -(het_rates(35)) - mat(17) = -(het_rates(36)) - mat(1509) = -(rxt(17) + rxt(18) + het_rates(16)) - mat(159) = rxt(16) - mat(267) = rxt(62) - mat(647) = 1.340_r8*rxt(66) - mat(177) = rxt(72) - mat(537) = rxt(76) - mat(279) = .690_r8*rxt(77) - mat(621) = rxt(78) - mat(514) = rxt(79) - mat(333) = .100_r8*rxt(83) - mat(183) = rxt(280) - mat(193) = 2.000_r8*rxt(292) - mat(983) = rxt(157)*y(12) + rxt(158)*y(12) - mat(1171) = -(het_rates(19)) - mat(156) = rxt(16) - mat(1501) = 2.000_r8*rxt(17) - mat(1477) = rxt(19) + 2.000_r8*rxt(21) - mat(830) = rxt(28) - mat(456) = rxt(34) - mat(74) = rxt(57) - mat(975) = rxt(157)*y(12) - mat(1114) = -(rxt(400) + het_rates(130)) - mat(217) = rxt(15) + rxt(206) - mat(610) = rxt(61) - mat(264) = rxt(62) - mat(643) = 1.340_r8*rxt(66) + .660_r8*rxt(67) - mat(128) = rxt(69) - mat(169) = rxt(71) - mat(664) = rxt(74) - mat(533) = rxt(76) - mat(277) = rxt(77) - mat(619) = rxt(78) - mat(512) = 2.000_r8*rxt(79) - mat(259) = .560_r8*rxt(81) - mat(377) = 2.000_r8*rxt(82) - mat(331) = .900_r8*rxt(83) - mat(213) = rxt(86) - mat(180) = rxt(280) - mat(192) = rxt(292) - mat(973) = rxt(157)*y(12) - mat(1149) = rxt(254)*y(79) + rxt(259)*y(80) - mat(1383) = rxt(255)*y(79) + rxt(258)*y(80) - mat(312) = -(rxt(22) + het_rates(20)) - mat(1075) = .500_r8*rxt(400) - mat(1484) = -(rxt(19) + rxt(20) + rxt(21) + het_rates(158)) - mat(49) = rxt(87) - mat(1392) = rxt(255)*y(79) + rxt(256)*y(86) + rxt(257)*y(84) + rxt(258)*y(80) + rxt(262)*y(96) & - + rxt(266)*y(12) - mat(1150) = -(rxt(213)*y(12) + rxt(254)*y(79) + rxt(259)*y(80) + rxt(264)*y(96) + rxt(265)*y(95)& - + het_rates(127)) - mat(56) = 2.000_r8*rxt(23) - mat(1046) = rxt(24) - mat(22) = 2.000_r8*rxt(26) - mat(490) = rxt(27) - mat(829) = rxt(28) - mat(564) = rxt(29) - mat(71) = rxt(31) - mat(68) = rxt(56) - mat(974) = 2.000_r8*rxt(138)*y(81) + 2.000_r8*rxt(139)*y(82) + 2.000_r8*rxt(140)*y(83) + & - 2.000_r8*rxt(141)*y(91) + rxt(142)*y(92) + rxt(143)*y(84) + rxt(144)*y(89) + rxt(145)*y(90) & - + 4.000_r8*rxt(146)*y(85) + rxt(148)*y(88) - mat(1384) = rxt(255)*y(79) + 3.000_r8*rxt(256)*y(86) + rxt(257)*y(84) + rxt(260)*y(89) + rxt(& - 261)*y(90) - mat(55) = -(rxt(23) + het_rates(23)) - mat(1044) = -(rxt(24) + het_rates(24)) - mat(138) = rxt(25) - mat(563) = rxt(30) - mat(21) = 2.000_r8*rxt(225) - mat(134) = -(rxt(25) + het_rates(25)) - mat(20) = -(rxt(26) + rxt(225) + het_rates(26)) - mat(824) = -(rxt(28) + het_rates(27)) - mat(1141) = rxt(213)*y(12) + 2.000_r8*rxt(254)*y(79) + rxt(259)*y(80) + rxt(264)*y(96) + rxt(& - 265)*y(95) - END SUBROUTINE linmat01 - - SUBROUTINE linmat02(mat, y, rxt, het_rates) - !---------------------------------------------- - ! ... linear matrix entries for implicit species - !---------------------------------------------- - USE chem_mods, ONLY: nzcnt - USE chem_mods, ONLY: gas_pcnst - USE chem_mods, ONLY: rxntot - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !---------------------------------------------- - ! ... dummy arguments - !---------------------------------------------- - REAL(KIND=r8), intent(in) :: y(gas_pcnst) - REAL(KIND=r8), intent(in) :: rxt(rxntot) - REAL(KIND=r8), intent(in) :: het_rates(max(1,gas_pcnst)) - REAL(KIND=r8), intent(inout) :: mat(nzcnt) - mat(486) = -(rxt(27) + het_rates(28)) - mat(559) = rxt(419) + rxt(425) + rxt(430) - mat(560) = -(rxt(29) + rxt(30) + rxt(419) + rxt(425) + rxt(430) + het_rates(29)) - mat(69) = -(rxt(31) + het_rates(30)) - mat(839) = -(het_rates(128)) - mat(70) = rxt(31) - mat(1187) = rxt(32) - mat(399) = rxt(33) - mat(453) = rxt(34) - mat(282) = rxt(35) - mat(966) = rxt(147)*y(80) + rxt(148)*y(88) + rxt(149)*y(87) + 2.000_r8*rxt(150)*y(93) + & - 2.000_r8*rxt(151)*y(94) + 3.000_r8*rxt(152)*y(95) + 2.000_r8*rxt(153)*y(96) - mat(1376) = rxt(258)*y(80) + 2.000_r8*rxt(262)*y(96) + 3.000_r8*rxt(263)*y(95) - mat(1142) = rxt(259)*y(80) + 2.000_r8*rxt(264)*y(96) + 3.000_r8*rxt(265)*y(95) - mat(1196) = -(rxt(32) + het_rates(31)) - mat(284) = rxt(36) - mat(452) = -(rxt(34) + het_rates(32)) - mat(397) = -(rxt(33) + het_rates(33)) - mat(281) = rxt(420) + rxt(428) + rxt(431) - mat(280) = -(rxt(35) + rxt(36) + rxt(420) + rxt(428) + rxt(431) + het_rates(34)) - mat(344) = -(het_rates(148)) - mat(405) = -(rxt(446) + het_rates(149)) - mat(894) = rxt(96) + rxt(108) - mat(297) = rxt(439)*y(97) - mat(201) = -(het_rates(150)) - mat(471) = rxt(95) - mat(296) = -(rxt(436) + rxt(439)*y(97) + het_rates(151)) - mat(923) = rxt(92) + rxt(93) + rxt(94) + rxt(105) + rxt(106) + rxt(107) - mat(891) = rxt(98) + rxt(99) + rxt(100) + rxt(110) + rxt(111) + rxt(112) - mat(414) = -(het_rates(152)) - mat(1219) = rxt(7) - mat(298) = rxt(436) - mat(406) = rxt(446) - mat(222) = -(het_rates(154)) - mat(425) = -(het_rates(153)) - mat(1220) = rxt(7) - mat(930) = rxt(92) + rxt(93) + rxt(94) + rxt(105) + rxt(106) + rxt(107) - mat(475) = rxt(95) - mat(896) = rxt(96) + rxt(98) + rxt(99) + rxt(100) + rxt(108) + rxt(110) + rxt(111) + rxt(112) - mat(587) = -(het_rates(48)) - mat(734) = .700_r8*rxt(68) - mat(494) = -(het_rates(65)) - mat(442) = -(het_rates(137)) - mat(607) = -(rxt(61) + het_rates(41)) - mat(262) = rxt(62) - mat(127) = rxt(69) - mat(329) = .400_r8*rxt(83) - mat(117) = rxt(84) - mat(319) = -(het_rates(40)) - mat(260) = -(rxt(62) + het_rates(52)) - mat(789) = -(het_rates(133)) - mat(195) = .600_r8*rxt(64) + rxt(311) - mat(641) = 1.340_r8*rxt(66) - mat(742) = .300_r8*rxt(68) - mat(174) = rxt(72) - mat(371) = rxt(73) - mat(663) = rxt(74) - mat(618) = rxt(78) - mat(187) = rxt(80) - mat(258) = .130_r8*rxt(81) - mat(118) = rxt(84) - mat(227) = -(rxt(63) + het_rates(45)) - mat(194) = -(rxt(64) + rxt(311) + het_rates(47)) - mat(150) = -(het_rates(64)) - mat(84) = -(het_rates(38)) - mat(233) = -(het_rates(37)) - mat(23) = -(het_rates(57)) - mat(288) = -(rxt(65) + rxt(357) + het_rates(63)) - mat(26) = -(het_rates(56)) - mat(108) = -(het_rates(139)) - mat(358) = -(het_rates(143)) - mat(324) = -(rxt(83) + het_rates(66)) - mat(184) = -(rxt(80) + het_rates(58)) - mat(323) = .800_r8*rxt(83) - mat(335) = -(het_rates(140)) - mat(115) = -(rxt(84) + het_rates(59)) - mat(33) = -(het_rates(73)) - mat(38) = -(het_rates(74)) - mat(246) = -(het_rates(146)) - mat(160) = -(rxt(85) + het_rates(75)) - mat(61) = -(het_rates(76)) - mat(540) = -(het_rates(147)) - mat(208) = -(rxt(86) + het_rates(78)) - mat(254) = -(rxt(81) + het_rates(67)) - mat(162) = .900_r8*rxt(85) - mat(375) = -(rxt(82) + het_rates(44)) - mat(255) = .130_r8*rxt(81) - mat(163) = .450_r8*rxt(85) - mat(697) = -(het_rates(144)) - mat(740) = -(rxt(68) + het_rates(60)) - mat(276) = .402_r8*rxt(77) - mat(212) = rxt(86) - mat(637) = -(rxt(66) + rxt(67) + het_rates(61)) - mat(273) = .288_r8*rxt(77) - mat(211) = rxt(86) - mat(721) = -(het_rates(142)) - mat(120) = -(het_rates(62)) - mat(760) = -(het_rates(141)) - mat(290) = rxt(65) + rxt(357) - mat(640) = .660_r8*rxt(66) - mat(462) = -(het_rates(132)) - mat(186) = rxt(80) - mat(125) = -(rxt(69) + het_rates(39)) - mat(303) = -(het_rates(77)) - mat(29) = -(het_rates(49)) - mat(517) = -(het_rates(136)) - mat(166) = -(rxt(71) + het_rates(50)) - mat(369) = -(rxt(73) + het_rates(51)) - mat(167) = .820_r8*rxt(71) - mat(327) = .250_r8*rxt(83) - mat(209) = .100_r8*rxt(86) - mat(172) = -(rxt(72) + het_rates(55)) - mat(268) = -(het_rates(15)) - mat(75) = -(het_rates(42)) - mat(510) = -(rxt(79) + het_rates(43)) - mat(616) = -(rxt(78) + het_rates(53)) - mat(388) = -(het_rates(134)) - mat(189) = -(rxt(292) + het_rates(135)) - mat(42) = rxt(70) - mat(41) = -(rxt(70) + het_rates(46)) - mat(139) = -(het_rates(68)) - mat(625) = -(het_rates(138)) - mat(662) = -(rxt(74) + het_rates(54)) - mat(257) = .180_r8*rxt(81) - mat(164) = .450_r8*rxt(85) - mat(572) = -(het_rates(69)) - mat(530) = -(rxt(76) + het_rates(70)) - mat(677) = -(het_rates(145)) - mat(130) = -(rxt(75) + het_rates(71)) - mat(272) = -(rxt(77) + het_rates(72)) - mat(90) = -(het_rates(98)) - mat(241) = -(het_rates(99)) - mat(178) = -(rxt(280) + het_rates(131)) - mat(44) = -(rxt(55) + het_rates(100)) - mat(958) = rxt(139)*y(82) + rxt(140)*y(83) + 2.000_r8*rxt(141)*y(91) + 2.000_r8*rxt(142)*y(92) & - + rxt(143)*y(84) + rxt(145)*y(90) + rxt(148)*y(88) + rxt(149)*y(87) + rxt(150)*y(93) & - + 2.000_r8*rxt(151)*y(94) - mat(1302) = rxt(257)*y(84) + rxt(261)*y(90) - mat(65) = -(rxt(56) + het_rates(101)) - mat(961) = rxt(138)*y(81) + rxt(140)*y(83) + rxt(144)*y(89) - mat(1305) = rxt(260)*y(89) - mat(72) = -(rxt(57) + het_rates(102)) - mat(432) = rxt(252)*y(12) - mat(433) = -(rxt(252)*y(12) + het_rates(103)) - mat(45) = 2.000_r8*rxt(55) - mat(66) = rxt(56) - mat(73) = rxt(57) - mat(962) = rxt(142)*y(92) + rxt(149)*y(87) - mat(552) = -(rxt(88) + het_rates(104)) - mat(81) = rxt(89) - mat(96) = -(het_rates(105)) - mat(142) = -(rxt(90) + het_rates(106)) - mat(379) = -(het_rates(107)) - mat(143) = rxt(90) - mat(803) = rxt(91) - mat(805) = -(rxt(91) + het_rates(108)) - mat(553) = rxt(88) - mat(80) = -(rxt(89) + het_rates(109)) - mat(48) = rxt(87) - mat(47) = -(rxt(87) + het_rates(110)) - mat(1) = -(het_rates(111)) - mat(2) = -(het_rates(112)) - mat(3) = -(het_rates(113)) - mat(4) = -(het_rates(114)) - mat(5) = -(het_rates(115)) - mat(6) = -(het_rates(116)) - mat(7) = -(het_rates(117)) - mat(8) = -(het_rates(118)) - mat(9) = -(het_rates(119)) - mat(10) = -(het_rates(120)) - mat(11) = -(het_rates(121)) - mat(12) = -(het_rates(122)) - mat(13) = -(het_rates(123)) - mat(14) = -(het_rates(124)) - mat(15) = -(het_rates(125)) - mat(16) = -(het_rates(126)) - END SUBROUTINE linmat02 - - SUBROUTINE linmat(mat, y, rxt, het_rates) - !---------------------------------------------- - ! ... linear matrix entries for implicit species - !---------------------------------------------- - USE chem_mods, ONLY: nzcnt - USE chem_mods, ONLY: gas_pcnst - USE chem_mods, ONLY: rxntot - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !---------------------------------------------- - ! ... dummy arguments - !---------------------------------------------- - REAL(KIND=r8), intent(in) :: y(gas_pcnst) - REAL(KIND=r8), intent(in) :: rxt(rxntot) - REAL(KIND=r8), intent(in) :: het_rates(max(1,gas_pcnst)) - REAL(KIND=r8), intent(inout) :: mat(nzcnt) - CALL linmat01(mat, y, rxt, het_rates) - CALL linmat02(mat, y, rxt, het_rates) - END SUBROUTINE linmat - END MODULE mo_lin_matrix diff --git a/test/ncar_kernels/WACCM_imp_sol/src/mo_lu_factor.F90 b/test/ncar_kernels/WACCM_imp_sol/src/mo_lu_factor.F90 deleted file mode 100644 index 98efeddaea..0000000000 --- a/test/ncar_kernels/WACCM_imp_sol/src/mo_lu_factor.F90 +++ /dev/null @@ -1,5823 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_lu_factor.F90 -! Generated at: 2015-05-13 11:02:22 -! KGEN version: 0.4.10 - - - - MODULE mo_lu_factor - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - PRIVATE - PUBLIC lu_fac - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - - SUBROUTINE lu_fac01(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(1) = 1._r8 / lu(1) - lu(2) = 1._r8 / lu(2) - lu(3) = 1._r8 / lu(3) - lu(4) = 1._r8 / lu(4) - lu(5) = 1._r8 / lu(5) - lu(6) = 1._r8 / lu(6) - lu(7) = 1._r8 / lu(7) - lu(8) = 1._r8 / lu(8) - lu(9) = 1._r8 / lu(9) - lu(10) = 1._r8 / lu(10) - lu(11) = 1._r8 / lu(11) - lu(12) = 1._r8 / lu(12) - lu(13) = 1._r8 / lu(13) - lu(14) = 1._r8 / lu(14) - lu(15) = 1._r8 / lu(15) - lu(16) = 1._r8 / lu(16) - lu(17) = 1._r8 / lu(17) - lu(18) = lu(18) * lu(17) - lu(19) = lu(19) * lu(17) - lu(1383) = lu(1383) - lu(18) * lu(1296) - lu(1389) = lu(1389) - lu(19) * lu(1296) - lu(20) = 1._r8 / lu(20) - lu(21) = lu(21) * lu(20) - lu(22) = lu(22) * lu(20) - lu(1044) = lu(1044) - lu(21) * lu(1029) - lu(1046) = lu(1046) - lu(22) * lu(1029) - lu(23) = 1._r8 / lu(23) - lu(24) = lu(24) * lu(23) - lu(25) = lu(25) * lu(23) - lu(1341) = lu(1341) - lu(24) * lu(1297) - lu(1389) = lu(1389) - lu(25) * lu(1297) - lu(26) = 1._r8 / lu(26) - lu(27) = lu(27) * lu(26) - lu(28) = lu(28) * lu(26) - lu(1311) = lu(1311) - lu(27) * lu(1298) - lu(1389) = lu(1389) - lu(28) * lu(1298) - lu(29) = 1._r8 / lu(29) - lu(30) = lu(30) * lu(29) - lu(31) = lu(31) * lu(29) - lu(32) = lu(32) * lu(29) - lu(1354) = lu(1354) - lu(30) * lu(1299) - lu(1389) = lu(1389) - lu(31) * lu(1299) - lu(1392) = lu(1392) - lu(32) * lu(1299) - lu(33) = 1._r8 / lu(33) - lu(34) = lu(34) * lu(33) - lu(35) = lu(35) * lu(33) - lu(36) = lu(36) * lu(33) - lu(37) = lu(37) * lu(33) - lu(1301) = lu(1301) - lu(34) * lu(1300) - lu(1330) = lu(1330) - lu(35) * lu(1300) - lu(1383) = lu(1383) - lu(36) * lu(1300) - lu(1389) = lu(1389) - lu(37) * lu(1300) - lu(38) = 1._r8 / lu(38) - lu(39) = lu(39) * lu(38) - lu(40) = lu(40) * lu(38) - lu(1304) = lu(1304) - lu(39) * lu(1301) - lu(1389) = lu(1389) - lu(40) * lu(1301) - lu(41) = 1._r8 / lu(41) - lu(42) = lu(42) * lu(41) - lu(43) = lu(43) * lu(41) - lu(387) = lu(387) - lu(42) * lu(386) - lu(394) = - lu(43) * lu(386) - lu(1066) = - lu(42) * lu(1056) - lu(1120) = lu(1120) - lu(43) * lu(1056) - lu(44) = 1._r8 / lu(44) - lu(45) = lu(45) * lu(44) - lu(46) = lu(46) * lu(44) - lu(962) = lu(962) - lu(45) * lu(958) - lu(970) = lu(970) - lu(46) * lu(958) - lu(1346) = - lu(45) * lu(1302) - lu(1380) = - lu(46) * lu(1302) - lu(47) = 1._r8 / lu(47) - lu(48) = lu(48) * lu(47) - lu(49) = lu(49) * lu(47) - lu(80) = lu(80) - lu(48) * lu(79) - lu(83) = lu(83) - lu(49) * lu(79) - lu(1462) = lu(1462) - lu(48) * lu(1460) - lu(1484) = lu(1484) - lu(49) * lu(1460) - END SUBROUTINE lu_fac01 - - SUBROUTINE lu_fac02(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(50) = 1._r8 / lu(50) - lu(51) = lu(51) * lu(50) - lu(54) = lu(54) - lu(51) * lu(52) - lu(903) = lu(903) - lu(51) * lu(886) - lu(942) = lu(942) - lu(51) * lu(917) - lu(1013) = lu(1013) - lu(51) * lu(984) - lu(53) = 1._r8 / lu(53) - lu(54) = lu(54) * lu(53) - lu(903) = lu(903) - lu(54) * lu(887) - lu(942) = lu(942) - lu(54) * lu(918) - lu(968) = lu(968) - lu(54) * lu(959) - lu(1013) = lu(1013) - lu(54) * lu(985) - lu(55) = 1._r8 / lu(55) - lu(56) = lu(56) * lu(55) - lu(490) = lu(490) - lu(56) * lu(485) - lu(564) = lu(564) - lu(56) * lu(558) - lu(829) = lu(829) - lu(56) * lu(819) - lu(1046) = lu(1046) - lu(56) * lu(1030) - lu(1150) = lu(1150) - lu(56) * lu(1125) - lu(57) = 1._r8 / lu(57) - lu(58) = lu(58) * lu(57) - lu(59) = lu(59) * lu(57) - lu(60) = lu(60) * lu(57) - lu(970) = lu(970) - lu(58) * lu(960) - lu(973) = lu(973) - lu(59) * lu(960) - lu(979) = lu(979) - lu(60) * lu(960) - lu(1380) = lu(1380) - lu(58) * lu(1303) - lu(1383) = lu(1383) - lu(59) * lu(1303) - lu(1389) = lu(1389) - lu(60) * lu(1303) - lu(61) = 1._r8 / lu(61) - lu(62) = lu(62) * lu(61) - lu(63) = lu(63) * lu(61) - lu(64) = lu(64) * lu(61) - lu(1263) = lu(1263) - lu(62) * lu(1259) - lu(1285) = lu(1285) - lu(63) * lu(1259) - lu(1290) = lu(1290) - lu(64) * lu(1259) - lu(1331) = - lu(62) * lu(1304) - lu(1383) = lu(1383) - lu(63) * lu(1304) - lu(1388) = lu(1388) - lu(64) * lu(1304) - lu(65) = 1._r8 / lu(65) - lu(66) = lu(66) * lu(65) - lu(67) = lu(67) * lu(65) - lu(68) = lu(68) * lu(65) - lu(962) = lu(962) - lu(66) * lu(961) - lu(970) = lu(970) - lu(67) * lu(961) - lu(974) = lu(974) - lu(68) * lu(961) - lu(1346) = lu(1346) - lu(66) * lu(1305) - lu(1380) = lu(1380) - lu(67) * lu(1305) - lu(1384) = lu(1384) - lu(68) * lu(1305) - lu(69) = 1._r8 / lu(69) - lu(70) = lu(70) * lu(69) - lu(71) = lu(71) * lu(69) - lu(399) = lu(399) - lu(70) * lu(396) - lu(401) = - lu(71) * lu(396) - lu(825) = - lu(70) * lu(820) - lu(829) = lu(829) - lu(71) * lu(820) - lu(1038) = lu(1038) - lu(70) * lu(1031) - lu(1046) = lu(1046) - lu(71) * lu(1031) - lu(1187) = lu(1187) - lu(70) * lu(1180) - lu(1194) = lu(1194) - lu(71) * lu(1180) - lu(72) = 1._r8 / lu(72) - lu(73) = lu(73) * lu(72) - lu(74) = lu(74) * lu(72) - lu(433) = lu(433) - lu(73) * lu(432) - lu(436) = lu(436) - lu(74) * lu(432) - lu(649) = lu(649) - lu(73) * lu(648) - lu(656) = lu(656) - lu(74) * lu(648) - lu(1439) = lu(1439) - lu(73) * lu(1438) - lu(1451) = - lu(74) * lu(1438) - lu(1463) = lu(1463) - lu(73) * lu(1461) - lu(1477) = lu(1477) - lu(74) * lu(1461) - lu(75) = 1._r8 / lu(75) - lu(76) = lu(76) * lu(75) - lu(77) = lu(77) * lu(75) - lu(78) = lu(78) * lu(75) - lu(463) = lu(463) - lu(76) * lu(459) - lu(466) = lu(466) - lu(77) * lu(459) - lu(469) = - lu(78) * lu(459) - lu(861) = lu(861) - lu(76) * lu(850) - lu(876) = lu(876) - lu(77) * lu(850) - lu(881) = - lu(78) * lu(850) - lu(1362) = lu(1362) - lu(76) * lu(1306) - lu(1383) = lu(1383) - lu(77) * lu(1306) - lu(1389) = lu(1389) - lu(78) * lu(1306) - lu(80) = 1._r8 / lu(80) - lu(81) = lu(81) * lu(80) - lu(82) = lu(82) * lu(80) - lu(83) = lu(83) * lu(80) - lu(552) = lu(552) - lu(81) * lu(551) - lu(554) = lu(554) - lu(82) * lu(551) - lu(557) = - lu(83) * lu(551) - lu(1357) = lu(1357) - lu(81) * lu(1307) - lu(1379) = lu(1379) - lu(82) * lu(1307) - lu(1392) = lu(1392) - lu(83) * lu(1307) - lu(1464) = - lu(81) * lu(1462) - lu(1471) = lu(1471) - lu(82) * lu(1462) - lu(1484) = lu(1484) - lu(83) * lu(1462) - lu(84) = 1._r8 / lu(84) - lu(85) = lu(85) * lu(84) - lu(86) = lu(86) * lu(84) - lu(87) = lu(87) * lu(84) - lu(88) = lu(88) * lu(84) - lu(89) = lu(89) * lu(84) - lu(1133) = lu(1133) - lu(85) * lu(1126) - lu(1141) = lu(1141) - lu(86) * lu(1126) - lu(1150) = lu(1150) - lu(87) * lu(1126) - lu(1155) = lu(1155) - lu(88) * lu(1126) - lu(1158) = - lu(89) * lu(1126) - lu(1349) = lu(1349) - lu(85) * lu(1308) - lu(1375) = lu(1375) - lu(86) * lu(1308) - lu(1384) = lu(1384) - lu(87) * lu(1308) - lu(1389) = lu(1389) - lu(88) * lu(1308) - lu(1392) = lu(1392) - lu(89) * lu(1308) - lu(90) = 1._r8 / lu(90) - lu(91) = lu(91) * lu(90) - lu(92) = lu(92) * lu(90) - lu(93) = lu(93) * lu(90) - lu(94) = lu(94) * lu(90) - lu(95) = lu(95) * lu(90) - lu(1129) = - lu(91) * lu(1127) - lu(1131) = - lu(92) * lu(1127) - lu(1137) = lu(1137) - lu(93) * lu(1127) - lu(1149) = lu(1149) - lu(94) * lu(1127) - lu(1155) = lu(1155) - lu(95) * lu(1127) - lu(1329) = lu(1329) - lu(91) * lu(1309) - lu(1343) = lu(1343) - lu(92) * lu(1309) - lu(1361) = lu(1361) - lu(93) * lu(1309) - lu(1383) = lu(1383) - lu(94) * lu(1309) - lu(1389) = lu(1389) - lu(95) * lu(1309) - END SUBROUTINE lu_fac02 - - SUBROUTINE lu_fac03(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(96) = 1._r8 / lu(96) - lu(97) = lu(97) * lu(96) - lu(98) = lu(98) * lu(96) - lu(99) = lu(99) * lu(96) - lu(100) = lu(100) * lu(96) - lu(101) = lu(101) * lu(96) - lu(1357) = lu(1357) - lu(97) * lu(1310) - lu(1383) = lu(1383) - lu(98) * lu(1310) - lu(1389) = lu(1389) - lu(99) * lu(1310) - lu(1390) = lu(1390) - lu(100) * lu(1310) - lu(1391) = lu(1391) - lu(101) * lu(1310) - lu(1404) = lu(1404) - lu(97) * lu(1394) - lu(1427) = lu(1427) - lu(98) * lu(1394) - lu(1433) = lu(1433) - lu(99) * lu(1394) - lu(1434) = lu(1434) - lu(100) * lu(1394) - lu(1435) = lu(1435) - lu(101) * lu(1394) - lu(102) = 1._r8 / lu(102) - lu(103) = lu(103) * lu(102) - lu(104) = lu(104) * lu(102) - lu(105) = lu(105) * lu(102) - lu(106) = lu(106) * lu(102) - lu(107) = lu(107) * lu(102) - lu(1281) = lu(1281) - lu(103) * lu(1260) - lu(1289) = lu(1289) - lu(104) * lu(1260) - lu(1290) = lu(1290) - lu(105) * lu(1260) - lu(1292) = lu(1292) - lu(106) * lu(1260) - lu(1293) = lu(1293) - lu(107) * lu(1260) - lu(1423) = lu(1423) - lu(103) * lu(1395) - lu(1431) = lu(1431) - lu(104) * lu(1395) - lu(1432) = lu(1432) - lu(105) * lu(1395) - lu(1434) = lu(1434) - lu(106) * lu(1395) - lu(1435) = lu(1435) - lu(107) * lu(1395) - lu(108) = 1._r8 / lu(108) - lu(109) = lu(109) * lu(108) - lu(110) = lu(110) * lu(108) - lu(111) = lu(111) * lu(108) - lu(112) = lu(112) * lu(108) - lu(113) = lu(113) * lu(108) - lu(114) = lu(114) * lu(108) - lu(1215) = lu(1215) - lu(109) * lu(1204) - lu(1230) = lu(1230) - lu(110) * lu(1204) - lu(1248) = lu(1248) - lu(111) * lu(1204) - lu(1252) = lu(1252) - lu(112) * lu(1204) - lu(1253) = lu(1253) - lu(113) * lu(1204) - lu(1258) = lu(1258) - lu(114) * lu(1204) - lu(1342) = lu(1342) - lu(109) * lu(1311) - lu(1362) = lu(1362) - lu(110) * lu(1311) - lu(1383) = lu(1383) - lu(111) * lu(1311) - lu(1387) = lu(1387) - lu(112) * lu(1311) - lu(1388) = lu(1388) - lu(113) * lu(1311) - lu(1393) = lu(1393) - lu(114) * lu(1311) - lu(115) = 1._r8 / lu(115) - lu(116) = lu(116) * lu(115) - lu(117) = lu(117) * lu(115) - lu(118) = lu(118) * lu(115) - lu(119) = lu(119) * lu(115) - lu(335) = lu(335) - lu(116) * lu(334) - lu(336) = lu(336) - lu(117) * lu(334) - lu(337) = lu(337) - lu(118) * lu(334) - lu(341) = - lu(119) * lu(334) - lu(1078) = lu(1078) - lu(116) * lu(1057) - lu(1094) = - lu(117) * lu(1057) - lu(1105) = lu(1105) - lu(118) * lu(1057) - lu(1120) = lu(1120) - lu(119) * lu(1057) - lu(1340) = lu(1340) - lu(116) * lu(1312) - lu(1362) = lu(1362) - lu(117) * lu(1312) - lu(1373) = lu(1373) - lu(118) * lu(1312) - lu(1389) = lu(1389) - lu(119) * lu(1312) - lu(120) = 1._r8 / lu(120) - lu(121) = lu(121) * lu(120) - lu(122) = lu(122) * lu(120) - lu(123) = lu(123) * lu(120) - lu(124) = lu(124) * lu(120) - lu(721) = lu(721) - lu(121) * lu(713) - lu(722) = - lu(122) * lu(713) - lu(725) = lu(725) - lu(123) * lu(713) - lu(729) = - lu(124) * lu(713) - lu(1102) = lu(1102) - lu(121) * lu(1058) - lu(1104) = lu(1104) - lu(122) * lu(1058) - lu(1114) = lu(1114) - lu(123) * lu(1058) - lu(1120) = lu(1120) - lu(124) * lu(1058) - lu(1370) = lu(1370) - lu(121) * lu(1313) - lu(1372) = lu(1372) - lu(122) * lu(1313) - lu(1383) = lu(1383) - lu(123) * lu(1313) - lu(1389) = lu(1389) - lu(124) * lu(1313) - lu(125) = 1._r8 / lu(125) - lu(126) = lu(126) * lu(125) - lu(127) = lu(127) * lu(125) - lu(128) = lu(128) * lu(125) - lu(129) = lu(129) * lu(125) - lu(462) = lu(462) - lu(126) * lu(460) - lu(463) = lu(463) - lu(127) * lu(460) - lu(466) = lu(466) - lu(128) * lu(460) - lu(469) = lu(469) - lu(129) * lu(460) - lu(1086) = lu(1086) - lu(126) * lu(1059) - lu(1094) = lu(1094) - lu(127) * lu(1059) - lu(1114) = lu(1114) - lu(128) * lu(1059) - lu(1120) = lu(1120) - lu(129) * lu(1059) - lu(1349) = lu(1349) - lu(126) * lu(1314) - lu(1362) = lu(1362) - lu(127) * lu(1314) - lu(1383) = lu(1383) - lu(128) * lu(1314) - lu(1389) = lu(1389) - lu(129) * lu(1314) - lu(130) = 1._r8 / lu(130) - lu(131) = lu(131) * lu(130) - lu(132) = lu(132) * lu(130) - lu(133) = lu(133) * lu(130) - lu(575) = - lu(131) * lu(570) - lu(580) = - lu(132) * lu(570) - lu(582) = - lu(133) * lu(570) - lu(677) = lu(677) - lu(131) * lu(670) - lu(684) = - lu(132) * lu(670) - lu(687) = - lu(133) * lu(670) - lu(1100) = lu(1100) - lu(131) * lu(1060) - lu(1120) = lu(1120) - lu(132) * lu(1060) - lu(1123) = lu(1123) - lu(133) * lu(1060) - lu(1368) = lu(1368) - lu(131) * lu(1315) - lu(1389) = lu(1389) - lu(132) * lu(1315) - lu(1392) = lu(1392) - lu(133) * lu(1315) - lu(134) = 1._r8 / lu(134) - lu(135) = lu(135) * lu(134) - lu(136) = lu(136) * lu(134) - lu(137) = lu(137) * lu(134) - lu(138) = lu(138) * lu(134) - lu(804) = lu(804) - lu(135) * lu(802) - lu(805) = lu(805) - lu(136) * lu(802) - lu(808) = lu(808) - lu(137) * lu(802) - lu(810) = lu(810) - lu(138) * lu(802) - lu(1034) = lu(1034) - lu(135) * lu(1032) - lu(1036) = lu(1036) - lu(136) * lu(1032) - lu(1041) = lu(1041) - lu(137) * lu(1032) - lu(1044) = lu(1044) - lu(138) * lu(1032) - lu(1184) = lu(1184) - lu(135) * lu(1181) - lu(1185) = lu(1185) - lu(136) * lu(1181) - lu(1189) = lu(1189) - lu(137) * lu(1181) - lu(1192) = lu(1192) - lu(138) * lu(1181) - END SUBROUTINE lu_fac03 - - SUBROUTINE lu_fac04(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(139) = 1._r8 / lu(139) - lu(140) = lu(140) * lu(139) - lu(141) = lu(141) * lu(139) - lu(532) = - lu(140) * lu(529) - lu(535) = lu(535) - lu(141) * lu(529) - lu(696) = - lu(140) * lu(689) - lu(708) = - lu(141) * lu(689) - lu(784) = lu(784) - lu(140) * lu(774) - lu(797) = - lu(141) * lu(774) - lu(866) = lu(866) - lu(140) * lu(851) - lu(881) = lu(881) - lu(141) * lu(851) - lu(1235) = lu(1235) - lu(140) * lu(1205) - lu(1254) = lu(1254) - lu(141) * lu(1205) - lu(1368) = lu(1368) - lu(140) * lu(1316) - lu(1389) = lu(1389) - lu(141) * lu(1316) - lu(1413) = lu(1413) - lu(140) * lu(1396) - lu(1433) = lu(1433) - lu(141) * lu(1396) - lu(142) = 1._r8 / lu(142) - lu(143) = lu(143) * lu(142) - lu(144) = lu(144) * lu(142) - lu(145) = lu(145) * lu(142) - lu(146) = lu(146) * lu(142) - lu(147) = lu(147) * lu(142) - lu(148) = lu(148) * lu(142) - lu(149) = lu(149) * lu(142) - lu(926) = - lu(143) * lu(919) - lu(934) = - lu(144) * lu(919) - lu(936) = lu(936) - lu(145) * lu(919) - lu(938) = lu(938) - lu(146) * lu(919) - lu(943) = lu(943) - lu(147) * lu(919) - lu(949) = lu(949) - lu(148) * lu(919) - lu(953) = lu(953) - lu(149) * lu(919) - lu(1344) = lu(1344) - lu(143) * lu(1317) - lu(1357) = lu(1357) - lu(144) * lu(1317) - lu(1361) = lu(1361) - lu(145) * lu(1317) - lu(1374) = lu(1374) - lu(146) * lu(1317) - lu(1379) = lu(1379) - lu(147) * lu(1317) - lu(1385) = lu(1385) - lu(148) * lu(1317) - lu(1389) = lu(1389) - lu(149) * lu(1317) - lu(150) = 1._r8 / lu(150) - lu(151) = lu(151) * lu(150) - lu(152) = lu(152) * lu(150) - lu(153) = lu(153) * lu(150) - lu(362) = - lu(151) * lu(354) - lu(366) = lu(366) - lu(152) * lu(354) - lu(367) = - lu(153) * lu(354) - lu(591) = - lu(151) * lu(584) - lu(597) = - lu(152) * lu(584) - lu(598) = lu(598) - lu(153) * lu(584) - lu(1234) = lu(1234) - lu(151) * lu(1206) - lu(1253) = lu(1253) - lu(152) * lu(1206) - lu(1254) = lu(1254) - lu(153) * lu(1206) - lu(1367) = lu(1367) - lu(151) * lu(1318) - lu(1388) = lu(1388) - lu(152) * lu(1318) - lu(1389) = lu(1389) - lu(153) * lu(1318) - lu(1412) = lu(1412) - lu(151) * lu(1397) - lu(1432) = lu(1432) - lu(152) * lu(1397) - lu(1433) = lu(1433) - lu(153) * lu(1397) - lu(154) = 1._r8 / lu(154) - lu(155) = lu(155) * lu(154) - lu(156) = lu(156) * lu(154) - lu(157) = lu(157) * lu(154) - lu(158) = lu(158) * lu(154) - lu(159) = lu(159) * lu(154) - lu(872) = lu(872) - lu(155) * lu(852) - lu(878) = - lu(156) * lu(852) - lu(881) = lu(881) - lu(157) * lu(852) - lu(884) = - lu(158) * lu(852) - lu(885) = lu(885) - lu(159) * lu(852) - lu(1108) = lu(1108) - lu(155) * lu(1061) - lu(1116) = lu(1116) - lu(156) * lu(1061) - lu(1120) = lu(1120) - lu(157) * lu(1061) - lu(1123) = lu(1123) - lu(158) * lu(1061) - lu(1124) = lu(1124) - lu(159) * lu(1061) - lu(1377) = lu(1377) - lu(155) * lu(1319) - lu(1385) = lu(1385) - lu(156) * lu(1319) - lu(1389) = lu(1389) - lu(157) * lu(1319) - lu(1392) = lu(1392) - lu(158) * lu(1319) - lu(1393) = lu(1393) - lu(159) * lu(1319) - lu(160) = 1._r8 / lu(160) - lu(161) = lu(161) * lu(160) - lu(162) = lu(162) * lu(160) - lu(163) = lu(163) * lu(160) - lu(164) = lu(164) * lu(160) - lu(165) = lu(165) * lu(160) - lu(246) = lu(246) - lu(161) * lu(245) - lu(247) = lu(247) - lu(162) * lu(245) - lu(248) = lu(248) - lu(163) * lu(245) - lu(249) = lu(249) - lu(164) * lu(245) - lu(253) = - lu(165) * lu(245) - lu(1071) = lu(1071) - lu(161) * lu(1062) - lu(1072) = - lu(162) * lu(1062) - lu(1081) = - lu(163) * lu(1062) - lu(1099) = - lu(164) * lu(1062) - lu(1120) = lu(1120) - lu(165) * lu(1062) - lu(1330) = lu(1330) - lu(161) * lu(1320) - lu(1331) = lu(1331) - lu(162) * lu(1320) - lu(1343) = lu(1343) - lu(163) * lu(1320) - lu(1367) = lu(1367) - lu(164) * lu(1320) - lu(1389) = lu(1389) - lu(165) * lu(1320) - lu(166) = 1._r8 / lu(166) - lu(167) = lu(167) * lu(166) - lu(168) = lu(168) * lu(166) - lu(169) = lu(169) * lu(166) - lu(170) = lu(170) * lu(166) - lu(171) = lu(171) * lu(166) - lu(516) = lu(516) - lu(167) * lu(515) - lu(517) = lu(517) - lu(168) * lu(515) - lu(523) = lu(523) - lu(169) * lu(515) - lu(526) = - lu(170) * lu(515) - lu(527) = - lu(171) * lu(515) - lu(1080) = - lu(167) * lu(1063) - lu(1089) = lu(1089) - lu(168) * lu(1063) - lu(1114) = lu(1114) - lu(169) * lu(1063) - lu(1120) = lu(1120) - lu(170) * lu(1063) - lu(1123) = lu(1123) - lu(171) * lu(1063) - lu(1342) = lu(1342) - lu(167) * lu(1321) - lu(1354) = lu(1354) - lu(168) * lu(1321) - lu(1383) = lu(1383) - lu(169) * lu(1321) - lu(1389) = lu(1389) - lu(170) * lu(1321) - lu(1392) = lu(1392) - lu(171) * lu(1321) - END SUBROUTINE lu_fac04 - - SUBROUTINE lu_fac05(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(172) = 1._r8 / lu(172) - lu(173) = lu(173) * lu(172) - lu(174) = lu(174) * lu(172) - lu(175) = lu(175) * lu(172) - lu(176) = lu(176) * lu(172) - lu(177) = lu(177) * lu(172) - lu(625) = lu(625) - lu(173) * lu(622) - lu(627) = lu(627) - lu(174) * lu(622) - lu(633) = - lu(175) * lu(622) - lu(634) = - lu(176) * lu(622) - lu(635) = lu(635) - lu(177) * lu(622) - lu(1096) = lu(1096) - lu(173) * lu(1064) - lu(1105) = lu(1105) - lu(174) * lu(1064) - lu(1120) = lu(1120) - lu(175) * lu(1064) - lu(1123) = lu(1123) - lu(176) * lu(1064) - lu(1124) = lu(1124) - lu(177) * lu(1064) - lu(1364) = lu(1364) - lu(173) * lu(1322) - lu(1373) = lu(1373) - lu(174) * lu(1322) - lu(1389) = lu(1389) - lu(175) * lu(1322) - lu(1392) = lu(1392) - lu(176) * lu(1322) - lu(1393) = lu(1393) - lu(177) * lu(1322) - lu(178) = 1._r8 / lu(178) - lu(179) = lu(179) * lu(178) - lu(180) = lu(180) * lu(178) - lu(181) = lu(181) * lu(178) - lu(182) = lu(182) * lu(178) - lu(183) = lu(183) * lu(178) - lu(1070) = lu(1070) - lu(179) * lu(1065) - lu(1114) = lu(1114) - lu(180) * lu(1065) - lu(1118) = lu(1118) - lu(181) * lu(1065) - lu(1119) = lu(1119) - lu(182) * lu(1065) - lu(1124) = lu(1124) - lu(183) * lu(1065) - lu(1210) = lu(1210) - lu(179) * lu(1207) - lu(1248) = lu(1248) - lu(180) * lu(1207) - lu(1252) = lu(1252) - lu(181) * lu(1207) - lu(1253) = lu(1253) - lu(182) * lu(1207) - lu(1258) = lu(1258) - lu(183) * lu(1207) - lu(1487) = - lu(179) * lu(1486) - lu(1499) = lu(1499) - lu(180) * lu(1486) - lu(1503) = - lu(181) * lu(1486) - lu(1504) = - lu(182) * lu(1486) - lu(1509) = lu(1509) - lu(183) * lu(1486) - lu(184) = 1._r8 / lu(184) - lu(185) = lu(185) * lu(184) - lu(186) = lu(186) * lu(184) - lu(187) = lu(187) * lu(184) - lu(188) = lu(188) * lu(184) - lu(325) = - lu(185) * lu(323) - lu(328) = - lu(186) * lu(323) - lu(330) = - lu(187) * lu(323) - lu(332) = lu(332) - lu(188) * lu(323) - lu(357) = - lu(185) * lu(355) - lu(360) = - lu(186) * lu(355) - lu(363) = - lu(187) * lu(355) - lu(367) = lu(367) - lu(188) * lu(355) - lu(1213) = lu(1213) - lu(185) * lu(1208) - lu(1222) = lu(1222) - lu(186) * lu(1208) - lu(1240) = lu(1240) - lu(187) * lu(1208) - lu(1254) = lu(1254) - lu(188) * lu(1208) - lu(1340) = lu(1340) - lu(185) * lu(1323) - lu(1349) = lu(1349) - lu(186) * lu(1323) - lu(1373) = lu(1373) - lu(187) * lu(1323) - lu(1389) = lu(1389) - lu(188) * lu(1323) - lu(189) = 1._r8 / lu(189) - lu(190) = lu(190) * lu(189) - lu(191) = lu(191) * lu(189) - lu(192) = lu(192) * lu(189) - lu(193) = lu(193) * lu(189) - lu(389) = - lu(190) * lu(387) - lu(390) = - lu(191) * lu(387) - lu(391) = lu(391) - lu(192) * lu(387) - lu(395) = lu(395) - lu(193) * lu(387) - lu(898) = lu(898) - lu(190) * lu(888) - lu(903) = lu(903) - lu(191) * lu(888) - lu(908) = lu(908) - lu(192) * lu(888) - lu(916) = - lu(193) * lu(888) - lu(1088) = - lu(190) * lu(1066) - lu(1109) = lu(1109) - lu(191) * lu(1066) - lu(1114) = lu(1114) - lu(192) * lu(1066) - lu(1124) = lu(1124) - lu(193) * lu(1066) - lu(1224) = lu(1224) - lu(190) * lu(1209) - lu(1243) = lu(1243) - lu(191) * lu(1209) - lu(1248) = lu(1248) - lu(192) * lu(1209) - lu(1258) = lu(1258) - lu(193) * lu(1209) - lu(194) = 1._r8 / lu(194) - lu(195) = lu(195) * lu(194) - lu(196) = lu(196) * lu(194) - lu(197) = lu(197) * lu(194) - lu(198) = lu(198) * lu(194) - lu(199) = lu(199) * lu(194) - lu(200) = lu(200) * lu(194) - lu(789) = lu(789) - lu(195) * lu(775) - lu(790) = lu(790) - lu(196) * lu(775) - lu(796) = lu(796) - lu(197) * lu(775) - lu(797) = lu(797) - lu(198) * lu(775) - lu(798) = - lu(199) * lu(775) - lu(801) = lu(801) - lu(200) * lu(775) - lu(1275) = lu(1275) - lu(195) * lu(1261) - lu(1279) = - lu(196) * lu(1261) - lu(1290) = lu(1290) - lu(197) * lu(1261) - lu(1291) = lu(1291) - lu(198) * lu(1261) - lu(1292) = lu(1292) - lu(199) * lu(1261) - lu(1295) = - lu(200) * lu(1261) - lu(1373) = lu(1373) - lu(195) * lu(1324) - lu(1377) = lu(1377) - lu(196) * lu(1324) - lu(1388) = lu(1388) - lu(197) * lu(1324) - lu(1389) = lu(1389) - lu(198) * lu(1324) - lu(1390) = lu(1390) - lu(199) * lu(1324) - lu(1393) = lu(1393) - lu(200) * lu(1324) - lu(201) = 1._r8 / lu(201) - lu(202) = lu(202) * lu(201) - lu(203) = lu(203) * lu(201) - lu(204) = lu(204) * lu(201) - lu(205) = lu(205) * lu(201) - lu(206) = lu(206) * lu(201) - lu(207) = lu(207) * lu(201) - lu(472) = - lu(202) * lu(471) - lu(473) = lu(473) - lu(203) * lu(471) - lu(474) = lu(474) - lu(204) * lu(471) - lu(476) = lu(476) - lu(205) * lu(471) - lu(478) = lu(478) - lu(206) * lu(471) - lu(479) = lu(479) - lu(207) * lu(471) - lu(891) = lu(891) - lu(202) * lu(889) - lu(894) = lu(894) - lu(203) * lu(889) - lu(895) = lu(895) - lu(204) * lu(889) - lu(897) = lu(897) - lu(205) * lu(889) - lu(903) = lu(903) - lu(206) * lu(889) - lu(904) = lu(904) - lu(207) * lu(889) - lu(923) = lu(923) - lu(202) * lu(920) - lu(928) = - lu(203) * lu(920) - lu(929) = lu(929) - lu(204) * lu(920) - lu(932) = lu(932) - lu(205) * lu(920) - lu(942) = lu(942) - lu(206) * lu(920) - lu(943) = lu(943) - lu(207) * lu(920) - END SUBROUTINE lu_fac05 - - SUBROUTINE lu_fac06(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(208) = 1._r8 / lu(208) - lu(209) = lu(209) * lu(208) - lu(210) = lu(210) * lu(208) - lu(211) = lu(211) * lu(208) - lu(212) = lu(212) * lu(208) - lu(213) = lu(213) * lu(208) - lu(214) = lu(214) * lu(208) - lu(539) = lu(539) - lu(209) * lu(538) - lu(540) = lu(540) - lu(210) * lu(538) - lu(542) = lu(542) - lu(211) * lu(538) - lu(543) = lu(543) - lu(212) * lu(538) - lu(546) = lu(546) - lu(213) * lu(538) - lu(549) = - lu(214) * lu(538) - lu(1080) = lu(1080) - lu(209) * lu(1067) - lu(1091) = lu(1091) - lu(210) * lu(1067) - lu(1097) = lu(1097) - lu(211) * lu(1067) - lu(1103) = lu(1103) - lu(212) * lu(1067) - lu(1114) = lu(1114) - lu(213) * lu(1067) - lu(1120) = lu(1120) - lu(214) * lu(1067) - lu(1342) = lu(1342) - lu(209) * lu(1325) - lu(1356) = lu(1356) - lu(210) * lu(1325) - lu(1365) = lu(1365) - lu(211) * lu(1325) - lu(1371) = lu(1371) - lu(212) * lu(1325) - lu(1383) = lu(1383) - lu(213) * lu(1325) - lu(1389) = lu(1389) - lu(214) * lu(1325) - lu(215) = 1._r8 / lu(215) - lu(216) = lu(216) * lu(215) - lu(217) = lu(217) * lu(215) - lu(218) = lu(218) * lu(215) - lu(219) = lu(219) * lu(215) - lu(220) = lu(220) * lu(215) - lu(221) = lu(221) * lu(215) - lu(1109) = lu(1109) - lu(216) * lu(1068) - lu(1114) = lu(1114) - lu(217) * lu(1068) - lu(1119) = lu(1119) - lu(218) * lu(1068) - lu(1120) = lu(1120) - lu(219) * lu(1068) - lu(1121) = lu(1121) - lu(220) * lu(1068) - lu(1123) = lu(1123) - lu(221) * lu(1068) - lu(1280) = lu(1280) - lu(216) * lu(1262) - lu(1285) = lu(1285) - lu(217) * lu(1262) - lu(1290) = lu(1290) - lu(218) * lu(1262) - lu(1291) = lu(1291) - lu(219) * lu(1262) - lu(1292) = lu(1292) - lu(220) * lu(1262) - lu(1294) = - lu(221) * lu(1262) - lu(1378) = lu(1378) - lu(216) * lu(1326) - lu(1383) = lu(1383) - lu(217) * lu(1326) - lu(1388) = lu(1388) - lu(218) * lu(1326) - lu(1389) = lu(1389) - lu(219) * lu(1326) - lu(1390) = lu(1390) - lu(220) * lu(1326) - lu(1392) = lu(1392) - lu(221) * lu(1326) - lu(222) = 1._r8 / lu(222) - lu(223) = lu(223) * lu(222) - lu(224) = lu(224) * lu(222) - lu(225) = lu(225) * lu(222) - lu(226) = lu(226) * lu(222) - lu(348) = lu(348) - lu(223) * lu(342) - lu(350) = lu(350) - lu(224) * lu(342) - lu(352) = - lu(225) * lu(342) - lu(353) = - lu(226) * lu(342) - lu(416) = lu(416) - lu(223) * lu(413) - lu(417) = - lu(224) * lu(413) - lu(419) = - lu(225) * lu(413) - lu(420) = - lu(226) * lu(413) - lu(426) = lu(426) - lu(223) * lu(421) - lu(428) = - lu(224) * lu(421) - lu(430) = lu(430) - lu(225) * lu(421) - lu(431) = - lu(226) * lu(421) - lu(897) = lu(897) - lu(223) * lu(890) - lu(903) = lu(903) - lu(224) * lu(890) - lu(905) = lu(905) - lu(225) * lu(890) - lu(912) = lu(912) - lu(226) * lu(890) - lu(932) = lu(932) - lu(223) * lu(921) - lu(942) = lu(942) - lu(224) * lu(921) - lu(944) = - lu(225) * lu(921) - lu(951) = lu(951) - lu(226) * lu(921) - lu(227) = 1._r8 / lu(227) - lu(228) = lu(228) * lu(227) - lu(229) = lu(229) * lu(227) - lu(230) = lu(230) * lu(227) - lu(231) = lu(231) * lu(227) - lu(232) = lu(232) * lu(227) - lu(761) = lu(761) - lu(228) * lu(755) - lu(762) = lu(762) - lu(229) * lu(755) - lu(769) = - lu(230) * lu(755) - lu(772) = - lu(231) * lu(755) - lu(773) = lu(773) - lu(232) * lu(755) - lu(789) = lu(789) - lu(228) * lu(776) - lu(790) = lu(790) - lu(229) * lu(776) - lu(797) = lu(797) - lu(230) * lu(776) - lu(800) = - lu(231) * lu(776) - lu(801) = lu(801) - lu(232) * lu(776) - lu(1105) = lu(1105) - lu(228) * lu(1069) - lu(1108) = lu(1108) - lu(229) * lu(1069) - lu(1120) = lu(1120) - lu(230) * lu(1069) - lu(1123) = lu(1123) - lu(231) * lu(1069) - lu(1124) = lu(1124) - lu(232) * lu(1069) - lu(1373) = lu(1373) - lu(228) * lu(1327) - lu(1377) = lu(1377) - lu(229) * lu(1327) - lu(1389) = lu(1389) - lu(230) * lu(1327) - lu(1392) = lu(1392) - lu(231) * lu(1327) - lu(1393) = lu(1393) - lu(232) * lu(1327) - lu(233) = 1._r8 / lu(233) - lu(234) = lu(234) * lu(233) - lu(235) = lu(235) * lu(233) - lu(236) = lu(236) * lu(233) - lu(237) = lu(237) * lu(233) - lu(238) = lu(238) * lu(233) - lu(239) = lu(239) * lu(233) - lu(240) = lu(240) * lu(233) - lu(987) = lu(987) - lu(234) * lu(986) - lu(991) = - lu(235) * lu(986) - lu(998) = lu(998) - lu(236) * lu(986) - lu(1016) = lu(1016) - lu(237) * lu(986) - lu(1018) = lu(1018) - lu(238) * lu(986) - lu(1024) = lu(1024) - lu(239) * lu(986) - lu(1028) = lu(1028) - lu(240) * lu(986) - lu(1129) = lu(1129) - lu(234) * lu(1128) - lu(1132) = - lu(235) * lu(1128) - lu(1137) = lu(1137) - lu(236) * lu(1128) - lu(1147) = lu(1147) - lu(237) * lu(1128) - lu(1149) = lu(1149) - lu(238) * lu(1128) - lu(1155) = lu(1155) - lu(239) * lu(1128) - lu(1159) = lu(1159) - lu(240) * lu(1128) - lu(1329) = lu(1329) - lu(234) * lu(1328) - lu(1345) = lu(1345) - lu(235) * lu(1328) - lu(1361) = lu(1361) - lu(236) * lu(1328) - lu(1381) = lu(1381) - lu(237) * lu(1328) - lu(1383) = lu(1383) - lu(238) * lu(1328) - lu(1389) = lu(1389) - lu(239) * lu(1328) - lu(1393) = lu(1393) - lu(240) * lu(1328) - lu(241) = 1._r8 / lu(241) - lu(242) = lu(242) * lu(241) - lu(243) = lu(243) * lu(241) - lu(244) = lu(244) * lu(241) - lu(1018) = lu(1018) - lu(242) * lu(987) - lu(1024) = lu(1024) - lu(243) * lu(987) - lu(1027) = - lu(244) * lu(987) - lu(1114) = lu(1114) - lu(242) * lu(1070) - lu(1120) = lu(1120) - lu(243) * lu(1070) - lu(1123) = lu(1123) - lu(244) * lu(1070) - lu(1149) = lu(1149) - lu(242) * lu(1129) - lu(1155) = lu(1155) - lu(243) * lu(1129) - lu(1158) = lu(1158) - lu(244) * lu(1129) - lu(1248) = lu(1248) - lu(242) * lu(1210) - lu(1254) = lu(1254) - lu(243) * lu(1210) - lu(1257) = - lu(244) * lu(1210) - lu(1383) = lu(1383) - lu(242) * lu(1329) - lu(1389) = lu(1389) - lu(243) * lu(1329) - lu(1392) = lu(1392) - lu(244) * lu(1329) - lu(1499) = lu(1499) - lu(242) * lu(1487) - lu(1505) = lu(1505) - lu(243) * lu(1487) - lu(1508) = lu(1508) - lu(244) * lu(1487) - END SUBROUTINE lu_fac06 - - SUBROUTINE lu_fac07(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(246) = 1._r8 / lu(246) - lu(247) = lu(247) * lu(246) - lu(248) = lu(248) * lu(246) - lu(249) = lu(249) * lu(246) - lu(250) = lu(250) * lu(246) - lu(251) = lu(251) * lu(246) - lu(252) = lu(252) * lu(246) - lu(253) = lu(253) * lu(246) - lu(1072) = lu(1072) - lu(247) * lu(1071) - lu(1081) = lu(1081) - lu(248) * lu(1071) - lu(1099) = lu(1099) - lu(249) * lu(1071) - lu(1114) = lu(1114) - lu(250) * lu(1071) - lu(1118) = lu(1118) - lu(251) * lu(1071) - lu(1119) = lu(1119) - lu(252) * lu(1071) - lu(1120) = lu(1120) - lu(253) * lu(1071) - lu(1212) = lu(1212) - lu(247) * lu(1211) - lu(1216) = lu(1216) - lu(248) * lu(1211) - lu(1234) = lu(1234) - lu(249) * lu(1211) - lu(1248) = lu(1248) - lu(250) * lu(1211) - lu(1252) = lu(1252) - lu(251) * lu(1211) - lu(1253) = lu(1253) - lu(252) * lu(1211) - lu(1254) = lu(1254) - lu(253) * lu(1211) - lu(1331) = lu(1331) - lu(247) * lu(1330) - lu(1343) = lu(1343) - lu(248) * lu(1330) - lu(1367) = lu(1367) - lu(249) * lu(1330) - lu(1383) = lu(1383) - lu(250) * lu(1330) - lu(1387) = lu(1387) - lu(251) * lu(1330) - lu(1388) = lu(1388) - lu(252) * lu(1330) - lu(1389) = lu(1389) - lu(253) * lu(1330) - lu(254) = 1._r8 / lu(254) - lu(255) = lu(255) * lu(254) - lu(256) = lu(256) * lu(254) - lu(257) = lu(257) * lu(254) - lu(258) = lu(258) * lu(254) - lu(259) = lu(259) * lu(254) - lu(1081) = lu(1081) - lu(255) * lu(1072) - lu(1093) = - lu(256) * lu(1072) - lu(1099) = lu(1099) - lu(257) * lu(1072) - lu(1105) = lu(1105) - lu(258) * lu(1072) - lu(1114) = lu(1114) - lu(259) * lu(1072) - lu(1216) = lu(1216) - lu(255) * lu(1212) - lu(1229) = lu(1229) - lu(256) * lu(1212) - lu(1234) = lu(1234) - lu(257) * lu(1212) - lu(1240) = lu(1240) - lu(258) * lu(1212) - lu(1248) = lu(1248) - lu(259) * lu(1212) - lu(1266) = - lu(255) * lu(1263) - lu(1271) = - lu(256) * lu(1263) - lu(1273) = - lu(257) * lu(1263) - lu(1275) = lu(1275) - lu(258) * lu(1263) - lu(1285) = lu(1285) - lu(259) * lu(1263) - lu(1343) = lu(1343) - lu(255) * lu(1331) - lu(1361) = lu(1361) - lu(256) * lu(1331) - lu(1367) = lu(1367) - lu(257) * lu(1331) - lu(1373) = lu(1373) - lu(258) * lu(1331) - lu(1383) = lu(1383) - lu(259) * lu(1331) - lu(260) = 1._r8 / lu(260) - lu(261) = lu(261) * lu(260) - lu(262) = lu(262) * lu(260) - lu(263) = lu(263) * lu(260) - lu(264) = lu(264) * lu(260) - lu(265) = lu(265) * lu(260) - lu(266) = lu(266) * lu(260) - lu(267) = lu(267) * lu(260) - lu(442) = lu(442) - lu(261) * lu(441) - lu(443) = lu(443) - lu(262) * lu(441) - lu(444) = - lu(263) * lu(441) - lu(446) = lu(446) - lu(264) * lu(441) - lu(449) = - lu(265) * lu(441) - lu(450) = - lu(266) * lu(441) - lu(451) = lu(451) - lu(267) * lu(441) - lu(1084) = lu(1084) - lu(261) * lu(1073) - lu(1094) = lu(1094) - lu(262) * lu(1073) - lu(1095) = - lu(263) * lu(1073) - lu(1114) = lu(1114) - lu(264) * lu(1073) - lu(1120) = lu(1120) - lu(265) * lu(1073) - lu(1123) = lu(1123) - lu(266) * lu(1073) - lu(1124) = lu(1124) - lu(267) * lu(1073) - lu(1347) = lu(1347) - lu(261) * lu(1332) - lu(1362) = lu(1362) - lu(262) * lu(1332) - lu(1363) = lu(1363) - lu(263) * lu(1332) - lu(1383) = lu(1383) - lu(264) * lu(1332) - lu(1389) = lu(1389) - lu(265) * lu(1332) - lu(1392) = lu(1392) - lu(266) * lu(1332) - lu(1393) = lu(1393) - lu(267) * lu(1332) - lu(268) = 1._r8 / lu(268) - lu(269) = lu(269) * lu(268) - lu(270) = lu(270) * lu(268) - lu(271) = lu(271) * lu(268) - lu(466) = lu(466) - lu(269) * lu(461) - lu(469) = lu(469) - lu(270) * lu(461) - lu(470) = lu(470) - lu(271) * lu(461) - lu(630) = lu(630) - lu(269) * lu(623) - lu(633) = lu(633) - lu(270) * lu(623) - lu(635) = lu(635) - lu(271) * lu(623) - lu(680) = lu(680) - lu(269) * lu(671) - lu(684) = lu(684) - lu(270) * lu(671) - lu(688) = lu(688) - lu(271) * lu(671) - lu(704) = lu(704) - lu(269) * lu(690) - lu(708) = lu(708) - lu(270) * lu(690) - lu(712) = lu(712) - lu(271) * lu(690) - lu(725) = lu(725) - lu(269) * lu(714) - lu(729) = lu(729) - lu(270) * lu(714) - lu(733) = lu(733) - lu(271) * lu(714) - lu(876) = lu(876) - lu(269) * lu(853) - lu(881) = lu(881) - lu(270) * lu(853) - lu(885) = lu(885) - lu(271) * lu(853) - lu(1383) = lu(1383) - lu(269) * lu(1333) - lu(1389) = lu(1389) - lu(270) * lu(1333) - lu(1393) = lu(1393) - lu(271) * lu(1333) - lu(272) = 1._r8 / lu(272) - lu(273) = lu(273) * lu(272) - lu(274) = lu(274) * lu(272) - lu(275) = lu(275) * lu(272) - lu(276) = lu(276) * lu(272) - lu(277) = lu(277) * lu(272) - lu(278) = lu(278) * lu(272) - lu(279) = lu(279) * lu(272) - lu(694) = lu(694) - lu(273) * lu(691) - lu(696) = lu(696) - lu(274) * lu(691) - lu(697) = lu(697) - lu(275) * lu(691) - lu(699) = lu(699) - lu(276) * lu(691) - lu(704) = lu(704) - lu(277) * lu(691) - lu(708) = lu(708) - lu(278) * lu(691) - lu(712) = lu(712) - lu(279) * lu(691) - lu(1097) = lu(1097) - lu(273) * lu(1074) - lu(1100) = lu(1100) - lu(274) * lu(1074) - lu(1101) = lu(1101) - lu(275) * lu(1074) - lu(1103) = lu(1103) - lu(276) * lu(1074) - lu(1114) = lu(1114) - lu(277) * lu(1074) - lu(1120) = lu(1120) - lu(278) * lu(1074) - lu(1124) = lu(1124) - lu(279) * lu(1074) - lu(1365) = lu(1365) - lu(273) * lu(1334) - lu(1368) = lu(1368) - lu(274) * lu(1334) - lu(1369) = lu(1369) - lu(275) * lu(1334) - lu(1371) = lu(1371) - lu(276) * lu(1334) - lu(1383) = lu(1383) - lu(277) * lu(1334) - lu(1389) = lu(1389) - lu(278) * lu(1334) - lu(1393) = lu(1393) - lu(279) * lu(1334) - lu(280) = 1._r8 / lu(280) - lu(281) = lu(281) * lu(280) - lu(282) = lu(282) * lu(280) - lu(283) = lu(283) * lu(280) - lu(284) = lu(284) * lu(280) - lu(285) = lu(285) * lu(280) - lu(286) = lu(286) * lu(280) - lu(287) = lu(287) * lu(280) - lu(927) = lu(927) - lu(281) * lu(922) - lu(940) = lu(940) - lu(282) * lu(922) - lu(943) = lu(943) - lu(283) * lu(922) - lu(950) = lu(950) - lu(284) * lu(922) - lu(952) = lu(952) - lu(285) * lu(922) - lu(954) = lu(954) - lu(286) * lu(922) - lu(955) = - lu(287) * lu(922) - lu(1183) = lu(1183) - lu(281) * lu(1182) - lu(1187) = lu(1187) - lu(282) * lu(1182) - lu(1189) = lu(1189) - lu(283) * lu(1182) - lu(1196) = lu(1196) - lu(284) * lu(1182) - lu(1198) = lu(1198) - lu(285) * lu(1182) - lu(1200) = - lu(286) * lu(1182) - lu(1201) = - lu(287) * lu(1182) - lu(1267) = - lu(281) * lu(1264) - lu(1278) = - lu(282) * lu(1264) - lu(1281) = lu(1281) - lu(283) * lu(1264) - lu(1288) = lu(1288) - lu(284) * lu(1264) - lu(1290) = lu(1290) - lu(285) * lu(1264) - lu(1292) = lu(1292) - lu(286) * lu(1264) - lu(1293) = lu(1293) - lu(287) * lu(1264) - END SUBROUTINE lu_fac07 - - SUBROUTINE lu_fac08(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(288) = 1._r8 / lu(288) - lu(289) = lu(289) * lu(288) - lu(290) = lu(290) * lu(288) - lu(291) = lu(291) * lu(288) - lu(292) = lu(292) * lu(288) - lu(293) = lu(293) * lu(288) - lu(294) = lu(294) * lu(288) - lu(295) = lu(295) * lu(288) - lu(758) = - lu(289) * lu(756) - lu(760) = lu(760) - lu(290) * lu(756) - lu(765) = lu(765) - lu(291) * lu(756) - lu(768) = lu(768) - lu(292) * lu(756) - lu(769) = lu(769) - lu(293) * lu(756) - lu(770) = lu(770) - lu(294) * lu(756) - lu(773) = lu(773) - lu(295) * lu(756) - lu(1272) = - lu(289) * lu(1265) - lu(1274) = lu(1274) - lu(290) * lu(1265) - lu(1285) = lu(1285) - lu(291) * lu(1265) - lu(1290) = lu(1290) - lu(292) * lu(1265) - lu(1291) = lu(1291) - lu(293) * lu(1265) - lu(1292) = lu(1292) - lu(294) * lu(1265) - lu(1295) = lu(1295) - lu(295) * lu(1265) - lu(1363) = lu(1363) - lu(289) * lu(1335) - lu(1372) = lu(1372) - lu(290) * lu(1335) - lu(1383) = lu(1383) - lu(291) * lu(1335) - lu(1388) = lu(1388) - lu(292) * lu(1335) - lu(1389) = lu(1389) - lu(293) * lu(1335) - lu(1390) = lu(1390) - lu(294) * lu(1335) - lu(1393) = lu(1393) - lu(295) * lu(1335) - lu(296) = 1._r8 / lu(296) - lu(297) = lu(297) * lu(296) - lu(298) = lu(298) * lu(296) - lu(299) = lu(299) * lu(296) - lu(300) = lu(300) * lu(296) - lu(301) = lu(301) * lu(296) - lu(302) = lu(302) * lu(296) - lu(345) = lu(345) - lu(297) * lu(343) - lu(346) = lu(346) - lu(298) * lu(343) - lu(348) = lu(348) - lu(299) * lu(343) - lu(349) = - lu(300) * lu(343) - lu(350) = lu(350) - lu(301) * lu(343) - lu(351) = lu(351) - lu(302) * lu(343) - lu(473) = lu(473) - lu(297) * lu(472) - lu(474) = lu(474) - lu(298) * lu(472) - lu(476) = lu(476) - lu(299) * lu(472) - lu(477) = - lu(300) * lu(472) - lu(478) = lu(478) - lu(301) * lu(472) - lu(479) = lu(479) - lu(302) * lu(472) - lu(894) = lu(894) - lu(297) * lu(891) - lu(895) = lu(895) - lu(298) * lu(891) - lu(897) = lu(897) - lu(299) * lu(891) - lu(900) = - lu(300) * lu(891) - lu(903) = lu(903) - lu(301) * lu(891) - lu(904) = lu(904) - lu(302) * lu(891) - lu(928) = lu(928) - lu(297) * lu(923) - lu(929) = lu(929) - lu(298) * lu(923) - lu(932) = lu(932) - lu(299) * lu(923) - lu(936) = lu(936) - lu(300) * lu(923) - lu(942) = lu(942) - lu(301) * lu(923) - lu(943) = lu(943) - lu(302) * lu(923) - lu(303) = 1._r8 / lu(303) - lu(304) = lu(304) * lu(303) - lu(305) = lu(305) * lu(303) - lu(306) = lu(306) * lu(303) - lu(307) = lu(307) * lu(303) - lu(308) = lu(308) * lu(303) - lu(309) = lu(309) * lu(303) - lu(310) = lu(310) * lu(303) - lu(311) = lu(311) * lu(303) - lu(994) = - lu(304) * lu(988) - lu(1002) = lu(1002) - lu(305) * lu(988) - lu(1007) = lu(1007) - lu(306) * lu(988) - lu(1016) = lu(1016) - lu(307) * lu(988) - lu(1018) = lu(1018) - lu(308) * lu(988) - lu(1023) = lu(1023) - lu(309) * lu(988) - lu(1024) = lu(1024) - lu(310) * lu(988) - lu(1025) = lu(1025) - lu(311) * lu(988) - lu(1356) = lu(1356) - lu(304) * lu(1336) - lu(1365) = lu(1365) - lu(305) * lu(1336) - lu(1371) = lu(1371) - lu(306) * lu(1336) - lu(1381) = lu(1381) - lu(307) * lu(1336) - lu(1383) = lu(1383) - lu(308) * lu(1336) - lu(1388) = lu(1388) - lu(309) * lu(1336) - lu(1389) = lu(1389) - lu(310) * lu(1336) - lu(1390) = lu(1390) - lu(311) * lu(1336) - lu(1403) = lu(1403) - lu(304) * lu(1398) - lu(1411) = lu(1411) - lu(305) * lu(1398) - lu(1416) = lu(1416) - lu(306) * lu(1398) - lu(1425) = - lu(307) * lu(1398) - lu(1427) = lu(1427) - lu(308) * lu(1398) - lu(1432) = lu(1432) - lu(309) * lu(1398) - lu(1433) = lu(1433) - lu(310) * lu(1398) - lu(1434) = lu(1434) - lu(311) * lu(1398) - lu(312) = 1._r8 / lu(312) - lu(313) = lu(313) * lu(312) - lu(314) = lu(314) * lu(312) - lu(315) = lu(315) * lu(312) - lu(316) = lu(316) * lu(312) - lu(317) = lu(317) * lu(312) - lu(318) = lu(318) * lu(312) - lu(939) = lu(939) - lu(313) * lu(924) - lu(943) = lu(943) - lu(314) * lu(924) - lu(947) = lu(947) - lu(315) * lu(924) - lu(948) = lu(948) - lu(316) * lu(924) - lu(953) = lu(953) - lu(317) * lu(924) - lu(956) = - lu(318) * lu(924) - lu(1106) = lu(1106) - lu(313) * lu(1075) - lu(1110) = lu(1110) - lu(314) * lu(1075) - lu(1114) = lu(1114) - lu(315) * lu(1075) - lu(1115) = lu(1115) - lu(316) * lu(1075) - lu(1120) = lu(1120) - lu(317) * lu(1075) - lu(1123) = lu(1123) - lu(318) * lu(1075) - lu(1141) = lu(1141) - lu(313) * lu(1130) - lu(1145) = - lu(314) * lu(1130) - lu(1149) = lu(1149) - lu(315) * lu(1130) - lu(1150) = lu(1150) - lu(316) * lu(1130) - lu(1155) = lu(1155) - lu(317) * lu(1130) - lu(1158) = lu(1158) - lu(318) * lu(1130) - lu(1375) = lu(1375) - lu(313) * lu(1337) - lu(1379) = lu(1379) - lu(314) * lu(1337) - lu(1383) = lu(1383) - lu(315) * lu(1337) - lu(1384) = lu(1384) - lu(316) * lu(1337) - lu(1389) = lu(1389) - lu(317) * lu(1337) - lu(1392) = lu(1392) - lu(318) * lu(1337) - lu(319) = 1._r8 / lu(319) - lu(320) = lu(320) * lu(319) - lu(321) = lu(321) * lu(319) - lu(322) = lu(322) * lu(319) - lu(502) = - lu(320) * lu(493) - lu(505) = lu(505) - lu(321) * lu(493) - lu(507) = - lu(322) * lu(493) - lu(592) = lu(592) - lu(320) * lu(585) - lu(598) = lu(598) - lu(321) * lu(585) - lu(600) = - lu(322) * lu(585) - lu(762) = lu(762) - lu(320) * lu(757) - lu(769) = lu(769) - lu(321) * lu(757) - lu(772) = lu(772) - lu(322) * lu(757) - lu(790) = lu(790) - lu(320) * lu(777) - lu(797) = lu(797) - lu(321) * lu(777) - lu(800) = lu(800) - lu(322) * lu(777) - lu(872) = lu(872) - lu(320) * lu(854) - lu(881) = lu(881) - lu(321) * lu(854) - lu(884) = lu(884) - lu(322) * lu(854) - lu(1012) = lu(1012) - lu(320) * lu(989) - lu(1024) = lu(1024) - lu(321) * lu(989) - lu(1027) = lu(1027) - lu(322) * lu(989) - lu(1108) = lu(1108) - lu(320) * lu(1076) - lu(1120) = lu(1120) - lu(321) * lu(1076) - lu(1123) = lu(1123) - lu(322) * lu(1076) - lu(1377) = lu(1377) - lu(320) * lu(1338) - lu(1389) = lu(1389) - lu(321) * lu(1338) - lu(1392) = lu(1392) - lu(322) * lu(1338) - lu(324) = 1._r8 / lu(324) - lu(325) = lu(325) * lu(324) - lu(326) = lu(326) * lu(324) - lu(327) = lu(327) * lu(324) - lu(328) = lu(328) * lu(324) - lu(329) = lu(329) * lu(324) - lu(330) = lu(330) * lu(324) - lu(331) = lu(331) * lu(324) - lu(332) = lu(332) * lu(324) - lu(333) = lu(333) * lu(324) - lu(357) = lu(357) - lu(325) * lu(356) - lu(358) = lu(358) - lu(326) * lu(356) - lu(359) = lu(359) - lu(327) * lu(356) - lu(360) = lu(360) - lu(328) * lu(356) - lu(361) = lu(361) - lu(329) * lu(356) - lu(363) = lu(363) - lu(330) * lu(356) - lu(364) = lu(364) - lu(331) * lu(356) - lu(367) = lu(367) - lu(332) * lu(356) - lu(368) = lu(368) - lu(333) * lu(356) - lu(1078) = lu(1078) - lu(325) * lu(1077) - lu(1079) = lu(1079) - lu(326) * lu(1077) - lu(1080) = lu(1080) - lu(327) * lu(1077) - lu(1086) = lu(1086) - lu(328) * lu(1077) - lu(1094) = lu(1094) - lu(329) * lu(1077) - lu(1105) = lu(1105) - lu(330) * lu(1077) - lu(1114) = lu(1114) - lu(331) * lu(1077) - lu(1120) = lu(1120) - lu(332) * lu(1077) - lu(1124) = lu(1124) - lu(333) * lu(1077) - lu(1340) = lu(1340) - lu(325) * lu(1339) - lu(1341) = lu(1341) - lu(326) * lu(1339) - lu(1342) = lu(1342) - lu(327) * lu(1339) - lu(1349) = lu(1349) - lu(328) * lu(1339) - lu(1362) = lu(1362) - lu(329) * lu(1339) - lu(1373) = lu(1373) - lu(330) * lu(1339) - lu(1383) = lu(1383) - lu(331) * lu(1339) - lu(1389) = lu(1389) - lu(332) * lu(1339) - lu(1393) = lu(1393) - lu(333) * lu(1339) - END SUBROUTINE lu_fac08 - - SUBROUTINE lu_fac09(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(335) = 1._r8 / lu(335) - lu(336) = lu(336) * lu(335) - lu(337) = lu(337) * lu(335) - lu(338) = lu(338) * lu(335) - lu(339) = lu(339) * lu(335) - lu(340) = lu(340) * lu(335) - lu(341) = lu(341) * lu(335) - lu(361) = lu(361) - lu(336) * lu(357) - lu(363) = lu(363) - lu(337) * lu(357) - lu(364) = lu(364) - lu(338) * lu(357) - lu(365) = lu(365) - lu(339) * lu(357) - lu(366) = lu(366) - lu(340) * lu(357) - lu(367) = lu(367) - lu(341) * lu(357) - lu(1094) = lu(1094) - lu(336) * lu(1078) - lu(1105) = lu(1105) - lu(337) * lu(1078) - lu(1114) = lu(1114) - lu(338) * lu(1078) - lu(1118) = lu(1118) - lu(339) * lu(1078) - lu(1119) = lu(1119) - lu(340) * lu(1078) - lu(1120) = lu(1120) - lu(341) * lu(1078) - lu(1230) = lu(1230) - lu(336) * lu(1213) - lu(1240) = lu(1240) - lu(337) * lu(1213) - lu(1248) = lu(1248) - lu(338) * lu(1213) - lu(1252) = lu(1252) - lu(339) * lu(1213) - lu(1253) = lu(1253) - lu(340) * lu(1213) - lu(1254) = lu(1254) - lu(341) * lu(1213) - lu(1362) = lu(1362) - lu(336) * lu(1340) - lu(1373) = lu(1373) - lu(337) * lu(1340) - lu(1383) = lu(1383) - lu(338) * lu(1340) - lu(1387) = lu(1387) - lu(339) * lu(1340) - lu(1388) = lu(1388) - lu(340) * lu(1340) - lu(1389) = lu(1389) - lu(341) * lu(1340) - lu(344) = 1._r8 / lu(344) - lu(345) = lu(345) * lu(344) - lu(346) = lu(346) * lu(344) - lu(347) = lu(347) * lu(344) - lu(348) = lu(348) * lu(344) - lu(349) = lu(349) * lu(344) - lu(350) = lu(350) * lu(344) - lu(351) = lu(351) * lu(344) - lu(352) = lu(352) * lu(344) - lu(353) = lu(353) * lu(344) - lu(423) = lu(423) - lu(345) * lu(422) - lu(424) = lu(424) - lu(346) * lu(422) - lu(425) = lu(425) - lu(347) * lu(422) - lu(426) = lu(426) - lu(348) * lu(422) - lu(427) = - lu(349) * lu(422) - lu(428) = lu(428) - lu(350) * lu(422) - lu(429) = lu(429) - lu(351) * lu(422) - lu(430) = lu(430) - lu(352) * lu(422) - lu(431) = lu(431) - lu(353) * lu(422) - lu(894) = lu(894) - lu(345) * lu(892) - lu(895) = lu(895) - lu(346) * lu(892) - lu(896) = lu(896) - lu(347) * lu(892) - lu(897) = lu(897) - lu(348) * lu(892) - lu(900) = lu(900) - lu(349) * lu(892) - lu(903) = lu(903) - lu(350) * lu(892) - lu(904) = lu(904) - lu(351) * lu(892) - lu(905) = lu(905) - lu(352) * lu(892) - lu(912) = lu(912) - lu(353) * lu(892) - lu(928) = lu(928) - lu(345) * lu(925) - lu(929) = lu(929) - lu(346) * lu(925) - lu(930) = lu(930) - lu(347) * lu(925) - lu(932) = lu(932) - lu(348) * lu(925) - lu(936) = lu(936) - lu(349) * lu(925) - lu(942) = lu(942) - lu(350) * lu(925) - lu(943) = lu(943) - lu(351) * lu(925) - lu(944) = lu(944) - lu(352) * lu(925) - lu(951) = lu(951) - lu(353) * lu(925) - lu(358) = 1._r8 / lu(358) - lu(359) = lu(359) * lu(358) - lu(360) = lu(360) * lu(358) - lu(361) = lu(361) * lu(358) - lu(362) = lu(362) * lu(358) - lu(363) = lu(363) * lu(358) - lu(364) = lu(364) * lu(358) - lu(365) = lu(365) * lu(358) - lu(366) = lu(366) * lu(358) - lu(367) = lu(367) * lu(358) - lu(368) = lu(368) * lu(358) - lu(1080) = lu(1080) - lu(359) * lu(1079) - lu(1086) = lu(1086) - lu(360) * lu(1079) - lu(1094) = lu(1094) - lu(361) * lu(1079) - lu(1099) = lu(1099) - lu(362) * lu(1079) - lu(1105) = lu(1105) - lu(363) * lu(1079) - lu(1114) = lu(1114) - lu(364) * lu(1079) - lu(1118) = lu(1118) - lu(365) * lu(1079) - lu(1119) = lu(1119) - lu(366) * lu(1079) - lu(1120) = lu(1120) - lu(367) * lu(1079) - lu(1124) = lu(1124) - lu(368) * lu(1079) - lu(1215) = lu(1215) - lu(359) * lu(1214) - lu(1222) = lu(1222) - lu(360) * lu(1214) - lu(1230) = lu(1230) - lu(361) * lu(1214) - lu(1234) = lu(1234) - lu(362) * lu(1214) - lu(1240) = lu(1240) - lu(363) * lu(1214) - lu(1248) = lu(1248) - lu(364) * lu(1214) - lu(1252) = lu(1252) - lu(365) * lu(1214) - lu(1253) = lu(1253) - lu(366) * lu(1214) - lu(1254) = lu(1254) - lu(367) * lu(1214) - lu(1258) = lu(1258) - lu(368) * lu(1214) - lu(1342) = lu(1342) - lu(359) * lu(1341) - lu(1349) = lu(1349) - lu(360) * lu(1341) - lu(1362) = lu(1362) - lu(361) * lu(1341) - lu(1367) = lu(1367) - lu(362) * lu(1341) - lu(1373) = lu(1373) - lu(363) * lu(1341) - lu(1383) = lu(1383) - lu(364) * lu(1341) - lu(1387) = lu(1387) - lu(365) * lu(1341) - lu(1388) = lu(1388) - lu(366) * lu(1341) - lu(1389) = lu(1389) - lu(367) * lu(1341) - lu(1393) = lu(1393) - lu(368) * lu(1341) - lu(369) = 1._r8 / lu(369) - lu(370) = lu(370) * lu(369) - lu(371) = lu(371) * lu(369) - lu(372) = lu(372) * lu(369) - lu(373) = lu(373) * lu(369) - lu(374) = lu(374) * lu(369) - lu(519) = - lu(370) * lu(516) - lu(520) = - lu(371) * lu(516) - lu(521) = lu(521) - lu(372) * lu(516) - lu(526) = lu(526) - lu(373) * lu(516) - lu(527) = lu(527) - lu(374) * lu(516) - lu(541) = - lu(370) * lu(539) - lu(544) = - lu(371) * lu(539) - lu(545) = - lu(372) * lu(539) - lu(549) = lu(549) - lu(373) * lu(539) - lu(550) = - lu(374) * lu(539) - lu(863) = lu(863) - lu(370) * lu(855) - lu(871) = lu(871) - lu(371) * lu(855) - lu(872) = lu(872) - lu(372) * lu(855) - lu(881) = lu(881) - lu(373) * lu(855) - lu(884) = lu(884) - lu(374) * lu(855) - lu(1096) = lu(1096) - lu(370) * lu(1080) - lu(1105) = lu(1105) - lu(371) * lu(1080) - lu(1108) = lu(1108) - lu(372) * lu(1080) - lu(1120) = lu(1120) - lu(373) * lu(1080) - lu(1123) = lu(1123) - lu(374) * lu(1080) - lu(1232) = lu(1232) - lu(370) * lu(1215) - lu(1240) = lu(1240) - lu(371) * lu(1215) - lu(1242) = lu(1242) - lu(372) * lu(1215) - lu(1254) = lu(1254) - lu(373) * lu(1215) - lu(1257) = lu(1257) - lu(374) * lu(1215) - lu(1364) = lu(1364) - lu(370) * lu(1342) - lu(1373) = lu(1373) - lu(371) * lu(1342) - lu(1377) = lu(1377) - lu(372) * lu(1342) - lu(1389) = lu(1389) - lu(373) * lu(1342) - lu(1392) = lu(1392) - lu(374) * lu(1342) - lu(375) = 1._r8 / lu(375) - lu(376) = lu(376) * lu(375) - lu(377) = lu(377) * lu(375) - lu(378) = lu(378) * lu(375) - lu(511) = lu(511) - lu(376) * lu(509) - lu(512) = lu(512) - lu(377) * lu(509) - lu(513) = lu(513) - lu(378) * lu(509) - lu(674) = lu(674) - lu(376) * lu(672) - lu(680) = lu(680) - lu(377) * lu(672) - lu(684) = lu(684) - lu(378) * lu(672) - lu(780) = lu(780) - lu(376) * lu(778) - lu(793) = lu(793) - lu(377) * lu(778) - lu(797) = lu(797) - lu(378) * lu(778) - lu(860) = lu(860) - lu(376) * lu(856) - lu(876) = lu(876) - lu(377) * lu(856) - lu(881) = lu(881) - lu(378) * lu(856) - lu(1093) = lu(1093) - lu(376) * lu(1081) - lu(1114) = lu(1114) - lu(377) * lu(1081) - lu(1120) = lu(1120) - lu(378) * lu(1081) - lu(1137) = lu(1137) - lu(376) * lu(1131) - lu(1149) = lu(1149) - lu(377) * lu(1131) - lu(1155) = lu(1155) - lu(378) * lu(1131) - lu(1229) = lu(1229) - lu(376) * lu(1216) - lu(1248) = lu(1248) - lu(377) * lu(1216) - lu(1254) = lu(1254) - lu(378) * lu(1216) - lu(1271) = lu(1271) - lu(376) * lu(1266) - lu(1285) = lu(1285) - lu(377) * lu(1266) - lu(1291) = lu(1291) - lu(378) * lu(1266) - lu(1361) = lu(1361) - lu(376) * lu(1343) - lu(1383) = lu(1383) - lu(377) * lu(1343) - lu(1389) = lu(1389) - lu(378) * lu(1343) - lu(1407) = lu(1407) - lu(376) * lu(1399) - lu(1427) = lu(1427) - lu(377) * lu(1399) - lu(1433) = lu(1433) - lu(378) * lu(1399) - lu(379) = 1._r8 / lu(379) - lu(380) = lu(380) * lu(379) - lu(381) = lu(381) * lu(379) - lu(382) = lu(382) * lu(379) - lu(383) = lu(383) * lu(379) - lu(384) = lu(384) * lu(379) - lu(385) = lu(385) * lu(379) - lu(805) = lu(805) - lu(380) * lu(803) - lu(807) = lu(807) - lu(381) * lu(803) - lu(808) = lu(808) - lu(382) * lu(803) - lu(809) = lu(809) - lu(383) * lu(803) - lu(813) = lu(813) - lu(384) * lu(803) - lu(817) = lu(817) - lu(385) * lu(803) - lu(901) = lu(901) - lu(380) * lu(893) - lu(903) = lu(903) - lu(381) * lu(893) - lu(904) = lu(904) - lu(382) * lu(893) - lu(906) = lu(906) - lu(383) * lu(893) - lu(910) = lu(910) - lu(384) * lu(893) - lu(914) = - lu(385) * lu(893) - lu(938) = lu(938) - lu(380) * lu(926) - lu(942) = lu(942) - lu(381) * lu(926) - lu(943) = lu(943) - lu(382) * lu(926) - lu(945) = lu(945) - lu(383) * lu(926) - lu(949) = lu(949) - lu(384) * lu(926) - lu(953) = lu(953) - lu(385) * lu(926) - lu(1010) = lu(1010) - lu(380) * lu(990) - lu(1013) = lu(1013) - lu(381) * lu(990) - lu(1014) = lu(1014) - lu(382) * lu(990) - lu(1016) = lu(1016) - lu(383) * lu(990) - lu(1020) = lu(1020) - lu(384) * lu(990) - lu(1024) = lu(1024) - lu(385) * lu(990) - lu(1374) = lu(1374) - lu(380) * lu(1344) - lu(1378) = lu(1378) - lu(381) * lu(1344) - lu(1379) = lu(1379) - lu(382) * lu(1344) - lu(1381) = lu(1381) - lu(383) * lu(1344) - lu(1385) = lu(1385) - lu(384) * lu(1344) - lu(1389) = lu(1389) - lu(385) * lu(1344) - END SUBROUTINE lu_fac09 - - SUBROUTINE lu_fac10(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(388) = 1._r8 / lu(388) - lu(389) = lu(389) * lu(388) - lu(390) = lu(390) * lu(388) - lu(391) = lu(391) * lu(388) - lu(392) = lu(392) * lu(388) - lu(393) = lu(393) * lu(388) - lu(394) = lu(394) * lu(388) - lu(395) = lu(395) * lu(388) - lu(993) = - lu(389) * lu(991) - lu(1013) = lu(1013) - lu(390) * lu(991) - lu(1018) = lu(1018) - lu(391) * lu(991) - lu(1022) = lu(1022) - lu(392) * lu(991) - lu(1023) = lu(1023) - lu(393) * lu(991) - lu(1024) = lu(1024) - lu(394) * lu(991) - lu(1028) = lu(1028) - lu(395) * lu(991) - lu(1088) = lu(1088) - lu(389) * lu(1082) - lu(1109) = lu(1109) - lu(390) * lu(1082) - lu(1114) = lu(1114) - lu(391) * lu(1082) - lu(1118) = lu(1118) - lu(392) * lu(1082) - lu(1119) = lu(1119) - lu(393) * lu(1082) - lu(1120) = lu(1120) - lu(394) * lu(1082) - lu(1124) = lu(1124) - lu(395) * lu(1082) - lu(1135) = - lu(389) * lu(1132) - lu(1144) = lu(1144) - lu(390) * lu(1132) - lu(1149) = lu(1149) - lu(391) * lu(1132) - lu(1153) = - lu(392) * lu(1132) - lu(1154) = - lu(393) * lu(1132) - lu(1155) = lu(1155) - lu(394) * lu(1132) - lu(1159) = lu(1159) - lu(395) * lu(1132) - lu(1224) = lu(1224) - lu(389) * lu(1217) - lu(1243) = lu(1243) - lu(390) * lu(1217) - lu(1248) = lu(1248) - lu(391) * lu(1217) - lu(1252) = lu(1252) - lu(392) * lu(1217) - lu(1253) = lu(1253) - lu(393) * lu(1217) - lu(1254) = lu(1254) - lu(394) * lu(1217) - lu(1258) = lu(1258) - lu(395) * lu(1217) - lu(1353) = lu(1353) - lu(389) * lu(1345) - lu(1378) = lu(1378) - lu(390) * lu(1345) - lu(1383) = lu(1383) - lu(391) * lu(1345) - lu(1387) = lu(1387) - lu(392) * lu(1345) - lu(1388) = lu(1388) - lu(393) * lu(1345) - lu(1389) = lu(1389) - lu(394) * lu(1345) - lu(1393) = lu(1393) - lu(395) * lu(1345) - lu(397) = 1._r8 / lu(397) - lu(398) = lu(398) * lu(397) - lu(399) = lu(399) * lu(397) - lu(400) = lu(400) * lu(397) - lu(401) = lu(401) * lu(397) - lu(402) = lu(402) * lu(397) - lu(403) = lu(403) * lu(397) - lu(404) = lu(404) * lu(397) - lu(824) = lu(824) - lu(398) * lu(821) - lu(825) = lu(825) - lu(399) * lu(821) - lu(826) = lu(826) - lu(400) * lu(821) - lu(829) = lu(829) - lu(401) * lu(821) - lu(831) = - lu(402) * lu(821) - lu(833) = lu(833) - lu(403) * lu(821) - lu(836) = lu(836) - lu(404) * lu(821) - lu(939) = lu(939) - lu(398) * lu(927) - lu(940) = lu(940) - lu(399) * lu(927) - lu(943) = lu(943) - lu(400) * lu(927) - lu(948) = lu(948) - lu(401) * lu(927) - lu(950) = lu(950) - lu(402) * lu(927) - lu(953) = lu(953) - lu(403) * lu(927) - lu(956) = lu(956) - lu(404) * lu(927) - lu(1106) = lu(1106) - lu(398) * lu(1083) - lu(1107) = lu(1107) - lu(399) * lu(1083) - lu(1110) = lu(1110) - lu(400) * lu(1083) - lu(1115) = lu(1115) - lu(401) * lu(1083) - lu(1117) = lu(1117) - lu(402) * lu(1083) - lu(1120) = lu(1120) - lu(403) * lu(1083) - lu(1123) = lu(1123) - lu(404) * lu(1083) - lu(1186) = - lu(398) * lu(1183) - lu(1187) = lu(1187) - lu(399) * lu(1183) - lu(1189) = lu(1189) - lu(400) * lu(1183) - lu(1194) = lu(1194) - lu(401) * lu(1183) - lu(1196) = lu(1196) - lu(402) * lu(1183) - lu(1199) = lu(1199) - lu(403) * lu(1183) - lu(1202) = - lu(404) * lu(1183) - lu(1277) = - lu(398) * lu(1267) - lu(1278) = lu(1278) - lu(399) * lu(1267) - lu(1281) = lu(1281) - lu(400) * lu(1267) - lu(1286) = - lu(401) * lu(1267) - lu(1288) = lu(1288) - lu(402) * lu(1267) - lu(1291) = lu(1291) - lu(403) * lu(1267) - lu(1294) = lu(1294) - lu(404) * lu(1267) - lu(405) = 1._r8 / lu(405) - lu(406) = lu(406) * lu(405) - lu(407) = lu(407) * lu(405) - lu(408) = lu(408) * lu(405) - lu(409) = lu(409) * lu(405) - lu(410) = lu(410) * lu(405) - lu(411) = lu(411) * lu(405) - lu(412) = lu(412) * lu(405) - lu(424) = lu(424) - lu(406) * lu(423) - lu(425) = lu(425) - lu(407) * lu(423) - lu(426) = lu(426) - lu(408) * lu(423) - lu(428) = lu(428) - lu(409) * lu(423) - lu(429) = lu(429) - lu(410) * lu(423) - lu(430) = lu(430) - lu(411) * lu(423) - lu(431) = lu(431) - lu(412) * lu(423) - lu(474) = lu(474) - lu(406) * lu(473) - lu(475) = lu(475) - lu(407) * lu(473) - lu(476) = lu(476) - lu(408) * lu(473) - lu(478) = lu(478) - lu(409) * lu(473) - lu(479) = lu(479) - lu(410) * lu(473) - lu(480) = - lu(411) * lu(473) - lu(482) = lu(482) - lu(412) * lu(473) - lu(895) = lu(895) - lu(406) * lu(894) - lu(896) = lu(896) - lu(407) * lu(894) - lu(897) = lu(897) - lu(408) * lu(894) - lu(903) = lu(903) - lu(409) * lu(894) - lu(904) = lu(904) - lu(410) * lu(894) - lu(905) = lu(905) - lu(411) * lu(894) - lu(912) = lu(912) - lu(412) * lu(894) - lu(929) = lu(929) - lu(406) * lu(928) - lu(930) = lu(930) - lu(407) * lu(928) - lu(932) = lu(932) - lu(408) * lu(928) - lu(942) = lu(942) - lu(409) * lu(928) - lu(943) = lu(943) - lu(410) * lu(928) - lu(944) = lu(944) - lu(411) * lu(928) - lu(951) = lu(951) - lu(412) * lu(928) - lu(1219) = lu(1219) - lu(406) * lu(1218) - lu(1220) = lu(1220) - lu(407) * lu(1218) - lu(1223) = lu(1223) - lu(408) * lu(1218) - lu(1243) = lu(1243) - lu(409) * lu(1218) - lu(1244) = lu(1244) - lu(410) * lu(1218) - lu(1245) = - lu(411) * lu(1218) - lu(1252) = lu(1252) - lu(412) * lu(1218) - lu(414) = 1._r8 / lu(414) - lu(415) = lu(415) * lu(414) - lu(416) = lu(416) * lu(414) - lu(417) = lu(417) * lu(414) - lu(418) = lu(418) * lu(414) - lu(419) = lu(419) * lu(414) - lu(420) = lu(420) * lu(414) - lu(425) = lu(425) - lu(415) * lu(424) - lu(426) = lu(426) - lu(416) * lu(424) - lu(428) = lu(428) - lu(417) * lu(424) - lu(429) = lu(429) - lu(418) * lu(424) - lu(430) = lu(430) - lu(419) * lu(424) - lu(431) = lu(431) - lu(420) * lu(424) - lu(475) = lu(475) - lu(415) * lu(474) - lu(476) = lu(476) - lu(416) * lu(474) - lu(478) = lu(478) - lu(417) * lu(474) - lu(479) = lu(479) - lu(418) * lu(474) - lu(480) = lu(480) - lu(419) * lu(474) - lu(482) = lu(482) - lu(420) * lu(474) - lu(896) = lu(896) - lu(415) * lu(895) - lu(897) = lu(897) - lu(416) * lu(895) - lu(903) = lu(903) - lu(417) * lu(895) - lu(904) = lu(904) - lu(418) * lu(895) - lu(905) = lu(905) - lu(419) * lu(895) - lu(912) = lu(912) - lu(420) * lu(895) - lu(930) = lu(930) - lu(415) * lu(929) - lu(932) = lu(932) - lu(416) * lu(929) - lu(942) = lu(942) - lu(417) * lu(929) - lu(943) = lu(943) - lu(418) * lu(929) - lu(944) = lu(944) - lu(419) * lu(929) - lu(951) = lu(951) - lu(420) * lu(929) - lu(1220) = lu(1220) - lu(415) * lu(1219) - lu(1223) = lu(1223) - lu(416) * lu(1219) - lu(1243) = lu(1243) - lu(417) * lu(1219) - lu(1244) = lu(1244) - lu(418) * lu(1219) - lu(1245) = lu(1245) - lu(419) * lu(1219) - lu(1252) = lu(1252) - lu(420) * lu(1219) - lu(425) = 1._r8 / lu(425) - lu(426) = lu(426) * lu(425) - lu(427) = lu(427) * lu(425) - lu(428) = lu(428) * lu(425) - lu(429) = lu(429) * lu(425) - lu(430) = lu(430) * lu(425) - lu(431) = lu(431) * lu(425) - lu(476) = lu(476) - lu(426) * lu(475) - lu(477) = lu(477) - lu(427) * lu(475) - lu(478) = lu(478) - lu(428) * lu(475) - lu(479) = lu(479) - lu(429) * lu(475) - lu(480) = lu(480) - lu(430) * lu(475) - lu(482) = lu(482) - lu(431) * lu(475) - lu(897) = lu(897) - lu(426) * lu(896) - lu(900) = lu(900) - lu(427) * lu(896) - lu(903) = lu(903) - lu(428) * lu(896) - lu(904) = lu(904) - lu(429) * lu(896) - lu(905) = lu(905) - lu(430) * lu(896) - lu(912) = lu(912) - lu(431) * lu(896) - lu(932) = lu(932) - lu(426) * lu(930) - lu(936) = lu(936) - lu(427) * lu(930) - lu(942) = lu(942) - lu(428) * lu(930) - lu(943) = lu(943) - lu(429) * lu(930) - lu(944) = lu(944) - lu(430) * lu(930) - lu(951) = lu(951) - lu(431) * lu(930) - lu(1223) = lu(1223) - lu(426) * lu(1220) - lu(1229) = lu(1229) - lu(427) * lu(1220) - lu(1243) = lu(1243) - lu(428) * lu(1220) - lu(1244) = lu(1244) - lu(429) * lu(1220) - lu(1245) = lu(1245) - lu(430) * lu(1220) - lu(1252) = lu(1252) - lu(431) * lu(1220) - lu(433) = 1._r8 / lu(433) - lu(434) = lu(434) * lu(433) - lu(435) = lu(435) * lu(433) - lu(436) = lu(436) * lu(433) - lu(437) = lu(437) * lu(433) - lu(438) = lu(438) * lu(433) - lu(439) = lu(439) * lu(433) - lu(440) = lu(440) * lu(433) - lu(650) = lu(650) - lu(434) * lu(649) - lu(652) = - lu(435) * lu(649) - lu(656) = lu(656) - lu(436) * lu(649) - lu(657) = lu(657) - lu(437) * lu(649) - lu(658) = - lu(438) * lu(649) - lu(659) = - lu(439) * lu(649) - lu(660) = lu(660) - lu(440) * lu(649) - lu(964) = lu(964) - lu(434) * lu(962) - lu(967) = lu(967) - lu(435) * lu(962) - lu(975) = lu(975) - lu(436) * lu(962) - lu(979) = lu(979) - lu(437) * lu(962) - lu(980) = - lu(438) * lu(962) - lu(981) = - lu(439) * lu(962) - lu(982) = lu(982) - lu(440) * lu(962) - lu(1366) = lu(1366) - lu(434) * lu(1346) - lu(1377) = lu(1377) - lu(435) * lu(1346) - lu(1385) = lu(1385) - lu(436) * lu(1346) - lu(1389) = lu(1389) - lu(437) * lu(1346) - lu(1390) = lu(1390) - lu(438) * lu(1346) - lu(1391) = lu(1391) - lu(439) * lu(1346) - lu(1392) = lu(1392) - lu(440) * lu(1346) - lu(1440) = - lu(434) * lu(1439) - lu(1443) = - lu(435) * lu(1439) - lu(1451) = lu(1451) - lu(436) * lu(1439) - lu(1455) = lu(1455) - lu(437) * lu(1439) - lu(1456) = lu(1456) - lu(438) * lu(1439) - lu(1457) = lu(1457) - lu(439) * lu(1439) - lu(1458) = lu(1458) - lu(440) * lu(1439) - lu(1465) = lu(1465) - lu(434) * lu(1463) - lu(1469) = - lu(435) * lu(1463) - lu(1477) = lu(1477) - lu(436) * lu(1463) - lu(1481) = lu(1481) - lu(437) * lu(1463) - lu(1482) = - lu(438) * lu(1463) - lu(1483) = - lu(439) * lu(1463) - lu(1484) = lu(1484) - lu(440) * lu(1463) - END SUBROUTINE lu_fac10 - - SUBROUTINE lu_fac11(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(442) = 1._r8 / lu(442) - lu(443) = lu(443) * lu(442) - lu(444) = lu(444) * lu(442) - lu(445) = lu(445) * lu(442) - lu(446) = lu(446) * lu(442) - lu(447) = lu(447) * lu(442) - lu(448) = lu(448) * lu(442) - lu(449) = lu(449) * lu(442) - lu(450) = lu(450) * lu(442) - lu(451) = lu(451) * lu(442) - lu(589) = lu(589) - lu(443) * lu(586) - lu(590) = - lu(444) * lu(586) - lu(593) = - lu(445) * lu(586) - lu(595) = lu(595) - lu(446) * lu(586) - lu(596) = - lu(447) * lu(586) - lu(597) = lu(597) - lu(448) * lu(586) - lu(598) = lu(598) - lu(449) * lu(586) - lu(600) = lu(600) - lu(450) * lu(586) - lu(601) = lu(601) - lu(451) * lu(586) - lu(1094) = lu(1094) - lu(443) * lu(1084) - lu(1095) = lu(1095) - lu(444) * lu(1084) - lu(1109) = lu(1109) - lu(445) * lu(1084) - lu(1114) = lu(1114) - lu(446) * lu(1084) - lu(1118) = lu(1118) - lu(447) * lu(1084) - lu(1119) = lu(1119) - lu(448) * lu(1084) - lu(1120) = lu(1120) - lu(449) * lu(1084) - lu(1123) = lu(1123) - lu(450) * lu(1084) - lu(1124) = lu(1124) - lu(451) * lu(1084) - lu(1230) = lu(1230) - lu(443) * lu(1221) - lu(1231) = lu(1231) - lu(444) * lu(1221) - lu(1243) = lu(1243) - lu(445) * lu(1221) - lu(1248) = lu(1248) - lu(446) * lu(1221) - lu(1252) = lu(1252) - lu(447) * lu(1221) - lu(1253) = lu(1253) - lu(448) * lu(1221) - lu(1254) = lu(1254) - lu(449) * lu(1221) - lu(1257) = lu(1257) - lu(450) * lu(1221) - lu(1258) = lu(1258) - lu(451) * lu(1221) - lu(1362) = lu(1362) - lu(443) * lu(1347) - lu(1363) = lu(1363) - lu(444) * lu(1347) - lu(1378) = lu(1378) - lu(445) * lu(1347) - lu(1383) = lu(1383) - lu(446) * lu(1347) - lu(1387) = lu(1387) - lu(447) * lu(1347) - lu(1388) = lu(1388) - lu(448) * lu(1347) - lu(1389) = lu(1389) - lu(449) * lu(1347) - lu(1392) = lu(1392) - lu(450) * lu(1347) - lu(1393) = lu(1393) - lu(451) * lu(1347) - lu(452) = 1._r8 / lu(452) - lu(453) = lu(453) * lu(452) - lu(454) = lu(454) * lu(452) - lu(455) = lu(455) * lu(452) - lu(456) = lu(456) * lu(452) - lu(457) = lu(457) * lu(452) - lu(458) = lu(458) * lu(452) - lu(839) = lu(839) - lu(453) * lu(837) - lu(841) = - lu(454) * lu(837) - lu(842) = - lu(455) * lu(837) - lu(845) = - lu(456) * lu(837) - lu(847) = - lu(457) * lu(837) - lu(848) = - lu(458) * lu(837) - lu(940) = lu(940) - lu(453) * lu(931) - lu(943) = lu(943) - lu(454) * lu(931) - lu(944) = lu(944) - lu(455) * lu(931) - lu(949) = lu(949) - lu(456) * lu(931) - lu(953) = lu(953) - lu(457) * lu(931) - lu(956) = lu(956) - lu(458) * lu(931) - lu(966) = lu(966) - lu(453) * lu(963) - lu(969) = lu(969) - lu(454) * lu(963) - lu(970) = lu(970) - lu(455) * lu(963) - lu(975) = lu(975) - lu(456) * lu(963) - lu(979) = lu(979) - lu(457) * lu(963) - lu(982) = lu(982) - lu(458) * lu(963) - lu(1107) = lu(1107) - lu(453) * lu(1085) - lu(1110) = lu(1110) - lu(454) * lu(1085) - lu(1111) = - lu(455) * lu(1085) - lu(1116) = lu(1116) - lu(456) * lu(1085) - lu(1120) = lu(1120) - lu(457) * lu(1085) - lu(1123) = lu(1123) - lu(458) * lu(1085) - lu(1376) = lu(1376) - lu(453) * lu(1348) - lu(1379) = lu(1379) - lu(454) * lu(1348) - lu(1380) = lu(1380) - lu(455) * lu(1348) - lu(1385) = lu(1385) - lu(456) * lu(1348) - lu(1389) = lu(1389) - lu(457) * lu(1348) - lu(1392) = lu(1392) - lu(458) * lu(1348) - lu(1492) = lu(1492) - lu(453) * lu(1488) - lu(1495) = lu(1495) - lu(454) * lu(1488) - lu(1496) = - lu(455) * lu(1488) - lu(1501) = lu(1501) - lu(456) * lu(1488) - lu(1505) = lu(1505) - lu(457) * lu(1488) - lu(1508) = lu(1508) - lu(458) * lu(1488) - lu(462) = 1._r8 / lu(462) - lu(463) = lu(463) * lu(462) - lu(464) = lu(464) * lu(462) - lu(465) = lu(465) * lu(462) - lu(466) = lu(466) * lu(462) - lu(467) = lu(467) * lu(462) - lu(468) = lu(468) * lu(462) - lu(469) = lu(469) * lu(462) - lu(470) = lu(470) * lu(462) - lu(861) = lu(861) - lu(463) * lu(857) - lu(872) = lu(872) - lu(464) * lu(857) - lu(873) = lu(873) - lu(465) * lu(857) - lu(876) = lu(876) - lu(466) * lu(857) - lu(879) = lu(879) - lu(467) * lu(857) - lu(880) = lu(880) - lu(468) * lu(857) - lu(881) = lu(881) - lu(469) * lu(857) - lu(885) = lu(885) - lu(470) * lu(857) - lu(1094) = lu(1094) - lu(463) * lu(1086) - lu(1108) = lu(1108) - lu(464) * lu(1086) - lu(1109) = lu(1109) - lu(465) * lu(1086) - lu(1114) = lu(1114) - lu(466) * lu(1086) - lu(1118) = lu(1118) - lu(467) * lu(1086) - lu(1119) = lu(1119) - lu(468) * lu(1086) - lu(1120) = lu(1120) - lu(469) * lu(1086) - lu(1124) = lu(1124) - lu(470) * lu(1086) - lu(1138) = - lu(463) * lu(1133) - lu(1143) = lu(1143) - lu(464) * lu(1133) - lu(1144) = lu(1144) - lu(465) * lu(1133) - lu(1149) = lu(1149) - lu(466) * lu(1133) - lu(1153) = lu(1153) - lu(467) * lu(1133) - lu(1154) = lu(1154) - lu(468) * lu(1133) - lu(1155) = lu(1155) - lu(469) * lu(1133) - lu(1159) = lu(1159) - lu(470) * lu(1133) - lu(1230) = lu(1230) - lu(463) * lu(1222) - lu(1242) = lu(1242) - lu(464) * lu(1222) - lu(1243) = lu(1243) - lu(465) * lu(1222) - lu(1248) = lu(1248) - lu(466) * lu(1222) - lu(1252) = lu(1252) - lu(467) * lu(1222) - lu(1253) = lu(1253) - lu(468) * lu(1222) - lu(1254) = lu(1254) - lu(469) * lu(1222) - lu(1258) = lu(1258) - lu(470) * lu(1222) - lu(1362) = lu(1362) - lu(463) * lu(1349) - lu(1377) = lu(1377) - lu(464) * lu(1349) - lu(1378) = lu(1378) - lu(465) * lu(1349) - lu(1383) = lu(1383) - lu(466) * lu(1349) - lu(1387) = lu(1387) - lu(467) * lu(1349) - lu(1388) = lu(1388) - lu(468) * lu(1349) - lu(1389) = lu(1389) - lu(469) * lu(1349) - lu(1393) = lu(1393) - lu(470) * lu(1349) - lu(476) = 1._r8 / lu(476) - lu(477) = lu(477) * lu(476) - lu(478) = lu(478) * lu(476) - lu(479) = lu(479) * lu(476) - lu(480) = lu(480) * lu(476) - lu(481) = lu(481) * lu(476) - lu(482) = lu(482) * lu(476) - lu(483) = lu(483) * lu(476) - lu(484) = lu(484) * lu(476) - lu(900) = lu(900) - lu(477) * lu(897) - lu(903) = lu(903) - lu(478) * lu(897) - lu(904) = lu(904) - lu(479) * lu(897) - lu(905) = lu(905) - lu(480) * lu(897) - lu(910) = lu(910) - lu(481) * lu(897) - lu(912) = lu(912) - lu(482) * lu(897) - lu(913) = - lu(483) * lu(897) - lu(914) = lu(914) - lu(484) * lu(897) - lu(936) = lu(936) - lu(477) * lu(932) - lu(942) = lu(942) - lu(478) * lu(932) - lu(943) = lu(943) - lu(479) * lu(932) - lu(944) = lu(944) - lu(480) * lu(932) - lu(949) = lu(949) - lu(481) * lu(932) - lu(951) = lu(951) - lu(482) * lu(932) - lu(952) = lu(952) - lu(483) * lu(932) - lu(953) = lu(953) - lu(484) * lu(932) - lu(1229) = lu(1229) - lu(477) * lu(1223) - lu(1243) = lu(1243) - lu(478) * lu(1223) - lu(1244) = lu(1244) - lu(479) * lu(1223) - lu(1245) = lu(1245) - lu(480) * lu(1223) - lu(1250) = - lu(481) * lu(1223) - lu(1252) = lu(1252) - lu(482) * lu(1223) - lu(1253) = lu(1253) - lu(483) * lu(1223) - lu(1254) = lu(1254) - lu(484) * lu(1223) - lu(1271) = lu(1271) - lu(477) * lu(1268) - lu(1280) = lu(1280) - lu(478) * lu(1268) - lu(1281) = lu(1281) - lu(479) * lu(1268) - lu(1282) = - lu(480) * lu(1268) - lu(1287) = - lu(481) * lu(1268) - lu(1289) = lu(1289) - lu(482) * lu(1268) - lu(1290) = lu(1290) - lu(483) * lu(1268) - lu(1291) = lu(1291) - lu(484) * lu(1268) - lu(1361) = lu(1361) - lu(477) * lu(1350) - lu(1378) = lu(1378) - lu(478) * lu(1350) - lu(1379) = lu(1379) - lu(479) * lu(1350) - lu(1380) = lu(1380) - lu(480) * lu(1350) - lu(1385) = lu(1385) - lu(481) * lu(1350) - lu(1387) = lu(1387) - lu(482) * lu(1350) - lu(1388) = lu(1388) - lu(483) * lu(1350) - lu(1389) = lu(1389) - lu(484) * lu(1350) - lu(486) = 1._r8 / lu(486) - lu(487) = lu(487) * lu(486) - lu(488) = lu(488) * lu(486) - lu(489) = lu(489) * lu(486) - lu(490) = lu(490) * lu(486) - lu(491) = lu(491) * lu(486) - lu(492) = lu(492) * lu(486) - lu(561) = lu(561) - lu(487) * lu(559) - lu(562) = lu(562) - lu(488) * lu(559) - lu(563) = lu(563) - lu(489) * lu(559) - lu(564) = lu(564) - lu(490) * lu(559) - lu(566) = lu(566) - lu(491) * lu(559) - lu(569) = - lu(492) * lu(559) - lu(824) = lu(824) - lu(487) * lu(822) - lu(826) = lu(826) - lu(488) * lu(822) - lu(828) = - lu(489) * lu(822) - lu(829) = lu(829) - lu(490) * lu(822) - lu(833) = lu(833) - lu(491) * lu(822) - lu(836) = lu(836) - lu(492) * lu(822) - lu(939) = lu(939) - lu(487) * lu(933) - lu(943) = lu(943) - lu(488) * lu(933) - lu(946) = lu(946) - lu(489) * lu(933) - lu(948) = lu(948) - lu(490) * lu(933) - lu(953) = lu(953) - lu(491) * lu(933) - lu(956) = lu(956) - lu(492) * lu(933) - lu(1037) = lu(1037) - lu(487) * lu(1033) - lu(1041) = lu(1041) - lu(488) * lu(1033) - lu(1044) = lu(1044) - lu(489) * lu(1033) - lu(1046) = lu(1046) - lu(490) * lu(1033) - lu(1051) = lu(1051) - lu(491) * lu(1033) - lu(1054) = - lu(492) * lu(1033) - lu(1106) = lu(1106) - lu(487) * lu(1087) - lu(1110) = lu(1110) - lu(488) * lu(1087) - lu(1113) = lu(1113) - lu(489) * lu(1087) - lu(1115) = lu(1115) - lu(490) * lu(1087) - lu(1120) = lu(1120) - lu(491) * lu(1087) - lu(1123) = lu(1123) - lu(492) * lu(1087) - lu(1141) = lu(1141) - lu(487) * lu(1134) - lu(1145) = lu(1145) - lu(488) * lu(1134) - lu(1148) = lu(1148) - lu(489) * lu(1134) - lu(1150) = lu(1150) - lu(490) * lu(1134) - lu(1155) = lu(1155) - lu(491) * lu(1134) - lu(1158) = lu(1158) - lu(492) * lu(1134) - lu(1375) = lu(1375) - lu(487) * lu(1351) - lu(1379) = lu(1379) - lu(488) * lu(1351) - lu(1382) = lu(1382) - lu(489) * lu(1351) - lu(1384) = lu(1384) - lu(490) * lu(1351) - lu(1389) = lu(1389) - lu(491) * lu(1351) - lu(1392) = lu(1392) - lu(492) * lu(1351) - END SUBROUTINE lu_fac11 - - SUBROUTINE lu_fac12(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(494) = 1._r8 / lu(494) - lu(495) = lu(495) * lu(494) - lu(496) = lu(496) * lu(494) - lu(497) = lu(497) * lu(494) - lu(498) = lu(498) * lu(494) - lu(499) = lu(499) * lu(494) - lu(500) = lu(500) * lu(494) - lu(501) = lu(501) * lu(494) - lu(502) = lu(502) * lu(494) - lu(503) = lu(503) * lu(494) - lu(504) = lu(504) * lu(494) - lu(505) = lu(505) * lu(494) - lu(506) = lu(506) * lu(494) - lu(507) = lu(507) * lu(494) - lu(508) = lu(508) * lu(494) - lu(996) = - lu(495) * lu(992) - lu(997) = lu(997) - lu(496) * lu(992) - lu(998) = lu(998) - lu(497) * lu(992) - lu(1002) = lu(1002) - lu(498) * lu(992) - lu(1005) = - lu(499) * lu(992) - lu(1007) = lu(1007) - lu(500) * lu(992) - lu(1008) = lu(1008) - lu(501) * lu(992) - lu(1012) = lu(1012) - lu(502) * lu(992) - lu(1016) = lu(1016) - lu(503) * lu(992) - lu(1018) = lu(1018) - lu(504) * lu(992) - lu(1024) = lu(1024) - lu(505) * lu(992) - lu(1025) = lu(1025) - lu(506) * lu(992) - lu(1027) = lu(1027) - lu(507) * lu(992) - lu(1028) = lu(1028) - lu(508) * lu(992) - lu(1359) = - lu(495) * lu(1352) - lu(1360) = lu(1360) - lu(496) * lu(1352) - lu(1361) = lu(1361) - lu(497) * lu(1352) - lu(1365) = lu(1365) - lu(498) * lu(1352) - lu(1369) = lu(1369) - lu(499) * lu(1352) - lu(1371) = lu(1371) - lu(500) * lu(1352) - lu(1372) = lu(1372) - lu(501) * lu(1352) - lu(1377) = lu(1377) - lu(502) * lu(1352) - lu(1381) = lu(1381) - lu(503) * lu(1352) - lu(1383) = lu(1383) - lu(504) * lu(1352) - lu(1389) = lu(1389) - lu(505) * lu(1352) - lu(1390) = lu(1390) - lu(506) * lu(1352) - lu(1392) = lu(1392) - lu(507) * lu(1352) - lu(1393) = lu(1393) - lu(508) * lu(1352) - lu(1405) = lu(1405) - lu(495) * lu(1400) - lu(1406) = lu(1406) - lu(496) * lu(1400) - lu(1407) = lu(1407) - lu(497) * lu(1400) - lu(1411) = lu(1411) - lu(498) * lu(1400) - lu(1414) = lu(1414) - lu(499) * lu(1400) - lu(1416) = lu(1416) - lu(500) * lu(1400) - lu(1417) = lu(1417) - lu(501) * lu(1400) - lu(1421) = - lu(502) * lu(1400) - lu(1425) = lu(1425) - lu(503) * lu(1400) - lu(1427) = lu(1427) - lu(504) * lu(1400) - lu(1433) = lu(1433) - lu(505) * lu(1400) - lu(1434) = lu(1434) - lu(506) * lu(1400) - lu(1436) = - lu(507) * lu(1400) - lu(1437) = lu(1437) - lu(508) * lu(1400) - lu(510) = 1._r8 / lu(510) - lu(511) = lu(511) * lu(510) - lu(512) = lu(512) * lu(510) - lu(513) = lu(513) * lu(510) - lu(514) = lu(514) * lu(510) - lu(674) = lu(674) - lu(511) * lu(673) - lu(680) = lu(680) - lu(512) * lu(673) - lu(684) = lu(684) - lu(513) * lu(673) - lu(688) = lu(688) - lu(514) * lu(673) - lu(717) = lu(717) - lu(511) * lu(715) - lu(725) = lu(725) - lu(512) * lu(715) - lu(729) = lu(729) - lu(513) * lu(715) - lu(733) = lu(733) - lu(514) * lu(715) - lu(780) = lu(780) - lu(511) * lu(779) - lu(793) = lu(793) - lu(512) * lu(779) - lu(797) = lu(797) - lu(513) * lu(779) - lu(801) = lu(801) - lu(514) * lu(779) - lu(860) = lu(860) - lu(511) * lu(858) - lu(876) = lu(876) - lu(512) * lu(858) - lu(881) = lu(881) - lu(513) * lu(858) - lu(885) = lu(885) - lu(514) * lu(858) - lu(900) = lu(900) - lu(511) * lu(898) - lu(908) = lu(908) - lu(512) * lu(898) - lu(914) = lu(914) - lu(513) * lu(898) - lu(916) = lu(916) - lu(514) * lu(898) - lu(998) = lu(998) - lu(511) * lu(993) - lu(1018) = lu(1018) - lu(512) * lu(993) - lu(1024) = lu(1024) - lu(513) * lu(993) - lu(1028) = lu(1028) - lu(514) * lu(993) - lu(1093) = lu(1093) - lu(511) * lu(1088) - lu(1114) = lu(1114) - lu(512) * lu(1088) - lu(1120) = lu(1120) - lu(513) * lu(1088) - lu(1124) = lu(1124) - lu(514) * lu(1088) - lu(1137) = lu(1137) - lu(511) * lu(1135) - lu(1149) = lu(1149) - lu(512) * lu(1135) - lu(1155) = lu(1155) - lu(513) * lu(1135) - lu(1159) = lu(1159) - lu(514) * lu(1135) - lu(1229) = lu(1229) - lu(511) * lu(1224) - lu(1248) = lu(1248) - lu(512) * lu(1224) - lu(1254) = lu(1254) - lu(513) * lu(1224) - lu(1258) = lu(1258) - lu(514) * lu(1224) - lu(1361) = lu(1361) - lu(511) * lu(1353) - lu(1383) = lu(1383) - lu(512) * lu(1353) - lu(1389) = lu(1389) - lu(513) * lu(1353) - lu(1393) = lu(1393) - lu(514) * lu(1353) - lu(1407) = lu(1407) - lu(511) * lu(1401) - lu(1427) = lu(1427) - lu(512) * lu(1401) - lu(1433) = lu(1433) - lu(513) * lu(1401) - lu(1437) = lu(1437) - lu(514) * lu(1401) - lu(517) = 1._r8 / lu(517) - lu(518) = lu(518) * lu(517) - lu(519) = lu(519) * lu(517) - lu(520) = lu(520) * lu(517) - lu(521) = lu(521) * lu(517) - lu(522) = lu(522) * lu(517) - lu(523) = lu(523) * lu(517) - lu(524) = lu(524) * lu(517) - lu(525) = lu(525) * lu(517) - lu(526) = lu(526) * lu(517) - lu(527) = lu(527) * lu(517) - lu(528) = lu(528) * lu(517) - lu(861) = lu(861) - lu(518) * lu(859) - lu(863) = lu(863) - lu(519) * lu(859) - lu(871) = lu(871) - lu(520) * lu(859) - lu(872) = lu(872) - lu(521) * lu(859) - lu(873) = lu(873) - lu(522) * lu(859) - lu(876) = lu(876) - lu(523) * lu(859) - lu(879) = lu(879) - lu(524) * lu(859) - lu(880) = lu(880) - lu(525) * lu(859) - lu(881) = lu(881) - lu(526) * lu(859) - lu(884) = lu(884) - lu(527) * lu(859) - lu(885) = lu(885) - lu(528) * lu(859) - lu(1094) = lu(1094) - lu(518) * lu(1089) - lu(1096) = lu(1096) - lu(519) * lu(1089) - lu(1105) = lu(1105) - lu(520) * lu(1089) - lu(1108) = lu(1108) - lu(521) * lu(1089) - lu(1109) = lu(1109) - lu(522) * lu(1089) - lu(1114) = lu(1114) - lu(523) * lu(1089) - lu(1118) = lu(1118) - lu(524) * lu(1089) - lu(1119) = lu(1119) - lu(525) * lu(1089) - lu(1120) = lu(1120) - lu(526) * lu(1089) - lu(1123) = lu(1123) - lu(527) * lu(1089) - lu(1124) = lu(1124) - lu(528) * lu(1089) - lu(1230) = lu(1230) - lu(518) * lu(1225) - lu(1232) = lu(1232) - lu(519) * lu(1225) - lu(1240) = lu(1240) - lu(520) * lu(1225) - lu(1242) = lu(1242) - lu(521) * lu(1225) - lu(1243) = lu(1243) - lu(522) * lu(1225) - lu(1248) = lu(1248) - lu(523) * lu(1225) - lu(1252) = lu(1252) - lu(524) * lu(1225) - lu(1253) = lu(1253) - lu(525) * lu(1225) - lu(1254) = lu(1254) - lu(526) * lu(1225) - lu(1257) = lu(1257) - lu(527) * lu(1225) - lu(1258) = lu(1258) - lu(528) * lu(1225) - lu(1362) = lu(1362) - lu(518) * lu(1354) - lu(1364) = lu(1364) - lu(519) * lu(1354) - lu(1373) = lu(1373) - lu(520) * lu(1354) - lu(1377) = lu(1377) - lu(521) * lu(1354) - lu(1378) = lu(1378) - lu(522) * lu(1354) - lu(1383) = lu(1383) - lu(523) * lu(1354) - lu(1387) = lu(1387) - lu(524) * lu(1354) - lu(1388) = lu(1388) - lu(525) * lu(1354) - lu(1389) = lu(1389) - lu(526) * lu(1354) - lu(1392) = lu(1392) - lu(527) * lu(1354) - lu(1393) = lu(1393) - lu(528) * lu(1354) - lu(530) = 1._r8 / lu(530) - lu(531) = lu(531) * lu(530) - lu(532) = lu(532) * lu(530) - lu(533) = lu(533) * lu(530) - lu(534) = lu(534) * lu(530) - lu(535) = lu(535) * lu(530) - lu(536) = lu(536) * lu(530) - lu(537) = lu(537) * lu(530) - lu(573) = - lu(531) * lu(571) - lu(575) = lu(575) - lu(532) * lu(571) - lu(577) = lu(577) - lu(533) * lu(571) - lu(579) = lu(579) - lu(534) * lu(571) - lu(580) = lu(580) - lu(535) * lu(571) - lu(581) = lu(581) - lu(536) * lu(571) - lu(583) = lu(583) - lu(537) * lu(571) - lu(693) = - lu(531) * lu(692) - lu(696) = lu(696) - lu(532) * lu(692) - lu(704) = lu(704) - lu(533) * lu(692) - lu(707) = lu(707) - lu(534) * lu(692) - lu(708) = lu(708) - lu(535) * lu(692) - lu(709) = lu(709) - lu(536) * lu(692) - lu(712) = lu(712) - lu(537) * lu(692) - lu(717) = lu(717) - lu(531) * lu(716) - lu(720) = - lu(532) * lu(716) - lu(725) = lu(725) - lu(533) * lu(716) - lu(728) = lu(728) - lu(534) * lu(716) - lu(729) = lu(729) - lu(535) * lu(716) - lu(730) = lu(730) - lu(536) * lu(716) - lu(733) = lu(733) - lu(537) * lu(716) - lu(1093) = lu(1093) - lu(531) * lu(1090) - lu(1100) = lu(1100) - lu(532) * lu(1090) - lu(1114) = lu(1114) - lu(533) * lu(1090) - lu(1119) = lu(1119) - lu(534) * lu(1090) - lu(1120) = lu(1120) - lu(535) * lu(1090) - lu(1121) = lu(1121) - lu(536) * lu(1090) - lu(1124) = lu(1124) - lu(537) * lu(1090) - lu(1229) = lu(1229) - lu(531) * lu(1226) - lu(1235) = lu(1235) - lu(532) * lu(1226) - lu(1248) = lu(1248) - lu(533) * lu(1226) - lu(1253) = lu(1253) - lu(534) * lu(1226) - lu(1254) = lu(1254) - lu(535) * lu(1226) - lu(1255) = lu(1255) - lu(536) * lu(1226) - lu(1258) = lu(1258) - lu(537) * lu(1226) - lu(1361) = lu(1361) - lu(531) * lu(1355) - lu(1368) = lu(1368) - lu(532) * lu(1355) - lu(1383) = lu(1383) - lu(533) * lu(1355) - lu(1388) = lu(1388) - lu(534) * lu(1355) - lu(1389) = lu(1389) - lu(535) * lu(1355) - lu(1390) = lu(1390) - lu(536) * lu(1355) - lu(1393) = lu(1393) - lu(537) * lu(1355) - lu(1407) = lu(1407) - lu(531) * lu(1402) - lu(1413) = lu(1413) - lu(532) * lu(1402) - lu(1427) = lu(1427) - lu(533) * lu(1402) - lu(1432) = lu(1432) - lu(534) * lu(1402) - lu(1433) = lu(1433) - lu(535) * lu(1402) - lu(1434) = lu(1434) - lu(536) * lu(1402) - lu(1437) = lu(1437) - lu(537) * lu(1402) - lu(540) = 1._r8 / lu(540) - lu(541) = lu(541) * lu(540) - lu(542) = lu(542) * lu(540) - lu(543) = lu(543) * lu(540) - lu(544) = lu(544) * lu(540) - lu(545) = lu(545) * lu(540) - lu(546) = lu(546) * lu(540) - lu(547) = lu(547) * lu(540) - lu(548) = lu(548) * lu(540) - lu(549) = lu(549) * lu(540) - lu(550) = lu(550) * lu(540) - lu(1001) = - lu(541) * lu(994) - lu(1002) = lu(1002) - lu(542) * lu(994) - lu(1007) = lu(1007) - lu(543) * lu(994) - lu(1009) = - lu(544) * lu(994) - lu(1012) = lu(1012) - lu(545) * lu(994) - lu(1018) = lu(1018) - lu(546) * lu(994) - lu(1022) = lu(1022) - lu(547) * lu(994) - lu(1023) = lu(1023) - lu(548) * lu(994) - lu(1024) = lu(1024) - lu(549) * lu(994) - lu(1027) = lu(1027) - lu(550) * lu(994) - lu(1096) = lu(1096) - lu(541) * lu(1091) - lu(1097) = lu(1097) - lu(542) * lu(1091) - lu(1103) = lu(1103) - lu(543) * lu(1091) - lu(1105) = lu(1105) - lu(544) * lu(1091) - lu(1108) = lu(1108) - lu(545) * lu(1091) - lu(1114) = lu(1114) - lu(546) * lu(1091) - lu(1118) = lu(1118) - lu(547) * lu(1091) - lu(1119) = lu(1119) - lu(548) * lu(1091) - lu(1120) = lu(1120) - lu(549) * lu(1091) - lu(1123) = lu(1123) - lu(550) * lu(1091) - lu(1232) = lu(1232) - lu(541) * lu(1227) - lu(1233) = lu(1233) - lu(542) * lu(1227) - lu(1238) = lu(1238) - lu(543) * lu(1227) - lu(1240) = lu(1240) - lu(544) * lu(1227) - lu(1242) = lu(1242) - lu(545) * lu(1227) - lu(1248) = lu(1248) - lu(546) * lu(1227) - lu(1252) = lu(1252) - lu(547) * lu(1227) - lu(1253) = lu(1253) - lu(548) * lu(1227) - lu(1254) = lu(1254) - lu(549) * lu(1227) - lu(1257) = lu(1257) - lu(550) * lu(1227) - lu(1364) = lu(1364) - lu(541) * lu(1356) - lu(1365) = lu(1365) - lu(542) * lu(1356) - lu(1371) = lu(1371) - lu(543) * lu(1356) - lu(1373) = lu(1373) - lu(544) * lu(1356) - lu(1377) = lu(1377) - lu(545) * lu(1356) - lu(1383) = lu(1383) - lu(546) * lu(1356) - lu(1387) = lu(1387) - lu(547) * lu(1356) - lu(1388) = lu(1388) - lu(548) * lu(1356) - lu(1389) = lu(1389) - lu(549) * lu(1356) - lu(1392) = lu(1392) - lu(550) * lu(1356) - lu(1410) = - lu(541) * lu(1403) - lu(1411) = lu(1411) - lu(542) * lu(1403) - lu(1416) = lu(1416) - lu(543) * lu(1403) - lu(1418) = lu(1418) - lu(544) * lu(1403) - lu(1421) = lu(1421) - lu(545) * lu(1403) - lu(1427) = lu(1427) - lu(546) * lu(1403) - lu(1431) = lu(1431) - lu(547) * lu(1403) - lu(1432) = lu(1432) - lu(548) * lu(1403) - lu(1433) = lu(1433) - lu(549) * lu(1403) - lu(1436) = lu(1436) - lu(550) * lu(1403) - END SUBROUTINE lu_fac12 - - SUBROUTINE lu_fac13(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(552) = 1._r8 / lu(552) - lu(553) = lu(553) * lu(552) - lu(554) = lu(554) * lu(552) - lu(555) = lu(555) * lu(552) - lu(556) = lu(556) * lu(552) - lu(557) = lu(557) * lu(552) - lu(805) = lu(805) - lu(553) * lu(804) - lu(808) = lu(808) - lu(554) * lu(804) - lu(811) = - lu(555) * lu(804) - lu(817) = lu(817) - lu(556) * lu(804) - lu(818) = - lu(557) * lu(804) - lu(901) = lu(901) - lu(553) * lu(899) - lu(904) = lu(904) - lu(554) * lu(899) - lu(908) = lu(908) - lu(555) * lu(899) - lu(914) = lu(914) - lu(556) * lu(899) - lu(915) = - lu(557) * lu(899) - lu(938) = lu(938) - lu(553) * lu(934) - lu(943) = lu(943) - lu(554) * lu(934) - lu(947) = lu(947) - lu(555) * lu(934) - lu(953) = lu(953) - lu(556) * lu(934) - lu(956) = lu(956) - lu(557) * lu(934) - lu(1010) = lu(1010) - lu(553) * lu(995) - lu(1014) = lu(1014) - lu(554) * lu(995) - lu(1018) = lu(1018) - lu(555) * lu(995) - lu(1024) = lu(1024) - lu(556) * lu(995) - lu(1027) = lu(1027) - lu(557) * lu(995) - lu(1036) = lu(1036) - lu(553) * lu(1034) - lu(1041) = lu(1041) - lu(554) * lu(1034) - lu(1045) = lu(1045) - lu(555) * lu(1034) - lu(1051) = lu(1051) - lu(556) * lu(1034) - lu(1054) = lu(1054) - lu(557) * lu(1034) - lu(1185) = lu(1185) - lu(553) * lu(1184) - lu(1189) = lu(1189) - lu(554) * lu(1184) - lu(1193) = lu(1193) - lu(555) * lu(1184) - lu(1199) = lu(1199) - lu(556) * lu(1184) - lu(1202) = lu(1202) - lu(557) * lu(1184) - lu(1276) = lu(1276) - lu(553) * lu(1269) - lu(1281) = lu(1281) - lu(554) * lu(1269) - lu(1285) = lu(1285) - lu(555) * lu(1269) - lu(1291) = lu(1291) - lu(556) * lu(1269) - lu(1294) = lu(1294) - lu(557) * lu(1269) - lu(1374) = lu(1374) - lu(553) * lu(1357) - lu(1379) = lu(1379) - lu(554) * lu(1357) - lu(1383) = lu(1383) - lu(555) * lu(1357) - lu(1389) = lu(1389) - lu(556) * lu(1357) - lu(1392) = lu(1392) - lu(557) * lu(1357) - lu(1419) = - lu(553) * lu(1404) - lu(1423) = lu(1423) - lu(554) * lu(1404) - lu(1427) = lu(1427) - lu(555) * lu(1404) - lu(1433) = lu(1433) - lu(556) * lu(1404) - lu(1436) = lu(1436) - lu(557) * lu(1404) - lu(1466) = - lu(553) * lu(1464) - lu(1471) = lu(1471) - lu(554) * lu(1464) - lu(1475) = - lu(555) * lu(1464) - lu(1481) = lu(1481) - lu(556) * lu(1464) - lu(1484) = lu(1484) - lu(557) * lu(1464) - lu(560) = 1._r8 / lu(560) - lu(561) = lu(561) * lu(560) - lu(562) = lu(562) * lu(560) - lu(563) = lu(563) * lu(560) - lu(564) = lu(564) * lu(560) - lu(565) = lu(565) * lu(560) - lu(566) = lu(566) * lu(560) - lu(567) = lu(567) * lu(560) - lu(568) = lu(568) * lu(560) - lu(569) = lu(569) * lu(560) - lu(824) = lu(824) - lu(561) * lu(823) - lu(826) = lu(826) - lu(562) * lu(823) - lu(828) = lu(828) - lu(563) * lu(823) - lu(829) = lu(829) - lu(564) * lu(823) - lu(832) = - lu(565) * lu(823) - lu(833) = lu(833) - lu(566) * lu(823) - lu(834) = - lu(567) * lu(823) - lu(835) = lu(835) - lu(568) * lu(823) - lu(836) = lu(836) - lu(569) * lu(823) - lu(939) = lu(939) - lu(561) * lu(935) - lu(943) = lu(943) - lu(562) * lu(935) - lu(946) = lu(946) - lu(563) * lu(935) - lu(948) = lu(948) - lu(564) * lu(935) - lu(952) = lu(952) - lu(565) * lu(935) - lu(953) = lu(953) - lu(566) * lu(935) - lu(954) = lu(954) - lu(567) * lu(935) - lu(955) = lu(955) - lu(568) * lu(935) - lu(956) = lu(956) - lu(569) * lu(935) - lu(1037) = lu(1037) - lu(561) * lu(1035) - lu(1041) = lu(1041) - lu(562) * lu(1035) - lu(1044) = lu(1044) - lu(563) * lu(1035) - lu(1046) = lu(1046) - lu(564) * lu(1035) - lu(1050) = lu(1050) - lu(565) * lu(1035) - lu(1051) = lu(1051) - lu(566) * lu(1035) - lu(1052) = - lu(567) * lu(1035) - lu(1053) = - lu(568) * lu(1035) - lu(1054) = lu(1054) - lu(569) * lu(1035) - lu(1141) = lu(1141) - lu(561) * lu(1136) - lu(1145) = lu(1145) - lu(562) * lu(1136) - lu(1148) = lu(1148) - lu(563) * lu(1136) - lu(1150) = lu(1150) - lu(564) * lu(1136) - lu(1154) = lu(1154) - lu(565) * lu(1136) - lu(1155) = lu(1155) - lu(566) * lu(1136) - lu(1156) = lu(1156) - lu(567) * lu(1136) - lu(1157) = - lu(568) * lu(1136) - lu(1158) = lu(1158) - lu(569) * lu(1136) - lu(1277) = lu(1277) - lu(561) * lu(1270) - lu(1281) = lu(1281) - lu(562) * lu(1270) - lu(1284) = lu(1284) - lu(563) * lu(1270) - lu(1286) = lu(1286) - lu(564) * lu(1270) - lu(1290) = lu(1290) - lu(565) * lu(1270) - lu(1291) = lu(1291) - lu(566) * lu(1270) - lu(1292) = lu(1292) - lu(567) * lu(1270) - lu(1293) = lu(1293) - lu(568) * lu(1270) - lu(1294) = lu(1294) - lu(569) * lu(1270) - lu(1375) = lu(1375) - lu(561) * lu(1358) - lu(1379) = lu(1379) - lu(562) * lu(1358) - lu(1382) = lu(1382) - lu(563) * lu(1358) - lu(1384) = lu(1384) - lu(564) * lu(1358) - lu(1388) = lu(1388) - lu(565) * lu(1358) - lu(1389) = lu(1389) - lu(566) * lu(1358) - lu(1390) = lu(1390) - lu(567) * lu(1358) - lu(1391) = lu(1391) - lu(568) * lu(1358) - lu(1392) = lu(1392) - lu(569) * lu(1358) - lu(572) = 1._r8 / lu(572) - lu(573) = lu(573) * lu(572) - lu(574) = lu(574) * lu(572) - lu(575) = lu(575) * lu(572) - lu(576) = lu(576) * lu(572) - lu(577) = lu(577) * lu(572) - lu(578) = lu(578) * lu(572) - lu(579) = lu(579) * lu(572) - lu(580) = lu(580) * lu(572) - lu(581) = lu(581) * lu(572) - lu(582) = lu(582) * lu(572) - lu(583) = lu(583) * lu(572) - lu(998) = lu(998) - lu(573) * lu(996) - lu(1002) = lu(1002) - lu(574) * lu(996) - lu(1004) = - lu(575) * lu(996) - lu(1007) = lu(1007) - lu(576) * lu(996) - lu(1018) = lu(1018) - lu(577) * lu(996) - lu(1022) = lu(1022) - lu(578) * lu(996) - lu(1023) = lu(1023) - lu(579) * lu(996) - lu(1024) = lu(1024) - lu(580) * lu(996) - lu(1025) = lu(1025) - lu(581) * lu(996) - lu(1027) = lu(1027) - lu(582) * lu(996) - lu(1028) = lu(1028) - lu(583) * lu(996) - lu(1093) = lu(1093) - lu(573) * lu(1092) - lu(1097) = lu(1097) - lu(574) * lu(1092) - lu(1100) = lu(1100) - lu(575) * lu(1092) - lu(1103) = lu(1103) - lu(576) * lu(1092) - lu(1114) = lu(1114) - lu(577) * lu(1092) - lu(1118) = lu(1118) - lu(578) * lu(1092) - lu(1119) = lu(1119) - lu(579) * lu(1092) - lu(1120) = lu(1120) - lu(580) * lu(1092) - lu(1121) = lu(1121) - lu(581) * lu(1092) - lu(1123) = lu(1123) - lu(582) * lu(1092) - lu(1124) = lu(1124) - lu(583) * lu(1092) - lu(1229) = lu(1229) - lu(573) * lu(1228) - lu(1233) = lu(1233) - lu(574) * lu(1228) - lu(1235) = lu(1235) - lu(575) * lu(1228) - lu(1238) = lu(1238) - lu(576) * lu(1228) - lu(1248) = lu(1248) - lu(577) * lu(1228) - lu(1252) = lu(1252) - lu(578) * lu(1228) - lu(1253) = lu(1253) - lu(579) * lu(1228) - lu(1254) = lu(1254) - lu(580) * lu(1228) - lu(1255) = lu(1255) - lu(581) * lu(1228) - lu(1257) = lu(1257) - lu(582) * lu(1228) - lu(1258) = lu(1258) - lu(583) * lu(1228) - lu(1361) = lu(1361) - lu(573) * lu(1359) - lu(1365) = lu(1365) - lu(574) * lu(1359) - lu(1368) = lu(1368) - lu(575) * lu(1359) - lu(1371) = lu(1371) - lu(576) * lu(1359) - lu(1383) = lu(1383) - lu(577) * lu(1359) - lu(1387) = lu(1387) - lu(578) * lu(1359) - lu(1388) = lu(1388) - lu(579) * lu(1359) - lu(1389) = lu(1389) - lu(580) * lu(1359) - lu(1390) = lu(1390) - lu(581) * lu(1359) - lu(1392) = lu(1392) - lu(582) * lu(1359) - lu(1393) = lu(1393) - lu(583) * lu(1359) - lu(1407) = lu(1407) - lu(573) * lu(1405) - lu(1411) = lu(1411) - lu(574) * lu(1405) - lu(1413) = lu(1413) - lu(575) * lu(1405) - lu(1416) = lu(1416) - lu(576) * lu(1405) - lu(1427) = lu(1427) - lu(577) * lu(1405) - lu(1431) = lu(1431) - lu(578) * lu(1405) - lu(1432) = lu(1432) - lu(579) * lu(1405) - lu(1433) = lu(1433) - lu(580) * lu(1405) - lu(1434) = lu(1434) - lu(581) * lu(1405) - lu(1436) = lu(1436) - lu(582) * lu(1405) - lu(1437) = lu(1437) - lu(583) * lu(1405) - lu(587) = 1._r8 / lu(587) - lu(588) = lu(588) * lu(587) - lu(589) = lu(589) * lu(587) - lu(590) = lu(590) * lu(587) - lu(591) = lu(591) * lu(587) - lu(592) = lu(592) * lu(587) - lu(593) = lu(593) * lu(587) - lu(594) = lu(594) * lu(587) - lu(595) = lu(595) * lu(587) - lu(596) = lu(596) * lu(587) - lu(597) = lu(597) * lu(587) - lu(598) = lu(598) * lu(587) - lu(599) = lu(599) * lu(587) - lu(600) = lu(600) * lu(587) - lu(601) = lu(601) * lu(587) - lu(735) = lu(735) - lu(588) * lu(734) - lu(736) = lu(736) - lu(589) * lu(734) - lu(737) = - lu(590) * lu(734) - lu(738) = lu(738) - lu(591) * lu(734) - lu(743) = lu(743) - lu(592) * lu(734) - lu(744) = - lu(593) * lu(734) - lu(745) = lu(745) - lu(594) * lu(734) - lu(746) = lu(746) - lu(595) * lu(734) - lu(748) = - lu(596) * lu(734) - lu(749) = - lu(597) * lu(734) - lu(750) = lu(750) - lu(598) * lu(734) - lu(751) = - lu(599) * lu(734) - lu(753) = - lu(600) * lu(734) - lu(754) = lu(754) - lu(601) * lu(734) - lu(998) = lu(998) - lu(588) * lu(997) - lu(999) = lu(999) - lu(589) * lu(997) - lu(1000) = - lu(590) * lu(997) - lu(1003) = lu(1003) - lu(591) * lu(997) - lu(1012) = lu(1012) - lu(592) * lu(997) - lu(1013) = lu(1013) - lu(593) * lu(997) - lu(1016) = lu(1016) - lu(594) * lu(997) - lu(1018) = lu(1018) - lu(595) * lu(997) - lu(1022) = lu(1022) - lu(596) * lu(997) - lu(1023) = lu(1023) - lu(597) * lu(997) - lu(1024) = lu(1024) - lu(598) * lu(997) - lu(1025) = lu(1025) - lu(599) * lu(997) - lu(1027) = lu(1027) - lu(600) * lu(997) - lu(1028) = lu(1028) - lu(601) * lu(997) - lu(1361) = lu(1361) - lu(588) * lu(1360) - lu(1362) = lu(1362) - lu(589) * lu(1360) - lu(1363) = lu(1363) - lu(590) * lu(1360) - lu(1367) = lu(1367) - lu(591) * lu(1360) - lu(1377) = lu(1377) - lu(592) * lu(1360) - lu(1378) = lu(1378) - lu(593) * lu(1360) - lu(1381) = lu(1381) - lu(594) * lu(1360) - lu(1383) = lu(1383) - lu(595) * lu(1360) - lu(1387) = lu(1387) - lu(596) * lu(1360) - lu(1388) = lu(1388) - lu(597) * lu(1360) - lu(1389) = lu(1389) - lu(598) * lu(1360) - lu(1390) = lu(1390) - lu(599) * lu(1360) - lu(1392) = lu(1392) - lu(600) * lu(1360) - lu(1393) = lu(1393) - lu(601) * lu(1360) - lu(1407) = lu(1407) - lu(588) * lu(1406) - lu(1408) = lu(1408) - lu(589) * lu(1406) - lu(1409) = lu(1409) - lu(590) * lu(1406) - lu(1412) = lu(1412) - lu(591) * lu(1406) - lu(1421) = lu(1421) - lu(592) * lu(1406) - lu(1422) = lu(1422) - lu(593) * lu(1406) - lu(1425) = lu(1425) - lu(594) * lu(1406) - lu(1427) = lu(1427) - lu(595) * lu(1406) - lu(1431) = lu(1431) - lu(596) * lu(1406) - lu(1432) = lu(1432) - lu(597) * lu(1406) - lu(1433) = lu(1433) - lu(598) * lu(1406) - lu(1434) = lu(1434) - lu(599) * lu(1406) - lu(1436) = lu(1436) - lu(600) * lu(1406) - lu(1437) = lu(1437) - lu(601) * lu(1406) - END SUBROUTINE lu_fac13 - - SUBROUTINE lu_fac14(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(602) = 1._r8 / lu(602) - lu(603) = lu(603) * lu(602) - lu(604) = lu(604) * lu(602) - lu(605) = lu(605) * lu(602) - lu(610) = lu(610) - lu(603) * lu(606) - lu(611) = - lu(604) * lu(606) - lu(612) = lu(612) - lu(605) * lu(606) - lu(643) = lu(643) - lu(603) * lu(636) - lu(644) = - lu(604) * lu(636) - lu(645) = lu(645) - lu(605) * lu(636) - lu(664) = lu(664) - lu(603) * lu(661) - lu(665) = - lu(604) * lu(661) - lu(666) = lu(666) - lu(605) * lu(661) - lu(680) = lu(680) - lu(603) * lu(674) - lu(681) = - lu(604) * lu(674) - lu(684) = lu(684) - lu(605) * lu(674) - lu(704) = lu(704) - lu(603) * lu(693) - lu(705) = - lu(604) * lu(693) - lu(708) = lu(708) - lu(605) * lu(693) - lu(725) = lu(725) - lu(603) * lu(717) - lu(726) = - lu(604) * lu(717) - lu(729) = lu(729) - lu(605) * lu(717) - lu(746) = lu(746) - lu(603) * lu(735) - lu(747) = - lu(604) * lu(735) - lu(750) = lu(750) - lu(605) * lu(735) - lu(793) = lu(793) - lu(603) * lu(780) - lu(794) = - lu(604) * lu(780) - lu(797) = lu(797) - lu(605) * lu(780) - lu(844) = lu(844) - lu(603) * lu(838) - lu(845) = lu(845) - lu(604) * lu(838) - lu(847) = lu(847) - lu(605) * lu(838) - lu(876) = lu(876) - lu(603) * lu(860) - lu(878) = lu(878) - lu(604) * lu(860) - lu(881) = lu(881) - lu(605) * lu(860) - lu(908) = lu(908) - lu(603) * lu(900) - lu(910) = lu(910) - lu(604) * lu(900) - lu(914) = lu(914) - lu(605) * lu(900) - lu(947) = lu(947) - lu(603) * lu(936) - lu(949) = lu(949) - lu(604) * lu(936) - lu(953) = lu(953) - lu(605) * lu(936) - lu(1018) = lu(1018) - lu(603) * lu(998) - lu(1020) = lu(1020) - lu(604) * lu(998) - lu(1024) = lu(1024) - lu(605) * lu(998) - lu(1114) = lu(1114) - lu(603) * lu(1093) - lu(1116) = lu(1116) - lu(604) * lu(1093) - lu(1120) = lu(1120) - lu(605) * lu(1093) - lu(1149) = lu(1149) - lu(603) * lu(1137) - lu(1151) = lu(1151) - lu(604) * lu(1137) - lu(1155) = lu(1155) - lu(605) * lu(1137) - lu(1248) = lu(1248) - lu(603) * lu(1229) - lu(1250) = lu(1250) - lu(604) * lu(1229) - lu(1254) = lu(1254) - lu(605) * lu(1229) - lu(1285) = lu(1285) - lu(603) * lu(1271) - lu(1287) = lu(1287) - lu(604) * lu(1271) - lu(1291) = lu(1291) - lu(605) * lu(1271) - lu(1383) = lu(1383) - lu(603) * lu(1361) - lu(1385) = lu(1385) - lu(604) * lu(1361) - lu(1389) = lu(1389) - lu(605) * lu(1361) - lu(1427) = lu(1427) - lu(603) * lu(1407) - lu(1429) = - lu(604) * lu(1407) - lu(1433) = lu(1433) - lu(605) * lu(1407) - lu(1499) = lu(1499) - lu(603) * lu(1489) - lu(1501) = lu(1501) - lu(604) * lu(1489) - lu(1505) = lu(1505) - lu(605) * lu(1489) - lu(607) = 1._r8 / lu(607) - lu(608) = lu(608) * lu(607) - lu(609) = lu(609) * lu(607) - lu(610) = lu(610) * lu(607) - lu(611) = lu(611) * lu(607) - lu(612) = lu(612) * lu(607) - lu(613) = lu(613) * lu(607) - lu(614) = lu(614) * lu(607) - lu(615) = lu(615) * lu(607) - lu(742) = lu(742) - lu(608) * lu(736) - lu(743) = lu(743) - lu(609) * lu(736) - lu(746) = lu(746) - lu(610) * lu(736) - lu(747) = lu(747) - lu(611) * lu(736) - lu(750) = lu(750) - lu(612) * lu(736) - lu(751) = lu(751) - lu(613) * lu(736) - lu(752) = - lu(614) * lu(736) - lu(753) = lu(753) - lu(615) * lu(736) - lu(871) = lu(871) - lu(608) * lu(861) - lu(872) = lu(872) - lu(609) * lu(861) - lu(876) = lu(876) - lu(610) * lu(861) - lu(878) = lu(878) - lu(611) * lu(861) - lu(881) = lu(881) - lu(612) * lu(861) - lu(882) = - lu(613) * lu(861) - lu(883) = - lu(614) * lu(861) - lu(884) = lu(884) - lu(615) * lu(861) - lu(1009) = lu(1009) - lu(608) * lu(999) - lu(1012) = lu(1012) - lu(609) * lu(999) - lu(1018) = lu(1018) - lu(610) * lu(999) - lu(1020) = lu(1020) - lu(611) * lu(999) - lu(1024) = lu(1024) - lu(612) * lu(999) - lu(1025) = lu(1025) - lu(613) * lu(999) - lu(1026) = - lu(614) * lu(999) - lu(1027) = lu(1027) - lu(615) * lu(999) - lu(1105) = lu(1105) - lu(608) * lu(1094) - lu(1108) = lu(1108) - lu(609) * lu(1094) - lu(1114) = lu(1114) - lu(610) * lu(1094) - lu(1116) = lu(1116) - lu(611) * lu(1094) - lu(1120) = lu(1120) - lu(612) * lu(1094) - lu(1121) = lu(1121) - lu(613) * lu(1094) - lu(1122) = - lu(614) * lu(1094) - lu(1123) = lu(1123) - lu(615) * lu(1094) - lu(1140) = - lu(608) * lu(1138) - lu(1143) = lu(1143) - lu(609) * lu(1138) - lu(1149) = lu(1149) - lu(610) * lu(1138) - lu(1151) = lu(1151) - lu(611) * lu(1138) - lu(1155) = lu(1155) - lu(612) * lu(1138) - lu(1156) = lu(1156) - lu(613) * lu(1138) - lu(1157) = lu(1157) - lu(614) * lu(1138) - lu(1158) = lu(1158) - lu(615) * lu(1138) - lu(1240) = lu(1240) - lu(608) * lu(1230) - lu(1242) = lu(1242) - lu(609) * lu(1230) - lu(1248) = lu(1248) - lu(610) * lu(1230) - lu(1250) = lu(1250) - lu(611) * lu(1230) - lu(1254) = lu(1254) - lu(612) * lu(1230) - lu(1255) = lu(1255) - lu(613) * lu(1230) - lu(1256) = - lu(614) * lu(1230) - lu(1257) = lu(1257) - lu(615) * lu(1230) - lu(1373) = lu(1373) - lu(608) * lu(1362) - lu(1377) = lu(1377) - lu(609) * lu(1362) - lu(1383) = lu(1383) - lu(610) * lu(1362) - lu(1385) = lu(1385) - lu(611) * lu(1362) - lu(1389) = lu(1389) - lu(612) * lu(1362) - lu(1390) = lu(1390) - lu(613) * lu(1362) - lu(1391) = lu(1391) - lu(614) * lu(1362) - lu(1392) = lu(1392) - lu(615) * lu(1362) - lu(1418) = lu(1418) - lu(608) * lu(1408) - lu(1421) = lu(1421) - lu(609) * lu(1408) - lu(1427) = lu(1427) - lu(610) * lu(1408) - lu(1429) = lu(1429) - lu(611) * lu(1408) - lu(1433) = lu(1433) - lu(612) * lu(1408) - lu(1434) = lu(1434) - lu(613) * lu(1408) - lu(1435) = lu(1435) - lu(614) * lu(1408) - lu(1436) = lu(1436) - lu(615) * lu(1408) - lu(616) = 1._r8 / lu(616) - lu(617) = lu(617) * lu(616) - lu(618) = lu(618) * lu(616) - lu(619) = lu(619) * lu(616) - lu(620) = lu(620) * lu(616) - lu(621) = lu(621) * lu(616) - lu(626) = lu(626) - lu(617) * lu(624) - lu(627) = lu(627) - lu(618) * lu(624) - lu(630) = lu(630) - lu(619) * lu(624) - lu(633) = lu(633) - lu(620) * lu(624) - lu(635) = lu(635) - lu(621) * lu(624) - lu(676) = lu(676) - lu(617) * lu(675) - lu(678) = lu(678) - lu(618) * lu(675) - lu(680) = lu(680) - lu(619) * lu(675) - lu(684) = lu(684) - lu(620) * lu(675) - lu(688) = lu(688) - lu(621) * lu(675) - lu(719) = lu(719) - lu(617) * lu(718) - lu(723) = lu(723) - lu(618) * lu(718) - lu(725) = lu(725) - lu(619) * lu(718) - lu(729) = lu(729) - lu(620) * lu(718) - lu(733) = lu(733) - lu(621) * lu(718) - lu(738) = lu(738) - lu(617) * lu(737) - lu(742) = lu(742) - lu(618) * lu(737) - lu(746) = lu(746) - lu(619) * lu(737) - lu(750) = lu(750) - lu(620) * lu(737) - lu(754) = lu(754) - lu(621) * lu(737) - lu(759) = - lu(617) * lu(758) - lu(761) = lu(761) - lu(618) * lu(758) - lu(765) = lu(765) - lu(619) * lu(758) - lu(769) = lu(769) - lu(620) * lu(758) - lu(773) = lu(773) - lu(621) * lu(758) - lu(783) = lu(783) - lu(617) * lu(781) - lu(789) = lu(789) - lu(618) * lu(781) - lu(793) = lu(793) - lu(619) * lu(781) - lu(797) = lu(797) - lu(620) * lu(781) - lu(801) = lu(801) - lu(621) * lu(781) - lu(865) = lu(865) - lu(617) * lu(862) - lu(871) = lu(871) - lu(618) * lu(862) - lu(876) = lu(876) - lu(619) * lu(862) - lu(881) = lu(881) - lu(620) * lu(862) - lu(885) = lu(885) - lu(621) * lu(862) - lu(1003) = lu(1003) - lu(617) * lu(1000) - lu(1009) = lu(1009) - lu(618) * lu(1000) - lu(1018) = lu(1018) - lu(619) * lu(1000) - lu(1024) = lu(1024) - lu(620) * lu(1000) - lu(1028) = lu(1028) - lu(621) * lu(1000) - lu(1099) = lu(1099) - lu(617) * lu(1095) - lu(1105) = lu(1105) - lu(618) * lu(1095) - lu(1114) = lu(1114) - lu(619) * lu(1095) - lu(1120) = lu(1120) - lu(620) * lu(1095) - lu(1124) = lu(1124) - lu(621) * lu(1095) - lu(1234) = lu(1234) - lu(617) * lu(1231) - lu(1240) = lu(1240) - lu(618) * lu(1231) - lu(1248) = lu(1248) - lu(619) * lu(1231) - lu(1254) = lu(1254) - lu(620) * lu(1231) - lu(1258) = lu(1258) - lu(621) * lu(1231) - lu(1273) = lu(1273) - lu(617) * lu(1272) - lu(1275) = lu(1275) - lu(618) * lu(1272) - lu(1285) = lu(1285) - lu(619) * lu(1272) - lu(1291) = lu(1291) - lu(620) * lu(1272) - lu(1295) = lu(1295) - lu(621) * lu(1272) - lu(1367) = lu(1367) - lu(617) * lu(1363) - lu(1373) = lu(1373) - lu(618) * lu(1363) - lu(1383) = lu(1383) - lu(619) * lu(1363) - lu(1389) = lu(1389) - lu(620) * lu(1363) - lu(1393) = lu(1393) - lu(621) * lu(1363) - lu(1412) = lu(1412) - lu(617) * lu(1409) - lu(1418) = lu(1418) - lu(618) * lu(1409) - lu(1427) = lu(1427) - lu(619) * lu(1409) - lu(1433) = lu(1433) - lu(620) * lu(1409) - lu(1437) = lu(1437) - lu(621) * lu(1409) - lu(625) = 1._r8 / lu(625) - lu(626) = lu(626) * lu(625) - lu(627) = lu(627) * lu(625) - lu(628) = lu(628) * lu(625) - lu(629) = lu(629) * lu(625) - lu(630) = lu(630) * lu(625) - lu(631) = lu(631) * lu(625) - lu(632) = lu(632) * lu(625) - lu(633) = lu(633) * lu(625) - lu(634) = lu(634) * lu(625) - lu(635) = lu(635) * lu(625) - lu(865) = lu(865) - lu(626) * lu(863) - lu(871) = lu(871) - lu(627) * lu(863) - lu(872) = lu(872) - lu(628) * lu(863) - lu(873) = lu(873) - lu(629) * lu(863) - lu(876) = lu(876) - lu(630) * lu(863) - lu(879) = lu(879) - lu(631) * lu(863) - lu(880) = lu(880) - lu(632) * lu(863) - lu(881) = lu(881) - lu(633) * lu(863) - lu(884) = lu(884) - lu(634) * lu(863) - lu(885) = lu(885) - lu(635) * lu(863) - lu(1003) = lu(1003) - lu(626) * lu(1001) - lu(1009) = lu(1009) - lu(627) * lu(1001) - lu(1012) = lu(1012) - lu(628) * lu(1001) - lu(1013) = lu(1013) - lu(629) * lu(1001) - lu(1018) = lu(1018) - lu(630) * lu(1001) - lu(1022) = lu(1022) - lu(631) * lu(1001) - lu(1023) = lu(1023) - lu(632) * lu(1001) - lu(1024) = lu(1024) - lu(633) * lu(1001) - lu(1027) = lu(1027) - lu(634) * lu(1001) - lu(1028) = lu(1028) - lu(635) * lu(1001) - lu(1099) = lu(1099) - lu(626) * lu(1096) - lu(1105) = lu(1105) - lu(627) * lu(1096) - lu(1108) = lu(1108) - lu(628) * lu(1096) - lu(1109) = lu(1109) - lu(629) * lu(1096) - lu(1114) = lu(1114) - lu(630) * lu(1096) - lu(1118) = lu(1118) - lu(631) * lu(1096) - lu(1119) = lu(1119) - lu(632) * lu(1096) - lu(1120) = lu(1120) - lu(633) * lu(1096) - lu(1123) = lu(1123) - lu(634) * lu(1096) - lu(1124) = lu(1124) - lu(635) * lu(1096) - lu(1234) = lu(1234) - lu(626) * lu(1232) - lu(1240) = lu(1240) - lu(627) * lu(1232) - lu(1242) = lu(1242) - lu(628) * lu(1232) - lu(1243) = lu(1243) - lu(629) * lu(1232) - lu(1248) = lu(1248) - lu(630) * lu(1232) - lu(1252) = lu(1252) - lu(631) * lu(1232) - lu(1253) = lu(1253) - lu(632) * lu(1232) - lu(1254) = lu(1254) - lu(633) * lu(1232) - lu(1257) = lu(1257) - lu(634) * lu(1232) - lu(1258) = lu(1258) - lu(635) * lu(1232) - lu(1367) = lu(1367) - lu(626) * lu(1364) - lu(1373) = lu(1373) - lu(627) * lu(1364) - lu(1377) = lu(1377) - lu(628) * lu(1364) - lu(1378) = lu(1378) - lu(629) * lu(1364) - lu(1383) = lu(1383) - lu(630) * lu(1364) - lu(1387) = lu(1387) - lu(631) * lu(1364) - lu(1388) = lu(1388) - lu(632) * lu(1364) - lu(1389) = lu(1389) - lu(633) * lu(1364) - lu(1392) = lu(1392) - lu(634) * lu(1364) - lu(1393) = lu(1393) - lu(635) * lu(1364) - lu(1412) = lu(1412) - lu(626) * lu(1410) - lu(1418) = lu(1418) - lu(627) * lu(1410) - lu(1421) = lu(1421) - lu(628) * lu(1410) - lu(1422) = lu(1422) - lu(629) * lu(1410) - lu(1427) = lu(1427) - lu(630) * lu(1410) - lu(1431) = lu(1431) - lu(631) * lu(1410) - lu(1432) = lu(1432) - lu(632) * lu(1410) - lu(1433) = lu(1433) - lu(633) * lu(1410) - lu(1436) = lu(1436) - lu(634) * lu(1410) - lu(1437) = lu(1437) - lu(635) * lu(1410) - lu(637) = 1._r8 / lu(637) - lu(638) = lu(638) * lu(637) - lu(639) = lu(639) * lu(637) - lu(640) = lu(640) * lu(637) - lu(641) = lu(641) * lu(637) - lu(642) = lu(642) * lu(637) - lu(643) = lu(643) * lu(637) - lu(644) = lu(644) * lu(637) - lu(645) = lu(645) * lu(637) - lu(646) = lu(646) * lu(637) - lu(647) = lu(647) * lu(637) - lu(695) = - lu(638) * lu(694) - lu(698) = - lu(639) * lu(694) - lu(700) = - lu(640) * lu(694) - lu(701) = lu(701) - lu(641) * lu(694) - lu(703) = - lu(642) * lu(694) - lu(704) = lu(704) - lu(643) * lu(694) - lu(705) = lu(705) - lu(644) * lu(694) - lu(708) = lu(708) - lu(645) * lu(694) - lu(711) = - lu(646) * lu(694) - lu(712) = lu(712) - lu(647) * lu(694) - lu(783) = lu(783) - lu(638) * lu(782) - lu(786) = lu(786) - lu(639) * lu(782) - lu(788) = lu(788) - lu(640) * lu(782) - lu(789) = lu(789) - lu(641) * lu(782) - lu(792) = lu(792) - lu(642) * lu(782) - lu(793) = lu(793) - lu(643) * lu(782) - lu(794) = lu(794) - lu(644) * lu(782) - lu(797) = lu(797) - lu(645) * lu(782) - lu(800) = lu(800) - lu(646) * lu(782) - lu(801) = lu(801) - lu(647) * lu(782) - lu(865) = lu(865) - lu(638) * lu(864) - lu(868) = lu(868) - lu(639) * lu(864) - lu(870) = lu(870) - lu(640) * lu(864) - lu(871) = lu(871) - lu(641) * lu(864) - lu(874) = - lu(642) * lu(864) - lu(876) = lu(876) - lu(643) * lu(864) - lu(878) = lu(878) - lu(644) * lu(864) - lu(881) = lu(881) - lu(645) * lu(864) - lu(884) = lu(884) - lu(646) * lu(864) - lu(885) = lu(885) - lu(647) * lu(864) - lu(1003) = lu(1003) - lu(638) * lu(1002) - lu(1006) = - lu(639) * lu(1002) - lu(1008) = lu(1008) - lu(640) * lu(1002) - lu(1009) = lu(1009) - lu(641) * lu(1002) - lu(1016) = lu(1016) - lu(642) * lu(1002) - lu(1018) = lu(1018) - lu(643) * lu(1002) - lu(1020) = lu(1020) - lu(644) * lu(1002) - lu(1024) = lu(1024) - lu(645) * lu(1002) - lu(1027) = lu(1027) - lu(646) * lu(1002) - lu(1028) = lu(1028) - lu(647) * lu(1002) - lu(1099) = lu(1099) - lu(638) * lu(1097) - lu(1102) = lu(1102) - lu(639) * lu(1097) - lu(1104) = lu(1104) - lu(640) * lu(1097) - lu(1105) = lu(1105) - lu(641) * lu(1097) - lu(1112) = lu(1112) - lu(642) * lu(1097) - lu(1114) = lu(1114) - lu(643) * lu(1097) - lu(1116) = lu(1116) - lu(644) * lu(1097) - lu(1120) = lu(1120) - lu(645) * lu(1097) - lu(1123) = lu(1123) - lu(646) * lu(1097) - lu(1124) = lu(1124) - lu(647) * lu(1097) - lu(1234) = lu(1234) - lu(638) * lu(1233) - lu(1237) = lu(1237) - lu(639) * lu(1233) - lu(1239) = lu(1239) - lu(640) * lu(1233) - lu(1240) = lu(1240) - lu(641) * lu(1233) - lu(1246) = lu(1246) - lu(642) * lu(1233) - lu(1248) = lu(1248) - lu(643) * lu(1233) - lu(1250) = lu(1250) - lu(644) * lu(1233) - lu(1254) = lu(1254) - lu(645) * lu(1233) - lu(1257) = lu(1257) - lu(646) * lu(1233) - lu(1258) = lu(1258) - lu(647) * lu(1233) - lu(1367) = lu(1367) - lu(638) * lu(1365) - lu(1370) = lu(1370) - lu(639) * lu(1365) - lu(1372) = lu(1372) - lu(640) * lu(1365) - lu(1373) = lu(1373) - lu(641) * lu(1365) - lu(1381) = lu(1381) - lu(642) * lu(1365) - lu(1383) = lu(1383) - lu(643) * lu(1365) - lu(1385) = lu(1385) - lu(644) * lu(1365) - lu(1389) = lu(1389) - lu(645) * lu(1365) - lu(1392) = lu(1392) - lu(646) * lu(1365) - lu(1393) = lu(1393) - lu(647) * lu(1365) - lu(1412) = lu(1412) - lu(638) * lu(1411) - lu(1415) = lu(1415) - lu(639) * lu(1411) - lu(1417) = lu(1417) - lu(640) * lu(1411) - lu(1418) = lu(1418) - lu(641) * lu(1411) - lu(1425) = lu(1425) - lu(642) * lu(1411) - lu(1427) = lu(1427) - lu(643) * lu(1411) - lu(1429) = lu(1429) - lu(644) * lu(1411) - lu(1433) = lu(1433) - lu(645) * lu(1411) - lu(1436) = lu(1436) - lu(646) * lu(1411) - lu(1437) = lu(1437) - lu(647) * lu(1411) - END SUBROUTINE lu_fac14 - - SUBROUTINE lu_fac15(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(650) = 1._r8 / lu(650) - lu(651) = lu(651) * lu(650) - lu(652) = lu(652) * lu(650) - lu(653) = lu(653) * lu(650) - lu(654) = lu(654) * lu(650) - lu(655) = lu(655) * lu(650) - lu(656) = lu(656) * lu(650) - lu(657) = lu(657) * lu(650) - lu(658) = lu(658) * lu(650) - lu(659) = lu(659) * lu(650) - lu(660) = lu(660) * lu(650) - lu(939) = lu(939) - lu(651) * lu(937) - lu(941) = - lu(652) * lu(937) - lu(943) = lu(943) - lu(653) * lu(937) - lu(944) = lu(944) - lu(654) * lu(937) - lu(948) = lu(948) - lu(655) * lu(937) - lu(949) = lu(949) - lu(656) * lu(937) - lu(953) = lu(953) - lu(657) * lu(937) - lu(954) = lu(954) - lu(658) * lu(937) - lu(955) = lu(955) - lu(659) * lu(937) - lu(956) = lu(956) - lu(660) * lu(937) - lu(965) = lu(965) - lu(651) * lu(964) - lu(967) = lu(967) - lu(652) * lu(964) - lu(969) = lu(969) - lu(653) * lu(964) - lu(970) = lu(970) - lu(654) * lu(964) - lu(974) = lu(974) - lu(655) * lu(964) - lu(975) = lu(975) - lu(656) * lu(964) - lu(979) = lu(979) - lu(657) * lu(964) - lu(980) = lu(980) - lu(658) * lu(964) - lu(981) = lu(981) - lu(659) * lu(964) - lu(982) = lu(982) - lu(660) * lu(964) - lu(1106) = lu(1106) - lu(651) * lu(1098) - lu(1108) = lu(1108) - lu(652) * lu(1098) - lu(1110) = lu(1110) - lu(653) * lu(1098) - lu(1111) = lu(1111) - lu(654) * lu(1098) - lu(1115) = lu(1115) - lu(655) * lu(1098) - lu(1116) = lu(1116) - lu(656) * lu(1098) - lu(1120) = lu(1120) - lu(657) * lu(1098) - lu(1121) = lu(1121) - lu(658) * lu(1098) - lu(1122) = lu(1122) - lu(659) * lu(1098) - lu(1123) = lu(1123) - lu(660) * lu(1098) - lu(1141) = lu(1141) - lu(651) * lu(1139) - lu(1143) = lu(1143) - lu(652) * lu(1139) - lu(1145) = lu(1145) - lu(653) * lu(1139) - lu(1146) = - lu(654) * lu(1139) - lu(1150) = lu(1150) - lu(655) * lu(1139) - lu(1151) = lu(1151) - lu(656) * lu(1139) - lu(1155) = lu(1155) - lu(657) * lu(1139) - lu(1156) = lu(1156) - lu(658) * lu(1139) - lu(1157) = lu(1157) - lu(659) * lu(1139) - lu(1158) = lu(1158) - lu(660) * lu(1139) - lu(1161) = - lu(651) * lu(1160) - lu(1163) = - lu(652) * lu(1160) - lu(1165) = lu(1165) - lu(653) * lu(1160) - lu(1166) = - lu(654) * lu(1160) - lu(1170) = - lu(655) * lu(1160) - lu(1171) = lu(1171) - lu(656) * lu(1160) - lu(1175) = lu(1175) - lu(657) * lu(1160) - lu(1176) = - lu(658) * lu(1160) - lu(1177) = - lu(659) * lu(1160) - lu(1178) = lu(1178) - lu(660) * lu(1160) - lu(1375) = lu(1375) - lu(651) * lu(1366) - lu(1377) = lu(1377) - lu(652) * lu(1366) - lu(1379) = lu(1379) - lu(653) * lu(1366) - lu(1380) = lu(1380) - lu(654) * lu(1366) - lu(1384) = lu(1384) - lu(655) * lu(1366) - lu(1385) = lu(1385) - lu(656) * lu(1366) - lu(1389) = lu(1389) - lu(657) * lu(1366) - lu(1390) = lu(1390) - lu(658) * lu(1366) - lu(1391) = lu(1391) - lu(659) * lu(1366) - lu(1392) = lu(1392) - lu(660) * lu(1366) - lu(1441) = - lu(651) * lu(1440) - lu(1443) = lu(1443) - lu(652) * lu(1440) - lu(1445) = - lu(653) * lu(1440) - lu(1446) = - lu(654) * lu(1440) - lu(1450) = - lu(655) * lu(1440) - lu(1451) = lu(1451) - lu(656) * lu(1440) - lu(1455) = lu(1455) - lu(657) * lu(1440) - lu(1456) = lu(1456) - lu(658) * lu(1440) - lu(1457) = lu(1457) - lu(659) * lu(1440) - lu(1458) = lu(1458) - lu(660) * lu(1440) - lu(1467) = - lu(651) * lu(1465) - lu(1469) = lu(1469) - lu(652) * lu(1465) - lu(1471) = lu(1471) - lu(653) * lu(1465) - lu(1472) = lu(1472) - lu(654) * lu(1465) - lu(1476) = - lu(655) * lu(1465) - lu(1477) = lu(1477) - lu(656) * lu(1465) - lu(1481) = lu(1481) - lu(657) * lu(1465) - lu(1482) = lu(1482) - lu(658) * lu(1465) - lu(1483) = lu(1483) - lu(659) * lu(1465) - lu(1484) = lu(1484) - lu(660) * lu(1465) - lu(1491) = lu(1491) - lu(651) * lu(1490) - lu(1493) = - lu(652) * lu(1490) - lu(1495) = lu(1495) - lu(653) * lu(1490) - lu(1496) = lu(1496) - lu(654) * lu(1490) - lu(1500) = lu(1500) - lu(655) * lu(1490) - lu(1501) = lu(1501) - lu(656) * lu(1490) - lu(1505) = lu(1505) - lu(657) * lu(1490) - lu(1506) = lu(1506) - lu(658) * lu(1490) - lu(1507) = lu(1507) - lu(659) * lu(1490) - lu(1508) = lu(1508) - lu(660) * lu(1490) - lu(662) = 1._r8 / lu(662) - lu(663) = lu(663) * lu(662) - lu(664) = lu(664) * lu(662) - lu(665) = lu(665) * lu(662) - lu(666) = lu(666) * lu(662) - lu(667) = lu(667) * lu(662) - lu(668) = lu(668) * lu(662) - lu(669) = lu(669) * lu(662) - lu(678) = lu(678) - lu(663) * lu(676) - lu(680) = lu(680) - lu(664) * lu(676) - lu(681) = lu(681) - lu(665) * lu(676) - lu(684) = lu(684) - lu(666) * lu(676) - lu(685) = lu(685) - lu(667) * lu(676) - lu(686) = - lu(668) * lu(676) - lu(687) = lu(687) - lu(669) * lu(676) - lu(701) = lu(701) - lu(663) * lu(695) - lu(704) = lu(704) - lu(664) * lu(695) - lu(705) = lu(705) - lu(665) * lu(695) - lu(708) = lu(708) - lu(666) * lu(695) - lu(709) = lu(709) - lu(667) * lu(695) - lu(710) = - lu(668) * lu(695) - lu(711) = lu(711) - lu(669) * lu(695) - lu(723) = lu(723) - lu(663) * lu(719) - lu(725) = lu(725) - lu(664) * lu(719) - lu(726) = lu(726) - lu(665) * lu(719) - lu(729) = lu(729) - lu(666) * lu(719) - lu(730) = lu(730) - lu(667) * lu(719) - lu(731) = - lu(668) * lu(719) - lu(732) = - lu(669) * lu(719) - lu(742) = lu(742) - lu(663) * lu(738) - lu(746) = lu(746) - lu(664) * lu(738) - lu(747) = lu(747) - lu(665) * lu(738) - lu(750) = lu(750) - lu(666) * lu(738) - lu(751) = lu(751) - lu(667) * lu(738) - lu(752) = lu(752) - lu(668) * lu(738) - lu(753) = lu(753) - lu(669) * lu(738) - lu(761) = lu(761) - lu(663) * lu(759) - lu(765) = lu(765) - lu(664) * lu(759) - lu(766) = - lu(665) * lu(759) - lu(769) = lu(769) - lu(666) * lu(759) - lu(770) = lu(770) - lu(667) * lu(759) - lu(771) = - lu(668) * lu(759) - lu(772) = lu(772) - lu(669) * lu(759) - lu(789) = lu(789) - lu(663) * lu(783) - lu(793) = lu(793) - lu(664) * lu(783) - lu(794) = lu(794) - lu(665) * lu(783) - lu(797) = lu(797) - lu(666) * lu(783) - lu(798) = lu(798) - lu(667) * lu(783) - lu(799) = - lu(668) * lu(783) - lu(800) = lu(800) - lu(669) * lu(783) - lu(871) = lu(871) - lu(663) * lu(865) - lu(876) = lu(876) - lu(664) * lu(865) - lu(878) = lu(878) - lu(665) * lu(865) - lu(881) = lu(881) - lu(666) * lu(865) - lu(882) = lu(882) - lu(667) * lu(865) - lu(883) = lu(883) - lu(668) * lu(865) - lu(884) = lu(884) - lu(669) * lu(865) - lu(1009) = lu(1009) - lu(663) * lu(1003) - lu(1018) = lu(1018) - lu(664) * lu(1003) - lu(1020) = lu(1020) - lu(665) * lu(1003) - lu(1024) = lu(1024) - lu(666) * lu(1003) - lu(1025) = lu(1025) - lu(667) * lu(1003) - lu(1026) = lu(1026) - lu(668) * lu(1003) - lu(1027) = lu(1027) - lu(669) * lu(1003) - lu(1105) = lu(1105) - lu(663) * lu(1099) - lu(1114) = lu(1114) - lu(664) * lu(1099) - lu(1116) = lu(1116) - lu(665) * lu(1099) - lu(1120) = lu(1120) - lu(666) * lu(1099) - lu(1121) = lu(1121) - lu(667) * lu(1099) - lu(1122) = lu(1122) - lu(668) * lu(1099) - lu(1123) = lu(1123) - lu(669) * lu(1099) - lu(1240) = lu(1240) - lu(663) * lu(1234) - lu(1248) = lu(1248) - lu(664) * lu(1234) - lu(1250) = lu(1250) - lu(665) * lu(1234) - lu(1254) = lu(1254) - lu(666) * lu(1234) - lu(1255) = lu(1255) - lu(667) * lu(1234) - lu(1256) = lu(1256) - lu(668) * lu(1234) - lu(1257) = lu(1257) - lu(669) * lu(1234) - lu(1275) = lu(1275) - lu(663) * lu(1273) - lu(1285) = lu(1285) - lu(664) * lu(1273) - lu(1287) = lu(1287) - lu(665) * lu(1273) - lu(1291) = lu(1291) - lu(666) * lu(1273) - lu(1292) = lu(1292) - lu(667) * lu(1273) - lu(1293) = lu(1293) - lu(668) * lu(1273) - lu(1294) = lu(1294) - lu(669) * lu(1273) - lu(1373) = lu(1373) - lu(663) * lu(1367) - lu(1383) = lu(1383) - lu(664) * lu(1367) - lu(1385) = lu(1385) - lu(665) * lu(1367) - lu(1389) = lu(1389) - lu(666) * lu(1367) - lu(1390) = lu(1390) - lu(667) * lu(1367) - lu(1391) = lu(1391) - lu(668) * lu(1367) - lu(1392) = lu(1392) - lu(669) * lu(1367) - lu(1418) = lu(1418) - lu(663) * lu(1412) - lu(1427) = lu(1427) - lu(664) * lu(1412) - lu(1429) = lu(1429) - lu(665) * lu(1412) - lu(1433) = lu(1433) - lu(666) * lu(1412) - lu(1434) = lu(1434) - lu(667) * lu(1412) - lu(1435) = lu(1435) - lu(668) * lu(1412) - lu(1436) = lu(1436) - lu(669) * lu(1412) - lu(677) = 1._r8 / lu(677) - lu(678) = lu(678) * lu(677) - lu(679) = lu(679) * lu(677) - lu(680) = lu(680) * lu(677) - lu(681) = lu(681) * lu(677) - lu(682) = lu(682) * lu(677) - lu(683) = lu(683) * lu(677) - lu(684) = lu(684) * lu(677) - lu(685) = lu(685) * lu(677) - lu(686) = lu(686) * lu(677) - lu(687) = lu(687) * lu(677) - lu(688) = lu(688) * lu(677) - lu(701) = lu(701) - lu(678) * lu(696) - lu(702) = lu(702) - lu(679) * lu(696) - lu(704) = lu(704) - lu(680) * lu(696) - lu(705) = lu(705) - lu(681) * lu(696) - lu(706) = lu(706) - lu(682) * lu(696) - lu(707) = lu(707) - lu(683) * lu(696) - lu(708) = lu(708) - lu(684) * lu(696) - lu(709) = lu(709) - lu(685) * lu(696) - lu(710) = lu(710) - lu(686) * lu(696) - lu(711) = lu(711) - lu(687) * lu(696) - lu(712) = lu(712) - lu(688) * lu(696) - lu(723) = lu(723) - lu(678) * lu(720) - lu(724) = lu(724) - lu(679) * lu(720) - lu(725) = lu(725) - lu(680) * lu(720) - lu(726) = lu(726) - lu(681) * lu(720) - lu(727) = lu(727) - lu(682) * lu(720) - lu(728) = lu(728) - lu(683) * lu(720) - lu(729) = lu(729) - lu(684) * lu(720) - lu(730) = lu(730) - lu(685) * lu(720) - lu(731) = lu(731) - lu(686) * lu(720) - lu(732) = lu(732) - lu(687) * lu(720) - lu(733) = lu(733) - lu(688) * lu(720) - lu(789) = lu(789) - lu(678) * lu(784) - lu(790) = lu(790) - lu(679) * lu(784) - lu(793) = lu(793) - lu(680) * lu(784) - lu(794) = lu(794) - lu(681) * lu(784) - lu(795) = lu(795) - lu(682) * lu(784) - lu(796) = lu(796) - lu(683) * lu(784) - lu(797) = lu(797) - lu(684) * lu(784) - lu(798) = lu(798) - lu(685) * lu(784) - lu(799) = lu(799) - lu(686) * lu(784) - lu(800) = lu(800) - lu(687) * lu(784) - lu(801) = lu(801) - lu(688) * lu(784) - lu(871) = lu(871) - lu(678) * lu(866) - lu(872) = lu(872) - lu(679) * lu(866) - lu(876) = lu(876) - lu(680) * lu(866) - lu(878) = lu(878) - lu(681) * lu(866) - lu(879) = lu(879) - lu(682) * lu(866) - lu(880) = lu(880) - lu(683) * lu(866) - lu(881) = lu(881) - lu(684) * lu(866) - lu(882) = lu(882) - lu(685) * lu(866) - lu(883) = lu(883) - lu(686) * lu(866) - lu(884) = lu(884) - lu(687) * lu(866) - lu(885) = lu(885) - lu(688) * lu(866) - lu(1009) = lu(1009) - lu(678) * lu(1004) - lu(1012) = lu(1012) - lu(679) * lu(1004) - lu(1018) = lu(1018) - lu(680) * lu(1004) - lu(1020) = lu(1020) - lu(681) * lu(1004) - lu(1022) = lu(1022) - lu(682) * lu(1004) - lu(1023) = lu(1023) - lu(683) * lu(1004) - lu(1024) = lu(1024) - lu(684) * lu(1004) - lu(1025) = lu(1025) - lu(685) * lu(1004) - lu(1026) = lu(1026) - lu(686) * lu(1004) - lu(1027) = lu(1027) - lu(687) * lu(1004) - lu(1028) = lu(1028) - lu(688) * lu(1004) - lu(1105) = lu(1105) - lu(678) * lu(1100) - lu(1108) = lu(1108) - lu(679) * lu(1100) - lu(1114) = lu(1114) - lu(680) * lu(1100) - lu(1116) = lu(1116) - lu(681) * lu(1100) - lu(1118) = lu(1118) - lu(682) * lu(1100) - lu(1119) = lu(1119) - lu(683) * lu(1100) - lu(1120) = lu(1120) - lu(684) * lu(1100) - lu(1121) = lu(1121) - lu(685) * lu(1100) - lu(1122) = lu(1122) - lu(686) * lu(1100) - lu(1123) = lu(1123) - lu(687) * lu(1100) - lu(1124) = lu(1124) - lu(688) * lu(1100) - lu(1240) = lu(1240) - lu(678) * lu(1235) - lu(1242) = lu(1242) - lu(679) * lu(1235) - lu(1248) = lu(1248) - lu(680) * lu(1235) - lu(1250) = lu(1250) - lu(681) * lu(1235) - lu(1252) = lu(1252) - lu(682) * lu(1235) - lu(1253) = lu(1253) - lu(683) * lu(1235) - lu(1254) = lu(1254) - lu(684) * lu(1235) - lu(1255) = lu(1255) - lu(685) * lu(1235) - lu(1256) = lu(1256) - lu(686) * lu(1235) - lu(1257) = lu(1257) - lu(687) * lu(1235) - lu(1258) = lu(1258) - lu(688) * lu(1235) - lu(1373) = lu(1373) - lu(678) * lu(1368) - lu(1377) = lu(1377) - lu(679) * lu(1368) - lu(1383) = lu(1383) - lu(680) * lu(1368) - lu(1385) = lu(1385) - lu(681) * lu(1368) - lu(1387) = lu(1387) - lu(682) * lu(1368) - lu(1388) = lu(1388) - lu(683) * lu(1368) - lu(1389) = lu(1389) - lu(684) * lu(1368) - lu(1390) = lu(1390) - lu(685) * lu(1368) - lu(1391) = lu(1391) - lu(686) * lu(1368) - lu(1392) = lu(1392) - lu(687) * lu(1368) - lu(1393) = lu(1393) - lu(688) * lu(1368) - lu(1418) = lu(1418) - lu(678) * lu(1413) - lu(1421) = lu(1421) - lu(679) * lu(1413) - lu(1427) = lu(1427) - lu(680) * lu(1413) - lu(1429) = lu(1429) - lu(681) * lu(1413) - lu(1431) = lu(1431) - lu(682) * lu(1413) - lu(1432) = lu(1432) - lu(683) * lu(1413) - lu(1433) = lu(1433) - lu(684) * lu(1413) - lu(1434) = lu(1434) - lu(685) * lu(1413) - lu(1435) = lu(1435) - lu(686) * lu(1413) - lu(1436) = lu(1436) - lu(687) * lu(1413) - lu(1437) = lu(1437) - lu(688) * lu(1413) - END SUBROUTINE lu_fac15 - - SUBROUTINE lu_fac16(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(697) = 1._r8 / lu(697) - lu(698) = lu(698) * lu(697) - lu(699) = lu(699) * lu(697) - lu(700) = lu(700) * lu(697) - lu(701) = lu(701) * lu(697) - lu(702) = lu(702) * lu(697) - lu(703) = lu(703) * lu(697) - lu(704) = lu(704) * lu(697) - lu(705) = lu(705) * lu(697) - lu(706) = lu(706) * lu(697) - lu(707) = lu(707) * lu(697) - lu(708) = lu(708) * lu(697) - lu(709) = lu(709) * lu(697) - lu(710) = lu(710) * lu(697) - lu(711) = lu(711) * lu(697) - lu(712) = lu(712) * lu(697) - lu(786) = lu(786) - lu(698) * lu(785) - lu(787) = lu(787) - lu(699) * lu(785) - lu(788) = lu(788) - lu(700) * lu(785) - lu(789) = lu(789) - lu(701) * lu(785) - lu(790) = lu(790) - lu(702) * lu(785) - lu(792) = lu(792) - lu(703) * lu(785) - lu(793) = lu(793) - lu(704) * lu(785) - lu(794) = lu(794) - lu(705) * lu(785) - lu(795) = lu(795) - lu(706) * lu(785) - lu(796) = lu(796) - lu(707) * lu(785) - lu(797) = lu(797) - lu(708) * lu(785) - lu(798) = lu(798) - lu(709) * lu(785) - lu(799) = lu(799) - lu(710) * lu(785) - lu(800) = lu(800) - lu(711) * lu(785) - lu(801) = lu(801) - lu(712) * lu(785) - lu(868) = lu(868) - lu(698) * lu(867) - lu(869) = lu(869) - lu(699) * lu(867) - lu(870) = lu(870) - lu(700) * lu(867) - lu(871) = lu(871) - lu(701) * lu(867) - lu(872) = lu(872) - lu(702) * lu(867) - lu(874) = lu(874) - lu(703) * lu(867) - lu(876) = lu(876) - lu(704) * lu(867) - lu(878) = lu(878) - lu(705) * lu(867) - lu(879) = lu(879) - lu(706) * lu(867) - lu(880) = lu(880) - lu(707) * lu(867) - lu(881) = lu(881) - lu(708) * lu(867) - lu(882) = lu(882) - lu(709) * lu(867) - lu(883) = lu(883) - lu(710) * lu(867) - lu(884) = lu(884) - lu(711) * lu(867) - lu(885) = lu(885) - lu(712) * lu(867) - lu(1006) = lu(1006) - lu(698) * lu(1005) - lu(1007) = lu(1007) - lu(699) * lu(1005) - lu(1008) = lu(1008) - lu(700) * lu(1005) - lu(1009) = lu(1009) - lu(701) * lu(1005) - lu(1012) = lu(1012) - lu(702) * lu(1005) - lu(1016) = lu(1016) - lu(703) * lu(1005) - lu(1018) = lu(1018) - lu(704) * lu(1005) - lu(1020) = lu(1020) - lu(705) * lu(1005) - lu(1022) = lu(1022) - lu(706) * lu(1005) - lu(1023) = lu(1023) - lu(707) * lu(1005) - lu(1024) = lu(1024) - lu(708) * lu(1005) - lu(1025) = lu(1025) - lu(709) * lu(1005) - lu(1026) = lu(1026) - lu(710) * lu(1005) - lu(1027) = lu(1027) - lu(711) * lu(1005) - lu(1028) = lu(1028) - lu(712) * lu(1005) - lu(1102) = lu(1102) - lu(698) * lu(1101) - lu(1103) = lu(1103) - lu(699) * lu(1101) - lu(1104) = lu(1104) - lu(700) * lu(1101) - lu(1105) = lu(1105) - lu(701) * lu(1101) - lu(1108) = lu(1108) - lu(702) * lu(1101) - lu(1112) = lu(1112) - lu(703) * lu(1101) - lu(1114) = lu(1114) - lu(704) * lu(1101) - lu(1116) = lu(1116) - lu(705) * lu(1101) - lu(1118) = lu(1118) - lu(706) * lu(1101) - lu(1119) = lu(1119) - lu(707) * lu(1101) - lu(1120) = lu(1120) - lu(708) * lu(1101) - lu(1121) = lu(1121) - lu(709) * lu(1101) - lu(1122) = lu(1122) - lu(710) * lu(1101) - lu(1123) = lu(1123) - lu(711) * lu(1101) - lu(1124) = lu(1124) - lu(712) * lu(1101) - lu(1237) = lu(1237) - lu(698) * lu(1236) - lu(1238) = lu(1238) - lu(699) * lu(1236) - lu(1239) = lu(1239) - lu(700) * lu(1236) - lu(1240) = lu(1240) - lu(701) * lu(1236) - lu(1242) = lu(1242) - lu(702) * lu(1236) - lu(1246) = lu(1246) - lu(703) * lu(1236) - lu(1248) = lu(1248) - lu(704) * lu(1236) - lu(1250) = lu(1250) - lu(705) * lu(1236) - lu(1252) = lu(1252) - lu(706) * lu(1236) - lu(1253) = lu(1253) - lu(707) * lu(1236) - lu(1254) = lu(1254) - lu(708) * lu(1236) - lu(1255) = lu(1255) - lu(709) * lu(1236) - lu(1256) = lu(1256) - lu(710) * lu(1236) - lu(1257) = lu(1257) - lu(711) * lu(1236) - lu(1258) = lu(1258) - lu(712) * lu(1236) - lu(1370) = lu(1370) - lu(698) * lu(1369) - lu(1371) = lu(1371) - lu(699) * lu(1369) - lu(1372) = lu(1372) - lu(700) * lu(1369) - lu(1373) = lu(1373) - lu(701) * lu(1369) - lu(1377) = lu(1377) - lu(702) * lu(1369) - lu(1381) = lu(1381) - lu(703) * lu(1369) - lu(1383) = lu(1383) - lu(704) * lu(1369) - lu(1385) = lu(1385) - lu(705) * lu(1369) - lu(1387) = lu(1387) - lu(706) * lu(1369) - lu(1388) = lu(1388) - lu(707) * lu(1369) - lu(1389) = lu(1389) - lu(708) * lu(1369) - lu(1390) = lu(1390) - lu(709) * lu(1369) - lu(1391) = lu(1391) - lu(710) * lu(1369) - lu(1392) = lu(1392) - lu(711) * lu(1369) - lu(1393) = lu(1393) - lu(712) * lu(1369) - lu(1415) = lu(1415) - lu(698) * lu(1414) - lu(1416) = lu(1416) - lu(699) * lu(1414) - lu(1417) = lu(1417) - lu(700) * lu(1414) - lu(1418) = lu(1418) - lu(701) * lu(1414) - lu(1421) = lu(1421) - lu(702) * lu(1414) - lu(1425) = lu(1425) - lu(703) * lu(1414) - lu(1427) = lu(1427) - lu(704) * lu(1414) - lu(1429) = lu(1429) - lu(705) * lu(1414) - lu(1431) = lu(1431) - lu(706) * lu(1414) - lu(1432) = lu(1432) - lu(707) * lu(1414) - lu(1433) = lu(1433) - lu(708) * lu(1414) - lu(1434) = lu(1434) - lu(709) * lu(1414) - lu(1435) = lu(1435) - lu(710) * lu(1414) - lu(1436) = lu(1436) - lu(711) * lu(1414) - lu(1437) = lu(1437) - lu(712) * lu(1414) - lu(721) = 1._r8 / lu(721) - lu(722) = lu(722) * lu(721) - lu(723) = lu(723) * lu(721) - lu(724) = lu(724) * lu(721) - lu(725) = lu(725) * lu(721) - lu(726) = lu(726) * lu(721) - lu(727) = lu(727) * lu(721) - lu(728) = lu(728) * lu(721) - lu(729) = lu(729) * lu(721) - lu(730) = lu(730) * lu(721) - lu(731) = lu(731) * lu(721) - lu(732) = lu(732) * lu(721) - lu(733) = lu(733) * lu(721) - lu(741) = - lu(722) * lu(739) - lu(742) = lu(742) - lu(723) * lu(739) - lu(743) = lu(743) - lu(724) * lu(739) - lu(746) = lu(746) - lu(725) * lu(739) - lu(747) = lu(747) - lu(726) * lu(739) - lu(748) = lu(748) - lu(727) * lu(739) - lu(749) = lu(749) - lu(728) * lu(739) - lu(750) = lu(750) - lu(729) * lu(739) - lu(751) = lu(751) - lu(730) * lu(739) - lu(752) = lu(752) - lu(731) * lu(739) - lu(753) = lu(753) - lu(732) * lu(739) - lu(754) = lu(754) - lu(733) * lu(739) - lu(788) = lu(788) - lu(722) * lu(786) - lu(789) = lu(789) - lu(723) * lu(786) - lu(790) = lu(790) - lu(724) * lu(786) - lu(793) = lu(793) - lu(725) * lu(786) - lu(794) = lu(794) - lu(726) * lu(786) - lu(795) = lu(795) - lu(727) * lu(786) - lu(796) = lu(796) - lu(728) * lu(786) - lu(797) = lu(797) - lu(729) * lu(786) - lu(798) = lu(798) - lu(730) * lu(786) - lu(799) = lu(799) - lu(731) * lu(786) - lu(800) = lu(800) - lu(732) * lu(786) - lu(801) = lu(801) - lu(733) * lu(786) - lu(870) = lu(870) - lu(722) * lu(868) - lu(871) = lu(871) - lu(723) * lu(868) - lu(872) = lu(872) - lu(724) * lu(868) - lu(876) = lu(876) - lu(725) * lu(868) - lu(878) = lu(878) - lu(726) * lu(868) - lu(879) = lu(879) - lu(727) * lu(868) - lu(880) = lu(880) - lu(728) * lu(868) - lu(881) = lu(881) - lu(729) * lu(868) - lu(882) = lu(882) - lu(730) * lu(868) - lu(883) = lu(883) - lu(731) * lu(868) - lu(884) = lu(884) - lu(732) * lu(868) - lu(885) = lu(885) - lu(733) * lu(868) - lu(1008) = lu(1008) - lu(722) * lu(1006) - lu(1009) = lu(1009) - lu(723) * lu(1006) - lu(1012) = lu(1012) - lu(724) * lu(1006) - lu(1018) = lu(1018) - lu(725) * lu(1006) - lu(1020) = lu(1020) - lu(726) * lu(1006) - lu(1022) = lu(1022) - lu(727) * lu(1006) - lu(1023) = lu(1023) - lu(728) * lu(1006) - lu(1024) = lu(1024) - lu(729) * lu(1006) - lu(1025) = lu(1025) - lu(730) * lu(1006) - lu(1026) = lu(1026) - lu(731) * lu(1006) - lu(1027) = lu(1027) - lu(732) * lu(1006) - lu(1028) = lu(1028) - lu(733) * lu(1006) - lu(1104) = lu(1104) - lu(722) * lu(1102) - lu(1105) = lu(1105) - lu(723) * lu(1102) - lu(1108) = lu(1108) - lu(724) * lu(1102) - lu(1114) = lu(1114) - lu(725) * lu(1102) - lu(1116) = lu(1116) - lu(726) * lu(1102) - lu(1118) = lu(1118) - lu(727) * lu(1102) - lu(1119) = lu(1119) - lu(728) * lu(1102) - lu(1120) = lu(1120) - lu(729) * lu(1102) - lu(1121) = lu(1121) - lu(730) * lu(1102) - lu(1122) = lu(1122) - lu(731) * lu(1102) - lu(1123) = lu(1123) - lu(732) * lu(1102) - lu(1124) = lu(1124) - lu(733) * lu(1102) - lu(1239) = lu(1239) - lu(722) * lu(1237) - lu(1240) = lu(1240) - lu(723) * lu(1237) - lu(1242) = lu(1242) - lu(724) * lu(1237) - lu(1248) = lu(1248) - lu(725) * lu(1237) - lu(1250) = lu(1250) - lu(726) * lu(1237) - lu(1252) = lu(1252) - lu(727) * lu(1237) - lu(1253) = lu(1253) - lu(728) * lu(1237) - lu(1254) = lu(1254) - lu(729) * lu(1237) - lu(1255) = lu(1255) - lu(730) * lu(1237) - lu(1256) = lu(1256) - lu(731) * lu(1237) - lu(1257) = lu(1257) - lu(732) * lu(1237) - lu(1258) = lu(1258) - lu(733) * lu(1237) - lu(1372) = lu(1372) - lu(722) * lu(1370) - lu(1373) = lu(1373) - lu(723) * lu(1370) - lu(1377) = lu(1377) - lu(724) * lu(1370) - lu(1383) = lu(1383) - lu(725) * lu(1370) - lu(1385) = lu(1385) - lu(726) * lu(1370) - lu(1387) = lu(1387) - lu(727) * lu(1370) - lu(1388) = lu(1388) - lu(728) * lu(1370) - lu(1389) = lu(1389) - lu(729) * lu(1370) - lu(1390) = lu(1390) - lu(730) * lu(1370) - lu(1391) = lu(1391) - lu(731) * lu(1370) - lu(1392) = lu(1392) - lu(732) * lu(1370) - lu(1393) = lu(1393) - lu(733) * lu(1370) - lu(1417) = lu(1417) - lu(722) * lu(1415) - lu(1418) = lu(1418) - lu(723) * lu(1415) - lu(1421) = lu(1421) - lu(724) * lu(1415) - lu(1427) = lu(1427) - lu(725) * lu(1415) - lu(1429) = lu(1429) - lu(726) * lu(1415) - lu(1431) = lu(1431) - lu(727) * lu(1415) - lu(1432) = lu(1432) - lu(728) * lu(1415) - lu(1433) = lu(1433) - lu(729) * lu(1415) - lu(1434) = lu(1434) - lu(730) * lu(1415) - lu(1435) = lu(1435) - lu(731) * lu(1415) - lu(1436) = lu(1436) - lu(732) * lu(1415) - lu(1437) = lu(1437) - lu(733) * lu(1415) - lu(740) = 1._r8 / lu(740) - lu(741) = lu(741) * lu(740) - lu(742) = lu(742) * lu(740) - lu(743) = lu(743) * lu(740) - lu(744) = lu(744) * lu(740) - lu(745) = lu(745) * lu(740) - lu(746) = lu(746) * lu(740) - lu(747) = lu(747) * lu(740) - lu(748) = lu(748) * lu(740) - lu(749) = lu(749) * lu(740) - lu(750) = lu(750) * lu(740) - lu(751) = lu(751) * lu(740) - lu(752) = lu(752) * lu(740) - lu(753) = lu(753) * lu(740) - lu(754) = lu(754) * lu(740) - lu(788) = lu(788) - lu(741) * lu(787) - lu(789) = lu(789) - lu(742) * lu(787) - lu(790) = lu(790) - lu(743) * lu(787) - lu(791) = - lu(744) * lu(787) - lu(792) = lu(792) - lu(745) * lu(787) - lu(793) = lu(793) - lu(746) * lu(787) - lu(794) = lu(794) - lu(747) * lu(787) - lu(795) = lu(795) - lu(748) * lu(787) - lu(796) = lu(796) - lu(749) * lu(787) - lu(797) = lu(797) - lu(750) * lu(787) - lu(798) = lu(798) - lu(751) * lu(787) - lu(799) = lu(799) - lu(752) * lu(787) - lu(800) = lu(800) - lu(753) * lu(787) - lu(801) = lu(801) - lu(754) * lu(787) - lu(870) = lu(870) - lu(741) * lu(869) - lu(871) = lu(871) - lu(742) * lu(869) - lu(872) = lu(872) - lu(743) * lu(869) - lu(873) = lu(873) - lu(744) * lu(869) - lu(874) = lu(874) - lu(745) * lu(869) - lu(876) = lu(876) - lu(746) * lu(869) - lu(878) = lu(878) - lu(747) * lu(869) - lu(879) = lu(879) - lu(748) * lu(869) - lu(880) = lu(880) - lu(749) * lu(869) - lu(881) = lu(881) - lu(750) * lu(869) - lu(882) = lu(882) - lu(751) * lu(869) - lu(883) = lu(883) - lu(752) * lu(869) - lu(884) = lu(884) - lu(753) * lu(869) - lu(885) = lu(885) - lu(754) * lu(869) - lu(1008) = lu(1008) - lu(741) * lu(1007) - lu(1009) = lu(1009) - lu(742) * lu(1007) - lu(1012) = lu(1012) - lu(743) * lu(1007) - lu(1013) = lu(1013) - lu(744) * lu(1007) - lu(1016) = lu(1016) - lu(745) * lu(1007) - lu(1018) = lu(1018) - lu(746) * lu(1007) - lu(1020) = lu(1020) - lu(747) * lu(1007) - lu(1022) = lu(1022) - lu(748) * lu(1007) - lu(1023) = lu(1023) - lu(749) * lu(1007) - lu(1024) = lu(1024) - lu(750) * lu(1007) - lu(1025) = lu(1025) - lu(751) * lu(1007) - lu(1026) = lu(1026) - lu(752) * lu(1007) - lu(1027) = lu(1027) - lu(753) * lu(1007) - lu(1028) = lu(1028) - lu(754) * lu(1007) - lu(1104) = lu(1104) - lu(741) * lu(1103) - lu(1105) = lu(1105) - lu(742) * lu(1103) - lu(1108) = lu(1108) - lu(743) * lu(1103) - lu(1109) = lu(1109) - lu(744) * lu(1103) - lu(1112) = lu(1112) - lu(745) * lu(1103) - lu(1114) = lu(1114) - lu(746) * lu(1103) - lu(1116) = lu(1116) - lu(747) * lu(1103) - lu(1118) = lu(1118) - lu(748) * lu(1103) - lu(1119) = lu(1119) - lu(749) * lu(1103) - lu(1120) = lu(1120) - lu(750) * lu(1103) - lu(1121) = lu(1121) - lu(751) * lu(1103) - lu(1122) = lu(1122) - lu(752) * lu(1103) - lu(1123) = lu(1123) - lu(753) * lu(1103) - lu(1124) = lu(1124) - lu(754) * lu(1103) - lu(1239) = lu(1239) - lu(741) * lu(1238) - lu(1240) = lu(1240) - lu(742) * lu(1238) - lu(1242) = lu(1242) - lu(743) * lu(1238) - lu(1243) = lu(1243) - lu(744) * lu(1238) - lu(1246) = lu(1246) - lu(745) * lu(1238) - lu(1248) = lu(1248) - lu(746) * lu(1238) - lu(1250) = lu(1250) - lu(747) * lu(1238) - lu(1252) = lu(1252) - lu(748) * lu(1238) - lu(1253) = lu(1253) - lu(749) * lu(1238) - lu(1254) = lu(1254) - lu(750) * lu(1238) - lu(1255) = lu(1255) - lu(751) * lu(1238) - lu(1256) = lu(1256) - lu(752) * lu(1238) - lu(1257) = lu(1257) - lu(753) * lu(1238) - lu(1258) = lu(1258) - lu(754) * lu(1238) - lu(1372) = lu(1372) - lu(741) * lu(1371) - lu(1373) = lu(1373) - lu(742) * lu(1371) - lu(1377) = lu(1377) - lu(743) * lu(1371) - lu(1378) = lu(1378) - lu(744) * lu(1371) - lu(1381) = lu(1381) - lu(745) * lu(1371) - lu(1383) = lu(1383) - lu(746) * lu(1371) - lu(1385) = lu(1385) - lu(747) * lu(1371) - lu(1387) = lu(1387) - lu(748) * lu(1371) - lu(1388) = lu(1388) - lu(749) * lu(1371) - lu(1389) = lu(1389) - lu(750) * lu(1371) - lu(1390) = lu(1390) - lu(751) * lu(1371) - lu(1391) = lu(1391) - lu(752) * lu(1371) - lu(1392) = lu(1392) - lu(753) * lu(1371) - lu(1393) = lu(1393) - lu(754) * lu(1371) - lu(1417) = lu(1417) - lu(741) * lu(1416) - lu(1418) = lu(1418) - lu(742) * lu(1416) - lu(1421) = lu(1421) - lu(743) * lu(1416) - lu(1422) = lu(1422) - lu(744) * lu(1416) - lu(1425) = lu(1425) - lu(745) * lu(1416) - lu(1427) = lu(1427) - lu(746) * lu(1416) - lu(1429) = lu(1429) - lu(747) * lu(1416) - lu(1431) = lu(1431) - lu(748) * lu(1416) - lu(1432) = lu(1432) - lu(749) * lu(1416) - lu(1433) = lu(1433) - lu(750) * lu(1416) - lu(1434) = lu(1434) - lu(751) * lu(1416) - lu(1435) = lu(1435) - lu(752) * lu(1416) - lu(1436) = lu(1436) - lu(753) * lu(1416) - lu(1437) = lu(1437) - lu(754) * lu(1416) - lu(760) = 1._r8 / lu(760) - lu(761) = lu(761) * lu(760) - lu(762) = lu(762) * lu(760) - lu(763) = lu(763) * lu(760) - lu(764) = lu(764) * lu(760) - lu(765) = lu(765) * lu(760) - lu(766) = lu(766) * lu(760) - lu(767) = lu(767) * lu(760) - lu(768) = lu(768) * lu(760) - lu(769) = lu(769) * lu(760) - lu(770) = lu(770) * lu(760) - lu(771) = lu(771) * lu(760) - lu(772) = lu(772) * lu(760) - lu(773) = lu(773) * lu(760) - lu(789) = lu(789) - lu(761) * lu(788) - lu(790) = lu(790) - lu(762) * lu(788) - lu(791) = lu(791) - lu(763) * lu(788) - lu(792) = lu(792) - lu(764) * lu(788) - lu(793) = lu(793) - lu(765) * lu(788) - lu(794) = lu(794) - lu(766) * lu(788) - lu(795) = lu(795) - lu(767) * lu(788) - lu(796) = lu(796) - lu(768) * lu(788) - lu(797) = lu(797) - lu(769) * lu(788) - lu(798) = lu(798) - lu(770) * lu(788) - lu(799) = lu(799) - lu(771) * lu(788) - lu(800) = lu(800) - lu(772) * lu(788) - lu(801) = lu(801) - lu(773) * lu(788) - lu(871) = lu(871) - lu(761) * lu(870) - lu(872) = lu(872) - lu(762) * lu(870) - lu(873) = lu(873) - lu(763) * lu(870) - lu(874) = lu(874) - lu(764) * lu(870) - lu(876) = lu(876) - lu(765) * lu(870) - lu(878) = lu(878) - lu(766) * lu(870) - lu(879) = lu(879) - lu(767) * lu(870) - lu(880) = lu(880) - lu(768) * lu(870) - lu(881) = lu(881) - lu(769) * lu(870) - lu(882) = lu(882) - lu(770) * lu(870) - lu(883) = lu(883) - lu(771) * lu(870) - lu(884) = lu(884) - lu(772) * lu(870) - lu(885) = lu(885) - lu(773) * lu(870) - lu(1009) = lu(1009) - lu(761) * lu(1008) - lu(1012) = lu(1012) - lu(762) * lu(1008) - lu(1013) = lu(1013) - lu(763) * lu(1008) - lu(1016) = lu(1016) - lu(764) * lu(1008) - lu(1018) = lu(1018) - lu(765) * lu(1008) - lu(1020) = lu(1020) - lu(766) * lu(1008) - lu(1022) = lu(1022) - lu(767) * lu(1008) - lu(1023) = lu(1023) - lu(768) * lu(1008) - lu(1024) = lu(1024) - lu(769) * lu(1008) - lu(1025) = lu(1025) - lu(770) * lu(1008) - lu(1026) = lu(1026) - lu(771) * lu(1008) - lu(1027) = lu(1027) - lu(772) * lu(1008) - lu(1028) = lu(1028) - lu(773) * lu(1008) - lu(1105) = lu(1105) - lu(761) * lu(1104) - lu(1108) = lu(1108) - lu(762) * lu(1104) - lu(1109) = lu(1109) - lu(763) * lu(1104) - lu(1112) = lu(1112) - lu(764) * lu(1104) - lu(1114) = lu(1114) - lu(765) * lu(1104) - lu(1116) = lu(1116) - lu(766) * lu(1104) - lu(1118) = lu(1118) - lu(767) * lu(1104) - lu(1119) = lu(1119) - lu(768) * lu(1104) - lu(1120) = lu(1120) - lu(769) * lu(1104) - lu(1121) = lu(1121) - lu(770) * lu(1104) - lu(1122) = lu(1122) - lu(771) * lu(1104) - lu(1123) = lu(1123) - lu(772) * lu(1104) - lu(1124) = lu(1124) - lu(773) * lu(1104) - lu(1240) = lu(1240) - lu(761) * lu(1239) - lu(1242) = lu(1242) - lu(762) * lu(1239) - lu(1243) = lu(1243) - lu(763) * lu(1239) - lu(1246) = lu(1246) - lu(764) * lu(1239) - lu(1248) = lu(1248) - lu(765) * lu(1239) - lu(1250) = lu(1250) - lu(766) * lu(1239) - lu(1252) = lu(1252) - lu(767) * lu(1239) - lu(1253) = lu(1253) - lu(768) * lu(1239) - lu(1254) = lu(1254) - lu(769) * lu(1239) - lu(1255) = lu(1255) - lu(770) * lu(1239) - lu(1256) = lu(1256) - lu(771) * lu(1239) - lu(1257) = lu(1257) - lu(772) * lu(1239) - lu(1258) = lu(1258) - lu(773) * lu(1239) - lu(1275) = lu(1275) - lu(761) * lu(1274) - lu(1279) = lu(1279) - lu(762) * lu(1274) - lu(1280) = lu(1280) - lu(763) * lu(1274) - lu(1283) = lu(1283) - lu(764) * lu(1274) - lu(1285) = lu(1285) - lu(765) * lu(1274) - lu(1287) = lu(1287) - lu(766) * lu(1274) - lu(1289) = lu(1289) - lu(767) * lu(1274) - lu(1290) = lu(1290) - lu(768) * lu(1274) - lu(1291) = lu(1291) - lu(769) * lu(1274) - lu(1292) = lu(1292) - lu(770) * lu(1274) - lu(1293) = lu(1293) - lu(771) * lu(1274) - lu(1294) = lu(1294) - lu(772) * lu(1274) - lu(1295) = lu(1295) - lu(773) * lu(1274) - lu(1373) = lu(1373) - lu(761) * lu(1372) - lu(1377) = lu(1377) - lu(762) * lu(1372) - lu(1378) = lu(1378) - lu(763) * lu(1372) - lu(1381) = lu(1381) - lu(764) * lu(1372) - lu(1383) = lu(1383) - lu(765) * lu(1372) - lu(1385) = lu(1385) - lu(766) * lu(1372) - lu(1387) = lu(1387) - lu(767) * lu(1372) - lu(1388) = lu(1388) - lu(768) * lu(1372) - lu(1389) = lu(1389) - lu(769) * lu(1372) - lu(1390) = lu(1390) - lu(770) * lu(1372) - lu(1391) = lu(1391) - lu(771) * lu(1372) - lu(1392) = lu(1392) - lu(772) * lu(1372) - lu(1393) = lu(1393) - lu(773) * lu(1372) - lu(1418) = lu(1418) - lu(761) * lu(1417) - lu(1421) = lu(1421) - lu(762) * lu(1417) - lu(1422) = lu(1422) - lu(763) * lu(1417) - lu(1425) = lu(1425) - lu(764) * lu(1417) - lu(1427) = lu(1427) - lu(765) * lu(1417) - lu(1429) = lu(1429) - lu(766) * lu(1417) - lu(1431) = lu(1431) - lu(767) * lu(1417) - lu(1432) = lu(1432) - lu(768) * lu(1417) - lu(1433) = lu(1433) - lu(769) * lu(1417) - lu(1434) = lu(1434) - lu(770) * lu(1417) - lu(1435) = lu(1435) - lu(771) * lu(1417) - lu(1436) = lu(1436) - lu(772) * lu(1417) - lu(1437) = lu(1437) - lu(773) * lu(1417) - END SUBROUTINE lu_fac16 - - SUBROUTINE lu_fac17(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(789) = 1._r8 / lu(789) - lu(790) = lu(790) * lu(789) - lu(791) = lu(791) * lu(789) - lu(792) = lu(792) * lu(789) - lu(793) = lu(793) * lu(789) - lu(794) = lu(794) * lu(789) - lu(795) = lu(795) * lu(789) - lu(796) = lu(796) * lu(789) - lu(797) = lu(797) * lu(789) - lu(798) = lu(798) * lu(789) - lu(799) = lu(799) * lu(789) - lu(800) = lu(800) * lu(789) - lu(801) = lu(801) * lu(789) - lu(872) = lu(872) - lu(790) * lu(871) - lu(873) = lu(873) - lu(791) * lu(871) - lu(874) = lu(874) - lu(792) * lu(871) - lu(876) = lu(876) - lu(793) * lu(871) - lu(878) = lu(878) - lu(794) * lu(871) - lu(879) = lu(879) - lu(795) * lu(871) - lu(880) = lu(880) - lu(796) * lu(871) - lu(881) = lu(881) - lu(797) * lu(871) - lu(882) = lu(882) - lu(798) * lu(871) - lu(883) = lu(883) - lu(799) * lu(871) - lu(884) = lu(884) - lu(800) * lu(871) - lu(885) = lu(885) - lu(801) * lu(871) - lu(1012) = lu(1012) - lu(790) * lu(1009) - lu(1013) = lu(1013) - lu(791) * lu(1009) - lu(1016) = lu(1016) - lu(792) * lu(1009) - lu(1018) = lu(1018) - lu(793) * lu(1009) - lu(1020) = lu(1020) - lu(794) * lu(1009) - lu(1022) = lu(1022) - lu(795) * lu(1009) - lu(1023) = lu(1023) - lu(796) * lu(1009) - lu(1024) = lu(1024) - lu(797) * lu(1009) - lu(1025) = lu(1025) - lu(798) * lu(1009) - lu(1026) = lu(1026) - lu(799) * lu(1009) - lu(1027) = lu(1027) - lu(800) * lu(1009) - lu(1028) = lu(1028) - lu(801) * lu(1009) - lu(1108) = lu(1108) - lu(790) * lu(1105) - lu(1109) = lu(1109) - lu(791) * lu(1105) - lu(1112) = lu(1112) - lu(792) * lu(1105) - lu(1114) = lu(1114) - lu(793) * lu(1105) - lu(1116) = lu(1116) - lu(794) * lu(1105) - lu(1118) = lu(1118) - lu(795) * lu(1105) - lu(1119) = lu(1119) - lu(796) * lu(1105) - lu(1120) = lu(1120) - lu(797) * lu(1105) - lu(1121) = lu(1121) - lu(798) * lu(1105) - lu(1122) = lu(1122) - lu(799) * lu(1105) - lu(1123) = lu(1123) - lu(800) * lu(1105) - lu(1124) = lu(1124) - lu(801) * lu(1105) - lu(1143) = lu(1143) - lu(790) * lu(1140) - lu(1144) = lu(1144) - lu(791) * lu(1140) - lu(1147) = lu(1147) - lu(792) * lu(1140) - lu(1149) = lu(1149) - lu(793) * lu(1140) - lu(1151) = lu(1151) - lu(794) * lu(1140) - lu(1153) = lu(1153) - lu(795) * lu(1140) - lu(1154) = lu(1154) - lu(796) * lu(1140) - lu(1155) = lu(1155) - lu(797) * lu(1140) - lu(1156) = lu(1156) - lu(798) * lu(1140) - lu(1157) = lu(1157) - lu(799) * lu(1140) - lu(1158) = lu(1158) - lu(800) * lu(1140) - lu(1159) = lu(1159) - lu(801) * lu(1140) - lu(1242) = lu(1242) - lu(790) * lu(1240) - lu(1243) = lu(1243) - lu(791) * lu(1240) - lu(1246) = lu(1246) - lu(792) * lu(1240) - lu(1248) = lu(1248) - lu(793) * lu(1240) - lu(1250) = lu(1250) - lu(794) * lu(1240) - lu(1252) = lu(1252) - lu(795) * lu(1240) - lu(1253) = lu(1253) - lu(796) * lu(1240) - lu(1254) = lu(1254) - lu(797) * lu(1240) - lu(1255) = lu(1255) - lu(798) * lu(1240) - lu(1256) = lu(1256) - lu(799) * lu(1240) - lu(1257) = lu(1257) - lu(800) * lu(1240) - lu(1258) = lu(1258) - lu(801) * lu(1240) - lu(1279) = lu(1279) - lu(790) * lu(1275) - lu(1280) = lu(1280) - lu(791) * lu(1275) - lu(1283) = lu(1283) - lu(792) * lu(1275) - lu(1285) = lu(1285) - lu(793) * lu(1275) - lu(1287) = lu(1287) - lu(794) * lu(1275) - lu(1289) = lu(1289) - lu(795) * lu(1275) - lu(1290) = lu(1290) - lu(796) * lu(1275) - lu(1291) = lu(1291) - lu(797) * lu(1275) - lu(1292) = lu(1292) - lu(798) * lu(1275) - lu(1293) = lu(1293) - lu(799) * lu(1275) - lu(1294) = lu(1294) - lu(800) * lu(1275) - lu(1295) = lu(1295) - lu(801) * lu(1275) - lu(1377) = lu(1377) - lu(790) * lu(1373) - lu(1378) = lu(1378) - lu(791) * lu(1373) - lu(1381) = lu(1381) - lu(792) * lu(1373) - lu(1383) = lu(1383) - lu(793) * lu(1373) - lu(1385) = lu(1385) - lu(794) * lu(1373) - lu(1387) = lu(1387) - lu(795) * lu(1373) - lu(1388) = lu(1388) - lu(796) * lu(1373) - lu(1389) = lu(1389) - lu(797) * lu(1373) - lu(1390) = lu(1390) - lu(798) * lu(1373) - lu(1391) = lu(1391) - lu(799) * lu(1373) - lu(1392) = lu(1392) - lu(800) * lu(1373) - lu(1393) = lu(1393) - lu(801) * lu(1373) - lu(1421) = lu(1421) - lu(790) * lu(1418) - lu(1422) = lu(1422) - lu(791) * lu(1418) - lu(1425) = lu(1425) - lu(792) * lu(1418) - lu(1427) = lu(1427) - lu(793) * lu(1418) - lu(1429) = lu(1429) - lu(794) * lu(1418) - lu(1431) = lu(1431) - lu(795) * lu(1418) - lu(1432) = lu(1432) - lu(796) * lu(1418) - lu(1433) = lu(1433) - lu(797) * lu(1418) - lu(1434) = lu(1434) - lu(798) * lu(1418) - lu(1435) = lu(1435) - lu(799) * lu(1418) - lu(1436) = lu(1436) - lu(800) * lu(1418) - lu(1437) = lu(1437) - lu(801) * lu(1418) - lu(805) = 1._r8 / lu(805) - lu(806) = lu(806) * lu(805) - lu(807) = lu(807) * lu(805) - lu(808) = lu(808) * lu(805) - lu(809) = lu(809) * lu(805) - lu(810) = lu(810) * lu(805) - lu(811) = lu(811) * lu(805) - lu(812) = lu(812) * lu(805) - lu(813) = lu(813) * lu(805) - lu(814) = lu(814) * lu(805) - lu(815) = lu(815) * lu(805) - lu(816) = lu(816) * lu(805) - lu(817) = lu(817) * lu(805) - lu(818) = lu(818) * lu(805) - lu(902) = - lu(806) * lu(901) - lu(903) = lu(903) - lu(807) * lu(901) - lu(904) = lu(904) - lu(808) * lu(901) - lu(906) = lu(906) - lu(809) * lu(901) - lu(907) = - lu(810) * lu(901) - lu(908) = lu(908) - lu(811) * lu(901) - lu(909) = - lu(812) * lu(901) - lu(910) = lu(910) - lu(813) * lu(901) - lu(911) = - lu(814) * lu(901) - lu(912) = lu(912) - lu(815) * lu(901) - lu(913) = lu(913) - lu(816) * lu(901) - lu(914) = lu(914) - lu(817) * lu(901) - lu(915) = lu(915) - lu(818) * lu(901) - lu(940) = lu(940) - lu(806) * lu(938) - lu(942) = lu(942) - lu(807) * lu(938) - lu(943) = lu(943) - lu(808) * lu(938) - lu(945) = lu(945) - lu(809) * lu(938) - lu(946) = lu(946) - lu(810) * lu(938) - lu(947) = lu(947) - lu(811) * lu(938) - lu(948) = lu(948) - lu(812) * lu(938) - lu(949) = lu(949) - lu(813) * lu(938) - lu(950) = lu(950) - lu(814) * lu(938) - lu(951) = lu(951) - lu(815) * lu(938) - lu(952) = lu(952) - lu(816) * lu(938) - lu(953) = lu(953) - lu(817) * lu(938) - lu(956) = lu(956) - lu(818) * lu(938) - lu(1011) = lu(1011) - lu(806) * lu(1010) - lu(1013) = lu(1013) - lu(807) * lu(1010) - lu(1014) = lu(1014) - lu(808) * lu(1010) - lu(1016) = lu(1016) - lu(809) * lu(1010) - lu(1017) = lu(1017) - lu(810) * lu(1010) - lu(1018) = lu(1018) - lu(811) * lu(1010) - lu(1019) = lu(1019) - lu(812) * lu(1010) - lu(1020) = lu(1020) - lu(813) * lu(1010) - lu(1021) = lu(1021) - lu(814) * lu(1010) - lu(1022) = lu(1022) - lu(815) * lu(1010) - lu(1023) = lu(1023) - lu(816) * lu(1010) - lu(1024) = lu(1024) - lu(817) * lu(1010) - lu(1027) = lu(1027) - lu(818) * lu(1010) - lu(1038) = lu(1038) - lu(806) * lu(1036) - lu(1040) = lu(1040) - lu(807) * lu(1036) - lu(1041) = lu(1041) - lu(808) * lu(1036) - lu(1043) = - lu(809) * lu(1036) - lu(1044) = lu(1044) - lu(810) * lu(1036) - lu(1045) = lu(1045) - lu(811) * lu(1036) - lu(1046) = lu(1046) - lu(812) * lu(1036) - lu(1047) = - lu(813) * lu(1036) - lu(1048) = lu(1048) - lu(814) * lu(1036) - lu(1049) = lu(1049) - lu(815) * lu(1036) - lu(1050) = lu(1050) - lu(816) * lu(1036) - lu(1051) = lu(1051) - lu(817) * lu(1036) - lu(1054) = lu(1054) - lu(818) * lu(1036) - lu(1187) = lu(1187) - lu(806) * lu(1185) - lu(1188) = lu(1188) - lu(807) * lu(1185) - lu(1189) = lu(1189) - lu(808) * lu(1185) - lu(1191) = - lu(809) * lu(1185) - lu(1192) = lu(1192) - lu(810) * lu(1185) - lu(1193) = lu(1193) - lu(811) * lu(1185) - lu(1194) = lu(1194) - lu(812) * lu(1185) - lu(1195) = - lu(813) * lu(1185) - lu(1196) = lu(1196) - lu(814) * lu(1185) - lu(1197) = lu(1197) - lu(815) * lu(1185) - lu(1198) = lu(1198) - lu(816) * lu(1185) - lu(1199) = lu(1199) - lu(817) * lu(1185) - lu(1202) = lu(1202) - lu(818) * lu(1185) - lu(1278) = lu(1278) - lu(806) * lu(1276) - lu(1280) = lu(1280) - lu(807) * lu(1276) - lu(1281) = lu(1281) - lu(808) * lu(1276) - lu(1283) = lu(1283) - lu(809) * lu(1276) - lu(1284) = lu(1284) - lu(810) * lu(1276) - lu(1285) = lu(1285) - lu(811) * lu(1276) - lu(1286) = lu(1286) - lu(812) * lu(1276) - lu(1287) = lu(1287) - lu(813) * lu(1276) - lu(1288) = lu(1288) - lu(814) * lu(1276) - lu(1289) = lu(1289) - lu(815) * lu(1276) - lu(1290) = lu(1290) - lu(816) * lu(1276) - lu(1291) = lu(1291) - lu(817) * lu(1276) - lu(1294) = lu(1294) - lu(818) * lu(1276) - lu(1376) = lu(1376) - lu(806) * lu(1374) - lu(1378) = lu(1378) - lu(807) * lu(1374) - lu(1379) = lu(1379) - lu(808) * lu(1374) - lu(1381) = lu(1381) - lu(809) * lu(1374) - lu(1382) = lu(1382) - lu(810) * lu(1374) - lu(1383) = lu(1383) - lu(811) * lu(1374) - lu(1384) = lu(1384) - lu(812) * lu(1374) - lu(1385) = lu(1385) - lu(813) * lu(1374) - lu(1386) = lu(1386) - lu(814) * lu(1374) - lu(1387) = lu(1387) - lu(815) * lu(1374) - lu(1388) = lu(1388) - lu(816) * lu(1374) - lu(1389) = lu(1389) - lu(817) * lu(1374) - lu(1392) = lu(1392) - lu(818) * lu(1374) - lu(1420) = - lu(806) * lu(1419) - lu(1422) = lu(1422) - lu(807) * lu(1419) - lu(1423) = lu(1423) - lu(808) * lu(1419) - lu(1425) = lu(1425) - lu(809) * lu(1419) - lu(1426) = - lu(810) * lu(1419) - lu(1427) = lu(1427) - lu(811) * lu(1419) - lu(1428) = - lu(812) * lu(1419) - lu(1429) = lu(1429) - lu(813) * lu(1419) - lu(1430) = - lu(814) * lu(1419) - lu(1431) = lu(1431) - lu(815) * lu(1419) - lu(1432) = lu(1432) - lu(816) * lu(1419) - lu(1433) = lu(1433) - lu(817) * lu(1419) - lu(1436) = lu(1436) - lu(818) * lu(1419) - lu(1468) = - lu(806) * lu(1466) - lu(1470) = - lu(807) * lu(1466) - lu(1471) = lu(1471) - lu(808) * lu(1466) - lu(1473) = - lu(809) * lu(1466) - lu(1474) = - lu(810) * lu(1466) - lu(1475) = lu(1475) - lu(811) * lu(1466) - lu(1476) = lu(1476) - lu(812) * lu(1466) - lu(1477) = lu(1477) - lu(813) * lu(1466) - lu(1478) = - lu(814) * lu(1466) - lu(1479) = - lu(815) * lu(1466) - lu(1480) = - lu(816) * lu(1466) - lu(1481) = lu(1481) - lu(817) * lu(1466) - lu(1484) = lu(1484) - lu(818) * lu(1466) - lu(824) = 1._r8 / lu(824) - lu(825) = lu(825) * lu(824) - lu(826) = lu(826) * lu(824) - lu(827) = lu(827) * lu(824) - lu(828) = lu(828) * lu(824) - lu(829) = lu(829) * lu(824) - lu(830) = lu(830) * lu(824) - lu(831) = lu(831) * lu(824) - lu(832) = lu(832) * lu(824) - lu(833) = lu(833) * lu(824) - lu(834) = lu(834) * lu(824) - lu(835) = lu(835) * lu(824) - lu(836) = lu(836) * lu(824) - lu(940) = lu(940) - lu(825) * lu(939) - lu(943) = lu(943) - lu(826) * lu(939) - lu(944) = lu(944) - lu(827) * lu(939) - lu(946) = lu(946) - lu(828) * lu(939) - lu(948) = lu(948) - lu(829) * lu(939) - lu(949) = lu(949) - lu(830) * lu(939) - lu(950) = lu(950) - lu(831) * lu(939) - lu(952) = lu(952) - lu(832) * lu(939) - lu(953) = lu(953) - lu(833) * lu(939) - lu(954) = lu(954) - lu(834) * lu(939) - lu(955) = lu(955) - lu(835) * lu(939) - lu(956) = lu(956) - lu(836) * lu(939) - lu(966) = lu(966) - lu(825) * lu(965) - lu(969) = lu(969) - lu(826) * lu(965) - lu(970) = lu(970) - lu(827) * lu(965) - lu(972) = - lu(828) * lu(965) - lu(974) = lu(974) - lu(829) * lu(965) - lu(975) = lu(975) - lu(830) * lu(965) - lu(976) = - lu(831) * lu(965) - lu(978) = - lu(832) * lu(965) - lu(979) = lu(979) - lu(833) * lu(965) - lu(980) = lu(980) - lu(834) * lu(965) - lu(981) = lu(981) - lu(835) * lu(965) - lu(982) = lu(982) - lu(836) * lu(965) - lu(1038) = lu(1038) - lu(825) * lu(1037) - lu(1041) = lu(1041) - lu(826) * lu(1037) - lu(1042) = - lu(827) * lu(1037) - lu(1044) = lu(1044) - lu(828) * lu(1037) - lu(1046) = lu(1046) - lu(829) * lu(1037) - lu(1047) = lu(1047) - lu(830) * lu(1037) - lu(1048) = lu(1048) - lu(831) * lu(1037) - lu(1050) = lu(1050) - lu(832) * lu(1037) - lu(1051) = lu(1051) - lu(833) * lu(1037) - lu(1052) = lu(1052) - lu(834) * lu(1037) - lu(1053) = lu(1053) - lu(835) * lu(1037) - lu(1054) = lu(1054) - lu(836) * lu(1037) - lu(1107) = lu(1107) - lu(825) * lu(1106) - lu(1110) = lu(1110) - lu(826) * lu(1106) - lu(1111) = lu(1111) - lu(827) * lu(1106) - lu(1113) = lu(1113) - lu(828) * lu(1106) - lu(1115) = lu(1115) - lu(829) * lu(1106) - lu(1116) = lu(1116) - lu(830) * lu(1106) - lu(1117) = lu(1117) - lu(831) * lu(1106) - lu(1119) = lu(1119) - lu(832) * lu(1106) - lu(1120) = lu(1120) - lu(833) * lu(1106) - lu(1121) = lu(1121) - lu(834) * lu(1106) - lu(1122) = lu(1122) - lu(835) * lu(1106) - lu(1123) = lu(1123) - lu(836) * lu(1106) - lu(1142) = lu(1142) - lu(825) * lu(1141) - lu(1145) = lu(1145) - lu(826) * lu(1141) - lu(1146) = lu(1146) - lu(827) * lu(1141) - lu(1148) = lu(1148) - lu(828) * lu(1141) - lu(1150) = lu(1150) - lu(829) * lu(1141) - lu(1151) = lu(1151) - lu(830) * lu(1141) - lu(1152) = - lu(831) * lu(1141) - lu(1154) = lu(1154) - lu(832) * lu(1141) - lu(1155) = lu(1155) - lu(833) * lu(1141) - lu(1156) = lu(1156) - lu(834) * lu(1141) - lu(1157) = lu(1157) - lu(835) * lu(1141) - lu(1158) = lu(1158) - lu(836) * lu(1141) - lu(1162) = - lu(825) * lu(1161) - lu(1165) = lu(1165) - lu(826) * lu(1161) - lu(1166) = lu(1166) - lu(827) * lu(1161) - lu(1168) = - lu(828) * lu(1161) - lu(1170) = lu(1170) - lu(829) * lu(1161) - lu(1171) = lu(1171) - lu(830) * lu(1161) - lu(1172) = - lu(831) * lu(1161) - lu(1174) = - lu(832) * lu(1161) - lu(1175) = lu(1175) - lu(833) * lu(1161) - lu(1176) = lu(1176) - lu(834) * lu(1161) - lu(1177) = lu(1177) - lu(835) * lu(1161) - lu(1178) = lu(1178) - lu(836) * lu(1161) - lu(1187) = lu(1187) - lu(825) * lu(1186) - lu(1189) = lu(1189) - lu(826) * lu(1186) - lu(1190) = - lu(827) * lu(1186) - lu(1192) = lu(1192) - lu(828) * lu(1186) - lu(1194) = lu(1194) - lu(829) * lu(1186) - lu(1195) = lu(1195) - lu(830) * lu(1186) - lu(1196) = lu(1196) - lu(831) * lu(1186) - lu(1198) = lu(1198) - lu(832) * lu(1186) - lu(1199) = lu(1199) - lu(833) * lu(1186) - lu(1200) = lu(1200) - lu(834) * lu(1186) - lu(1201) = lu(1201) - lu(835) * lu(1186) - lu(1202) = lu(1202) - lu(836) * lu(1186) - lu(1278) = lu(1278) - lu(825) * lu(1277) - lu(1281) = lu(1281) - lu(826) * lu(1277) - lu(1282) = lu(1282) - lu(827) * lu(1277) - lu(1284) = lu(1284) - lu(828) * lu(1277) - lu(1286) = lu(1286) - lu(829) * lu(1277) - lu(1287) = lu(1287) - lu(830) * lu(1277) - lu(1288) = lu(1288) - lu(831) * lu(1277) - lu(1290) = lu(1290) - lu(832) * lu(1277) - lu(1291) = lu(1291) - lu(833) * lu(1277) - lu(1292) = lu(1292) - lu(834) * lu(1277) - lu(1293) = lu(1293) - lu(835) * lu(1277) - lu(1294) = lu(1294) - lu(836) * lu(1277) - lu(1376) = lu(1376) - lu(825) * lu(1375) - lu(1379) = lu(1379) - lu(826) * lu(1375) - lu(1380) = lu(1380) - lu(827) * lu(1375) - lu(1382) = lu(1382) - lu(828) * lu(1375) - lu(1384) = lu(1384) - lu(829) * lu(1375) - lu(1385) = lu(1385) - lu(830) * lu(1375) - lu(1386) = lu(1386) - lu(831) * lu(1375) - lu(1388) = lu(1388) - lu(832) * lu(1375) - lu(1389) = lu(1389) - lu(833) * lu(1375) - lu(1390) = lu(1390) - lu(834) * lu(1375) - lu(1391) = lu(1391) - lu(835) * lu(1375) - lu(1392) = lu(1392) - lu(836) * lu(1375) - lu(1442) = - lu(825) * lu(1441) - lu(1445) = lu(1445) - lu(826) * lu(1441) - lu(1446) = lu(1446) - lu(827) * lu(1441) - lu(1448) = - lu(828) * lu(1441) - lu(1450) = lu(1450) - lu(829) * lu(1441) - lu(1451) = lu(1451) - lu(830) * lu(1441) - lu(1452) = - lu(831) * lu(1441) - lu(1454) = lu(1454) - lu(832) * lu(1441) - lu(1455) = lu(1455) - lu(833) * lu(1441) - lu(1456) = lu(1456) - lu(834) * lu(1441) - lu(1457) = lu(1457) - lu(835) * lu(1441) - lu(1458) = lu(1458) - lu(836) * lu(1441) - lu(1468) = lu(1468) - lu(825) * lu(1467) - lu(1471) = lu(1471) - lu(826) * lu(1467) - lu(1472) = lu(1472) - lu(827) * lu(1467) - lu(1474) = lu(1474) - lu(828) * lu(1467) - lu(1476) = lu(1476) - lu(829) * lu(1467) - lu(1477) = lu(1477) - lu(830) * lu(1467) - lu(1478) = lu(1478) - lu(831) * lu(1467) - lu(1480) = lu(1480) - lu(832) * lu(1467) - lu(1481) = lu(1481) - lu(833) * lu(1467) - lu(1482) = lu(1482) - lu(834) * lu(1467) - lu(1483) = lu(1483) - lu(835) * lu(1467) - lu(1484) = lu(1484) - lu(836) * lu(1467) - lu(1492) = lu(1492) - lu(825) * lu(1491) - lu(1495) = lu(1495) - lu(826) * lu(1491) - lu(1496) = lu(1496) - lu(827) * lu(1491) - lu(1498) = - lu(828) * lu(1491) - lu(1500) = lu(1500) - lu(829) * lu(1491) - lu(1501) = lu(1501) - lu(830) * lu(1491) - lu(1502) = - lu(831) * lu(1491) - lu(1504) = lu(1504) - lu(832) * lu(1491) - lu(1505) = lu(1505) - lu(833) * lu(1491) - lu(1506) = lu(1506) - lu(834) * lu(1491) - lu(1507) = lu(1507) - lu(835) * lu(1491) - lu(1508) = lu(1508) - lu(836) * lu(1491) - END SUBROUTINE lu_fac17 - - SUBROUTINE lu_fac18(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(839) = 1._r8 / lu(839) - lu(840) = lu(840) * lu(839) - lu(841) = lu(841) * lu(839) - lu(842) = lu(842) * lu(839) - lu(843) = lu(843) * lu(839) - lu(844) = lu(844) * lu(839) - lu(845) = lu(845) * lu(839) - lu(846) = lu(846) * lu(839) - lu(847) = lu(847) * lu(839) - lu(848) = lu(848) * lu(839) - lu(849) = lu(849) * lu(839) - lu(903) = lu(903) - lu(840) * lu(902) - lu(904) = lu(904) - lu(841) * lu(902) - lu(905) = lu(905) - lu(842) * lu(902) - lu(906) = lu(906) - lu(843) * lu(902) - lu(908) = lu(908) - lu(844) * lu(902) - lu(910) = lu(910) - lu(845) * lu(902) - lu(911) = lu(911) - lu(846) * lu(902) - lu(914) = lu(914) - lu(847) * lu(902) - lu(915) = lu(915) - lu(848) * lu(902) - lu(916) = lu(916) - lu(849) * lu(902) - lu(942) = lu(942) - lu(840) * lu(940) - lu(943) = lu(943) - lu(841) * lu(940) - lu(944) = lu(944) - lu(842) * lu(940) - lu(945) = lu(945) - lu(843) * lu(940) - lu(947) = lu(947) - lu(844) * lu(940) - lu(949) = lu(949) - lu(845) * lu(940) - lu(950) = lu(950) - lu(846) * lu(940) - lu(953) = lu(953) - lu(847) * lu(940) - lu(956) = lu(956) - lu(848) * lu(940) - lu(957) = lu(957) - lu(849) * lu(940) - lu(968) = lu(968) - lu(840) * lu(966) - lu(969) = lu(969) - lu(841) * lu(966) - lu(970) = lu(970) - lu(842) * lu(966) - lu(971) = lu(971) - lu(843) * lu(966) - lu(973) = lu(973) - lu(844) * lu(966) - lu(975) = lu(975) - lu(845) * lu(966) - lu(976) = lu(976) - lu(846) * lu(966) - lu(979) = lu(979) - lu(847) * lu(966) - lu(982) = lu(982) - lu(848) * lu(966) - lu(983) = lu(983) - lu(849) * lu(966) - lu(1013) = lu(1013) - lu(840) * lu(1011) - lu(1014) = lu(1014) - lu(841) * lu(1011) - lu(1015) = lu(1015) - lu(842) * lu(1011) - lu(1016) = lu(1016) - lu(843) * lu(1011) - lu(1018) = lu(1018) - lu(844) * lu(1011) - lu(1020) = lu(1020) - lu(845) * lu(1011) - lu(1021) = lu(1021) - lu(846) * lu(1011) - lu(1024) = lu(1024) - lu(847) * lu(1011) - lu(1027) = lu(1027) - lu(848) * lu(1011) - lu(1028) = lu(1028) - lu(849) * lu(1011) - lu(1040) = lu(1040) - lu(840) * lu(1038) - lu(1041) = lu(1041) - lu(841) * lu(1038) - lu(1042) = lu(1042) - lu(842) * lu(1038) - lu(1043) = lu(1043) - lu(843) * lu(1038) - lu(1045) = lu(1045) - lu(844) * lu(1038) - lu(1047) = lu(1047) - lu(845) * lu(1038) - lu(1048) = lu(1048) - lu(846) * lu(1038) - lu(1051) = lu(1051) - lu(847) * lu(1038) - lu(1054) = lu(1054) - lu(848) * lu(1038) - lu(1055) = lu(1055) - lu(849) * lu(1038) - lu(1109) = lu(1109) - lu(840) * lu(1107) - lu(1110) = lu(1110) - lu(841) * lu(1107) - lu(1111) = lu(1111) - lu(842) * lu(1107) - lu(1112) = lu(1112) - lu(843) * lu(1107) - lu(1114) = lu(1114) - lu(844) * lu(1107) - lu(1116) = lu(1116) - lu(845) * lu(1107) - lu(1117) = lu(1117) - lu(846) * lu(1107) - lu(1120) = lu(1120) - lu(847) * lu(1107) - lu(1123) = lu(1123) - lu(848) * lu(1107) - lu(1124) = lu(1124) - lu(849) * lu(1107) - lu(1144) = lu(1144) - lu(840) * lu(1142) - lu(1145) = lu(1145) - lu(841) * lu(1142) - lu(1146) = lu(1146) - lu(842) * lu(1142) - lu(1147) = lu(1147) - lu(843) * lu(1142) - lu(1149) = lu(1149) - lu(844) * lu(1142) - lu(1151) = lu(1151) - lu(845) * lu(1142) - lu(1152) = lu(1152) - lu(846) * lu(1142) - lu(1155) = lu(1155) - lu(847) * lu(1142) - lu(1158) = lu(1158) - lu(848) * lu(1142) - lu(1159) = lu(1159) - lu(849) * lu(1142) - lu(1164) = lu(1164) - lu(840) * lu(1162) - lu(1165) = lu(1165) - lu(841) * lu(1162) - lu(1166) = lu(1166) - lu(842) * lu(1162) - lu(1167) = lu(1167) - lu(843) * lu(1162) - lu(1169) = lu(1169) - lu(844) * lu(1162) - lu(1171) = lu(1171) - lu(845) * lu(1162) - lu(1172) = lu(1172) - lu(846) * lu(1162) - lu(1175) = lu(1175) - lu(847) * lu(1162) - lu(1178) = lu(1178) - lu(848) * lu(1162) - lu(1179) = - lu(849) * lu(1162) - lu(1188) = lu(1188) - lu(840) * lu(1187) - lu(1189) = lu(1189) - lu(841) * lu(1187) - lu(1190) = lu(1190) - lu(842) * lu(1187) - lu(1191) = lu(1191) - lu(843) * lu(1187) - lu(1193) = lu(1193) - lu(844) * lu(1187) - lu(1195) = lu(1195) - lu(845) * lu(1187) - lu(1196) = lu(1196) - lu(846) * lu(1187) - lu(1199) = lu(1199) - lu(847) * lu(1187) - lu(1202) = lu(1202) - lu(848) * lu(1187) - lu(1203) = - lu(849) * lu(1187) - lu(1243) = lu(1243) - lu(840) * lu(1241) - lu(1244) = lu(1244) - lu(841) * lu(1241) - lu(1245) = lu(1245) - lu(842) * lu(1241) - lu(1246) = lu(1246) - lu(843) * lu(1241) - lu(1248) = lu(1248) - lu(844) * lu(1241) - lu(1250) = lu(1250) - lu(845) * lu(1241) - lu(1251) = lu(1251) - lu(846) * lu(1241) - lu(1254) = lu(1254) - lu(847) * lu(1241) - lu(1257) = lu(1257) - lu(848) * lu(1241) - lu(1258) = lu(1258) - lu(849) * lu(1241) - lu(1280) = lu(1280) - lu(840) * lu(1278) - lu(1281) = lu(1281) - lu(841) * lu(1278) - lu(1282) = lu(1282) - lu(842) * lu(1278) - lu(1283) = lu(1283) - lu(843) * lu(1278) - lu(1285) = lu(1285) - lu(844) * lu(1278) - lu(1287) = lu(1287) - lu(845) * lu(1278) - lu(1288) = lu(1288) - lu(846) * lu(1278) - lu(1291) = lu(1291) - lu(847) * lu(1278) - lu(1294) = lu(1294) - lu(848) * lu(1278) - lu(1295) = lu(1295) - lu(849) * lu(1278) - lu(1378) = lu(1378) - lu(840) * lu(1376) - lu(1379) = lu(1379) - lu(841) * lu(1376) - lu(1380) = lu(1380) - lu(842) * lu(1376) - lu(1381) = lu(1381) - lu(843) * lu(1376) - lu(1383) = lu(1383) - lu(844) * lu(1376) - lu(1385) = lu(1385) - lu(845) * lu(1376) - lu(1386) = lu(1386) - lu(846) * lu(1376) - lu(1389) = lu(1389) - lu(847) * lu(1376) - lu(1392) = lu(1392) - lu(848) * lu(1376) - lu(1393) = lu(1393) - lu(849) * lu(1376) - lu(1422) = lu(1422) - lu(840) * lu(1420) - lu(1423) = lu(1423) - lu(841) * lu(1420) - lu(1424) = - lu(842) * lu(1420) - lu(1425) = lu(1425) - lu(843) * lu(1420) - lu(1427) = lu(1427) - lu(844) * lu(1420) - lu(1429) = lu(1429) - lu(845) * lu(1420) - lu(1430) = lu(1430) - lu(846) * lu(1420) - lu(1433) = lu(1433) - lu(847) * lu(1420) - lu(1436) = lu(1436) - lu(848) * lu(1420) - lu(1437) = lu(1437) - lu(849) * lu(1420) - lu(1444) = - lu(840) * lu(1442) - lu(1445) = lu(1445) - lu(841) * lu(1442) - lu(1446) = lu(1446) - lu(842) * lu(1442) - lu(1447) = - lu(843) * lu(1442) - lu(1449) = - lu(844) * lu(1442) - lu(1451) = lu(1451) - lu(845) * lu(1442) - lu(1452) = lu(1452) - lu(846) * lu(1442) - lu(1455) = lu(1455) - lu(847) * lu(1442) - lu(1458) = lu(1458) - lu(848) * lu(1442) - lu(1459) = - lu(849) * lu(1442) - lu(1470) = lu(1470) - lu(840) * lu(1468) - lu(1471) = lu(1471) - lu(841) * lu(1468) - lu(1472) = lu(1472) - lu(842) * lu(1468) - lu(1473) = lu(1473) - lu(843) * lu(1468) - lu(1475) = lu(1475) - lu(844) * lu(1468) - lu(1477) = lu(1477) - lu(845) * lu(1468) - lu(1478) = lu(1478) - lu(846) * lu(1468) - lu(1481) = lu(1481) - lu(847) * lu(1468) - lu(1484) = lu(1484) - lu(848) * lu(1468) - lu(1485) = - lu(849) * lu(1468) - lu(1494) = - lu(840) * lu(1492) - lu(1495) = lu(1495) - lu(841) * lu(1492) - lu(1496) = lu(1496) - lu(842) * lu(1492) - lu(1497) = - lu(843) * lu(1492) - lu(1499) = lu(1499) - lu(844) * lu(1492) - lu(1501) = lu(1501) - lu(845) * lu(1492) - lu(1502) = lu(1502) - lu(846) * lu(1492) - lu(1505) = lu(1505) - lu(847) * lu(1492) - lu(1508) = lu(1508) - lu(848) * lu(1492) - lu(1509) = lu(1509) - lu(849) * lu(1492) - lu(872) = 1._r8 / lu(872) - lu(873) = lu(873) * lu(872) - lu(874) = lu(874) * lu(872) - lu(875) = lu(875) * lu(872) - lu(876) = lu(876) * lu(872) - lu(877) = lu(877) * lu(872) - lu(878) = lu(878) * lu(872) - lu(879) = lu(879) * lu(872) - lu(880) = lu(880) * lu(872) - lu(881) = lu(881) * lu(872) - lu(882) = lu(882) * lu(872) - lu(883) = lu(883) * lu(872) - lu(884) = lu(884) * lu(872) - lu(885) = lu(885) * lu(872) - lu(942) = lu(942) - lu(873) * lu(941) - lu(945) = lu(945) - lu(874) * lu(941) - lu(946) = lu(946) - lu(875) * lu(941) - lu(947) = lu(947) - lu(876) * lu(941) - lu(948) = lu(948) - lu(877) * lu(941) - lu(949) = lu(949) - lu(878) * lu(941) - lu(951) = lu(951) - lu(879) * lu(941) - lu(952) = lu(952) - lu(880) * lu(941) - lu(953) = lu(953) - lu(881) * lu(941) - lu(954) = lu(954) - lu(882) * lu(941) - lu(955) = lu(955) - lu(883) * lu(941) - lu(956) = lu(956) - lu(884) * lu(941) - lu(957) = lu(957) - lu(885) * lu(941) - lu(968) = lu(968) - lu(873) * lu(967) - lu(971) = lu(971) - lu(874) * lu(967) - lu(972) = lu(972) - lu(875) * lu(967) - lu(973) = lu(973) - lu(876) * lu(967) - lu(974) = lu(974) - lu(877) * lu(967) - lu(975) = lu(975) - lu(878) * lu(967) - lu(977) = lu(977) - lu(879) * lu(967) - lu(978) = lu(978) - lu(880) * lu(967) - lu(979) = lu(979) - lu(881) * lu(967) - lu(980) = lu(980) - lu(882) * lu(967) - lu(981) = lu(981) - lu(883) * lu(967) - lu(982) = lu(982) - lu(884) * lu(967) - lu(983) = lu(983) - lu(885) * lu(967) - lu(1013) = lu(1013) - lu(873) * lu(1012) - lu(1016) = lu(1016) - lu(874) * lu(1012) - lu(1017) = lu(1017) - lu(875) * lu(1012) - lu(1018) = lu(1018) - lu(876) * lu(1012) - lu(1019) = lu(1019) - lu(877) * lu(1012) - lu(1020) = lu(1020) - lu(878) * lu(1012) - lu(1022) = lu(1022) - lu(879) * lu(1012) - lu(1023) = lu(1023) - lu(880) * lu(1012) - lu(1024) = lu(1024) - lu(881) * lu(1012) - lu(1025) = lu(1025) - lu(882) * lu(1012) - lu(1026) = lu(1026) - lu(883) * lu(1012) - lu(1027) = lu(1027) - lu(884) * lu(1012) - lu(1028) = lu(1028) - lu(885) * lu(1012) - lu(1040) = lu(1040) - lu(873) * lu(1039) - lu(1043) = lu(1043) - lu(874) * lu(1039) - lu(1044) = lu(1044) - lu(875) * lu(1039) - lu(1045) = lu(1045) - lu(876) * lu(1039) - lu(1046) = lu(1046) - lu(877) * lu(1039) - lu(1047) = lu(1047) - lu(878) * lu(1039) - lu(1049) = lu(1049) - lu(879) * lu(1039) - lu(1050) = lu(1050) - lu(880) * lu(1039) - lu(1051) = lu(1051) - lu(881) * lu(1039) - lu(1052) = lu(1052) - lu(882) * lu(1039) - lu(1053) = lu(1053) - lu(883) * lu(1039) - lu(1054) = lu(1054) - lu(884) * lu(1039) - lu(1055) = lu(1055) - lu(885) * lu(1039) - lu(1109) = lu(1109) - lu(873) * lu(1108) - lu(1112) = lu(1112) - lu(874) * lu(1108) - lu(1113) = lu(1113) - lu(875) * lu(1108) - lu(1114) = lu(1114) - lu(876) * lu(1108) - lu(1115) = lu(1115) - lu(877) * lu(1108) - lu(1116) = lu(1116) - lu(878) * lu(1108) - lu(1118) = lu(1118) - lu(879) * lu(1108) - lu(1119) = lu(1119) - lu(880) * lu(1108) - lu(1120) = lu(1120) - lu(881) * lu(1108) - lu(1121) = lu(1121) - lu(882) * lu(1108) - lu(1122) = lu(1122) - lu(883) * lu(1108) - lu(1123) = lu(1123) - lu(884) * lu(1108) - lu(1124) = lu(1124) - lu(885) * lu(1108) - lu(1144) = lu(1144) - lu(873) * lu(1143) - lu(1147) = lu(1147) - lu(874) * lu(1143) - lu(1148) = lu(1148) - lu(875) * lu(1143) - lu(1149) = lu(1149) - lu(876) * lu(1143) - lu(1150) = lu(1150) - lu(877) * lu(1143) - lu(1151) = lu(1151) - lu(878) * lu(1143) - lu(1153) = lu(1153) - lu(879) * lu(1143) - lu(1154) = lu(1154) - lu(880) * lu(1143) - lu(1155) = lu(1155) - lu(881) * lu(1143) - lu(1156) = lu(1156) - lu(882) * lu(1143) - lu(1157) = lu(1157) - lu(883) * lu(1143) - lu(1158) = lu(1158) - lu(884) * lu(1143) - lu(1159) = lu(1159) - lu(885) * lu(1143) - lu(1164) = lu(1164) - lu(873) * lu(1163) - lu(1167) = lu(1167) - lu(874) * lu(1163) - lu(1168) = lu(1168) - lu(875) * lu(1163) - lu(1169) = lu(1169) - lu(876) * lu(1163) - lu(1170) = lu(1170) - lu(877) * lu(1163) - lu(1171) = lu(1171) - lu(878) * lu(1163) - lu(1173) = - lu(879) * lu(1163) - lu(1174) = lu(1174) - lu(880) * lu(1163) - lu(1175) = lu(1175) - lu(881) * lu(1163) - lu(1176) = lu(1176) - lu(882) * lu(1163) - lu(1177) = lu(1177) - lu(883) * lu(1163) - lu(1178) = lu(1178) - lu(884) * lu(1163) - lu(1179) = lu(1179) - lu(885) * lu(1163) - lu(1243) = lu(1243) - lu(873) * lu(1242) - lu(1246) = lu(1246) - lu(874) * lu(1242) - lu(1247) = lu(1247) - lu(875) * lu(1242) - lu(1248) = lu(1248) - lu(876) * lu(1242) - lu(1249) = lu(1249) - lu(877) * lu(1242) - lu(1250) = lu(1250) - lu(878) * lu(1242) - lu(1252) = lu(1252) - lu(879) * lu(1242) - lu(1253) = lu(1253) - lu(880) * lu(1242) - lu(1254) = lu(1254) - lu(881) * lu(1242) - lu(1255) = lu(1255) - lu(882) * lu(1242) - lu(1256) = lu(1256) - lu(883) * lu(1242) - lu(1257) = lu(1257) - lu(884) * lu(1242) - lu(1258) = lu(1258) - lu(885) * lu(1242) - lu(1280) = lu(1280) - lu(873) * lu(1279) - lu(1283) = lu(1283) - lu(874) * lu(1279) - lu(1284) = lu(1284) - lu(875) * lu(1279) - lu(1285) = lu(1285) - lu(876) * lu(1279) - lu(1286) = lu(1286) - lu(877) * lu(1279) - lu(1287) = lu(1287) - lu(878) * lu(1279) - lu(1289) = lu(1289) - lu(879) * lu(1279) - lu(1290) = lu(1290) - lu(880) * lu(1279) - lu(1291) = lu(1291) - lu(881) * lu(1279) - lu(1292) = lu(1292) - lu(882) * lu(1279) - lu(1293) = lu(1293) - lu(883) * lu(1279) - lu(1294) = lu(1294) - lu(884) * lu(1279) - lu(1295) = lu(1295) - lu(885) * lu(1279) - lu(1378) = lu(1378) - lu(873) * lu(1377) - lu(1381) = lu(1381) - lu(874) * lu(1377) - lu(1382) = lu(1382) - lu(875) * lu(1377) - lu(1383) = lu(1383) - lu(876) * lu(1377) - lu(1384) = lu(1384) - lu(877) * lu(1377) - lu(1385) = lu(1385) - lu(878) * lu(1377) - lu(1387) = lu(1387) - lu(879) * lu(1377) - lu(1388) = lu(1388) - lu(880) * lu(1377) - lu(1389) = lu(1389) - lu(881) * lu(1377) - lu(1390) = lu(1390) - lu(882) * lu(1377) - lu(1391) = lu(1391) - lu(883) * lu(1377) - lu(1392) = lu(1392) - lu(884) * lu(1377) - lu(1393) = lu(1393) - lu(885) * lu(1377) - lu(1422) = lu(1422) - lu(873) * lu(1421) - lu(1425) = lu(1425) - lu(874) * lu(1421) - lu(1426) = lu(1426) - lu(875) * lu(1421) - lu(1427) = lu(1427) - lu(876) * lu(1421) - lu(1428) = lu(1428) - lu(877) * lu(1421) - lu(1429) = lu(1429) - lu(878) * lu(1421) - lu(1431) = lu(1431) - lu(879) * lu(1421) - lu(1432) = lu(1432) - lu(880) * lu(1421) - lu(1433) = lu(1433) - lu(881) * lu(1421) - lu(1434) = lu(1434) - lu(882) * lu(1421) - lu(1435) = lu(1435) - lu(883) * lu(1421) - lu(1436) = lu(1436) - lu(884) * lu(1421) - lu(1437) = lu(1437) - lu(885) * lu(1421) - lu(1444) = lu(1444) - lu(873) * lu(1443) - lu(1447) = lu(1447) - lu(874) * lu(1443) - lu(1448) = lu(1448) - lu(875) * lu(1443) - lu(1449) = lu(1449) - lu(876) * lu(1443) - lu(1450) = lu(1450) - lu(877) * lu(1443) - lu(1451) = lu(1451) - lu(878) * lu(1443) - lu(1453) = - lu(879) * lu(1443) - lu(1454) = lu(1454) - lu(880) * lu(1443) - lu(1455) = lu(1455) - lu(881) * lu(1443) - lu(1456) = lu(1456) - lu(882) * lu(1443) - lu(1457) = lu(1457) - lu(883) * lu(1443) - lu(1458) = lu(1458) - lu(884) * lu(1443) - lu(1459) = lu(1459) - lu(885) * lu(1443) - lu(1470) = lu(1470) - lu(873) * lu(1469) - lu(1473) = lu(1473) - lu(874) * lu(1469) - lu(1474) = lu(1474) - lu(875) * lu(1469) - lu(1475) = lu(1475) - lu(876) * lu(1469) - lu(1476) = lu(1476) - lu(877) * lu(1469) - lu(1477) = lu(1477) - lu(878) * lu(1469) - lu(1479) = lu(1479) - lu(879) * lu(1469) - lu(1480) = lu(1480) - lu(880) * lu(1469) - lu(1481) = lu(1481) - lu(881) * lu(1469) - lu(1482) = lu(1482) - lu(882) * lu(1469) - lu(1483) = lu(1483) - lu(883) * lu(1469) - lu(1484) = lu(1484) - lu(884) * lu(1469) - lu(1485) = lu(1485) - lu(885) * lu(1469) - lu(1494) = lu(1494) - lu(873) * lu(1493) - lu(1497) = lu(1497) - lu(874) * lu(1493) - lu(1498) = lu(1498) - lu(875) * lu(1493) - lu(1499) = lu(1499) - lu(876) * lu(1493) - lu(1500) = lu(1500) - lu(877) * lu(1493) - lu(1501) = lu(1501) - lu(878) * lu(1493) - lu(1503) = lu(1503) - lu(879) * lu(1493) - lu(1504) = lu(1504) - lu(880) * lu(1493) - lu(1505) = lu(1505) - lu(881) * lu(1493) - lu(1506) = lu(1506) - lu(882) * lu(1493) - lu(1507) = lu(1507) - lu(883) * lu(1493) - lu(1508) = lu(1508) - lu(884) * lu(1493) - lu(1509) = lu(1509) - lu(885) * lu(1493) - lu(903) = 1._r8 / lu(903) - lu(904) = lu(904) * lu(903) - lu(905) = lu(905) * lu(903) - lu(906) = lu(906) * lu(903) - lu(907) = lu(907) * lu(903) - lu(908) = lu(908) * lu(903) - lu(909) = lu(909) * lu(903) - lu(910) = lu(910) * lu(903) - lu(911) = lu(911) * lu(903) - lu(912) = lu(912) * lu(903) - lu(913) = lu(913) * lu(903) - lu(914) = lu(914) * lu(903) - lu(915) = lu(915) * lu(903) - lu(916) = lu(916) * lu(903) - lu(943) = lu(943) - lu(904) * lu(942) - lu(944) = lu(944) - lu(905) * lu(942) - lu(945) = lu(945) - lu(906) * lu(942) - lu(946) = lu(946) - lu(907) * lu(942) - lu(947) = lu(947) - lu(908) * lu(942) - lu(948) = lu(948) - lu(909) * lu(942) - lu(949) = lu(949) - lu(910) * lu(942) - lu(950) = lu(950) - lu(911) * lu(942) - lu(951) = lu(951) - lu(912) * lu(942) - lu(952) = lu(952) - lu(913) * lu(942) - lu(953) = lu(953) - lu(914) * lu(942) - lu(956) = lu(956) - lu(915) * lu(942) - lu(957) = lu(957) - lu(916) * lu(942) - lu(969) = lu(969) - lu(904) * lu(968) - lu(970) = lu(970) - lu(905) * lu(968) - lu(971) = lu(971) - lu(906) * lu(968) - lu(972) = lu(972) - lu(907) * lu(968) - lu(973) = lu(973) - lu(908) * lu(968) - lu(974) = lu(974) - lu(909) * lu(968) - lu(975) = lu(975) - lu(910) * lu(968) - lu(976) = lu(976) - lu(911) * lu(968) - lu(977) = lu(977) - lu(912) * lu(968) - lu(978) = lu(978) - lu(913) * lu(968) - lu(979) = lu(979) - lu(914) * lu(968) - lu(982) = lu(982) - lu(915) * lu(968) - lu(983) = lu(983) - lu(916) * lu(968) - lu(1014) = lu(1014) - lu(904) * lu(1013) - lu(1015) = lu(1015) - lu(905) * lu(1013) - lu(1016) = lu(1016) - lu(906) * lu(1013) - lu(1017) = lu(1017) - lu(907) * lu(1013) - lu(1018) = lu(1018) - lu(908) * lu(1013) - lu(1019) = lu(1019) - lu(909) * lu(1013) - lu(1020) = lu(1020) - lu(910) * lu(1013) - lu(1021) = lu(1021) - lu(911) * lu(1013) - lu(1022) = lu(1022) - lu(912) * lu(1013) - lu(1023) = lu(1023) - lu(913) * lu(1013) - lu(1024) = lu(1024) - lu(914) * lu(1013) - lu(1027) = lu(1027) - lu(915) * lu(1013) - lu(1028) = lu(1028) - lu(916) * lu(1013) - lu(1041) = lu(1041) - lu(904) * lu(1040) - lu(1042) = lu(1042) - lu(905) * lu(1040) - lu(1043) = lu(1043) - lu(906) * lu(1040) - lu(1044) = lu(1044) - lu(907) * lu(1040) - lu(1045) = lu(1045) - lu(908) * lu(1040) - lu(1046) = lu(1046) - lu(909) * lu(1040) - lu(1047) = lu(1047) - lu(910) * lu(1040) - lu(1048) = lu(1048) - lu(911) * lu(1040) - lu(1049) = lu(1049) - lu(912) * lu(1040) - lu(1050) = lu(1050) - lu(913) * lu(1040) - lu(1051) = lu(1051) - lu(914) * lu(1040) - lu(1054) = lu(1054) - lu(915) * lu(1040) - lu(1055) = lu(1055) - lu(916) * lu(1040) - lu(1110) = lu(1110) - lu(904) * lu(1109) - lu(1111) = lu(1111) - lu(905) * lu(1109) - lu(1112) = lu(1112) - lu(906) * lu(1109) - lu(1113) = lu(1113) - lu(907) * lu(1109) - lu(1114) = lu(1114) - lu(908) * lu(1109) - lu(1115) = lu(1115) - lu(909) * lu(1109) - lu(1116) = lu(1116) - lu(910) * lu(1109) - lu(1117) = lu(1117) - lu(911) * lu(1109) - lu(1118) = lu(1118) - lu(912) * lu(1109) - lu(1119) = lu(1119) - lu(913) * lu(1109) - lu(1120) = lu(1120) - lu(914) * lu(1109) - lu(1123) = lu(1123) - lu(915) * lu(1109) - lu(1124) = lu(1124) - lu(916) * lu(1109) - lu(1145) = lu(1145) - lu(904) * lu(1144) - lu(1146) = lu(1146) - lu(905) * lu(1144) - lu(1147) = lu(1147) - lu(906) * lu(1144) - lu(1148) = lu(1148) - lu(907) * lu(1144) - lu(1149) = lu(1149) - lu(908) * lu(1144) - lu(1150) = lu(1150) - lu(909) * lu(1144) - lu(1151) = lu(1151) - lu(910) * lu(1144) - lu(1152) = lu(1152) - lu(911) * lu(1144) - lu(1153) = lu(1153) - lu(912) * lu(1144) - lu(1154) = lu(1154) - lu(913) * lu(1144) - lu(1155) = lu(1155) - lu(914) * lu(1144) - lu(1158) = lu(1158) - lu(915) * lu(1144) - lu(1159) = lu(1159) - lu(916) * lu(1144) - lu(1165) = lu(1165) - lu(904) * lu(1164) - lu(1166) = lu(1166) - lu(905) * lu(1164) - lu(1167) = lu(1167) - lu(906) * lu(1164) - lu(1168) = lu(1168) - lu(907) * lu(1164) - lu(1169) = lu(1169) - lu(908) * lu(1164) - lu(1170) = lu(1170) - lu(909) * lu(1164) - lu(1171) = lu(1171) - lu(910) * lu(1164) - lu(1172) = lu(1172) - lu(911) * lu(1164) - lu(1173) = lu(1173) - lu(912) * lu(1164) - lu(1174) = lu(1174) - lu(913) * lu(1164) - lu(1175) = lu(1175) - lu(914) * lu(1164) - lu(1178) = lu(1178) - lu(915) * lu(1164) - lu(1179) = lu(1179) - lu(916) * lu(1164) - lu(1189) = lu(1189) - lu(904) * lu(1188) - lu(1190) = lu(1190) - lu(905) * lu(1188) - lu(1191) = lu(1191) - lu(906) * lu(1188) - lu(1192) = lu(1192) - lu(907) * lu(1188) - lu(1193) = lu(1193) - lu(908) * lu(1188) - lu(1194) = lu(1194) - lu(909) * lu(1188) - lu(1195) = lu(1195) - lu(910) * lu(1188) - lu(1196) = lu(1196) - lu(911) * lu(1188) - lu(1197) = lu(1197) - lu(912) * lu(1188) - lu(1198) = lu(1198) - lu(913) * lu(1188) - lu(1199) = lu(1199) - lu(914) * lu(1188) - lu(1202) = lu(1202) - lu(915) * lu(1188) - lu(1203) = lu(1203) - lu(916) * lu(1188) - lu(1244) = lu(1244) - lu(904) * lu(1243) - lu(1245) = lu(1245) - lu(905) * lu(1243) - lu(1246) = lu(1246) - lu(906) * lu(1243) - lu(1247) = lu(1247) - lu(907) * lu(1243) - lu(1248) = lu(1248) - lu(908) * lu(1243) - lu(1249) = lu(1249) - lu(909) * lu(1243) - lu(1250) = lu(1250) - lu(910) * lu(1243) - lu(1251) = lu(1251) - lu(911) * lu(1243) - lu(1252) = lu(1252) - lu(912) * lu(1243) - lu(1253) = lu(1253) - lu(913) * lu(1243) - lu(1254) = lu(1254) - lu(914) * lu(1243) - lu(1257) = lu(1257) - lu(915) * lu(1243) - lu(1258) = lu(1258) - lu(916) * lu(1243) - lu(1281) = lu(1281) - lu(904) * lu(1280) - lu(1282) = lu(1282) - lu(905) * lu(1280) - lu(1283) = lu(1283) - lu(906) * lu(1280) - lu(1284) = lu(1284) - lu(907) * lu(1280) - lu(1285) = lu(1285) - lu(908) * lu(1280) - lu(1286) = lu(1286) - lu(909) * lu(1280) - lu(1287) = lu(1287) - lu(910) * lu(1280) - lu(1288) = lu(1288) - lu(911) * lu(1280) - lu(1289) = lu(1289) - lu(912) * lu(1280) - lu(1290) = lu(1290) - lu(913) * lu(1280) - lu(1291) = lu(1291) - lu(914) * lu(1280) - lu(1294) = lu(1294) - lu(915) * lu(1280) - lu(1295) = lu(1295) - lu(916) * lu(1280) - lu(1379) = lu(1379) - lu(904) * lu(1378) - lu(1380) = lu(1380) - lu(905) * lu(1378) - lu(1381) = lu(1381) - lu(906) * lu(1378) - lu(1382) = lu(1382) - lu(907) * lu(1378) - lu(1383) = lu(1383) - lu(908) * lu(1378) - lu(1384) = lu(1384) - lu(909) * lu(1378) - lu(1385) = lu(1385) - lu(910) * lu(1378) - lu(1386) = lu(1386) - lu(911) * lu(1378) - lu(1387) = lu(1387) - lu(912) * lu(1378) - lu(1388) = lu(1388) - lu(913) * lu(1378) - lu(1389) = lu(1389) - lu(914) * lu(1378) - lu(1392) = lu(1392) - lu(915) * lu(1378) - lu(1393) = lu(1393) - lu(916) * lu(1378) - lu(1423) = lu(1423) - lu(904) * lu(1422) - lu(1424) = lu(1424) - lu(905) * lu(1422) - lu(1425) = lu(1425) - lu(906) * lu(1422) - lu(1426) = lu(1426) - lu(907) * lu(1422) - lu(1427) = lu(1427) - lu(908) * lu(1422) - lu(1428) = lu(1428) - lu(909) * lu(1422) - lu(1429) = lu(1429) - lu(910) * lu(1422) - lu(1430) = lu(1430) - lu(911) * lu(1422) - lu(1431) = lu(1431) - lu(912) * lu(1422) - lu(1432) = lu(1432) - lu(913) * lu(1422) - lu(1433) = lu(1433) - lu(914) * lu(1422) - lu(1436) = lu(1436) - lu(915) * lu(1422) - lu(1437) = lu(1437) - lu(916) * lu(1422) - lu(1445) = lu(1445) - lu(904) * lu(1444) - lu(1446) = lu(1446) - lu(905) * lu(1444) - lu(1447) = lu(1447) - lu(906) * lu(1444) - lu(1448) = lu(1448) - lu(907) * lu(1444) - lu(1449) = lu(1449) - lu(908) * lu(1444) - lu(1450) = lu(1450) - lu(909) * lu(1444) - lu(1451) = lu(1451) - lu(910) * lu(1444) - lu(1452) = lu(1452) - lu(911) * lu(1444) - lu(1453) = lu(1453) - lu(912) * lu(1444) - lu(1454) = lu(1454) - lu(913) * lu(1444) - lu(1455) = lu(1455) - lu(914) * lu(1444) - lu(1458) = lu(1458) - lu(915) * lu(1444) - lu(1459) = lu(1459) - lu(916) * lu(1444) - lu(1471) = lu(1471) - lu(904) * lu(1470) - lu(1472) = lu(1472) - lu(905) * lu(1470) - lu(1473) = lu(1473) - lu(906) * lu(1470) - lu(1474) = lu(1474) - lu(907) * lu(1470) - lu(1475) = lu(1475) - lu(908) * lu(1470) - lu(1476) = lu(1476) - lu(909) * lu(1470) - lu(1477) = lu(1477) - lu(910) * lu(1470) - lu(1478) = lu(1478) - lu(911) * lu(1470) - lu(1479) = lu(1479) - lu(912) * lu(1470) - lu(1480) = lu(1480) - lu(913) * lu(1470) - lu(1481) = lu(1481) - lu(914) * lu(1470) - lu(1484) = lu(1484) - lu(915) * lu(1470) - lu(1485) = lu(1485) - lu(916) * lu(1470) - lu(1495) = lu(1495) - lu(904) * lu(1494) - lu(1496) = lu(1496) - lu(905) * lu(1494) - lu(1497) = lu(1497) - lu(906) * lu(1494) - lu(1498) = lu(1498) - lu(907) * lu(1494) - lu(1499) = lu(1499) - lu(908) * lu(1494) - lu(1500) = lu(1500) - lu(909) * lu(1494) - lu(1501) = lu(1501) - lu(910) * lu(1494) - lu(1502) = lu(1502) - lu(911) * lu(1494) - lu(1503) = lu(1503) - lu(912) * lu(1494) - lu(1504) = lu(1504) - lu(913) * lu(1494) - lu(1505) = lu(1505) - lu(914) * lu(1494) - lu(1508) = lu(1508) - lu(915) * lu(1494) - lu(1509) = lu(1509) - lu(916) * lu(1494) - END SUBROUTINE lu_fac18 - - SUBROUTINE lu_fac19(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(943) = 1._r8 / lu(943) - lu(944) = lu(944) * lu(943) - lu(945) = lu(945) * lu(943) - lu(946) = lu(946) * lu(943) - lu(947) = lu(947) * lu(943) - lu(948) = lu(948) * lu(943) - lu(949) = lu(949) * lu(943) - lu(950) = lu(950) * lu(943) - lu(951) = lu(951) * lu(943) - lu(952) = lu(952) * lu(943) - lu(953) = lu(953) * lu(943) - lu(954) = lu(954) * lu(943) - lu(955) = lu(955) * lu(943) - lu(956) = lu(956) * lu(943) - lu(957) = lu(957) * lu(943) - lu(970) = lu(970) - lu(944) * lu(969) - lu(971) = lu(971) - lu(945) * lu(969) - lu(972) = lu(972) - lu(946) * lu(969) - lu(973) = lu(973) - lu(947) * lu(969) - lu(974) = lu(974) - lu(948) * lu(969) - lu(975) = lu(975) - lu(949) * lu(969) - lu(976) = lu(976) - lu(950) * lu(969) - lu(977) = lu(977) - lu(951) * lu(969) - lu(978) = lu(978) - lu(952) * lu(969) - lu(979) = lu(979) - lu(953) * lu(969) - lu(980) = lu(980) - lu(954) * lu(969) - lu(981) = lu(981) - lu(955) * lu(969) - lu(982) = lu(982) - lu(956) * lu(969) - lu(983) = lu(983) - lu(957) * lu(969) - lu(1015) = lu(1015) - lu(944) * lu(1014) - lu(1016) = lu(1016) - lu(945) * lu(1014) - lu(1017) = lu(1017) - lu(946) * lu(1014) - lu(1018) = lu(1018) - lu(947) * lu(1014) - lu(1019) = lu(1019) - lu(948) * lu(1014) - lu(1020) = lu(1020) - lu(949) * lu(1014) - lu(1021) = lu(1021) - lu(950) * lu(1014) - lu(1022) = lu(1022) - lu(951) * lu(1014) - lu(1023) = lu(1023) - lu(952) * lu(1014) - lu(1024) = lu(1024) - lu(953) * lu(1014) - lu(1025) = lu(1025) - lu(954) * lu(1014) - lu(1026) = lu(1026) - lu(955) * lu(1014) - lu(1027) = lu(1027) - lu(956) * lu(1014) - lu(1028) = lu(1028) - lu(957) * lu(1014) - lu(1042) = lu(1042) - lu(944) * lu(1041) - lu(1043) = lu(1043) - lu(945) * lu(1041) - lu(1044) = lu(1044) - lu(946) * lu(1041) - lu(1045) = lu(1045) - lu(947) * lu(1041) - lu(1046) = lu(1046) - lu(948) * lu(1041) - lu(1047) = lu(1047) - lu(949) * lu(1041) - lu(1048) = lu(1048) - lu(950) * lu(1041) - lu(1049) = lu(1049) - lu(951) * lu(1041) - lu(1050) = lu(1050) - lu(952) * lu(1041) - lu(1051) = lu(1051) - lu(953) * lu(1041) - lu(1052) = lu(1052) - lu(954) * lu(1041) - lu(1053) = lu(1053) - lu(955) * lu(1041) - lu(1054) = lu(1054) - lu(956) * lu(1041) - lu(1055) = lu(1055) - lu(957) * lu(1041) - lu(1111) = lu(1111) - lu(944) * lu(1110) - lu(1112) = lu(1112) - lu(945) * lu(1110) - lu(1113) = lu(1113) - lu(946) * lu(1110) - lu(1114) = lu(1114) - lu(947) * lu(1110) - lu(1115) = lu(1115) - lu(948) * lu(1110) - lu(1116) = lu(1116) - lu(949) * lu(1110) - lu(1117) = lu(1117) - lu(950) * lu(1110) - lu(1118) = lu(1118) - lu(951) * lu(1110) - lu(1119) = lu(1119) - lu(952) * lu(1110) - lu(1120) = lu(1120) - lu(953) * lu(1110) - lu(1121) = lu(1121) - lu(954) * lu(1110) - lu(1122) = lu(1122) - lu(955) * lu(1110) - lu(1123) = lu(1123) - lu(956) * lu(1110) - lu(1124) = lu(1124) - lu(957) * lu(1110) - lu(1146) = lu(1146) - lu(944) * lu(1145) - lu(1147) = lu(1147) - lu(945) * lu(1145) - lu(1148) = lu(1148) - lu(946) * lu(1145) - lu(1149) = lu(1149) - lu(947) * lu(1145) - lu(1150) = lu(1150) - lu(948) * lu(1145) - lu(1151) = lu(1151) - lu(949) * lu(1145) - lu(1152) = lu(1152) - lu(950) * lu(1145) - lu(1153) = lu(1153) - lu(951) * lu(1145) - lu(1154) = lu(1154) - lu(952) * lu(1145) - lu(1155) = lu(1155) - lu(953) * lu(1145) - lu(1156) = lu(1156) - lu(954) * lu(1145) - lu(1157) = lu(1157) - lu(955) * lu(1145) - lu(1158) = lu(1158) - lu(956) * lu(1145) - lu(1159) = lu(1159) - lu(957) * lu(1145) - lu(1166) = lu(1166) - lu(944) * lu(1165) - lu(1167) = lu(1167) - lu(945) * lu(1165) - lu(1168) = lu(1168) - lu(946) * lu(1165) - lu(1169) = lu(1169) - lu(947) * lu(1165) - lu(1170) = lu(1170) - lu(948) * lu(1165) - lu(1171) = lu(1171) - lu(949) * lu(1165) - lu(1172) = lu(1172) - lu(950) * lu(1165) - lu(1173) = lu(1173) - lu(951) * lu(1165) - lu(1174) = lu(1174) - lu(952) * lu(1165) - lu(1175) = lu(1175) - lu(953) * lu(1165) - lu(1176) = lu(1176) - lu(954) * lu(1165) - lu(1177) = lu(1177) - lu(955) * lu(1165) - lu(1178) = lu(1178) - lu(956) * lu(1165) - lu(1179) = lu(1179) - lu(957) * lu(1165) - lu(1190) = lu(1190) - lu(944) * lu(1189) - lu(1191) = lu(1191) - lu(945) * lu(1189) - lu(1192) = lu(1192) - lu(946) * lu(1189) - lu(1193) = lu(1193) - lu(947) * lu(1189) - lu(1194) = lu(1194) - lu(948) * lu(1189) - lu(1195) = lu(1195) - lu(949) * lu(1189) - lu(1196) = lu(1196) - lu(950) * lu(1189) - lu(1197) = lu(1197) - lu(951) * lu(1189) - lu(1198) = lu(1198) - lu(952) * lu(1189) - lu(1199) = lu(1199) - lu(953) * lu(1189) - lu(1200) = lu(1200) - lu(954) * lu(1189) - lu(1201) = lu(1201) - lu(955) * lu(1189) - lu(1202) = lu(1202) - lu(956) * lu(1189) - lu(1203) = lu(1203) - lu(957) * lu(1189) - lu(1245) = lu(1245) - lu(944) * lu(1244) - lu(1246) = lu(1246) - lu(945) * lu(1244) - lu(1247) = lu(1247) - lu(946) * lu(1244) - lu(1248) = lu(1248) - lu(947) * lu(1244) - lu(1249) = lu(1249) - lu(948) * lu(1244) - lu(1250) = lu(1250) - lu(949) * lu(1244) - lu(1251) = lu(1251) - lu(950) * lu(1244) - lu(1252) = lu(1252) - lu(951) * lu(1244) - lu(1253) = lu(1253) - lu(952) * lu(1244) - lu(1254) = lu(1254) - lu(953) * lu(1244) - lu(1255) = lu(1255) - lu(954) * lu(1244) - lu(1256) = lu(1256) - lu(955) * lu(1244) - lu(1257) = lu(1257) - lu(956) * lu(1244) - lu(1258) = lu(1258) - lu(957) * lu(1244) - lu(1282) = lu(1282) - lu(944) * lu(1281) - lu(1283) = lu(1283) - lu(945) * lu(1281) - lu(1284) = lu(1284) - lu(946) * lu(1281) - lu(1285) = lu(1285) - lu(947) * lu(1281) - lu(1286) = lu(1286) - lu(948) * lu(1281) - lu(1287) = lu(1287) - lu(949) * lu(1281) - lu(1288) = lu(1288) - lu(950) * lu(1281) - lu(1289) = lu(1289) - lu(951) * lu(1281) - lu(1290) = lu(1290) - lu(952) * lu(1281) - lu(1291) = lu(1291) - lu(953) * lu(1281) - lu(1292) = lu(1292) - lu(954) * lu(1281) - lu(1293) = lu(1293) - lu(955) * lu(1281) - lu(1294) = lu(1294) - lu(956) * lu(1281) - lu(1295) = lu(1295) - lu(957) * lu(1281) - lu(1380) = lu(1380) - lu(944) * lu(1379) - lu(1381) = lu(1381) - lu(945) * lu(1379) - lu(1382) = lu(1382) - lu(946) * lu(1379) - lu(1383) = lu(1383) - lu(947) * lu(1379) - lu(1384) = lu(1384) - lu(948) * lu(1379) - lu(1385) = lu(1385) - lu(949) * lu(1379) - lu(1386) = lu(1386) - lu(950) * lu(1379) - lu(1387) = lu(1387) - lu(951) * lu(1379) - lu(1388) = lu(1388) - lu(952) * lu(1379) - lu(1389) = lu(1389) - lu(953) * lu(1379) - lu(1390) = lu(1390) - lu(954) * lu(1379) - lu(1391) = lu(1391) - lu(955) * lu(1379) - lu(1392) = lu(1392) - lu(956) * lu(1379) - lu(1393) = lu(1393) - lu(957) * lu(1379) - lu(1424) = lu(1424) - lu(944) * lu(1423) - lu(1425) = lu(1425) - lu(945) * lu(1423) - lu(1426) = lu(1426) - lu(946) * lu(1423) - lu(1427) = lu(1427) - lu(947) * lu(1423) - lu(1428) = lu(1428) - lu(948) * lu(1423) - lu(1429) = lu(1429) - lu(949) * lu(1423) - lu(1430) = lu(1430) - lu(950) * lu(1423) - lu(1431) = lu(1431) - lu(951) * lu(1423) - lu(1432) = lu(1432) - lu(952) * lu(1423) - lu(1433) = lu(1433) - lu(953) * lu(1423) - lu(1434) = lu(1434) - lu(954) * lu(1423) - lu(1435) = lu(1435) - lu(955) * lu(1423) - lu(1436) = lu(1436) - lu(956) * lu(1423) - lu(1437) = lu(1437) - lu(957) * lu(1423) - lu(1446) = lu(1446) - lu(944) * lu(1445) - lu(1447) = lu(1447) - lu(945) * lu(1445) - lu(1448) = lu(1448) - lu(946) * lu(1445) - lu(1449) = lu(1449) - lu(947) * lu(1445) - lu(1450) = lu(1450) - lu(948) * lu(1445) - lu(1451) = lu(1451) - lu(949) * lu(1445) - lu(1452) = lu(1452) - lu(950) * lu(1445) - lu(1453) = lu(1453) - lu(951) * lu(1445) - lu(1454) = lu(1454) - lu(952) * lu(1445) - lu(1455) = lu(1455) - lu(953) * lu(1445) - lu(1456) = lu(1456) - lu(954) * lu(1445) - lu(1457) = lu(1457) - lu(955) * lu(1445) - lu(1458) = lu(1458) - lu(956) * lu(1445) - lu(1459) = lu(1459) - lu(957) * lu(1445) - lu(1472) = lu(1472) - lu(944) * lu(1471) - lu(1473) = lu(1473) - lu(945) * lu(1471) - lu(1474) = lu(1474) - lu(946) * lu(1471) - lu(1475) = lu(1475) - lu(947) * lu(1471) - lu(1476) = lu(1476) - lu(948) * lu(1471) - lu(1477) = lu(1477) - lu(949) * lu(1471) - lu(1478) = lu(1478) - lu(950) * lu(1471) - lu(1479) = lu(1479) - lu(951) * lu(1471) - lu(1480) = lu(1480) - lu(952) * lu(1471) - lu(1481) = lu(1481) - lu(953) * lu(1471) - lu(1482) = lu(1482) - lu(954) * lu(1471) - lu(1483) = lu(1483) - lu(955) * lu(1471) - lu(1484) = lu(1484) - lu(956) * lu(1471) - lu(1485) = lu(1485) - lu(957) * lu(1471) - lu(1496) = lu(1496) - lu(944) * lu(1495) - lu(1497) = lu(1497) - lu(945) * lu(1495) - lu(1498) = lu(1498) - lu(946) * lu(1495) - lu(1499) = lu(1499) - lu(947) * lu(1495) - lu(1500) = lu(1500) - lu(948) * lu(1495) - lu(1501) = lu(1501) - lu(949) * lu(1495) - lu(1502) = lu(1502) - lu(950) * lu(1495) - lu(1503) = lu(1503) - lu(951) * lu(1495) - lu(1504) = lu(1504) - lu(952) * lu(1495) - lu(1505) = lu(1505) - lu(953) * lu(1495) - lu(1506) = lu(1506) - lu(954) * lu(1495) - lu(1507) = lu(1507) - lu(955) * lu(1495) - lu(1508) = lu(1508) - lu(956) * lu(1495) - lu(1509) = lu(1509) - lu(957) * lu(1495) - lu(970) = 1._r8 / lu(970) - lu(971) = lu(971) * lu(970) - lu(972) = lu(972) * lu(970) - lu(973) = lu(973) * lu(970) - lu(974) = lu(974) * lu(970) - lu(975) = lu(975) * lu(970) - lu(976) = lu(976) * lu(970) - lu(977) = lu(977) * lu(970) - lu(978) = lu(978) * lu(970) - lu(979) = lu(979) * lu(970) - lu(980) = lu(980) * lu(970) - lu(981) = lu(981) * lu(970) - lu(982) = lu(982) * lu(970) - lu(983) = lu(983) * lu(970) - lu(1016) = lu(1016) - lu(971) * lu(1015) - lu(1017) = lu(1017) - lu(972) * lu(1015) - lu(1018) = lu(1018) - lu(973) * lu(1015) - lu(1019) = lu(1019) - lu(974) * lu(1015) - lu(1020) = lu(1020) - lu(975) * lu(1015) - lu(1021) = lu(1021) - lu(976) * lu(1015) - lu(1022) = lu(1022) - lu(977) * lu(1015) - lu(1023) = lu(1023) - lu(978) * lu(1015) - lu(1024) = lu(1024) - lu(979) * lu(1015) - lu(1025) = lu(1025) - lu(980) * lu(1015) - lu(1026) = lu(1026) - lu(981) * lu(1015) - lu(1027) = lu(1027) - lu(982) * lu(1015) - lu(1028) = lu(1028) - lu(983) * lu(1015) - lu(1043) = lu(1043) - lu(971) * lu(1042) - lu(1044) = lu(1044) - lu(972) * lu(1042) - lu(1045) = lu(1045) - lu(973) * lu(1042) - lu(1046) = lu(1046) - lu(974) * lu(1042) - lu(1047) = lu(1047) - lu(975) * lu(1042) - lu(1048) = lu(1048) - lu(976) * lu(1042) - lu(1049) = lu(1049) - lu(977) * lu(1042) - lu(1050) = lu(1050) - lu(978) * lu(1042) - lu(1051) = lu(1051) - lu(979) * lu(1042) - lu(1052) = lu(1052) - lu(980) * lu(1042) - lu(1053) = lu(1053) - lu(981) * lu(1042) - lu(1054) = lu(1054) - lu(982) * lu(1042) - lu(1055) = lu(1055) - lu(983) * lu(1042) - lu(1112) = lu(1112) - lu(971) * lu(1111) - lu(1113) = lu(1113) - lu(972) * lu(1111) - lu(1114) = lu(1114) - lu(973) * lu(1111) - lu(1115) = lu(1115) - lu(974) * lu(1111) - lu(1116) = lu(1116) - lu(975) * lu(1111) - lu(1117) = lu(1117) - lu(976) * lu(1111) - lu(1118) = lu(1118) - lu(977) * lu(1111) - lu(1119) = lu(1119) - lu(978) * lu(1111) - lu(1120) = lu(1120) - lu(979) * lu(1111) - lu(1121) = lu(1121) - lu(980) * lu(1111) - lu(1122) = lu(1122) - lu(981) * lu(1111) - lu(1123) = lu(1123) - lu(982) * lu(1111) - lu(1124) = lu(1124) - lu(983) * lu(1111) - lu(1147) = lu(1147) - lu(971) * lu(1146) - lu(1148) = lu(1148) - lu(972) * lu(1146) - lu(1149) = lu(1149) - lu(973) * lu(1146) - lu(1150) = lu(1150) - lu(974) * lu(1146) - lu(1151) = lu(1151) - lu(975) * lu(1146) - lu(1152) = lu(1152) - lu(976) * lu(1146) - lu(1153) = lu(1153) - lu(977) * lu(1146) - lu(1154) = lu(1154) - lu(978) * lu(1146) - lu(1155) = lu(1155) - lu(979) * lu(1146) - lu(1156) = lu(1156) - lu(980) * lu(1146) - lu(1157) = lu(1157) - lu(981) * lu(1146) - lu(1158) = lu(1158) - lu(982) * lu(1146) - lu(1159) = lu(1159) - lu(983) * lu(1146) - lu(1167) = lu(1167) - lu(971) * lu(1166) - lu(1168) = lu(1168) - lu(972) * lu(1166) - lu(1169) = lu(1169) - lu(973) * lu(1166) - lu(1170) = lu(1170) - lu(974) * lu(1166) - lu(1171) = lu(1171) - lu(975) * lu(1166) - lu(1172) = lu(1172) - lu(976) * lu(1166) - lu(1173) = lu(1173) - lu(977) * lu(1166) - lu(1174) = lu(1174) - lu(978) * lu(1166) - lu(1175) = lu(1175) - lu(979) * lu(1166) - lu(1176) = lu(1176) - lu(980) * lu(1166) - lu(1177) = lu(1177) - lu(981) * lu(1166) - lu(1178) = lu(1178) - lu(982) * lu(1166) - lu(1179) = lu(1179) - lu(983) * lu(1166) - lu(1191) = lu(1191) - lu(971) * lu(1190) - lu(1192) = lu(1192) - lu(972) * lu(1190) - lu(1193) = lu(1193) - lu(973) * lu(1190) - lu(1194) = lu(1194) - lu(974) * lu(1190) - lu(1195) = lu(1195) - lu(975) * lu(1190) - lu(1196) = lu(1196) - lu(976) * lu(1190) - lu(1197) = lu(1197) - lu(977) * lu(1190) - lu(1198) = lu(1198) - lu(978) * lu(1190) - lu(1199) = lu(1199) - lu(979) * lu(1190) - lu(1200) = lu(1200) - lu(980) * lu(1190) - lu(1201) = lu(1201) - lu(981) * lu(1190) - lu(1202) = lu(1202) - lu(982) * lu(1190) - lu(1203) = lu(1203) - lu(983) * lu(1190) - lu(1246) = lu(1246) - lu(971) * lu(1245) - lu(1247) = lu(1247) - lu(972) * lu(1245) - lu(1248) = lu(1248) - lu(973) * lu(1245) - lu(1249) = lu(1249) - lu(974) * lu(1245) - lu(1250) = lu(1250) - lu(975) * lu(1245) - lu(1251) = lu(1251) - lu(976) * lu(1245) - lu(1252) = lu(1252) - lu(977) * lu(1245) - lu(1253) = lu(1253) - lu(978) * lu(1245) - lu(1254) = lu(1254) - lu(979) * lu(1245) - lu(1255) = lu(1255) - lu(980) * lu(1245) - lu(1256) = lu(1256) - lu(981) * lu(1245) - lu(1257) = lu(1257) - lu(982) * lu(1245) - lu(1258) = lu(1258) - lu(983) * lu(1245) - lu(1283) = lu(1283) - lu(971) * lu(1282) - lu(1284) = lu(1284) - lu(972) * lu(1282) - lu(1285) = lu(1285) - lu(973) * lu(1282) - lu(1286) = lu(1286) - lu(974) * lu(1282) - lu(1287) = lu(1287) - lu(975) * lu(1282) - lu(1288) = lu(1288) - lu(976) * lu(1282) - lu(1289) = lu(1289) - lu(977) * lu(1282) - lu(1290) = lu(1290) - lu(978) * lu(1282) - lu(1291) = lu(1291) - lu(979) * lu(1282) - lu(1292) = lu(1292) - lu(980) * lu(1282) - lu(1293) = lu(1293) - lu(981) * lu(1282) - lu(1294) = lu(1294) - lu(982) * lu(1282) - lu(1295) = lu(1295) - lu(983) * lu(1282) - lu(1381) = lu(1381) - lu(971) * lu(1380) - lu(1382) = lu(1382) - lu(972) * lu(1380) - lu(1383) = lu(1383) - lu(973) * lu(1380) - lu(1384) = lu(1384) - lu(974) * lu(1380) - lu(1385) = lu(1385) - lu(975) * lu(1380) - lu(1386) = lu(1386) - lu(976) * lu(1380) - lu(1387) = lu(1387) - lu(977) * lu(1380) - lu(1388) = lu(1388) - lu(978) * lu(1380) - lu(1389) = lu(1389) - lu(979) * lu(1380) - lu(1390) = lu(1390) - lu(980) * lu(1380) - lu(1391) = lu(1391) - lu(981) * lu(1380) - lu(1392) = lu(1392) - lu(982) * lu(1380) - lu(1393) = lu(1393) - lu(983) * lu(1380) - lu(1425) = lu(1425) - lu(971) * lu(1424) - lu(1426) = lu(1426) - lu(972) * lu(1424) - lu(1427) = lu(1427) - lu(973) * lu(1424) - lu(1428) = lu(1428) - lu(974) * lu(1424) - lu(1429) = lu(1429) - lu(975) * lu(1424) - lu(1430) = lu(1430) - lu(976) * lu(1424) - lu(1431) = lu(1431) - lu(977) * lu(1424) - lu(1432) = lu(1432) - lu(978) * lu(1424) - lu(1433) = lu(1433) - lu(979) * lu(1424) - lu(1434) = lu(1434) - lu(980) * lu(1424) - lu(1435) = lu(1435) - lu(981) * lu(1424) - lu(1436) = lu(1436) - lu(982) * lu(1424) - lu(1437) = lu(1437) - lu(983) * lu(1424) - lu(1447) = lu(1447) - lu(971) * lu(1446) - lu(1448) = lu(1448) - lu(972) * lu(1446) - lu(1449) = lu(1449) - lu(973) * lu(1446) - lu(1450) = lu(1450) - lu(974) * lu(1446) - lu(1451) = lu(1451) - lu(975) * lu(1446) - lu(1452) = lu(1452) - lu(976) * lu(1446) - lu(1453) = lu(1453) - lu(977) * lu(1446) - lu(1454) = lu(1454) - lu(978) * lu(1446) - lu(1455) = lu(1455) - lu(979) * lu(1446) - lu(1456) = lu(1456) - lu(980) * lu(1446) - lu(1457) = lu(1457) - lu(981) * lu(1446) - lu(1458) = lu(1458) - lu(982) * lu(1446) - lu(1459) = lu(1459) - lu(983) * lu(1446) - lu(1473) = lu(1473) - lu(971) * lu(1472) - lu(1474) = lu(1474) - lu(972) * lu(1472) - lu(1475) = lu(1475) - lu(973) * lu(1472) - lu(1476) = lu(1476) - lu(974) * lu(1472) - lu(1477) = lu(1477) - lu(975) * lu(1472) - lu(1478) = lu(1478) - lu(976) * lu(1472) - lu(1479) = lu(1479) - lu(977) * lu(1472) - lu(1480) = lu(1480) - lu(978) * lu(1472) - lu(1481) = lu(1481) - lu(979) * lu(1472) - lu(1482) = lu(1482) - lu(980) * lu(1472) - lu(1483) = lu(1483) - lu(981) * lu(1472) - lu(1484) = lu(1484) - lu(982) * lu(1472) - lu(1485) = lu(1485) - lu(983) * lu(1472) - lu(1497) = lu(1497) - lu(971) * lu(1496) - lu(1498) = lu(1498) - lu(972) * lu(1496) - lu(1499) = lu(1499) - lu(973) * lu(1496) - lu(1500) = lu(1500) - lu(974) * lu(1496) - lu(1501) = lu(1501) - lu(975) * lu(1496) - lu(1502) = lu(1502) - lu(976) * lu(1496) - lu(1503) = lu(1503) - lu(977) * lu(1496) - lu(1504) = lu(1504) - lu(978) * lu(1496) - lu(1505) = lu(1505) - lu(979) * lu(1496) - lu(1506) = lu(1506) - lu(980) * lu(1496) - lu(1507) = lu(1507) - lu(981) * lu(1496) - lu(1508) = lu(1508) - lu(982) * lu(1496) - lu(1509) = lu(1509) - lu(983) * lu(1496) - lu(1016) = 1._r8 / lu(1016) - lu(1017) = lu(1017) * lu(1016) - lu(1018) = lu(1018) * lu(1016) - lu(1019) = lu(1019) * lu(1016) - lu(1020) = lu(1020) * lu(1016) - lu(1021) = lu(1021) * lu(1016) - lu(1022) = lu(1022) * lu(1016) - lu(1023) = lu(1023) * lu(1016) - lu(1024) = lu(1024) * lu(1016) - lu(1025) = lu(1025) * lu(1016) - lu(1026) = lu(1026) * lu(1016) - lu(1027) = lu(1027) * lu(1016) - lu(1028) = lu(1028) * lu(1016) - lu(1044) = lu(1044) - lu(1017) * lu(1043) - lu(1045) = lu(1045) - lu(1018) * lu(1043) - lu(1046) = lu(1046) - lu(1019) * lu(1043) - lu(1047) = lu(1047) - lu(1020) * lu(1043) - lu(1048) = lu(1048) - lu(1021) * lu(1043) - lu(1049) = lu(1049) - lu(1022) * lu(1043) - lu(1050) = lu(1050) - lu(1023) * lu(1043) - lu(1051) = lu(1051) - lu(1024) * lu(1043) - lu(1052) = lu(1052) - lu(1025) * lu(1043) - lu(1053) = lu(1053) - lu(1026) * lu(1043) - lu(1054) = lu(1054) - lu(1027) * lu(1043) - lu(1055) = lu(1055) - lu(1028) * lu(1043) - lu(1113) = lu(1113) - lu(1017) * lu(1112) - lu(1114) = lu(1114) - lu(1018) * lu(1112) - lu(1115) = lu(1115) - lu(1019) * lu(1112) - lu(1116) = lu(1116) - lu(1020) * lu(1112) - lu(1117) = lu(1117) - lu(1021) * lu(1112) - lu(1118) = lu(1118) - lu(1022) * lu(1112) - lu(1119) = lu(1119) - lu(1023) * lu(1112) - lu(1120) = lu(1120) - lu(1024) * lu(1112) - lu(1121) = lu(1121) - lu(1025) * lu(1112) - lu(1122) = lu(1122) - lu(1026) * lu(1112) - lu(1123) = lu(1123) - lu(1027) * lu(1112) - lu(1124) = lu(1124) - lu(1028) * lu(1112) - lu(1148) = lu(1148) - lu(1017) * lu(1147) - lu(1149) = lu(1149) - lu(1018) * lu(1147) - lu(1150) = lu(1150) - lu(1019) * lu(1147) - lu(1151) = lu(1151) - lu(1020) * lu(1147) - lu(1152) = lu(1152) - lu(1021) * lu(1147) - lu(1153) = lu(1153) - lu(1022) * lu(1147) - lu(1154) = lu(1154) - lu(1023) * lu(1147) - lu(1155) = lu(1155) - lu(1024) * lu(1147) - lu(1156) = lu(1156) - lu(1025) * lu(1147) - lu(1157) = lu(1157) - lu(1026) * lu(1147) - lu(1158) = lu(1158) - lu(1027) * lu(1147) - lu(1159) = lu(1159) - lu(1028) * lu(1147) - lu(1168) = lu(1168) - lu(1017) * lu(1167) - lu(1169) = lu(1169) - lu(1018) * lu(1167) - lu(1170) = lu(1170) - lu(1019) * lu(1167) - lu(1171) = lu(1171) - lu(1020) * lu(1167) - lu(1172) = lu(1172) - lu(1021) * lu(1167) - lu(1173) = lu(1173) - lu(1022) * lu(1167) - lu(1174) = lu(1174) - lu(1023) * lu(1167) - lu(1175) = lu(1175) - lu(1024) * lu(1167) - lu(1176) = lu(1176) - lu(1025) * lu(1167) - lu(1177) = lu(1177) - lu(1026) * lu(1167) - lu(1178) = lu(1178) - lu(1027) * lu(1167) - lu(1179) = lu(1179) - lu(1028) * lu(1167) - lu(1192) = lu(1192) - lu(1017) * lu(1191) - lu(1193) = lu(1193) - lu(1018) * lu(1191) - lu(1194) = lu(1194) - lu(1019) * lu(1191) - lu(1195) = lu(1195) - lu(1020) * lu(1191) - lu(1196) = lu(1196) - lu(1021) * lu(1191) - lu(1197) = lu(1197) - lu(1022) * lu(1191) - lu(1198) = lu(1198) - lu(1023) * lu(1191) - lu(1199) = lu(1199) - lu(1024) * lu(1191) - lu(1200) = lu(1200) - lu(1025) * lu(1191) - lu(1201) = lu(1201) - lu(1026) * lu(1191) - lu(1202) = lu(1202) - lu(1027) * lu(1191) - lu(1203) = lu(1203) - lu(1028) * lu(1191) - lu(1247) = lu(1247) - lu(1017) * lu(1246) - lu(1248) = lu(1248) - lu(1018) * lu(1246) - lu(1249) = lu(1249) - lu(1019) * lu(1246) - lu(1250) = lu(1250) - lu(1020) * lu(1246) - lu(1251) = lu(1251) - lu(1021) * lu(1246) - lu(1252) = lu(1252) - lu(1022) * lu(1246) - lu(1253) = lu(1253) - lu(1023) * lu(1246) - lu(1254) = lu(1254) - lu(1024) * lu(1246) - lu(1255) = lu(1255) - lu(1025) * lu(1246) - lu(1256) = lu(1256) - lu(1026) * lu(1246) - lu(1257) = lu(1257) - lu(1027) * lu(1246) - lu(1258) = lu(1258) - lu(1028) * lu(1246) - lu(1284) = lu(1284) - lu(1017) * lu(1283) - lu(1285) = lu(1285) - lu(1018) * lu(1283) - lu(1286) = lu(1286) - lu(1019) * lu(1283) - lu(1287) = lu(1287) - lu(1020) * lu(1283) - lu(1288) = lu(1288) - lu(1021) * lu(1283) - lu(1289) = lu(1289) - lu(1022) * lu(1283) - lu(1290) = lu(1290) - lu(1023) * lu(1283) - lu(1291) = lu(1291) - lu(1024) * lu(1283) - lu(1292) = lu(1292) - lu(1025) * lu(1283) - lu(1293) = lu(1293) - lu(1026) * lu(1283) - lu(1294) = lu(1294) - lu(1027) * lu(1283) - lu(1295) = lu(1295) - lu(1028) * lu(1283) - lu(1382) = lu(1382) - lu(1017) * lu(1381) - lu(1383) = lu(1383) - lu(1018) * lu(1381) - lu(1384) = lu(1384) - lu(1019) * lu(1381) - lu(1385) = lu(1385) - lu(1020) * lu(1381) - lu(1386) = lu(1386) - lu(1021) * lu(1381) - lu(1387) = lu(1387) - lu(1022) * lu(1381) - lu(1388) = lu(1388) - lu(1023) * lu(1381) - lu(1389) = lu(1389) - lu(1024) * lu(1381) - lu(1390) = lu(1390) - lu(1025) * lu(1381) - lu(1391) = lu(1391) - lu(1026) * lu(1381) - lu(1392) = lu(1392) - lu(1027) * lu(1381) - lu(1393) = lu(1393) - lu(1028) * lu(1381) - lu(1426) = lu(1426) - lu(1017) * lu(1425) - lu(1427) = lu(1427) - lu(1018) * lu(1425) - lu(1428) = lu(1428) - lu(1019) * lu(1425) - lu(1429) = lu(1429) - lu(1020) * lu(1425) - lu(1430) = lu(1430) - lu(1021) * lu(1425) - lu(1431) = lu(1431) - lu(1022) * lu(1425) - lu(1432) = lu(1432) - lu(1023) * lu(1425) - lu(1433) = lu(1433) - lu(1024) * lu(1425) - lu(1434) = lu(1434) - lu(1025) * lu(1425) - lu(1435) = lu(1435) - lu(1026) * lu(1425) - lu(1436) = lu(1436) - lu(1027) * lu(1425) - lu(1437) = lu(1437) - lu(1028) * lu(1425) - lu(1448) = lu(1448) - lu(1017) * lu(1447) - lu(1449) = lu(1449) - lu(1018) * lu(1447) - lu(1450) = lu(1450) - lu(1019) * lu(1447) - lu(1451) = lu(1451) - lu(1020) * lu(1447) - lu(1452) = lu(1452) - lu(1021) * lu(1447) - lu(1453) = lu(1453) - lu(1022) * lu(1447) - lu(1454) = lu(1454) - lu(1023) * lu(1447) - lu(1455) = lu(1455) - lu(1024) * lu(1447) - lu(1456) = lu(1456) - lu(1025) * lu(1447) - lu(1457) = lu(1457) - lu(1026) * lu(1447) - lu(1458) = lu(1458) - lu(1027) * lu(1447) - lu(1459) = lu(1459) - lu(1028) * lu(1447) - lu(1474) = lu(1474) - lu(1017) * lu(1473) - lu(1475) = lu(1475) - lu(1018) * lu(1473) - lu(1476) = lu(1476) - lu(1019) * lu(1473) - lu(1477) = lu(1477) - lu(1020) * lu(1473) - lu(1478) = lu(1478) - lu(1021) * lu(1473) - lu(1479) = lu(1479) - lu(1022) * lu(1473) - lu(1480) = lu(1480) - lu(1023) * lu(1473) - lu(1481) = lu(1481) - lu(1024) * lu(1473) - lu(1482) = lu(1482) - lu(1025) * lu(1473) - lu(1483) = lu(1483) - lu(1026) * lu(1473) - lu(1484) = lu(1484) - lu(1027) * lu(1473) - lu(1485) = lu(1485) - lu(1028) * lu(1473) - lu(1498) = lu(1498) - lu(1017) * lu(1497) - lu(1499) = lu(1499) - lu(1018) * lu(1497) - lu(1500) = lu(1500) - lu(1019) * lu(1497) - lu(1501) = lu(1501) - lu(1020) * lu(1497) - lu(1502) = lu(1502) - lu(1021) * lu(1497) - lu(1503) = lu(1503) - lu(1022) * lu(1497) - lu(1504) = lu(1504) - lu(1023) * lu(1497) - lu(1505) = lu(1505) - lu(1024) * lu(1497) - lu(1506) = lu(1506) - lu(1025) * lu(1497) - lu(1507) = lu(1507) - lu(1026) * lu(1497) - lu(1508) = lu(1508) - lu(1027) * lu(1497) - lu(1509) = lu(1509) - lu(1028) * lu(1497) - lu(1044) = 1._r8 / lu(1044) - lu(1045) = lu(1045) * lu(1044) - lu(1046) = lu(1046) * lu(1044) - lu(1047) = lu(1047) * lu(1044) - lu(1048) = lu(1048) * lu(1044) - lu(1049) = lu(1049) * lu(1044) - lu(1050) = lu(1050) * lu(1044) - lu(1051) = lu(1051) * lu(1044) - lu(1052) = lu(1052) * lu(1044) - lu(1053) = lu(1053) * lu(1044) - lu(1054) = lu(1054) * lu(1044) - lu(1055) = lu(1055) * lu(1044) - lu(1114) = lu(1114) - lu(1045) * lu(1113) - lu(1115) = lu(1115) - lu(1046) * lu(1113) - lu(1116) = lu(1116) - lu(1047) * lu(1113) - lu(1117) = lu(1117) - lu(1048) * lu(1113) - lu(1118) = lu(1118) - lu(1049) * lu(1113) - lu(1119) = lu(1119) - lu(1050) * lu(1113) - lu(1120) = lu(1120) - lu(1051) * lu(1113) - lu(1121) = lu(1121) - lu(1052) * lu(1113) - lu(1122) = lu(1122) - lu(1053) * lu(1113) - lu(1123) = lu(1123) - lu(1054) * lu(1113) - lu(1124) = lu(1124) - lu(1055) * lu(1113) - lu(1149) = lu(1149) - lu(1045) * lu(1148) - lu(1150) = lu(1150) - lu(1046) * lu(1148) - lu(1151) = lu(1151) - lu(1047) * lu(1148) - lu(1152) = lu(1152) - lu(1048) * lu(1148) - lu(1153) = lu(1153) - lu(1049) * lu(1148) - lu(1154) = lu(1154) - lu(1050) * lu(1148) - lu(1155) = lu(1155) - lu(1051) * lu(1148) - lu(1156) = lu(1156) - lu(1052) * lu(1148) - lu(1157) = lu(1157) - lu(1053) * lu(1148) - lu(1158) = lu(1158) - lu(1054) * lu(1148) - lu(1159) = lu(1159) - lu(1055) * lu(1148) - lu(1169) = lu(1169) - lu(1045) * lu(1168) - lu(1170) = lu(1170) - lu(1046) * lu(1168) - lu(1171) = lu(1171) - lu(1047) * lu(1168) - lu(1172) = lu(1172) - lu(1048) * lu(1168) - lu(1173) = lu(1173) - lu(1049) * lu(1168) - lu(1174) = lu(1174) - lu(1050) * lu(1168) - lu(1175) = lu(1175) - lu(1051) * lu(1168) - lu(1176) = lu(1176) - lu(1052) * lu(1168) - lu(1177) = lu(1177) - lu(1053) * lu(1168) - lu(1178) = lu(1178) - lu(1054) * lu(1168) - lu(1179) = lu(1179) - lu(1055) * lu(1168) - lu(1193) = lu(1193) - lu(1045) * lu(1192) - lu(1194) = lu(1194) - lu(1046) * lu(1192) - lu(1195) = lu(1195) - lu(1047) * lu(1192) - lu(1196) = lu(1196) - lu(1048) * lu(1192) - lu(1197) = lu(1197) - lu(1049) * lu(1192) - lu(1198) = lu(1198) - lu(1050) * lu(1192) - lu(1199) = lu(1199) - lu(1051) * lu(1192) - lu(1200) = lu(1200) - lu(1052) * lu(1192) - lu(1201) = lu(1201) - lu(1053) * lu(1192) - lu(1202) = lu(1202) - lu(1054) * lu(1192) - lu(1203) = lu(1203) - lu(1055) * lu(1192) - lu(1248) = lu(1248) - lu(1045) * lu(1247) - lu(1249) = lu(1249) - lu(1046) * lu(1247) - lu(1250) = lu(1250) - lu(1047) * lu(1247) - lu(1251) = lu(1251) - lu(1048) * lu(1247) - lu(1252) = lu(1252) - lu(1049) * lu(1247) - lu(1253) = lu(1253) - lu(1050) * lu(1247) - lu(1254) = lu(1254) - lu(1051) * lu(1247) - lu(1255) = lu(1255) - lu(1052) * lu(1247) - lu(1256) = lu(1256) - lu(1053) * lu(1247) - lu(1257) = lu(1257) - lu(1054) * lu(1247) - lu(1258) = lu(1258) - lu(1055) * lu(1247) - lu(1285) = lu(1285) - lu(1045) * lu(1284) - lu(1286) = lu(1286) - lu(1046) * lu(1284) - lu(1287) = lu(1287) - lu(1047) * lu(1284) - lu(1288) = lu(1288) - lu(1048) * lu(1284) - lu(1289) = lu(1289) - lu(1049) * lu(1284) - lu(1290) = lu(1290) - lu(1050) * lu(1284) - lu(1291) = lu(1291) - lu(1051) * lu(1284) - lu(1292) = lu(1292) - lu(1052) * lu(1284) - lu(1293) = lu(1293) - lu(1053) * lu(1284) - lu(1294) = lu(1294) - lu(1054) * lu(1284) - lu(1295) = lu(1295) - lu(1055) * lu(1284) - lu(1383) = lu(1383) - lu(1045) * lu(1382) - lu(1384) = lu(1384) - lu(1046) * lu(1382) - lu(1385) = lu(1385) - lu(1047) * lu(1382) - lu(1386) = lu(1386) - lu(1048) * lu(1382) - lu(1387) = lu(1387) - lu(1049) * lu(1382) - lu(1388) = lu(1388) - lu(1050) * lu(1382) - lu(1389) = lu(1389) - lu(1051) * lu(1382) - lu(1390) = lu(1390) - lu(1052) * lu(1382) - lu(1391) = lu(1391) - lu(1053) * lu(1382) - lu(1392) = lu(1392) - lu(1054) * lu(1382) - lu(1393) = lu(1393) - lu(1055) * lu(1382) - lu(1427) = lu(1427) - lu(1045) * lu(1426) - lu(1428) = lu(1428) - lu(1046) * lu(1426) - lu(1429) = lu(1429) - lu(1047) * lu(1426) - lu(1430) = lu(1430) - lu(1048) * lu(1426) - lu(1431) = lu(1431) - lu(1049) * lu(1426) - lu(1432) = lu(1432) - lu(1050) * lu(1426) - lu(1433) = lu(1433) - lu(1051) * lu(1426) - lu(1434) = lu(1434) - lu(1052) * lu(1426) - lu(1435) = lu(1435) - lu(1053) * lu(1426) - lu(1436) = lu(1436) - lu(1054) * lu(1426) - lu(1437) = lu(1437) - lu(1055) * lu(1426) - lu(1449) = lu(1449) - lu(1045) * lu(1448) - lu(1450) = lu(1450) - lu(1046) * lu(1448) - lu(1451) = lu(1451) - lu(1047) * lu(1448) - lu(1452) = lu(1452) - lu(1048) * lu(1448) - lu(1453) = lu(1453) - lu(1049) * lu(1448) - lu(1454) = lu(1454) - lu(1050) * lu(1448) - lu(1455) = lu(1455) - lu(1051) * lu(1448) - lu(1456) = lu(1456) - lu(1052) * lu(1448) - lu(1457) = lu(1457) - lu(1053) * lu(1448) - lu(1458) = lu(1458) - lu(1054) * lu(1448) - lu(1459) = lu(1459) - lu(1055) * lu(1448) - lu(1475) = lu(1475) - lu(1045) * lu(1474) - lu(1476) = lu(1476) - lu(1046) * lu(1474) - lu(1477) = lu(1477) - lu(1047) * lu(1474) - lu(1478) = lu(1478) - lu(1048) * lu(1474) - lu(1479) = lu(1479) - lu(1049) * lu(1474) - lu(1480) = lu(1480) - lu(1050) * lu(1474) - lu(1481) = lu(1481) - lu(1051) * lu(1474) - lu(1482) = lu(1482) - lu(1052) * lu(1474) - lu(1483) = lu(1483) - lu(1053) * lu(1474) - lu(1484) = lu(1484) - lu(1054) * lu(1474) - lu(1485) = lu(1485) - lu(1055) * lu(1474) - lu(1499) = lu(1499) - lu(1045) * lu(1498) - lu(1500) = lu(1500) - lu(1046) * lu(1498) - lu(1501) = lu(1501) - lu(1047) * lu(1498) - lu(1502) = lu(1502) - lu(1048) * lu(1498) - lu(1503) = lu(1503) - lu(1049) * lu(1498) - lu(1504) = lu(1504) - lu(1050) * lu(1498) - lu(1505) = lu(1505) - lu(1051) * lu(1498) - lu(1506) = lu(1506) - lu(1052) * lu(1498) - lu(1507) = lu(1507) - lu(1053) * lu(1498) - lu(1508) = lu(1508) - lu(1054) * lu(1498) - lu(1509) = lu(1509) - lu(1055) * lu(1498) - END SUBROUTINE lu_fac19 - - SUBROUTINE lu_fac20(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(1114) = 1._r8 / lu(1114) - lu(1115) = lu(1115) * lu(1114) - lu(1116) = lu(1116) * lu(1114) - lu(1117) = lu(1117) * lu(1114) - lu(1118) = lu(1118) * lu(1114) - lu(1119) = lu(1119) * lu(1114) - lu(1120) = lu(1120) * lu(1114) - lu(1121) = lu(1121) * lu(1114) - lu(1122) = lu(1122) * lu(1114) - lu(1123) = lu(1123) * lu(1114) - lu(1124) = lu(1124) * lu(1114) - lu(1150) = lu(1150) - lu(1115) * lu(1149) - lu(1151) = lu(1151) - lu(1116) * lu(1149) - lu(1152) = lu(1152) - lu(1117) * lu(1149) - lu(1153) = lu(1153) - lu(1118) * lu(1149) - lu(1154) = lu(1154) - lu(1119) * lu(1149) - lu(1155) = lu(1155) - lu(1120) * lu(1149) - lu(1156) = lu(1156) - lu(1121) * lu(1149) - lu(1157) = lu(1157) - lu(1122) * lu(1149) - lu(1158) = lu(1158) - lu(1123) * lu(1149) - lu(1159) = lu(1159) - lu(1124) * lu(1149) - lu(1170) = lu(1170) - lu(1115) * lu(1169) - lu(1171) = lu(1171) - lu(1116) * lu(1169) - lu(1172) = lu(1172) - lu(1117) * lu(1169) - lu(1173) = lu(1173) - lu(1118) * lu(1169) - lu(1174) = lu(1174) - lu(1119) * lu(1169) - lu(1175) = lu(1175) - lu(1120) * lu(1169) - lu(1176) = lu(1176) - lu(1121) * lu(1169) - lu(1177) = lu(1177) - lu(1122) * lu(1169) - lu(1178) = lu(1178) - lu(1123) * lu(1169) - lu(1179) = lu(1179) - lu(1124) * lu(1169) - lu(1194) = lu(1194) - lu(1115) * lu(1193) - lu(1195) = lu(1195) - lu(1116) * lu(1193) - lu(1196) = lu(1196) - lu(1117) * lu(1193) - lu(1197) = lu(1197) - lu(1118) * lu(1193) - lu(1198) = lu(1198) - lu(1119) * lu(1193) - lu(1199) = lu(1199) - lu(1120) * lu(1193) - lu(1200) = lu(1200) - lu(1121) * lu(1193) - lu(1201) = lu(1201) - lu(1122) * lu(1193) - lu(1202) = lu(1202) - lu(1123) * lu(1193) - lu(1203) = lu(1203) - lu(1124) * lu(1193) - lu(1249) = lu(1249) - lu(1115) * lu(1248) - lu(1250) = lu(1250) - lu(1116) * lu(1248) - lu(1251) = lu(1251) - lu(1117) * lu(1248) - lu(1252) = lu(1252) - lu(1118) * lu(1248) - lu(1253) = lu(1253) - lu(1119) * lu(1248) - lu(1254) = lu(1254) - lu(1120) * lu(1248) - lu(1255) = lu(1255) - lu(1121) * lu(1248) - lu(1256) = lu(1256) - lu(1122) * lu(1248) - lu(1257) = lu(1257) - lu(1123) * lu(1248) - lu(1258) = lu(1258) - lu(1124) * lu(1248) - lu(1286) = lu(1286) - lu(1115) * lu(1285) - lu(1287) = lu(1287) - lu(1116) * lu(1285) - lu(1288) = lu(1288) - lu(1117) * lu(1285) - lu(1289) = lu(1289) - lu(1118) * lu(1285) - lu(1290) = lu(1290) - lu(1119) * lu(1285) - lu(1291) = lu(1291) - lu(1120) * lu(1285) - lu(1292) = lu(1292) - lu(1121) * lu(1285) - lu(1293) = lu(1293) - lu(1122) * lu(1285) - lu(1294) = lu(1294) - lu(1123) * lu(1285) - lu(1295) = lu(1295) - lu(1124) * lu(1285) - lu(1384) = lu(1384) - lu(1115) * lu(1383) - lu(1385) = lu(1385) - lu(1116) * lu(1383) - lu(1386) = lu(1386) - lu(1117) * lu(1383) - lu(1387) = lu(1387) - lu(1118) * lu(1383) - lu(1388) = lu(1388) - lu(1119) * lu(1383) - lu(1389) = lu(1389) - lu(1120) * lu(1383) - lu(1390) = lu(1390) - lu(1121) * lu(1383) - lu(1391) = lu(1391) - lu(1122) * lu(1383) - lu(1392) = lu(1392) - lu(1123) * lu(1383) - lu(1393) = lu(1393) - lu(1124) * lu(1383) - lu(1428) = lu(1428) - lu(1115) * lu(1427) - lu(1429) = lu(1429) - lu(1116) * lu(1427) - lu(1430) = lu(1430) - lu(1117) * lu(1427) - lu(1431) = lu(1431) - lu(1118) * lu(1427) - lu(1432) = lu(1432) - lu(1119) * lu(1427) - lu(1433) = lu(1433) - lu(1120) * lu(1427) - lu(1434) = lu(1434) - lu(1121) * lu(1427) - lu(1435) = lu(1435) - lu(1122) * lu(1427) - lu(1436) = lu(1436) - lu(1123) * lu(1427) - lu(1437) = lu(1437) - lu(1124) * lu(1427) - lu(1450) = lu(1450) - lu(1115) * lu(1449) - lu(1451) = lu(1451) - lu(1116) * lu(1449) - lu(1452) = lu(1452) - lu(1117) * lu(1449) - lu(1453) = lu(1453) - lu(1118) * lu(1449) - lu(1454) = lu(1454) - lu(1119) * lu(1449) - lu(1455) = lu(1455) - lu(1120) * lu(1449) - lu(1456) = lu(1456) - lu(1121) * lu(1449) - lu(1457) = lu(1457) - lu(1122) * lu(1449) - lu(1458) = lu(1458) - lu(1123) * lu(1449) - lu(1459) = lu(1459) - lu(1124) * lu(1449) - lu(1476) = lu(1476) - lu(1115) * lu(1475) - lu(1477) = lu(1477) - lu(1116) * lu(1475) - lu(1478) = lu(1478) - lu(1117) * lu(1475) - lu(1479) = lu(1479) - lu(1118) * lu(1475) - lu(1480) = lu(1480) - lu(1119) * lu(1475) - lu(1481) = lu(1481) - lu(1120) * lu(1475) - lu(1482) = lu(1482) - lu(1121) * lu(1475) - lu(1483) = lu(1483) - lu(1122) * lu(1475) - lu(1484) = lu(1484) - lu(1123) * lu(1475) - lu(1485) = lu(1485) - lu(1124) * lu(1475) - lu(1500) = lu(1500) - lu(1115) * lu(1499) - lu(1501) = lu(1501) - lu(1116) * lu(1499) - lu(1502) = lu(1502) - lu(1117) * lu(1499) - lu(1503) = lu(1503) - lu(1118) * lu(1499) - lu(1504) = lu(1504) - lu(1119) * lu(1499) - lu(1505) = lu(1505) - lu(1120) * lu(1499) - lu(1506) = lu(1506) - lu(1121) * lu(1499) - lu(1507) = lu(1507) - lu(1122) * lu(1499) - lu(1508) = lu(1508) - lu(1123) * lu(1499) - lu(1509) = lu(1509) - lu(1124) * lu(1499) - lu(1150) = 1._r8 / lu(1150) - lu(1151) = lu(1151) * lu(1150) - lu(1152) = lu(1152) * lu(1150) - lu(1153) = lu(1153) * lu(1150) - lu(1154) = lu(1154) * lu(1150) - lu(1155) = lu(1155) * lu(1150) - lu(1156) = lu(1156) * lu(1150) - lu(1157) = lu(1157) * lu(1150) - lu(1158) = lu(1158) * lu(1150) - lu(1159) = lu(1159) * lu(1150) - lu(1171) = lu(1171) - lu(1151) * lu(1170) - lu(1172) = lu(1172) - lu(1152) * lu(1170) - lu(1173) = lu(1173) - lu(1153) * lu(1170) - lu(1174) = lu(1174) - lu(1154) * lu(1170) - lu(1175) = lu(1175) - lu(1155) * lu(1170) - lu(1176) = lu(1176) - lu(1156) * lu(1170) - lu(1177) = lu(1177) - lu(1157) * lu(1170) - lu(1178) = lu(1178) - lu(1158) * lu(1170) - lu(1179) = lu(1179) - lu(1159) * lu(1170) - lu(1195) = lu(1195) - lu(1151) * lu(1194) - lu(1196) = lu(1196) - lu(1152) * lu(1194) - lu(1197) = lu(1197) - lu(1153) * lu(1194) - lu(1198) = lu(1198) - lu(1154) * lu(1194) - lu(1199) = lu(1199) - lu(1155) * lu(1194) - lu(1200) = lu(1200) - lu(1156) * lu(1194) - lu(1201) = lu(1201) - lu(1157) * lu(1194) - lu(1202) = lu(1202) - lu(1158) * lu(1194) - lu(1203) = lu(1203) - lu(1159) * lu(1194) - lu(1250) = lu(1250) - lu(1151) * lu(1249) - lu(1251) = lu(1251) - lu(1152) * lu(1249) - lu(1252) = lu(1252) - lu(1153) * lu(1249) - lu(1253) = lu(1253) - lu(1154) * lu(1249) - lu(1254) = lu(1254) - lu(1155) * lu(1249) - lu(1255) = lu(1255) - lu(1156) * lu(1249) - lu(1256) = lu(1256) - lu(1157) * lu(1249) - lu(1257) = lu(1257) - lu(1158) * lu(1249) - lu(1258) = lu(1258) - lu(1159) * lu(1249) - lu(1287) = lu(1287) - lu(1151) * lu(1286) - lu(1288) = lu(1288) - lu(1152) * lu(1286) - lu(1289) = lu(1289) - lu(1153) * lu(1286) - lu(1290) = lu(1290) - lu(1154) * lu(1286) - lu(1291) = lu(1291) - lu(1155) * lu(1286) - lu(1292) = lu(1292) - lu(1156) * lu(1286) - lu(1293) = lu(1293) - lu(1157) * lu(1286) - lu(1294) = lu(1294) - lu(1158) * lu(1286) - lu(1295) = lu(1295) - lu(1159) * lu(1286) - lu(1385) = lu(1385) - lu(1151) * lu(1384) - lu(1386) = lu(1386) - lu(1152) * lu(1384) - lu(1387) = lu(1387) - lu(1153) * lu(1384) - lu(1388) = lu(1388) - lu(1154) * lu(1384) - lu(1389) = lu(1389) - lu(1155) * lu(1384) - lu(1390) = lu(1390) - lu(1156) * lu(1384) - lu(1391) = lu(1391) - lu(1157) * lu(1384) - lu(1392) = lu(1392) - lu(1158) * lu(1384) - lu(1393) = lu(1393) - lu(1159) * lu(1384) - lu(1429) = lu(1429) - lu(1151) * lu(1428) - lu(1430) = lu(1430) - lu(1152) * lu(1428) - lu(1431) = lu(1431) - lu(1153) * lu(1428) - lu(1432) = lu(1432) - lu(1154) * lu(1428) - lu(1433) = lu(1433) - lu(1155) * lu(1428) - lu(1434) = lu(1434) - lu(1156) * lu(1428) - lu(1435) = lu(1435) - lu(1157) * lu(1428) - lu(1436) = lu(1436) - lu(1158) * lu(1428) - lu(1437) = lu(1437) - lu(1159) * lu(1428) - lu(1451) = lu(1451) - lu(1151) * lu(1450) - lu(1452) = lu(1452) - lu(1152) * lu(1450) - lu(1453) = lu(1453) - lu(1153) * lu(1450) - lu(1454) = lu(1454) - lu(1154) * lu(1450) - lu(1455) = lu(1455) - lu(1155) * lu(1450) - lu(1456) = lu(1456) - lu(1156) * lu(1450) - lu(1457) = lu(1457) - lu(1157) * lu(1450) - lu(1458) = lu(1458) - lu(1158) * lu(1450) - lu(1459) = lu(1459) - lu(1159) * lu(1450) - lu(1477) = lu(1477) - lu(1151) * lu(1476) - lu(1478) = lu(1478) - lu(1152) * lu(1476) - lu(1479) = lu(1479) - lu(1153) * lu(1476) - lu(1480) = lu(1480) - lu(1154) * lu(1476) - lu(1481) = lu(1481) - lu(1155) * lu(1476) - lu(1482) = lu(1482) - lu(1156) * lu(1476) - lu(1483) = lu(1483) - lu(1157) * lu(1476) - lu(1484) = lu(1484) - lu(1158) * lu(1476) - lu(1485) = lu(1485) - lu(1159) * lu(1476) - lu(1501) = lu(1501) - lu(1151) * lu(1500) - lu(1502) = lu(1502) - lu(1152) * lu(1500) - lu(1503) = lu(1503) - lu(1153) * lu(1500) - lu(1504) = lu(1504) - lu(1154) * lu(1500) - lu(1505) = lu(1505) - lu(1155) * lu(1500) - lu(1506) = lu(1506) - lu(1156) * lu(1500) - lu(1507) = lu(1507) - lu(1157) * lu(1500) - lu(1508) = lu(1508) - lu(1158) * lu(1500) - lu(1509) = lu(1509) - lu(1159) * lu(1500) - lu(1171) = 1._r8 / lu(1171) - lu(1172) = lu(1172) * lu(1171) - lu(1173) = lu(1173) * lu(1171) - lu(1174) = lu(1174) * lu(1171) - lu(1175) = lu(1175) * lu(1171) - lu(1176) = lu(1176) * lu(1171) - lu(1177) = lu(1177) * lu(1171) - lu(1178) = lu(1178) * lu(1171) - lu(1179) = lu(1179) * lu(1171) - lu(1196) = lu(1196) - lu(1172) * lu(1195) - lu(1197) = lu(1197) - lu(1173) * lu(1195) - lu(1198) = lu(1198) - lu(1174) * lu(1195) - lu(1199) = lu(1199) - lu(1175) * lu(1195) - lu(1200) = lu(1200) - lu(1176) * lu(1195) - lu(1201) = lu(1201) - lu(1177) * lu(1195) - lu(1202) = lu(1202) - lu(1178) * lu(1195) - lu(1203) = lu(1203) - lu(1179) * lu(1195) - lu(1251) = lu(1251) - lu(1172) * lu(1250) - lu(1252) = lu(1252) - lu(1173) * lu(1250) - lu(1253) = lu(1253) - lu(1174) * lu(1250) - lu(1254) = lu(1254) - lu(1175) * lu(1250) - lu(1255) = lu(1255) - lu(1176) * lu(1250) - lu(1256) = lu(1256) - lu(1177) * lu(1250) - lu(1257) = lu(1257) - lu(1178) * lu(1250) - lu(1258) = lu(1258) - lu(1179) * lu(1250) - lu(1288) = lu(1288) - lu(1172) * lu(1287) - lu(1289) = lu(1289) - lu(1173) * lu(1287) - lu(1290) = lu(1290) - lu(1174) * lu(1287) - lu(1291) = lu(1291) - lu(1175) * lu(1287) - lu(1292) = lu(1292) - lu(1176) * lu(1287) - lu(1293) = lu(1293) - lu(1177) * lu(1287) - lu(1294) = lu(1294) - lu(1178) * lu(1287) - lu(1295) = lu(1295) - lu(1179) * lu(1287) - lu(1386) = lu(1386) - lu(1172) * lu(1385) - lu(1387) = lu(1387) - lu(1173) * lu(1385) - lu(1388) = lu(1388) - lu(1174) * lu(1385) - lu(1389) = lu(1389) - lu(1175) * lu(1385) - lu(1390) = lu(1390) - lu(1176) * lu(1385) - lu(1391) = lu(1391) - lu(1177) * lu(1385) - lu(1392) = lu(1392) - lu(1178) * lu(1385) - lu(1393) = lu(1393) - lu(1179) * lu(1385) - lu(1430) = lu(1430) - lu(1172) * lu(1429) - lu(1431) = lu(1431) - lu(1173) * lu(1429) - lu(1432) = lu(1432) - lu(1174) * lu(1429) - lu(1433) = lu(1433) - lu(1175) * lu(1429) - lu(1434) = lu(1434) - lu(1176) * lu(1429) - lu(1435) = lu(1435) - lu(1177) * lu(1429) - lu(1436) = lu(1436) - lu(1178) * lu(1429) - lu(1437) = lu(1437) - lu(1179) * lu(1429) - lu(1452) = lu(1452) - lu(1172) * lu(1451) - lu(1453) = lu(1453) - lu(1173) * lu(1451) - lu(1454) = lu(1454) - lu(1174) * lu(1451) - lu(1455) = lu(1455) - lu(1175) * lu(1451) - lu(1456) = lu(1456) - lu(1176) * lu(1451) - lu(1457) = lu(1457) - lu(1177) * lu(1451) - lu(1458) = lu(1458) - lu(1178) * lu(1451) - lu(1459) = lu(1459) - lu(1179) * lu(1451) - lu(1478) = lu(1478) - lu(1172) * lu(1477) - lu(1479) = lu(1479) - lu(1173) * lu(1477) - lu(1480) = lu(1480) - lu(1174) * lu(1477) - lu(1481) = lu(1481) - lu(1175) * lu(1477) - lu(1482) = lu(1482) - lu(1176) * lu(1477) - lu(1483) = lu(1483) - lu(1177) * lu(1477) - lu(1484) = lu(1484) - lu(1178) * lu(1477) - lu(1485) = lu(1485) - lu(1179) * lu(1477) - lu(1502) = lu(1502) - lu(1172) * lu(1501) - lu(1503) = lu(1503) - lu(1173) * lu(1501) - lu(1504) = lu(1504) - lu(1174) * lu(1501) - lu(1505) = lu(1505) - lu(1175) * lu(1501) - lu(1506) = lu(1506) - lu(1176) * lu(1501) - lu(1507) = lu(1507) - lu(1177) * lu(1501) - lu(1508) = lu(1508) - lu(1178) * lu(1501) - lu(1509) = lu(1509) - lu(1179) * lu(1501) - lu(1196) = 1._r8 / lu(1196) - lu(1197) = lu(1197) * lu(1196) - lu(1198) = lu(1198) * lu(1196) - lu(1199) = lu(1199) * lu(1196) - lu(1200) = lu(1200) * lu(1196) - lu(1201) = lu(1201) * lu(1196) - lu(1202) = lu(1202) * lu(1196) - lu(1203) = lu(1203) * lu(1196) - lu(1252) = lu(1252) - lu(1197) * lu(1251) - lu(1253) = lu(1253) - lu(1198) * lu(1251) - lu(1254) = lu(1254) - lu(1199) * lu(1251) - lu(1255) = lu(1255) - lu(1200) * lu(1251) - lu(1256) = lu(1256) - lu(1201) * lu(1251) - lu(1257) = lu(1257) - lu(1202) * lu(1251) - lu(1258) = lu(1258) - lu(1203) * lu(1251) - lu(1289) = lu(1289) - lu(1197) * lu(1288) - lu(1290) = lu(1290) - lu(1198) * lu(1288) - lu(1291) = lu(1291) - lu(1199) * lu(1288) - lu(1292) = lu(1292) - lu(1200) * lu(1288) - lu(1293) = lu(1293) - lu(1201) * lu(1288) - lu(1294) = lu(1294) - lu(1202) * lu(1288) - lu(1295) = lu(1295) - lu(1203) * lu(1288) - lu(1387) = lu(1387) - lu(1197) * lu(1386) - lu(1388) = lu(1388) - lu(1198) * lu(1386) - lu(1389) = lu(1389) - lu(1199) * lu(1386) - lu(1390) = lu(1390) - lu(1200) * lu(1386) - lu(1391) = lu(1391) - lu(1201) * lu(1386) - lu(1392) = lu(1392) - lu(1202) * lu(1386) - lu(1393) = lu(1393) - lu(1203) * lu(1386) - lu(1431) = lu(1431) - lu(1197) * lu(1430) - lu(1432) = lu(1432) - lu(1198) * lu(1430) - lu(1433) = lu(1433) - lu(1199) * lu(1430) - lu(1434) = lu(1434) - lu(1200) * lu(1430) - lu(1435) = lu(1435) - lu(1201) * lu(1430) - lu(1436) = lu(1436) - lu(1202) * lu(1430) - lu(1437) = lu(1437) - lu(1203) * lu(1430) - lu(1453) = lu(1453) - lu(1197) * lu(1452) - lu(1454) = lu(1454) - lu(1198) * lu(1452) - lu(1455) = lu(1455) - lu(1199) * lu(1452) - lu(1456) = lu(1456) - lu(1200) * lu(1452) - lu(1457) = lu(1457) - lu(1201) * lu(1452) - lu(1458) = lu(1458) - lu(1202) * lu(1452) - lu(1459) = lu(1459) - lu(1203) * lu(1452) - lu(1479) = lu(1479) - lu(1197) * lu(1478) - lu(1480) = lu(1480) - lu(1198) * lu(1478) - lu(1481) = lu(1481) - lu(1199) * lu(1478) - lu(1482) = lu(1482) - lu(1200) * lu(1478) - lu(1483) = lu(1483) - lu(1201) * lu(1478) - lu(1484) = lu(1484) - lu(1202) * lu(1478) - lu(1485) = lu(1485) - lu(1203) * lu(1478) - lu(1503) = lu(1503) - lu(1197) * lu(1502) - lu(1504) = lu(1504) - lu(1198) * lu(1502) - lu(1505) = lu(1505) - lu(1199) * lu(1502) - lu(1506) = lu(1506) - lu(1200) * lu(1502) - lu(1507) = lu(1507) - lu(1201) * lu(1502) - lu(1508) = lu(1508) - lu(1202) * lu(1502) - lu(1509) = lu(1509) - lu(1203) * lu(1502) - lu(1252) = 1._r8 / lu(1252) - lu(1253) = lu(1253) * lu(1252) - lu(1254) = lu(1254) * lu(1252) - lu(1255) = lu(1255) * lu(1252) - lu(1256) = lu(1256) * lu(1252) - lu(1257) = lu(1257) * lu(1252) - lu(1258) = lu(1258) * lu(1252) - lu(1290) = lu(1290) - lu(1253) * lu(1289) - lu(1291) = lu(1291) - lu(1254) * lu(1289) - lu(1292) = lu(1292) - lu(1255) * lu(1289) - lu(1293) = lu(1293) - lu(1256) * lu(1289) - lu(1294) = lu(1294) - lu(1257) * lu(1289) - lu(1295) = lu(1295) - lu(1258) * lu(1289) - lu(1388) = lu(1388) - lu(1253) * lu(1387) - lu(1389) = lu(1389) - lu(1254) * lu(1387) - lu(1390) = lu(1390) - lu(1255) * lu(1387) - lu(1391) = lu(1391) - lu(1256) * lu(1387) - lu(1392) = lu(1392) - lu(1257) * lu(1387) - lu(1393) = lu(1393) - lu(1258) * lu(1387) - lu(1432) = lu(1432) - lu(1253) * lu(1431) - lu(1433) = lu(1433) - lu(1254) * lu(1431) - lu(1434) = lu(1434) - lu(1255) * lu(1431) - lu(1435) = lu(1435) - lu(1256) * lu(1431) - lu(1436) = lu(1436) - lu(1257) * lu(1431) - lu(1437) = lu(1437) - lu(1258) * lu(1431) - lu(1454) = lu(1454) - lu(1253) * lu(1453) - lu(1455) = lu(1455) - lu(1254) * lu(1453) - lu(1456) = lu(1456) - lu(1255) * lu(1453) - lu(1457) = lu(1457) - lu(1256) * lu(1453) - lu(1458) = lu(1458) - lu(1257) * lu(1453) - lu(1459) = lu(1459) - lu(1258) * lu(1453) - lu(1480) = lu(1480) - lu(1253) * lu(1479) - lu(1481) = lu(1481) - lu(1254) * lu(1479) - lu(1482) = lu(1482) - lu(1255) * lu(1479) - lu(1483) = lu(1483) - lu(1256) * lu(1479) - lu(1484) = lu(1484) - lu(1257) * lu(1479) - lu(1485) = lu(1485) - lu(1258) * lu(1479) - lu(1504) = lu(1504) - lu(1253) * lu(1503) - lu(1505) = lu(1505) - lu(1254) * lu(1503) - lu(1506) = lu(1506) - lu(1255) * lu(1503) - lu(1507) = lu(1507) - lu(1256) * lu(1503) - lu(1508) = lu(1508) - lu(1257) * lu(1503) - lu(1509) = lu(1509) - lu(1258) * lu(1503) - lu(1290) = 1._r8 / lu(1290) - lu(1291) = lu(1291) * lu(1290) - lu(1292) = lu(1292) * lu(1290) - lu(1293) = lu(1293) * lu(1290) - lu(1294) = lu(1294) * lu(1290) - lu(1295) = lu(1295) * lu(1290) - lu(1389) = lu(1389) - lu(1291) * lu(1388) - lu(1390) = lu(1390) - lu(1292) * lu(1388) - lu(1391) = lu(1391) - lu(1293) * lu(1388) - lu(1392) = lu(1392) - lu(1294) * lu(1388) - lu(1393) = lu(1393) - lu(1295) * lu(1388) - lu(1433) = lu(1433) - lu(1291) * lu(1432) - lu(1434) = lu(1434) - lu(1292) * lu(1432) - lu(1435) = lu(1435) - lu(1293) * lu(1432) - lu(1436) = lu(1436) - lu(1294) * lu(1432) - lu(1437) = lu(1437) - lu(1295) * lu(1432) - lu(1455) = lu(1455) - lu(1291) * lu(1454) - lu(1456) = lu(1456) - lu(1292) * lu(1454) - lu(1457) = lu(1457) - lu(1293) * lu(1454) - lu(1458) = lu(1458) - lu(1294) * lu(1454) - lu(1459) = lu(1459) - lu(1295) * lu(1454) - lu(1481) = lu(1481) - lu(1291) * lu(1480) - lu(1482) = lu(1482) - lu(1292) * lu(1480) - lu(1483) = lu(1483) - lu(1293) * lu(1480) - lu(1484) = lu(1484) - lu(1294) * lu(1480) - lu(1485) = lu(1485) - lu(1295) * lu(1480) - lu(1505) = lu(1505) - lu(1291) * lu(1504) - lu(1506) = lu(1506) - lu(1292) * lu(1504) - lu(1507) = lu(1507) - lu(1293) * lu(1504) - lu(1508) = lu(1508) - lu(1294) * lu(1504) - lu(1509) = lu(1509) - lu(1295) * lu(1504) - END SUBROUTINE lu_fac20 - - SUBROUTINE lu_fac21(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(1389) = 1._r8 / lu(1389) - lu(1390) = lu(1390) * lu(1389) - lu(1391) = lu(1391) * lu(1389) - lu(1392) = lu(1392) * lu(1389) - lu(1393) = lu(1393) * lu(1389) - lu(1434) = lu(1434) - lu(1390) * lu(1433) - lu(1435) = lu(1435) - lu(1391) * lu(1433) - lu(1436) = lu(1436) - lu(1392) * lu(1433) - lu(1437) = lu(1437) - lu(1393) * lu(1433) - lu(1456) = lu(1456) - lu(1390) * lu(1455) - lu(1457) = lu(1457) - lu(1391) * lu(1455) - lu(1458) = lu(1458) - lu(1392) * lu(1455) - lu(1459) = lu(1459) - lu(1393) * lu(1455) - lu(1482) = lu(1482) - lu(1390) * lu(1481) - lu(1483) = lu(1483) - lu(1391) * lu(1481) - lu(1484) = lu(1484) - lu(1392) * lu(1481) - lu(1485) = lu(1485) - lu(1393) * lu(1481) - lu(1506) = lu(1506) - lu(1390) * lu(1505) - lu(1507) = lu(1507) - lu(1391) * lu(1505) - lu(1508) = lu(1508) - lu(1392) * lu(1505) - lu(1509) = lu(1509) - lu(1393) * lu(1505) - lu(1434) = 1._r8 / lu(1434) - lu(1435) = lu(1435) * lu(1434) - lu(1436) = lu(1436) * lu(1434) - lu(1437) = lu(1437) * lu(1434) - lu(1457) = lu(1457) - lu(1435) * lu(1456) - lu(1458) = lu(1458) - lu(1436) * lu(1456) - lu(1459) = lu(1459) - lu(1437) * lu(1456) - lu(1483) = lu(1483) - lu(1435) * lu(1482) - lu(1484) = lu(1484) - lu(1436) * lu(1482) - lu(1485) = lu(1485) - lu(1437) * lu(1482) - lu(1507) = lu(1507) - lu(1435) * lu(1506) - lu(1508) = lu(1508) - lu(1436) * lu(1506) - lu(1509) = lu(1509) - lu(1437) * lu(1506) - lu(1457) = 1._r8 / lu(1457) - lu(1458) = lu(1458) * lu(1457) - lu(1459) = lu(1459) * lu(1457) - lu(1484) = lu(1484) - lu(1458) * lu(1483) - lu(1485) = lu(1485) - lu(1459) * lu(1483) - lu(1508) = lu(1508) - lu(1458) * lu(1507) - lu(1509) = lu(1509) - lu(1459) * lu(1507) - lu(1484) = 1._r8 / lu(1484) - lu(1485) = lu(1485) * lu(1484) - lu(1509) = lu(1509) - lu(1485) * lu(1508) - lu(1509) = 1._r8 / lu(1509) - END SUBROUTINE lu_fac21 - - SUBROUTINE lu_fac(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - CALL lu_fac01(lu) - CALL lu_fac02(lu) - CALL lu_fac03(lu) - CALL lu_fac04(lu) - CALL lu_fac05(lu) - CALL lu_fac06(lu) - CALL lu_fac07(lu) - CALL lu_fac08(lu) - CALL lu_fac09(lu) - CALL lu_fac10(lu) - CALL lu_fac11(lu) - CALL lu_fac12(lu) - CALL lu_fac13(lu) - CALL lu_fac14(lu) - CALL lu_fac15(lu) - CALL lu_fac16(lu) - CALL lu_fac17(lu) - CALL lu_fac18(lu) - CALL lu_fac19(lu) - CALL lu_fac20(lu) - CALL lu_fac21(lu) - END SUBROUTINE lu_fac - END MODULE mo_lu_factor diff --git a/test/ncar_kernels/WACCM_imp_sol/src/mo_lu_solve.F90 b/test/ncar_kernels/WACCM_imp_sol/src/mo_lu_solve.F90 deleted file mode 100644 index 60b7d1326a..0000000000 --- a/test/ncar_kernels/WACCM_imp_sol/src/mo_lu_solve.F90 +++ /dev/null @@ -1,1677 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_lu_solve.F90 -! Generated at: 2015-05-13 11:02:22 -! KGEN version: 0.4.10 - - - - MODULE mo_lu_solve - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - PRIVATE - PUBLIC lu_slv - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - - SUBROUTINE lu_slv01(lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(in) :: lu(:) - REAL(KIND=r8), intent(inout) :: b(:) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - b(125) = b(125) - lu(18) * b(17) - b(131) = b(131) - lu(19) * b(17) - b(124) = b(124) - lu(21) * b(18) - b(126) = b(126) - lu(22) * b(18) - b(79) = b(79) - lu(24) * b(19) - b(131) = b(131) - lu(25) * b(19) - b(41) = b(41) - lu(27) * b(20) - b(131) = b(131) - lu(28) * b(20) - b(96) = b(96) - lu(30) * b(21) - b(131) = b(131) - lu(31) * b(21) - b(134) = b(134) - lu(32) * b(21) - b(23) = b(23) - lu(34) * b(22) - b(65) = b(65) - lu(35) * b(22) - b(125) = b(125) - lu(36) * b(22) - b(131) = b(131) - lu(37) * b(22) - b(31) = b(31) - lu(39) * b(23) - b(131) = b(131) - lu(40) * b(23) - b(56) = b(56) - lu(42) * b(24) - b(131) = b(131) - lu(43) * b(24) - b(88) = b(88) - lu(45) * b(25) - b(122) = b(122) - lu(46) * b(25) - b(36) = b(36) - lu(48) * b(26) - b(134) = b(134) - lu(49) * b(26) - b(120) = b(120) - lu(51) * b(27) - b(120) = b(120) - lu(54) * b(28) - b(126) = b(126) - lu(56) * b(29) - b(122) = b(122) - lu(58) * b(30) - b(125) = b(125) - lu(59) * b(30) - b(131) = b(131) - lu(60) * b(30) - b(66) = b(66) - lu(62) * b(31) - b(125) = b(125) - lu(63) * b(31) - b(130) = b(130) - lu(64) * b(31) - b(88) = b(88) - lu(66) * b(32) - b(122) = b(122) - lu(67) * b(32) - b(126) = b(126) - lu(68) * b(32) - b(118) = b(118) - lu(70) * b(33) - b(126) = b(126) - lu(71) * b(33) - b(88) = b(88) - lu(73) * b(34) - b(127) = b(127) - lu(74) * b(34) - b(104) = b(104) - lu(76) * b(35) - b(125) = b(125) - lu(77) * b(35) - b(131) = b(131) - lu(78) * b(35) - b(99) = b(99) - lu(81) * b(36) - b(121) = b(121) - lu(82) * b(36) - b(134) = b(134) - lu(83) * b(36) - b(91) = b(91) - lu(85) * b(37) - b(117) = b(117) - lu(86) * b(37) - b(126) = b(126) - lu(87) * b(37) - b(131) = b(131) - lu(88) * b(37) - b(134) = b(134) - lu(89) * b(37) - b(64) = b(64) - lu(91) * b(38) - b(81) = b(81) - lu(92) * b(38) - b(103) = b(103) - lu(93) * b(38) - b(125) = b(125) - lu(94) * b(38) - b(131) = b(131) - lu(95) * b(38) - b(99) = b(99) - lu(97) * b(39) - b(125) = b(125) - lu(98) * b(39) - b(131) = b(131) - lu(99) * b(39) - b(132) = b(132) - lu(100) * b(39) - b(133) = b(133) - lu(101) * b(39) - b(121) = b(121) - lu(103) * b(40) - b(129) = b(129) - lu(104) * b(40) - b(130) = b(130) - lu(105) * b(40) - b(132) = b(132) - lu(106) * b(40) - b(133) = b(133) - lu(107) * b(40) - b(80) = b(80) - lu(109) * b(41) - b(104) = b(104) - lu(110) * b(41) - b(125) = b(125) - lu(111) * b(41) - b(129) = b(129) - lu(112) * b(41) - b(130) = b(130) - lu(113) * b(41) - b(135) = b(135) - lu(114) * b(41) - b(77) = b(77) - lu(116) * b(42) - b(104) = b(104) - lu(117) * b(42) - b(115) = b(115) - lu(118) * b(42) - b(131) = b(131) - lu(119) * b(42) - b(112) = b(112) - lu(121) * b(43) - b(114) = b(114) - lu(122) * b(43) - b(125) = b(125) - lu(123) * b(43) - b(131) = b(131) - lu(124) * b(43) - b(91) = b(91) - lu(126) * b(44) - b(104) = b(104) - lu(127) * b(44) - b(125) = b(125) - lu(128) * b(44) - b(131) = b(131) - lu(129) * b(44) - b(110) = b(110) - lu(131) * b(45) - b(131) = b(131) - lu(132) * b(45) - b(134) = b(134) - lu(133) * b(45) - b(99) = b(99) - lu(135) * b(46) - b(116) = b(116) - lu(136) * b(46) - b(121) = b(121) - lu(137) * b(46) - b(124) = b(124) - lu(138) * b(46) - b(110) = b(110) - lu(140) * b(47) - b(131) = b(131) - lu(141) * b(47) - b(82) = b(82) - lu(143) * b(48) - b(99) = b(99) - lu(144) * b(48) - b(103) = b(103) - lu(145) * b(48) - b(116) = b(116) - lu(146) * b(48) - b(121) = b(121) - lu(147) * b(48) - b(127) = b(127) - lu(148) * b(48) - b(131) = b(131) - lu(149) * b(48) - b(109) = b(109) - lu(151) * b(49) - b(130) = b(130) - lu(152) * b(49) - b(131) = b(131) - lu(153) * b(49) - b(119) = b(119) - lu(155) * b(50) - b(127) = b(127) - lu(156) * b(50) - b(131) = b(131) - lu(157) * b(50) - b(134) = b(134) - lu(158) * b(50) - b(135) = b(135) - lu(159) * b(50) - b(65) = b(65) - lu(161) * b(51) - b(66) = b(66) - lu(162) * b(51) - b(81) = b(81) - lu(163) * b(51) - b(109) = b(109) - lu(164) * b(51) - b(131) = b(131) - lu(165) * b(51) - b(80) = b(80) - lu(167) * b(52) - b(96) = b(96) - lu(168) * b(52) - b(125) = b(125) - lu(169) * b(52) - b(131) = b(131) - lu(170) * b(52) - b(134) = b(134) - lu(171) * b(52) - b(106) = b(106) - lu(173) * b(53) - b(115) = b(115) - lu(174) * b(53) - b(131) = b(131) - lu(175) * b(53) - b(134) = b(134) - lu(176) * b(53) - b(135) = b(135) - lu(177) * b(53) - b(64) = b(64) - lu(179) * b(54) - b(125) = b(125) - lu(180) * b(54) - b(129) = b(129) - lu(181) * b(54) - b(130) = b(130) - lu(182) * b(54) - b(135) = b(135) - lu(183) * b(54) - b(77) = b(77) - lu(185) * b(55) - b(91) = b(91) - lu(186) * b(55) - b(115) = b(115) - lu(187) * b(55) - b(131) = b(131) - lu(188) * b(55) - b(95) = b(95) - lu(190) * b(56) - b(120) = b(120) - lu(191) * b(56) - b(125) = b(125) - lu(192) * b(56) - b(135) = b(135) - lu(193) * b(56) - b(115) = b(115) - lu(195) * b(57) - b(119) = b(119) - lu(196) * b(57) - b(130) = b(130) - lu(197) * b(57) - b(131) = b(131) - lu(198) * b(57) - b(132) = b(132) - lu(199) * b(57) - b(135) = b(135) - lu(200) * b(57) - b(72) = b(72) - lu(202) * b(58) - b(85) = b(85) - lu(203) * b(58) - b(86) = b(86) - lu(204) * b(58) - b(92) = b(92) - lu(205) * b(58) - b(120) = b(120) - lu(206) * b(58) - b(121) = b(121) - lu(207) * b(58) - b(80) = b(80) - lu(209) * b(59) - b(98) = b(98) - lu(210) * b(59) - b(107) = b(107) - lu(211) * b(59) - b(113) = b(113) - lu(212) * b(59) - b(125) = b(125) - lu(213) * b(59) - b(131) = b(131) - lu(214) * b(59) - b(120) = b(120) - lu(216) * b(60) - b(125) = b(125) - lu(217) * b(60) - b(130) = b(130) - lu(218) * b(60) - b(131) = b(131) - lu(219) * b(60) - b(132) = b(132) - lu(220) * b(60) - b(134) = b(134) - lu(221) * b(60) - b(92) = b(92) - lu(223) * b(61) - b(120) = b(120) - lu(224) * b(61) - b(122) = b(122) - lu(225) * b(61) - b(129) = b(129) - lu(226) * b(61) - b(115) = b(115) - lu(228) * b(62) - b(119) = b(119) - lu(229) * b(62) - b(131) = b(131) - lu(230) * b(62) - b(134) = b(134) - lu(231) * b(62) - b(135) = b(135) - lu(232) * b(62) - b(64) = b(64) - lu(234) * b(63) - b(83) = b(83) - lu(235) * b(63) - b(103) = b(103) - lu(236) * b(63) - b(123) = b(123) - lu(237) * b(63) - b(125) = b(125) - lu(238) * b(63) - b(131) = b(131) - lu(239) * b(63) - b(135) = b(135) - lu(240) * b(63) - b(125) = b(125) - lu(242) * b(64) - b(131) = b(131) - lu(243) * b(64) - b(134) = b(134) - lu(244) * b(64) - b(66) = b(66) - lu(247) * b(65) - b(81) = b(81) - lu(248) * b(65) - b(109) = b(109) - lu(249) * b(65) - b(125) = b(125) - lu(250) * b(65) - b(129) = b(129) - lu(251) * b(65) - b(130) = b(130) - lu(252) * b(65) - b(131) = b(131) - lu(253) * b(65) - b(81) = b(81) - lu(255) * b(66) - b(103) = b(103) - lu(256) * b(66) - b(109) = b(109) - lu(257) * b(66) - b(115) = b(115) - lu(258) * b(66) - b(125) = b(125) - lu(259) * b(66) - b(89) = b(89) - lu(261) * b(67) - b(104) = b(104) - lu(262) * b(67) - b(105) = b(105) - lu(263) * b(67) - b(125) = b(125) - lu(264) * b(67) - b(131) = b(131) - lu(265) * b(67) - b(134) = b(134) - lu(266) * b(67) - b(135) = b(135) - lu(267) * b(67) - b(125) = b(125) - lu(269) * b(68) - b(131) = b(131) - lu(270) * b(68) - b(135) = b(135) - lu(271) * b(68) - b(107) = b(107) - lu(273) * b(69) - b(110) = b(110) - lu(274) * b(69) - b(111) = b(111) - lu(275) * b(69) - b(113) = b(113) - lu(276) * b(69) - b(125) = b(125) - lu(277) * b(69) - b(131) = b(131) - lu(278) * b(69) - b(135) = b(135) - lu(279) * b(69) - END SUBROUTINE lu_slv01 - - SUBROUTINE lu_slv02(lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(in) :: lu(:) - REAL(KIND=r8), intent(inout) :: b(:) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - b(84) = b(84) - lu(281) * b(70) - b(118) = b(118) - lu(282) * b(70) - b(121) = b(121) - lu(283) * b(70) - b(128) = b(128) - lu(284) * b(70) - b(130) = b(130) - lu(285) * b(70) - b(132) = b(132) - lu(286) * b(70) - b(133) = b(133) - lu(287) * b(70) - b(105) = b(105) - lu(289) * b(71) - b(114) = b(114) - lu(290) * b(71) - b(125) = b(125) - lu(291) * b(71) - b(130) = b(130) - lu(292) * b(71) - b(131) = b(131) - lu(293) * b(71) - b(132) = b(132) - lu(294) * b(71) - b(135) = b(135) - lu(295) * b(71) - b(85) = b(85) - lu(297) * b(72) - b(86) = b(86) - lu(298) * b(72) - b(92) = b(92) - lu(299) * b(72) - b(103) = b(103) - lu(300) * b(72) - b(120) = b(120) - lu(301) * b(72) - b(121) = b(121) - lu(302) * b(72) - b(98) = b(98) - lu(304) * b(73) - b(107) = b(107) - lu(305) * b(73) - b(113) = b(113) - lu(306) * b(73) - b(123) = b(123) - lu(307) * b(73) - b(125) = b(125) - lu(308) * b(73) - b(130) = b(130) - lu(309) * b(73) - b(131) = b(131) - lu(310) * b(73) - b(132) = b(132) - lu(311) * b(73) - b(117) = b(117) - lu(313) * b(74) - b(121) = b(121) - lu(314) * b(74) - b(125) = b(125) - lu(315) * b(74) - b(126) = b(126) - lu(316) * b(74) - b(131) = b(131) - lu(317) * b(74) - b(134) = b(134) - lu(318) * b(74) - b(119) = b(119) - lu(320) * b(75) - b(131) = b(131) - lu(321) * b(75) - b(134) = b(134) - lu(322) * b(75) - b(77) = b(77) - lu(325) * b(76) - b(79) = b(79) - lu(326) * b(76) - b(80) = b(80) - lu(327) * b(76) - b(91) = b(91) - lu(328) * b(76) - b(104) = b(104) - lu(329) * b(76) - b(115) = b(115) - lu(330) * b(76) - b(125) = b(125) - lu(331) * b(76) - b(131) = b(131) - lu(332) * b(76) - b(135) = b(135) - lu(333) * b(76) - b(104) = b(104) - lu(336) * b(77) - b(115) = b(115) - lu(337) * b(77) - b(125) = b(125) - lu(338) * b(77) - b(129) = b(129) - lu(339) * b(77) - b(130) = b(130) - lu(340) * b(77) - b(131) = b(131) - lu(341) * b(77) - b(85) = b(85) - lu(345) * b(78) - b(86) = b(86) - lu(346) * b(78) - b(87) = b(87) - lu(347) * b(78) - b(92) = b(92) - lu(348) * b(78) - b(103) = b(103) - lu(349) * b(78) - b(120) = b(120) - lu(350) * b(78) - b(121) = b(121) - lu(351) * b(78) - b(122) = b(122) - lu(352) * b(78) - b(129) = b(129) - lu(353) * b(78) - b(80) = b(80) - lu(359) * b(79) - b(91) = b(91) - lu(360) * b(79) - b(104) = b(104) - lu(361) * b(79) - b(109) = b(109) - lu(362) * b(79) - b(115) = b(115) - lu(363) * b(79) - b(125) = b(125) - lu(364) * b(79) - b(129) = b(129) - lu(365) * b(79) - b(130) = b(130) - lu(366) * b(79) - b(131) = b(131) - lu(367) * b(79) - b(135) = b(135) - lu(368) * b(79) - b(106) = b(106) - lu(370) * b(80) - b(115) = b(115) - lu(371) * b(80) - b(119) = b(119) - lu(372) * b(80) - b(131) = b(131) - lu(373) * b(80) - b(134) = b(134) - lu(374) * b(80) - b(103) = b(103) - lu(376) * b(81) - b(125) = b(125) - lu(377) * b(81) - b(131) = b(131) - lu(378) * b(81) - b(116) = b(116) - lu(380) * b(82) - b(120) = b(120) - lu(381) * b(82) - b(121) = b(121) - lu(382) * b(82) - b(123) = b(123) - lu(383) * b(82) - b(127) = b(127) - lu(384) * b(82) - b(131) = b(131) - lu(385) * b(82) - b(95) = b(95) - lu(389) * b(83) - b(120) = b(120) - lu(390) * b(83) - b(125) = b(125) - lu(391) * b(83) - b(129) = b(129) - lu(392) * b(83) - b(130) = b(130) - lu(393) * b(83) - b(131) = b(131) - lu(394) * b(83) - b(135) = b(135) - lu(395) * b(83) - b(117) = b(117) - lu(398) * b(84) - b(118) = b(118) - lu(399) * b(84) - b(121) = b(121) - lu(400) * b(84) - b(126) = b(126) - lu(401) * b(84) - b(128) = b(128) - lu(402) * b(84) - b(131) = b(131) - lu(403) * b(84) - b(134) = b(134) - lu(404) * b(84) - b(86) = b(86) - lu(406) * b(85) - b(87) = b(87) - lu(407) * b(85) - b(92) = b(92) - lu(408) * b(85) - b(120) = b(120) - lu(409) * b(85) - b(121) = b(121) - lu(410) * b(85) - b(122) = b(122) - lu(411) * b(85) - b(129) = b(129) - lu(412) * b(85) - b(87) = b(87) - lu(415) * b(86) - b(92) = b(92) - lu(416) * b(86) - b(120) = b(120) - lu(417) * b(86) - b(121) = b(121) - lu(418) * b(86) - b(122) = b(122) - lu(419) * b(86) - b(129) = b(129) - lu(420) * b(86) - b(92) = b(92) - lu(426) * b(87) - b(103) = b(103) - lu(427) * b(87) - b(120) = b(120) - lu(428) * b(87) - b(121) = b(121) - lu(429) * b(87) - b(122) = b(122) - lu(430) * b(87) - b(129) = b(129) - lu(431) * b(87) - b(108) = b(108) - lu(434) * b(88) - b(119) = b(119) - lu(435) * b(88) - b(127) = b(127) - lu(436) * b(88) - b(131) = b(131) - lu(437) * b(88) - b(132) = b(132) - lu(438) * b(88) - b(133) = b(133) - lu(439) * b(88) - b(134) = b(134) - lu(440) * b(88) - b(104) = b(104) - lu(443) * b(89) - b(105) = b(105) - lu(444) * b(89) - b(120) = b(120) - lu(445) * b(89) - b(125) = b(125) - lu(446) * b(89) - b(129) = b(129) - lu(447) * b(89) - b(130) = b(130) - lu(448) * b(89) - b(131) = b(131) - lu(449) * b(89) - b(134) = b(134) - lu(450) * b(89) - b(135) = b(135) - lu(451) * b(89) - b(118) = b(118) - lu(453) * b(90) - b(121) = b(121) - lu(454) * b(90) - b(122) = b(122) - lu(455) * b(90) - b(127) = b(127) - lu(456) * b(90) - b(131) = b(131) - lu(457) * b(90) - b(134) = b(134) - lu(458) * b(90) - b(104) = b(104) - lu(463) * b(91) - b(119) = b(119) - lu(464) * b(91) - b(120) = b(120) - lu(465) * b(91) - b(125) = b(125) - lu(466) * b(91) - b(129) = b(129) - lu(467) * b(91) - b(130) = b(130) - lu(468) * b(91) - b(131) = b(131) - lu(469) * b(91) - b(135) = b(135) - lu(470) * b(91) - b(103) = b(103) - lu(477) * b(92) - b(120) = b(120) - lu(478) * b(92) - b(121) = b(121) - lu(479) * b(92) - b(122) = b(122) - lu(480) * b(92) - b(127) = b(127) - lu(481) * b(92) - b(129) = b(129) - lu(482) * b(92) - b(130) = b(130) - lu(483) * b(92) - b(131) = b(131) - lu(484) * b(92) - b(117) = b(117) - lu(487) * b(93) - b(121) = b(121) - lu(488) * b(93) - b(124) = b(124) - lu(489) * b(93) - b(126) = b(126) - lu(490) * b(93) - b(131) = b(131) - lu(491) * b(93) - b(134) = b(134) - lu(492) * b(93) - b(101) = b(101) - lu(495) * b(94) - b(102) = b(102) - lu(496) * b(94) - b(103) = b(103) - lu(497) * b(94) - b(107) = b(107) - lu(498) * b(94) - b(111) = b(111) - lu(499) * b(94) - b(113) = b(113) - lu(500) * b(94) - b(114) = b(114) - lu(501) * b(94) - b(119) = b(119) - lu(502) * b(94) - b(123) = b(123) - lu(503) * b(94) - b(125) = b(125) - lu(504) * b(94) - b(131) = b(131) - lu(505) * b(94) - b(132) = b(132) - lu(506) * b(94) - b(134) = b(134) - lu(507) * b(94) - b(135) = b(135) - lu(508) * b(94) - b(103) = b(103) - lu(511) * b(95) - b(125) = b(125) - lu(512) * b(95) - b(131) = b(131) - lu(513) * b(95) - b(135) = b(135) - lu(514) * b(95) - b(104) = b(104) - lu(518) * b(96) - b(106) = b(106) - lu(519) * b(96) - b(115) = b(115) - lu(520) * b(96) - b(119) = b(119) - lu(521) * b(96) - b(120) = b(120) - lu(522) * b(96) - b(125) = b(125) - lu(523) * b(96) - b(129) = b(129) - lu(524) * b(96) - b(130) = b(130) - lu(525) * b(96) - b(131) = b(131) - lu(526) * b(96) - b(134) = b(134) - lu(527) * b(96) - b(135) = b(135) - lu(528) * b(96) - b(103) = b(103) - lu(531) * b(97) - b(110) = b(110) - lu(532) * b(97) - b(125) = b(125) - lu(533) * b(97) - b(130) = b(130) - lu(534) * b(97) - b(131) = b(131) - lu(535) * b(97) - b(132) = b(132) - lu(536) * b(97) - b(135) = b(135) - lu(537) * b(97) - b(106) = b(106) - lu(541) * b(98) - b(107) = b(107) - lu(542) * b(98) - b(113) = b(113) - lu(543) * b(98) - b(115) = b(115) - lu(544) * b(98) - b(119) = b(119) - lu(545) * b(98) - b(125) = b(125) - lu(546) * b(98) - b(129) = b(129) - lu(547) * b(98) - b(130) = b(130) - lu(548) * b(98) - b(131) = b(131) - lu(549) * b(98) - b(134) = b(134) - lu(550) * b(98) - END SUBROUTINE lu_slv02 - - SUBROUTINE lu_slv03(lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(in) :: lu(:) - REAL(KIND=r8), intent(inout) :: b(:) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - b(116) = b(116) - lu(553) * b(99) - b(121) = b(121) - lu(554) * b(99) - b(125) = b(125) - lu(555) * b(99) - b(131) = b(131) - lu(556) * b(99) - b(134) = b(134) - lu(557) * b(99) - b(117) = b(117) - lu(561) * b(100) - b(121) = b(121) - lu(562) * b(100) - b(124) = b(124) - lu(563) * b(100) - b(126) = b(126) - lu(564) * b(100) - b(130) = b(130) - lu(565) * b(100) - b(131) = b(131) - lu(566) * b(100) - b(132) = b(132) - lu(567) * b(100) - b(133) = b(133) - lu(568) * b(100) - b(134) = b(134) - lu(569) * b(100) - b(103) = b(103) - lu(573) * b(101) - b(107) = b(107) - lu(574) * b(101) - b(110) = b(110) - lu(575) * b(101) - b(113) = b(113) - lu(576) * b(101) - b(125) = b(125) - lu(577) * b(101) - b(129) = b(129) - lu(578) * b(101) - b(130) = b(130) - lu(579) * b(101) - b(131) = b(131) - lu(580) * b(101) - b(132) = b(132) - lu(581) * b(101) - b(134) = b(134) - lu(582) * b(101) - b(135) = b(135) - lu(583) * b(101) - b(103) = b(103) - lu(588) * b(102) - b(104) = b(104) - lu(589) * b(102) - b(105) = b(105) - lu(590) * b(102) - b(109) = b(109) - lu(591) * b(102) - b(119) = b(119) - lu(592) * b(102) - b(120) = b(120) - lu(593) * b(102) - b(123) = b(123) - lu(594) * b(102) - b(125) = b(125) - lu(595) * b(102) - b(129) = b(129) - lu(596) * b(102) - b(130) = b(130) - lu(597) * b(102) - b(131) = b(131) - lu(598) * b(102) - b(132) = b(132) - lu(599) * b(102) - b(134) = b(134) - lu(600) * b(102) - b(135) = b(135) - lu(601) * b(102) - b(125) = b(125) - lu(603) * b(103) - b(127) = b(127) - lu(604) * b(103) - b(131) = b(131) - lu(605) * b(103) - b(115) = b(115) - lu(608) * b(104) - b(119) = b(119) - lu(609) * b(104) - b(125) = b(125) - lu(610) * b(104) - b(127) = b(127) - lu(611) * b(104) - b(131) = b(131) - lu(612) * b(104) - b(132) = b(132) - lu(613) * b(104) - b(133) = b(133) - lu(614) * b(104) - b(134) = b(134) - lu(615) * b(104) - b(109) = b(109) - lu(617) * b(105) - b(115) = b(115) - lu(618) * b(105) - b(125) = b(125) - lu(619) * b(105) - b(131) = b(131) - lu(620) * b(105) - b(135) = b(135) - lu(621) * b(105) - b(109) = b(109) - lu(626) * b(106) - b(115) = b(115) - lu(627) * b(106) - b(119) = b(119) - lu(628) * b(106) - b(120) = b(120) - lu(629) * b(106) - b(125) = b(125) - lu(630) * b(106) - b(129) = b(129) - lu(631) * b(106) - b(130) = b(130) - lu(632) * b(106) - b(131) = b(131) - lu(633) * b(106) - b(134) = b(134) - lu(634) * b(106) - b(135) = b(135) - lu(635) * b(106) - b(109) = b(109) - lu(638) * b(107) - b(112) = b(112) - lu(639) * b(107) - b(114) = b(114) - lu(640) * b(107) - b(115) = b(115) - lu(641) * b(107) - b(123) = b(123) - lu(642) * b(107) - b(125) = b(125) - lu(643) * b(107) - b(127) = b(127) - lu(644) * b(107) - b(131) = b(131) - lu(645) * b(107) - b(134) = b(134) - lu(646) * b(107) - b(135) = b(135) - lu(647) * b(107) - b(117) = b(117) - lu(651) * b(108) - b(119) = b(119) - lu(652) * b(108) - b(121) = b(121) - lu(653) * b(108) - b(122) = b(122) - lu(654) * b(108) - b(126) = b(126) - lu(655) * b(108) - b(127) = b(127) - lu(656) * b(108) - b(131) = b(131) - lu(657) * b(108) - b(132) = b(132) - lu(658) * b(108) - b(133) = b(133) - lu(659) * b(108) - b(134) = b(134) - lu(660) * b(108) - b(115) = b(115) - lu(663) * b(109) - b(125) = b(125) - lu(664) * b(109) - b(127) = b(127) - lu(665) * b(109) - b(131) = b(131) - lu(666) * b(109) - b(132) = b(132) - lu(667) * b(109) - b(133) = b(133) - lu(668) * b(109) - b(134) = b(134) - lu(669) * b(109) - b(115) = b(115) - lu(678) * b(110) - b(119) = b(119) - lu(679) * b(110) - b(125) = b(125) - lu(680) * b(110) - b(127) = b(127) - lu(681) * b(110) - b(129) = b(129) - lu(682) * b(110) - b(130) = b(130) - lu(683) * b(110) - b(131) = b(131) - lu(684) * b(110) - b(132) = b(132) - lu(685) * b(110) - b(133) = b(133) - lu(686) * b(110) - b(134) = b(134) - lu(687) * b(110) - b(135) = b(135) - lu(688) * b(110) - b(112) = b(112) - lu(698) * b(111) - b(113) = b(113) - lu(699) * b(111) - b(114) = b(114) - lu(700) * b(111) - b(115) = b(115) - lu(701) * b(111) - b(119) = b(119) - lu(702) * b(111) - b(123) = b(123) - lu(703) * b(111) - b(125) = b(125) - lu(704) * b(111) - b(127) = b(127) - lu(705) * b(111) - b(129) = b(129) - lu(706) * b(111) - b(130) = b(130) - lu(707) * b(111) - b(131) = b(131) - lu(708) * b(111) - b(132) = b(132) - lu(709) * b(111) - b(133) = b(133) - lu(710) * b(111) - b(134) = b(134) - lu(711) * b(111) - b(135) = b(135) - lu(712) * b(111) - b(114) = b(114) - lu(722) * b(112) - b(115) = b(115) - lu(723) * b(112) - b(119) = b(119) - lu(724) * b(112) - b(125) = b(125) - lu(725) * b(112) - b(127) = b(127) - lu(726) * b(112) - b(129) = b(129) - lu(727) * b(112) - b(130) = b(130) - lu(728) * b(112) - b(131) = b(131) - lu(729) * b(112) - b(132) = b(132) - lu(730) * b(112) - b(133) = b(133) - lu(731) * b(112) - b(134) = b(134) - lu(732) * b(112) - b(135) = b(135) - lu(733) * b(112) - b(114) = b(114) - lu(741) * b(113) - b(115) = b(115) - lu(742) * b(113) - b(119) = b(119) - lu(743) * b(113) - b(120) = b(120) - lu(744) * b(113) - b(123) = b(123) - lu(745) * b(113) - b(125) = b(125) - lu(746) * b(113) - b(127) = b(127) - lu(747) * b(113) - b(129) = b(129) - lu(748) * b(113) - b(130) = b(130) - lu(749) * b(113) - b(131) = b(131) - lu(750) * b(113) - b(132) = b(132) - lu(751) * b(113) - b(133) = b(133) - lu(752) * b(113) - b(134) = b(134) - lu(753) * b(113) - b(135) = b(135) - lu(754) * b(113) - b(115) = b(115) - lu(761) * b(114) - b(119) = b(119) - lu(762) * b(114) - b(120) = b(120) - lu(763) * b(114) - b(123) = b(123) - lu(764) * b(114) - b(125) = b(125) - lu(765) * b(114) - b(127) = b(127) - lu(766) * b(114) - b(129) = b(129) - lu(767) * b(114) - b(130) = b(130) - lu(768) * b(114) - b(131) = b(131) - lu(769) * b(114) - b(132) = b(132) - lu(770) * b(114) - b(133) = b(133) - lu(771) * b(114) - b(134) = b(134) - lu(772) * b(114) - b(135) = b(135) - lu(773) * b(114) - b(119) = b(119) - lu(790) * b(115) - b(120) = b(120) - lu(791) * b(115) - b(123) = b(123) - lu(792) * b(115) - b(125) = b(125) - lu(793) * b(115) - b(127) = b(127) - lu(794) * b(115) - b(129) = b(129) - lu(795) * b(115) - b(130) = b(130) - lu(796) * b(115) - b(131) = b(131) - lu(797) * b(115) - b(132) = b(132) - lu(798) * b(115) - b(133) = b(133) - lu(799) * b(115) - b(134) = b(134) - lu(800) * b(115) - b(135) = b(135) - lu(801) * b(115) - b(118) = b(118) - lu(806) * b(116) - b(120) = b(120) - lu(807) * b(116) - b(121) = b(121) - lu(808) * b(116) - b(123) = b(123) - lu(809) * b(116) - b(124) = b(124) - lu(810) * b(116) - b(125) = b(125) - lu(811) * b(116) - b(126) = b(126) - lu(812) * b(116) - b(127) = b(127) - lu(813) * b(116) - b(128) = b(128) - lu(814) * b(116) - b(129) = b(129) - lu(815) * b(116) - b(130) = b(130) - lu(816) * b(116) - b(131) = b(131) - lu(817) * b(116) - b(134) = b(134) - lu(818) * b(116) - b(118) = b(118) - lu(825) * b(117) - b(121) = b(121) - lu(826) * b(117) - b(122) = b(122) - lu(827) * b(117) - b(124) = b(124) - lu(828) * b(117) - b(126) = b(126) - lu(829) * b(117) - b(127) = b(127) - lu(830) * b(117) - b(128) = b(128) - lu(831) * b(117) - b(130) = b(130) - lu(832) * b(117) - b(131) = b(131) - lu(833) * b(117) - b(132) = b(132) - lu(834) * b(117) - b(133) = b(133) - lu(835) * b(117) - b(134) = b(134) - lu(836) * b(117) - b(120) = b(120) - lu(840) * b(118) - b(121) = b(121) - lu(841) * b(118) - b(122) = b(122) - lu(842) * b(118) - b(123) = b(123) - lu(843) * b(118) - b(125) = b(125) - lu(844) * b(118) - b(127) = b(127) - lu(845) * b(118) - b(128) = b(128) - lu(846) * b(118) - b(131) = b(131) - lu(847) * b(118) - b(134) = b(134) - lu(848) * b(118) - b(135) = b(135) - lu(849) * b(118) - END SUBROUTINE lu_slv03 - - SUBROUTINE lu_slv04(lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(in) :: lu(:) - REAL(KIND=r8), intent(inout) :: b(:) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - b(120) = b(120) - lu(873) * b(119) - b(123) = b(123) - lu(874) * b(119) - b(124) = b(124) - lu(875) * b(119) - b(125) = b(125) - lu(876) * b(119) - b(126) = b(126) - lu(877) * b(119) - b(127) = b(127) - lu(878) * b(119) - b(129) = b(129) - lu(879) * b(119) - b(130) = b(130) - lu(880) * b(119) - b(131) = b(131) - lu(881) * b(119) - b(132) = b(132) - lu(882) * b(119) - b(133) = b(133) - lu(883) * b(119) - b(134) = b(134) - lu(884) * b(119) - b(135) = b(135) - lu(885) * b(119) - b(121) = b(121) - lu(904) * b(120) - b(122) = b(122) - lu(905) * b(120) - b(123) = b(123) - lu(906) * b(120) - b(124) = b(124) - lu(907) * b(120) - b(125) = b(125) - lu(908) * b(120) - b(126) = b(126) - lu(909) * b(120) - b(127) = b(127) - lu(910) * b(120) - b(128) = b(128) - lu(911) * b(120) - b(129) = b(129) - lu(912) * b(120) - b(130) = b(130) - lu(913) * b(120) - b(131) = b(131) - lu(914) * b(120) - b(134) = b(134) - lu(915) * b(120) - b(135) = b(135) - lu(916) * b(120) - b(122) = b(122) - lu(944) * b(121) - b(123) = b(123) - lu(945) * b(121) - b(124) = b(124) - lu(946) * b(121) - b(125) = b(125) - lu(947) * b(121) - b(126) = b(126) - lu(948) * b(121) - b(127) = b(127) - lu(949) * b(121) - b(128) = b(128) - lu(950) * b(121) - b(129) = b(129) - lu(951) * b(121) - b(130) = b(130) - lu(952) * b(121) - b(131) = b(131) - lu(953) * b(121) - b(132) = b(132) - lu(954) * b(121) - b(133) = b(133) - lu(955) * b(121) - b(134) = b(134) - lu(956) * b(121) - b(135) = b(135) - lu(957) * b(121) - b(123) = b(123) - lu(971) * b(122) - b(124) = b(124) - lu(972) * b(122) - b(125) = b(125) - lu(973) * b(122) - b(126) = b(126) - lu(974) * b(122) - b(127) = b(127) - lu(975) * b(122) - b(128) = b(128) - lu(976) * b(122) - b(129) = b(129) - lu(977) * b(122) - b(130) = b(130) - lu(978) * b(122) - b(131) = b(131) - lu(979) * b(122) - b(132) = b(132) - lu(980) * b(122) - b(133) = b(133) - lu(981) * b(122) - b(134) = b(134) - lu(982) * b(122) - b(135) = b(135) - lu(983) * b(122) - b(124) = b(124) - lu(1017) * b(123) - b(125) = b(125) - lu(1018) * b(123) - b(126) = b(126) - lu(1019) * b(123) - b(127) = b(127) - lu(1020) * b(123) - b(128) = b(128) - lu(1021) * b(123) - b(129) = b(129) - lu(1022) * b(123) - b(130) = b(130) - lu(1023) * b(123) - b(131) = b(131) - lu(1024) * b(123) - b(132) = b(132) - lu(1025) * b(123) - b(133) = b(133) - lu(1026) * b(123) - b(134) = b(134) - lu(1027) * b(123) - b(135) = b(135) - lu(1028) * b(123) - b(125) = b(125) - lu(1045) * b(124) - b(126) = b(126) - lu(1046) * b(124) - b(127) = b(127) - lu(1047) * b(124) - b(128) = b(128) - lu(1048) * b(124) - b(129) = b(129) - lu(1049) * b(124) - b(130) = b(130) - lu(1050) * b(124) - b(131) = b(131) - lu(1051) * b(124) - b(132) = b(132) - lu(1052) * b(124) - b(133) = b(133) - lu(1053) * b(124) - b(134) = b(134) - lu(1054) * b(124) - b(135) = b(135) - lu(1055) * b(124) - b(126) = b(126) - lu(1115) * b(125) - b(127) = b(127) - lu(1116) * b(125) - b(128) = b(128) - lu(1117) * b(125) - b(129) = b(129) - lu(1118) * b(125) - b(130) = b(130) - lu(1119) * b(125) - b(131) = b(131) - lu(1120) * b(125) - b(132) = b(132) - lu(1121) * b(125) - b(133) = b(133) - lu(1122) * b(125) - b(134) = b(134) - lu(1123) * b(125) - b(135) = b(135) - lu(1124) * b(125) - b(127) = b(127) - lu(1151) * b(126) - b(128) = b(128) - lu(1152) * b(126) - b(129) = b(129) - lu(1153) * b(126) - b(130) = b(130) - lu(1154) * b(126) - b(131) = b(131) - lu(1155) * b(126) - b(132) = b(132) - lu(1156) * b(126) - b(133) = b(133) - lu(1157) * b(126) - b(134) = b(134) - lu(1158) * b(126) - b(135) = b(135) - lu(1159) * b(126) - b(128) = b(128) - lu(1172) * b(127) - b(129) = b(129) - lu(1173) * b(127) - b(130) = b(130) - lu(1174) * b(127) - b(131) = b(131) - lu(1175) * b(127) - b(132) = b(132) - lu(1176) * b(127) - b(133) = b(133) - lu(1177) * b(127) - b(134) = b(134) - lu(1178) * b(127) - b(135) = b(135) - lu(1179) * b(127) - b(129) = b(129) - lu(1197) * b(128) - b(130) = b(130) - lu(1198) * b(128) - b(131) = b(131) - lu(1199) * b(128) - b(132) = b(132) - lu(1200) * b(128) - b(133) = b(133) - lu(1201) * b(128) - b(134) = b(134) - lu(1202) * b(128) - b(135) = b(135) - lu(1203) * b(128) - b(130) = b(130) - lu(1253) * b(129) - b(131) = b(131) - lu(1254) * b(129) - b(132) = b(132) - lu(1255) * b(129) - b(133) = b(133) - lu(1256) * b(129) - b(134) = b(134) - lu(1257) * b(129) - b(135) = b(135) - lu(1258) * b(129) - b(131) = b(131) - lu(1291) * b(130) - b(132) = b(132) - lu(1292) * b(130) - b(133) = b(133) - lu(1293) * b(130) - b(134) = b(134) - lu(1294) * b(130) - b(135) = b(135) - lu(1295) * b(130) - b(132) = b(132) - lu(1390) * b(131) - b(133) = b(133) - lu(1391) * b(131) - b(134) = b(134) - lu(1392) * b(131) - b(135) = b(135) - lu(1393) * b(131) - b(133) = b(133) - lu(1435) * b(132) - b(134) = b(134) - lu(1436) * b(132) - b(135) = b(135) - lu(1437) * b(132) - b(134) = b(134) - lu(1458) * b(133) - b(135) = b(135) - lu(1459) * b(133) - b(135) = b(135) - lu(1485) * b(134) - END SUBROUTINE lu_slv04 - - SUBROUTINE lu_slv05(lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(in) :: lu(:) - REAL(KIND=r8), intent(inout) :: b(:) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... Solve U * x = y - !----------------------------------------------------------------------- - b(135) = b(135) * lu(1509) - b(134) = b(134) - lu(1508) * b(135) - b(133) = b(133) - lu(1507) * b(135) - b(132) = b(132) - lu(1506) * b(135) - b(131) = b(131) - lu(1505) * b(135) - b(130) = b(130) - lu(1504) * b(135) - b(129) = b(129) - lu(1503) * b(135) - b(128) = b(128) - lu(1502) * b(135) - b(127) = b(127) - lu(1501) * b(135) - b(126) = b(126) - lu(1500) * b(135) - b(125) = b(125) - lu(1499) * b(135) - b(124) = b(124) - lu(1498) * b(135) - b(123) = b(123) - lu(1497) * b(135) - b(122) = b(122) - lu(1496) * b(135) - b(121) = b(121) - lu(1495) * b(135) - b(120) = b(120) - lu(1494) * b(135) - b(119) = b(119) - lu(1493) * b(135) - b(118) = b(118) - lu(1492) * b(135) - b(117) = b(117) - lu(1491) * b(135) - b(108) = b(108) - lu(1490) * b(135) - b(103) = b(103) - lu(1489) * b(135) - b(90) = b(90) - lu(1488) * b(135) - b(64) = b(64) - lu(1487) * b(135) - b(54) = b(54) - lu(1486) * b(135) - b(134) = b(134) * lu(1484) - b(133) = b(133) - lu(1483) * b(134) - b(132) = b(132) - lu(1482) * b(134) - b(131) = b(131) - lu(1481) * b(134) - b(130) = b(130) - lu(1480) * b(134) - b(129) = b(129) - lu(1479) * b(134) - b(128) = b(128) - lu(1478) * b(134) - b(127) = b(127) - lu(1477) * b(134) - b(126) = b(126) - lu(1476) * b(134) - b(125) = b(125) - lu(1475) * b(134) - b(124) = b(124) - lu(1474) * b(134) - b(123) = b(123) - lu(1473) * b(134) - b(122) = b(122) - lu(1472) * b(134) - b(121) = b(121) - lu(1471) * b(134) - b(120) = b(120) - lu(1470) * b(134) - b(119) = b(119) - lu(1469) * b(134) - b(118) = b(118) - lu(1468) * b(134) - b(117) = b(117) - lu(1467) * b(134) - b(116) = b(116) - lu(1466) * b(134) - b(108) = b(108) - lu(1465) * b(134) - b(99) = b(99) - lu(1464) * b(134) - b(88) = b(88) - lu(1463) * b(134) - b(36) = b(36) - lu(1462) * b(134) - b(34) = b(34) - lu(1461) * b(134) - b(26) = b(26) - lu(1460) * b(134) - b(133) = b(133) * lu(1457) - b(132) = b(132) - lu(1456) * b(133) - b(131) = b(131) - lu(1455) * b(133) - b(130) = b(130) - lu(1454) * b(133) - b(129) = b(129) - lu(1453) * b(133) - b(128) = b(128) - lu(1452) * b(133) - b(127) = b(127) - lu(1451) * b(133) - b(126) = b(126) - lu(1450) * b(133) - b(125) = b(125) - lu(1449) * b(133) - b(124) = b(124) - lu(1448) * b(133) - b(123) = b(123) - lu(1447) * b(133) - b(122) = b(122) - lu(1446) * b(133) - b(121) = b(121) - lu(1445) * b(133) - b(120) = b(120) - lu(1444) * b(133) - b(119) = b(119) - lu(1443) * b(133) - b(118) = b(118) - lu(1442) * b(133) - b(117) = b(117) - lu(1441) * b(133) - b(108) = b(108) - lu(1440) * b(133) - b(88) = b(88) - lu(1439) * b(133) - b(34) = b(34) - lu(1438) * b(133) - b(132) = b(132) * lu(1434) - b(131) = b(131) - lu(1433) * b(132) - b(130) = b(130) - lu(1432) * b(132) - b(129) = b(129) - lu(1431) * b(132) - b(128) = b(128) - lu(1430) * b(132) - b(127) = b(127) - lu(1429) * b(132) - b(126) = b(126) - lu(1428) * b(132) - b(125) = b(125) - lu(1427) * b(132) - b(124) = b(124) - lu(1426) * b(132) - b(123) = b(123) - lu(1425) * b(132) - b(122) = b(122) - lu(1424) * b(132) - b(121) = b(121) - lu(1423) * b(132) - b(120) = b(120) - lu(1422) * b(132) - b(119) = b(119) - lu(1421) * b(132) - b(118) = b(118) - lu(1420) * b(132) - b(116) = b(116) - lu(1419) * b(132) - b(115) = b(115) - lu(1418) * b(132) - b(114) = b(114) - lu(1417) * b(132) - b(113) = b(113) - lu(1416) * b(132) - b(112) = b(112) - lu(1415) * b(132) - b(111) = b(111) - lu(1414) * b(132) - b(110) = b(110) - lu(1413) * b(132) - b(109) = b(109) - lu(1412) * b(132) - b(107) = b(107) - lu(1411) * b(132) - b(106) = b(106) - lu(1410) * b(132) - b(105) = b(105) - lu(1409) * b(132) - b(104) = b(104) - lu(1408) * b(132) - b(103) = b(103) - lu(1407) * b(132) - b(102) = b(102) - lu(1406) * b(132) - b(101) = b(101) - lu(1405) * b(132) - b(99) = b(99) - lu(1404) * b(132) - b(98) = b(98) - lu(1403) * b(132) - b(97) = b(97) - lu(1402) * b(132) - b(95) = b(95) - lu(1401) * b(132) - b(94) = b(94) - lu(1400) * b(132) - b(81) = b(81) - lu(1399) * b(132) - b(73) = b(73) - lu(1398) * b(132) - b(49) = b(49) - lu(1397) * b(132) - b(47) = b(47) - lu(1396) * b(132) - b(40) = b(40) - lu(1395) * b(132) - b(39) = b(39) - lu(1394) * b(132) - b(131) = b(131) * lu(1389) - b(130) = b(130) - lu(1388) * b(131) - b(129) = b(129) - lu(1387) * b(131) - b(128) = b(128) - lu(1386) * b(131) - b(127) = b(127) - lu(1385) * b(131) - b(126) = b(126) - lu(1384) * b(131) - b(125) = b(125) - lu(1383) * b(131) - b(124) = b(124) - lu(1382) * b(131) - b(123) = b(123) - lu(1381) * b(131) - b(122) = b(122) - lu(1380) * b(131) - b(121) = b(121) - lu(1379) * b(131) - b(120) = b(120) - lu(1378) * b(131) - b(119) = b(119) - lu(1377) * b(131) - b(118) = b(118) - lu(1376) * b(131) - b(117) = b(117) - lu(1375) * b(131) - b(116) = b(116) - lu(1374) * b(131) - b(115) = b(115) - lu(1373) * b(131) - b(114) = b(114) - lu(1372) * b(131) - b(113) = b(113) - lu(1371) * b(131) - b(112) = b(112) - lu(1370) * b(131) - b(111) = b(111) - lu(1369) * b(131) - b(110) = b(110) - lu(1368) * b(131) - b(109) = b(109) - lu(1367) * b(131) - b(108) = b(108) - lu(1366) * b(131) - b(107) = b(107) - lu(1365) * b(131) - b(106) = b(106) - lu(1364) * b(131) - b(105) = b(105) - lu(1363) * b(131) - b(104) = b(104) - lu(1362) * b(131) - b(103) = b(103) - lu(1361) * b(131) - b(102) = b(102) - lu(1360) * b(131) - b(101) = b(101) - lu(1359) * b(131) - b(100) = b(100) - lu(1358) * b(131) - b(99) = b(99) - lu(1357) * b(131) - b(98) = b(98) - lu(1356) * b(131) - b(97) = b(97) - lu(1355) * b(131) - b(96) = b(96) - lu(1354) * b(131) - b(95) = b(95) - lu(1353) * b(131) - b(94) = b(94) - lu(1352) * b(131) - b(93) = b(93) - lu(1351) * b(131) - b(92) = b(92) - lu(1350) * b(131) - b(91) = b(91) - lu(1349) * b(131) - b(90) = b(90) - lu(1348) * b(131) - b(89) = b(89) - lu(1347) * b(131) - b(88) = b(88) - lu(1346) * b(131) - b(83) = b(83) - lu(1345) * b(131) - b(82) = b(82) - lu(1344) * b(131) - b(81) = b(81) - lu(1343) * b(131) - b(80) = b(80) - lu(1342) * b(131) - b(79) = b(79) - lu(1341) * b(131) - b(77) = b(77) - lu(1340) * b(131) - b(76) = b(76) - lu(1339) * b(131) - b(75) = b(75) - lu(1338) * b(131) - b(74) = b(74) - lu(1337) * b(131) - b(73) = b(73) - lu(1336) * b(131) - b(71) = b(71) - lu(1335) * b(131) - b(69) = b(69) - lu(1334) * b(131) - b(68) = b(68) - lu(1333) * b(131) - b(67) = b(67) - lu(1332) * b(131) - b(66) = b(66) - lu(1331) * b(131) - b(65) = b(65) - lu(1330) * b(131) - b(64) = b(64) - lu(1329) * b(131) - b(63) = b(63) - lu(1328) * b(131) - b(62) = b(62) - lu(1327) * b(131) - b(60) = b(60) - lu(1326) * b(131) - b(59) = b(59) - lu(1325) * b(131) - b(57) = b(57) - lu(1324) * b(131) - b(55) = b(55) - lu(1323) * b(131) - b(53) = b(53) - lu(1322) * b(131) - b(52) = b(52) - lu(1321) * b(131) - b(51) = b(51) - lu(1320) * b(131) - b(50) = b(50) - lu(1319) * b(131) - b(49) = b(49) - lu(1318) * b(131) - b(48) = b(48) - lu(1317) * b(131) - b(47) = b(47) - lu(1316) * b(131) - b(45) = b(45) - lu(1315) * b(131) - b(44) = b(44) - lu(1314) * b(131) - b(43) = b(43) - lu(1313) * b(131) - b(42) = b(42) - lu(1312) * b(131) - b(41) = b(41) - lu(1311) * b(131) - b(39) = b(39) - lu(1310) * b(131) - b(38) = b(38) - lu(1309) * b(131) - b(37) = b(37) - lu(1308) * b(131) - b(36) = b(36) - lu(1307) * b(131) - b(35) = b(35) - lu(1306) * b(131) - b(32) = b(32) - lu(1305) * b(131) - b(31) = b(31) - lu(1304) * b(131) - b(30) = b(30) - lu(1303) * b(131) - b(25) = b(25) - lu(1302) * b(131) - b(23) = b(23) - lu(1301) * b(131) - b(22) = b(22) - lu(1300) * b(131) - b(21) = b(21) - lu(1299) * b(131) - b(20) = b(20) - lu(1298) * b(131) - b(19) = b(19) - lu(1297) * b(131) - b(17) = b(17) - lu(1296) * b(131) - END SUBROUTINE lu_slv05 - - SUBROUTINE lu_slv06(lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(in) :: lu(:) - REAL(KIND=r8), intent(inout) :: b(:) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - b(130) = b(130) * lu(1290) - b(129) = b(129) - lu(1289) * b(130) - b(128) = b(128) - lu(1288) * b(130) - b(127) = b(127) - lu(1287) * b(130) - b(126) = b(126) - lu(1286) * b(130) - b(125) = b(125) - lu(1285) * b(130) - b(124) = b(124) - lu(1284) * b(130) - b(123) = b(123) - lu(1283) * b(130) - b(122) = b(122) - lu(1282) * b(130) - b(121) = b(121) - lu(1281) * b(130) - b(120) = b(120) - lu(1280) * b(130) - b(119) = b(119) - lu(1279) * b(130) - b(118) = b(118) - lu(1278) * b(130) - b(117) = b(117) - lu(1277) * b(130) - b(116) = b(116) - lu(1276) * b(130) - b(115) = b(115) - lu(1275) * b(130) - b(114) = b(114) - lu(1274) * b(130) - b(109) = b(109) - lu(1273) * b(130) - b(105) = b(105) - lu(1272) * b(130) - b(103) = b(103) - lu(1271) * b(130) - b(100) = b(100) - lu(1270) * b(130) - b(99) = b(99) - lu(1269) * b(130) - b(92) = b(92) - lu(1268) * b(130) - b(84) = b(84) - lu(1267) * b(130) - b(81) = b(81) - lu(1266) * b(130) - b(71) = b(71) - lu(1265) * b(130) - b(70) = b(70) - lu(1264) * b(130) - b(66) = b(66) - lu(1263) * b(130) - b(60) = b(60) - lu(1262) * b(130) - b(57) = b(57) - lu(1261) * b(130) - b(40) = b(40) - lu(1260) * b(130) - b(31) = b(31) - lu(1259) * b(130) - b(129) = b(129) * lu(1252) - b(128) = b(128) - lu(1251) * b(129) - b(127) = b(127) - lu(1250) * b(129) - b(126) = b(126) - lu(1249) * b(129) - b(125) = b(125) - lu(1248) * b(129) - b(124) = b(124) - lu(1247) * b(129) - b(123) = b(123) - lu(1246) * b(129) - b(122) = b(122) - lu(1245) * b(129) - b(121) = b(121) - lu(1244) * b(129) - b(120) = b(120) - lu(1243) * b(129) - b(119) = b(119) - lu(1242) * b(129) - b(118) = b(118) - lu(1241) * b(129) - b(115) = b(115) - lu(1240) * b(129) - b(114) = b(114) - lu(1239) * b(129) - b(113) = b(113) - lu(1238) * b(129) - b(112) = b(112) - lu(1237) * b(129) - b(111) = b(111) - lu(1236) * b(129) - b(110) = b(110) - lu(1235) * b(129) - b(109) = b(109) - lu(1234) * b(129) - b(107) = b(107) - lu(1233) * b(129) - b(106) = b(106) - lu(1232) * b(129) - b(105) = b(105) - lu(1231) * b(129) - b(104) = b(104) - lu(1230) * b(129) - b(103) = b(103) - lu(1229) * b(129) - b(101) = b(101) - lu(1228) * b(129) - b(98) = b(98) - lu(1227) * b(129) - b(97) = b(97) - lu(1226) * b(129) - b(96) = b(96) - lu(1225) * b(129) - b(95) = b(95) - lu(1224) * b(129) - b(92) = b(92) - lu(1223) * b(129) - b(91) = b(91) - lu(1222) * b(129) - b(89) = b(89) - lu(1221) * b(129) - b(87) = b(87) - lu(1220) * b(129) - b(86) = b(86) - lu(1219) * b(129) - b(85) = b(85) - lu(1218) * b(129) - b(83) = b(83) - lu(1217) * b(129) - b(81) = b(81) - lu(1216) * b(129) - b(80) = b(80) - lu(1215) * b(129) - b(79) = b(79) - lu(1214) * b(129) - b(77) = b(77) - lu(1213) * b(129) - b(66) = b(66) - lu(1212) * b(129) - b(65) = b(65) - lu(1211) * b(129) - b(64) = b(64) - lu(1210) * b(129) - b(56) = b(56) - lu(1209) * b(129) - b(55) = b(55) - lu(1208) * b(129) - b(54) = b(54) - lu(1207) * b(129) - b(49) = b(49) - lu(1206) * b(129) - b(47) = b(47) - lu(1205) * b(129) - b(41) = b(41) - lu(1204) * b(129) - b(128) = b(128) * lu(1196) - b(127) = b(127) - lu(1195) * b(128) - b(126) = b(126) - lu(1194) * b(128) - b(125) = b(125) - lu(1193) * b(128) - b(124) = b(124) - lu(1192) * b(128) - b(123) = b(123) - lu(1191) * b(128) - b(122) = b(122) - lu(1190) * b(128) - b(121) = b(121) - lu(1189) * b(128) - b(120) = b(120) - lu(1188) * b(128) - b(118) = b(118) - lu(1187) * b(128) - b(117) = b(117) - lu(1186) * b(128) - b(116) = b(116) - lu(1185) * b(128) - b(99) = b(99) - lu(1184) * b(128) - b(84) = b(84) - lu(1183) * b(128) - b(70) = b(70) - lu(1182) * b(128) - b(46) = b(46) - lu(1181) * b(128) - b(33) = b(33) - lu(1180) * b(128) - b(127) = b(127) * lu(1171) - b(126) = b(126) - lu(1170) * b(127) - b(125) = b(125) - lu(1169) * b(127) - b(124) = b(124) - lu(1168) * b(127) - b(123) = b(123) - lu(1167) * b(127) - b(122) = b(122) - lu(1166) * b(127) - b(121) = b(121) - lu(1165) * b(127) - b(120) = b(120) - lu(1164) * b(127) - b(119) = b(119) - lu(1163) * b(127) - b(118) = b(118) - lu(1162) * b(127) - b(117) = b(117) - lu(1161) * b(127) - b(108) = b(108) - lu(1160) * b(127) - b(126) = b(126) * lu(1150) - b(125) = b(125) - lu(1149) * b(126) - b(124) = b(124) - lu(1148) * b(126) - b(123) = b(123) - lu(1147) * b(126) - b(122) = b(122) - lu(1146) * b(126) - b(121) = b(121) - lu(1145) * b(126) - b(120) = b(120) - lu(1144) * b(126) - b(119) = b(119) - lu(1143) * b(126) - b(118) = b(118) - lu(1142) * b(126) - b(117) = b(117) - lu(1141) * b(126) - b(115) = b(115) - lu(1140) * b(126) - b(108) = b(108) - lu(1139) * b(126) - b(104) = b(104) - lu(1138) * b(126) - b(103) = b(103) - lu(1137) * b(126) - b(100) = b(100) - lu(1136) * b(126) - b(95) = b(95) - lu(1135) * b(126) - b(93) = b(93) - lu(1134) * b(126) - b(91) = b(91) - lu(1133) * b(126) - b(83) = b(83) - lu(1132) * b(126) - b(81) = b(81) - lu(1131) * b(126) - b(74) = b(74) - lu(1130) * b(126) - b(64) = b(64) - lu(1129) * b(126) - b(63) = b(63) - lu(1128) * b(126) - b(38) = b(38) - lu(1127) * b(126) - b(37) = b(37) - lu(1126) * b(126) - b(29) = b(29) - lu(1125) * b(126) - b(125) = b(125) * lu(1114) - b(124) = b(124) - lu(1113) * b(125) - b(123) = b(123) - lu(1112) * b(125) - b(122) = b(122) - lu(1111) * b(125) - b(121) = b(121) - lu(1110) * b(125) - b(120) = b(120) - lu(1109) * b(125) - b(119) = b(119) - lu(1108) * b(125) - b(118) = b(118) - lu(1107) * b(125) - b(117) = b(117) - lu(1106) * b(125) - b(115) = b(115) - lu(1105) * b(125) - b(114) = b(114) - lu(1104) * b(125) - b(113) = b(113) - lu(1103) * b(125) - b(112) = b(112) - lu(1102) * b(125) - b(111) = b(111) - lu(1101) * b(125) - b(110) = b(110) - lu(1100) * b(125) - b(109) = b(109) - lu(1099) * b(125) - b(108) = b(108) - lu(1098) * b(125) - b(107) = b(107) - lu(1097) * b(125) - b(106) = b(106) - lu(1096) * b(125) - b(105) = b(105) - lu(1095) * b(125) - b(104) = b(104) - lu(1094) * b(125) - b(103) = b(103) - lu(1093) * b(125) - b(101) = b(101) - lu(1092) * b(125) - b(98) = b(98) - lu(1091) * b(125) - b(97) = b(97) - lu(1090) * b(125) - b(96) = b(96) - lu(1089) * b(125) - b(95) = b(95) - lu(1088) * b(125) - b(93) = b(93) - lu(1087) * b(125) - b(91) = b(91) - lu(1086) * b(125) - b(90) = b(90) - lu(1085) * b(125) - b(89) = b(89) - lu(1084) * b(125) - b(84) = b(84) - lu(1083) * b(125) - b(83) = b(83) - lu(1082) * b(125) - b(81) = b(81) - lu(1081) * b(125) - b(80) = b(80) - lu(1080) * b(125) - b(79) = b(79) - lu(1079) * b(125) - b(77) = b(77) - lu(1078) * b(125) - b(76) = b(76) - lu(1077) * b(125) - b(75) = b(75) - lu(1076) * b(125) - b(74) = b(74) - lu(1075) * b(125) - b(69) = b(69) - lu(1074) * b(125) - b(67) = b(67) - lu(1073) * b(125) - b(66) = b(66) - lu(1072) * b(125) - b(65) = b(65) - lu(1071) * b(125) - b(64) = b(64) - lu(1070) * b(125) - b(62) = b(62) - lu(1069) * b(125) - b(60) = b(60) - lu(1068) * b(125) - b(59) = b(59) - lu(1067) * b(125) - b(56) = b(56) - lu(1066) * b(125) - b(54) = b(54) - lu(1065) * b(125) - b(53) = b(53) - lu(1064) * b(125) - b(52) = b(52) - lu(1063) * b(125) - b(51) = b(51) - lu(1062) * b(125) - b(50) = b(50) - lu(1061) * b(125) - b(45) = b(45) - lu(1060) * b(125) - b(44) = b(44) - lu(1059) * b(125) - b(43) = b(43) - lu(1058) * b(125) - b(42) = b(42) - lu(1057) * b(125) - b(24) = b(24) - lu(1056) * b(125) - b(124) = b(124) * lu(1044) - b(123) = b(123) - lu(1043) * b(124) - b(122) = b(122) - lu(1042) * b(124) - b(121) = b(121) - lu(1041) * b(124) - b(120) = b(120) - lu(1040) * b(124) - b(119) = b(119) - lu(1039) * b(124) - b(118) = b(118) - lu(1038) * b(124) - b(117) = b(117) - lu(1037) * b(124) - b(116) = b(116) - lu(1036) * b(124) - b(100) = b(100) - lu(1035) * b(124) - b(99) = b(99) - lu(1034) * b(124) - b(93) = b(93) - lu(1033) * b(124) - b(46) = b(46) - lu(1032) * b(124) - b(33) = b(33) - lu(1031) * b(124) - b(29) = b(29) - lu(1030) * b(124) - b(18) = b(18) - lu(1029) * b(124) - END SUBROUTINE lu_slv06 - - SUBROUTINE lu_slv07(lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(in) :: lu(:) - REAL(KIND=r8), intent(inout) :: b(:) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - b(123) = b(123) * lu(1016) - b(122) = b(122) - lu(1015) * b(123) - b(121) = b(121) - lu(1014) * b(123) - b(120) = b(120) - lu(1013) * b(123) - b(119) = b(119) - lu(1012) * b(123) - b(118) = b(118) - lu(1011) * b(123) - b(116) = b(116) - lu(1010) * b(123) - b(115) = b(115) - lu(1009) * b(123) - b(114) = b(114) - lu(1008) * b(123) - b(113) = b(113) - lu(1007) * b(123) - b(112) = b(112) - lu(1006) * b(123) - b(111) = b(111) - lu(1005) * b(123) - b(110) = b(110) - lu(1004) * b(123) - b(109) = b(109) - lu(1003) * b(123) - b(107) = b(107) - lu(1002) * b(123) - b(106) = b(106) - lu(1001) * b(123) - b(105) = b(105) - lu(1000) * b(123) - b(104) = b(104) - lu(999) * b(123) - b(103) = b(103) - lu(998) * b(123) - b(102) = b(102) - lu(997) * b(123) - b(101) = b(101) - lu(996) * b(123) - b(99) = b(99) - lu(995) * b(123) - b(98) = b(98) - lu(994) * b(123) - b(95) = b(95) - lu(993) * b(123) - b(94) = b(94) - lu(992) * b(123) - b(83) = b(83) - lu(991) * b(123) - b(82) = b(82) - lu(990) * b(123) - b(75) = b(75) - lu(989) * b(123) - b(73) = b(73) - lu(988) * b(123) - b(64) = b(64) - lu(987) * b(123) - b(63) = b(63) - lu(986) * b(123) - b(28) = b(28) - lu(985) * b(123) - b(27) = b(27) - lu(984) * b(123) - b(122) = b(122) * lu(970) - b(121) = b(121) - lu(969) * b(122) - b(120) = b(120) - lu(968) * b(122) - b(119) = b(119) - lu(967) * b(122) - b(118) = b(118) - lu(966) * b(122) - b(117) = b(117) - lu(965) * b(122) - b(108) = b(108) - lu(964) * b(122) - b(90) = b(90) - lu(963) * b(122) - b(88) = b(88) - lu(962) * b(122) - b(32) = b(32) - lu(961) * b(122) - b(30) = b(30) - lu(960) * b(122) - b(28) = b(28) - lu(959) * b(122) - b(25) = b(25) - lu(958) * b(122) - b(121) = b(121) * lu(943) - b(120) = b(120) - lu(942) * b(121) - b(119) = b(119) - lu(941) * b(121) - b(118) = b(118) - lu(940) * b(121) - b(117) = b(117) - lu(939) * b(121) - b(116) = b(116) - lu(938) * b(121) - b(108) = b(108) - lu(937) * b(121) - b(103) = b(103) - lu(936) * b(121) - b(100) = b(100) - lu(935) * b(121) - b(99) = b(99) - lu(934) * b(121) - b(93) = b(93) - lu(933) * b(121) - b(92) = b(92) - lu(932) * b(121) - b(90) = b(90) - lu(931) * b(121) - b(87) = b(87) - lu(930) * b(121) - b(86) = b(86) - lu(929) * b(121) - b(85) = b(85) - lu(928) * b(121) - b(84) = b(84) - lu(927) * b(121) - b(82) = b(82) - lu(926) * b(121) - b(78) = b(78) - lu(925) * b(121) - b(74) = b(74) - lu(924) * b(121) - b(72) = b(72) - lu(923) * b(121) - b(70) = b(70) - lu(922) * b(121) - b(61) = b(61) - lu(921) * b(121) - b(58) = b(58) - lu(920) * b(121) - b(48) = b(48) - lu(919) * b(121) - b(28) = b(28) - lu(918) * b(121) - b(27) = b(27) - lu(917) * b(121) - b(120) = b(120) * lu(903) - b(118) = b(118) - lu(902) * b(120) - b(116) = b(116) - lu(901) * b(120) - b(103) = b(103) - lu(900) * b(120) - b(99) = b(99) - lu(899) * b(120) - b(95) = b(95) - lu(898) * b(120) - b(92) = b(92) - lu(897) * b(120) - b(87) = b(87) - lu(896) * b(120) - b(86) = b(86) - lu(895) * b(120) - b(85) = b(85) - lu(894) * b(120) - b(82) = b(82) - lu(893) * b(120) - b(78) = b(78) - lu(892) * b(120) - b(72) = b(72) - lu(891) * b(120) - b(61) = b(61) - lu(890) * b(120) - b(58) = b(58) - lu(889) * b(120) - b(56) = b(56) - lu(888) * b(120) - b(28) = b(28) - lu(887) * b(120) - b(27) = b(27) - lu(886) * b(120) - b(119) = b(119) * lu(872) - b(115) = b(115) - lu(871) * b(119) - b(114) = b(114) - lu(870) * b(119) - b(113) = b(113) - lu(869) * b(119) - b(112) = b(112) - lu(868) * b(119) - b(111) = b(111) - lu(867) * b(119) - b(110) = b(110) - lu(866) * b(119) - b(109) = b(109) - lu(865) * b(119) - b(107) = b(107) - lu(864) * b(119) - b(106) = b(106) - lu(863) * b(119) - b(105) = b(105) - lu(862) * b(119) - b(104) = b(104) - lu(861) * b(119) - b(103) = b(103) - lu(860) * b(119) - b(96) = b(96) - lu(859) * b(119) - b(95) = b(95) - lu(858) * b(119) - b(91) = b(91) - lu(857) * b(119) - b(81) = b(81) - lu(856) * b(119) - b(80) = b(80) - lu(855) * b(119) - b(75) = b(75) - lu(854) * b(119) - b(68) = b(68) - lu(853) * b(119) - b(50) = b(50) - lu(852) * b(119) - b(47) = b(47) - lu(851) * b(119) - b(35) = b(35) - lu(850) * b(119) - b(118) = b(118) * lu(839) - b(103) = b(103) - lu(838) * b(118) - b(90) = b(90) - lu(837) * b(118) - b(117) = b(117) * lu(824) - b(100) = b(100) - lu(823) * b(117) - b(93) = b(93) - lu(822) * b(117) - b(84) = b(84) - lu(821) * b(117) - b(33) = b(33) - lu(820) * b(117) - b(29) = b(29) - lu(819) * b(117) - b(116) = b(116) * lu(805) - b(99) = b(99) - lu(804) * b(116) - b(82) = b(82) - lu(803) * b(116) - b(46) = b(46) - lu(802) * b(116) - b(115) = b(115) * lu(789) - b(114) = b(114) - lu(788) * b(115) - b(113) = b(113) - lu(787) * b(115) - b(112) = b(112) - lu(786) * b(115) - b(111) = b(111) - lu(785) * b(115) - b(110) = b(110) - lu(784) * b(115) - b(109) = b(109) - lu(783) * b(115) - b(107) = b(107) - lu(782) * b(115) - b(105) = b(105) - lu(781) * b(115) - b(103) = b(103) - lu(780) * b(115) - b(95) = b(95) - lu(779) * b(115) - b(81) = b(81) - lu(778) * b(115) - b(75) = b(75) - lu(777) * b(115) - b(62) = b(62) - lu(776) * b(115) - b(57) = b(57) - lu(775) * b(115) - b(47) = b(47) - lu(774) * b(115) - b(114) = b(114) * lu(760) - b(109) = b(109) - lu(759) * b(114) - b(105) = b(105) - lu(758) * b(114) - b(75) = b(75) - lu(757) * b(114) - b(71) = b(71) - lu(756) * b(114) - b(62) = b(62) - lu(755) * b(114) - b(113) = b(113) * lu(740) - b(112) = b(112) - lu(739) * b(113) - b(109) = b(109) - lu(738) * b(113) - b(105) = b(105) - lu(737) * b(113) - b(104) = b(104) - lu(736) * b(113) - b(103) = b(103) - lu(735) * b(113) - b(102) = b(102) - lu(734) * b(113) - b(112) = b(112) * lu(721) - b(110) = b(110) - lu(720) * b(112) - b(109) = b(109) - lu(719) * b(112) - b(105) = b(105) - lu(718) * b(112) - b(103) = b(103) - lu(717) * b(112) - b(97) = b(97) - lu(716) * b(112) - b(95) = b(95) - lu(715) * b(112) - b(68) = b(68) - lu(714) * b(112) - b(43) = b(43) - lu(713) * b(112) - b(111) = b(111) * lu(697) - b(110) = b(110) - lu(696) * b(111) - b(109) = b(109) - lu(695) * b(111) - b(107) = b(107) - lu(694) * b(111) - b(103) = b(103) - lu(693) * b(111) - b(97) = b(97) - lu(692) * b(111) - b(69) = b(69) - lu(691) * b(111) - b(68) = b(68) - lu(690) * b(111) - b(47) = b(47) - lu(689) * b(111) - b(110) = b(110) * lu(677) - b(109) = b(109) - lu(676) * b(110) - b(105) = b(105) - lu(675) * b(110) - b(103) = b(103) - lu(674) * b(110) - b(95) = b(95) - lu(673) * b(110) - b(81) = b(81) - lu(672) * b(110) - b(68) = b(68) - lu(671) * b(110) - b(45) = b(45) - lu(670) * b(110) - b(109) = b(109) * lu(662) - b(103) = b(103) - lu(661) * b(109) - b(108) = b(108) * lu(650) - b(88) = b(88) - lu(649) * b(108) - b(34) = b(34) - lu(648) * b(108) - b(107) = b(107) * lu(637) - b(103) = b(103) - lu(636) * b(107) - b(106) = b(106) * lu(625) - b(105) = b(105) - lu(624) * b(106) - b(68) = b(68) - lu(623) * b(106) - b(53) = b(53) - lu(622) * b(106) - b(105) = b(105) * lu(616) - b(104) = b(104) * lu(607) - b(103) = b(103) - lu(606) * b(104) - b(103) = b(103) * lu(602) - b(102) = b(102) * lu(587) - b(89) = b(89) - lu(586) * b(102) - b(75) = b(75) - lu(585) * b(102) - b(49) = b(49) - lu(584) * b(102) - END SUBROUTINE lu_slv07 - - SUBROUTINE lu_slv08(lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(in) :: lu(:) - REAL(KIND=r8), intent(inout) :: b(:) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - b(101) = b(101) * lu(572) - b(97) = b(97) - lu(571) * b(101) - b(45) = b(45) - lu(570) * b(101) - b(100) = b(100) * lu(560) - b(93) = b(93) - lu(559) * b(100) - b(29) = b(29) - lu(558) * b(100) - b(99) = b(99) * lu(552) - b(36) = b(36) - lu(551) * b(99) - b(98) = b(98) * lu(540) - b(80) = b(80) - lu(539) * b(98) - b(59) = b(59) - lu(538) * b(98) - b(97) = b(97) * lu(530) - b(47) = b(47) - lu(529) * b(97) - b(96) = b(96) * lu(517) - b(80) = b(80) - lu(516) * b(96) - b(52) = b(52) - lu(515) * b(96) - b(95) = b(95) * lu(510) - b(81) = b(81) - lu(509) * b(95) - b(94) = b(94) * lu(494) - b(75) = b(75) - lu(493) * b(94) - b(93) = b(93) * lu(486) - b(29) = b(29) - lu(485) * b(93) - b(92) = b(92) * lu(476) - b(87) = b(87) - lu(475) * b(92) - b(86) = b(86) - lu(474) * b(92) - b(85) = b(85) - lu(473) * b(92) - b(72) = b(72) - lu(472) * b(92) - b(58) = b(58) - lu(471) * b(92) - b(91) = b(91) * lu(462) - b(68) = b(68) - lu(461) * b(91) - b(44) = b(44) - lu(460) * b(91) - b(35) = b(35) - lu(459) * b(91) - b(90) = b(90) * lu(452) - b(89) = b(89) * lu(442) - b(67) = b(67) - lu(441) * b(89) - b(88) = b(88) * lu(433) - b(34) = b(34) - lu(432) * b(88) - b(87) = b(87) * lu(425) - b(86) = b(86) - lu(424) * b(87) - b(85) = b(85) - lu(423) * b(87) - b(78) = b(78) - lu(422) * b(87) - b(61) = b(61) - lu(421) * b(87) - b(86) = b(86) * lu(414) - b(61) = b(61) - lu(413) * b(86) - b(85) = b(85) * lu(405) - b(84) = b(84) * lu(397) - b(33) = b(33) - lu(396) * b(84) - b(83) = b(83) * lu(388) - b(56) = b(56) - lu(387) * b(83) - b(24) = b(24) - lu(386) * b(83) - b(82) = b(82) * lu(379) - b(81) = b(81) * lu(375) - b(80) = b(80) * lu(369) - b(79) = b(79) * lu(358) - b(77) = b(77) - lu(357) * b(79) - b(76) = b(76) - lu(356) * b(79) - b(55) = b(55) - lu(355) * b(79) - b(49) = b(49) - lu(354) * b(79) - b(78) = b(78) * lu(344) - b(72) = b(72) - lu(343) * b(78) - b(61) = b(61) - lu(342) * b(78) - b(77) = b(77) * lu(335) - b(42) = b(42) - lu(334) * b(77) - b(76) = b(76) * lu(324) - b(55) = b(55) - lu(323) * b(76) - b(75) = b(75) * lu(319) - b(74) = b(74) * lu(312) - b(73) = b(73) * lu(303) - b(72) = b(72) * lu(296) - b(71) = b(71) * lu(288) - b(70) = b(70) * lu(280) - b(69) = b(69) * lu(272) - b(68) = b(68) * lu(268) - b(67) = b(67) * lu(260) - b(66) = b(66) * lu(254) - b(65) = b(65) * lu(246) - b(51) = b(51) - lu(245) * b(65) - b(64) = b(64) * lu(241) - b(63) = b(63) * lu(233) - b(62) = b(62) * lu(227) - b(61) = b(61) * lu(222) - b(60) = b(60) * lu(215) - b(59) = b(59) * lu(208) - b(58) = b(58) * lu(201) - b(57) = b(57) * lu(194) - b(56) = b(56) * lu(189) - b(55) = b(55) * lu(184) - b(54) = b(54) * lu(178) - b(53) = b(53) * lu(172) - b(52) = b(52) * lu(166) - b(51) = b(51) * lu(160) - b(50) = b(50) * lu(154) - b(49) = b(49) * lu(150) - b(48) = b(48) * lu(142) - b(47) = b(47) * lu(139) - b(46) = b(46) * lu(134) - b(45) = b(45) * lu(130) - b(44) = b(44) * lu(125) - b(43) = b(43) * lu(120) - b(42) = b(42) * lu(115) - b(41) = b(41) * lu(108) - b(40) = b(40) * lu(102) - b(39) = b(39) * lu(96) - b(38) = b(38) * lu(90) - b(37) = b(37) * lu(84) - b(36) = b(36) * lu(80) - b(26) = b(26) - lu(79) * b(36) - b(35) = b(35) * lu(75) - b(34) = b(34) * lu(72) - b(33) = b(33) * lu(69) - b(32) = b(32) * lu(65) - b(31) = b(31) * lu(61) - b(30) = b(30) * lu(57) - b(29) = b(29) * lu(55) - b(28) = b(28) * lu(53) - b(27) = b(27) - lu(52) * b(28) - b(27) = b(27) * lu(50) - b(26) = b(26) * lu(47) - b(25) = b(25) * lu(44) - b(24) = b(24) * lu(41) - b(23) = b(23) * lu(38) - b(22) = b(22) * lu(33) - b(21) = b(21) * lu(29) - b(20) = b(20) * lu(26) - b(19) = b(19) * lu(23) - b(18) = b(18) * lu(20) - b(17) = b(17) * lu(17) - b(16) = b(16) * lu(16) - b(15) = b(15) * lu(15) - b(14) = b(14) * lu(14) - b(13) = b(13) * lu(13) - b(12) = b(12) * lu(12) - b(11) = b(11) * lu(11) - b(10) = b(10) * lu(10) - b(9) = b(9) * lu(9) - b(8) = b(8) * lu(8) - b(7) = b(7) * lu(7) - b(6) = b(6) * lu(6) - b(5) = b(5) * lu(5) - b(4) = b(4) * lu(4) - b(3) = b(3) * lu(3) - b(2) = b(2) * lu(2) - b(1) = b(1) * lu(1) - END SUBROUTINE lu_slv08 - - SUBROUTINE lu_slv(lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(in) :: lu(:) - REAL(KIND=r8), intent(inout) :: b(:) - CALL lu_slv01(lu, b) - CALL lu_slv02(lu, b) - CALL lu_slv03(lu, b) - CALL lu_slv04(lu, b) - CALL lu_slv05(lu, b) - CALL lu_slv06(lu, b) - CALL lu_slv07(lu, b) - CALL lu_slv08(lu, b) - END SUBROUTINE lu_slv - END MODULE mo_lu_solve diff --git a/test/ncar_kernels/WACCM_imp_sol/src/mo_nln_matrix.F90 b/test/ncar_kernels/WACCM_imp_sol/src/mo_nln_matrix.F90 deleted file mode 100644 index 1a5b4a593c..0000000000 --- a/test/ncar_kernels/WACCM_imp_sol/src/mo_nln_matrix.F90 +++ /dev/null @@ -1,2326 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_nln_matrix.F90 -! Generated at: 2015-05-13 11:02:21 -! KGEN version: 0.4.10 - - - - MODULE mo_nln_matrix - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - PRIVATE - PUBLIC nlnmat - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - - SUBROUTINE nlnmat01(mat, y, rxt) - USE chem_mods, ONLY: nzcnt - USE chem_mods, ONLY: gas_pcnst - USE chem_mods, ONLY: rxntot - IMPLICIT NONE - !---------------------------------------------- - ! ... dummy arguments - !---------------------------------------------- - REAL(KIND=r8), intent(in) :: y(gas_pcnst) - REAL(KIND=r8), intent(in) :: rxt(rxntot) - REAL(KIND=r8), intent(inout) :: mat(nzcnt) - !---------------------------------------------- - ! ... local variables - !---------------------------------------------- - !---------------------------------------------- - ! ... complete matrix entries implicit species - !---------------------------------------------- - mat(1016) = -(rxt(119)*y(2) + rxt(137)*y(157) + rxt(164)*y(19) + rxt(169) *y(129) + rxt(177)*y(& - 130) + rxt(192)*y(6) + rxt(195)*y(7) + rxt(207)*y(127) + rxt(234)*y(128) + rxt(293)*y(37) + rxt(& - 314) *y(48) + rxt(336)*y(60) + rxt(342)*y(61) + rxt(360)*y(65) + rxt(392)& - *y(77) + rxt(405)*y(107) + rxt(408)*y(108)) - mat(945) = -rxt(119)*y(1) - mat(971) = -rxt(137)*y(1) - mat(1167) = -rxt(164)*y(1) - mat(1381) = -rxt(169)*y(1) - mat(1112) = -rxt(177)*y(1) - mat(1246) = -rxt(192)*y(1) - mat(1283) = -rxt(195)*y(1) - mat(1147) = -rxt(207)*y(1) - mat(843) = -rxt(234)*y(1) - mat(237) = -rxt(293)*y(1) - mat(594) = -rxt(314)*y(1) - mat(745) = -rxt(336)*y(1) - mat(642) = -rxt(342)*y(1) - mat(503) = -rxt(360)*y(1) - mat(307) = -rxt(392)*y(1) - mat(383) = -rxt(405)*y(1) - mat(809) = -rxt(408)*y(1) - mat(1016) = mat(1016) + .100_r8*rxt(360)*y(65) + .200_r8*rxt(336)*y(60) + .200_r8*rxt(342)*y(61) - mat(945) = mat(945) + rxt(118)*y(3) - mat(906) = rxt(118)*y(2) - mat(1112) = mat(1112) + .250_r8*rxt(304)*y(133) + .250_r8*rxt(352)*y(141) - mat(503) = mat(503) + .100_r8*rxt(360)*y(1) - mat(792) = .250_r8*rxt(304)*y(130) - mat(745) = mat(745) + .200_r8*rxt(336)*y(1) - mat(642) = mat(642) + .200_r8*rxt(342)*y(1) - mat(764) = .250_r8*rxt(352)*y(130) - mat(943) = -(rxt(118)*y(3) + rxt(119)*y(1) + 4._r8*rxt(120)*y(2) + rxt(168) *y(129) + rxt(175)& - *y(18) + rxt(176)*y(130) + rxt(179)*y(20) + rxt(190)*y(6) + (rxt(193) + rxt(194)) * y(7) + rxt(& - 201)*y(8) + rxt(214)*y(24) + rxt(227)*y(27) + rxt(228)*y(28) + rxt(231) & - *y(29) + rxt(237)*y(31) + rxt(247)*y(32) + rxt(248)*y(33) + rxt(249)*y(34) + rxt(271)*y(16) + & - rxt(401)*y(106) + (rxt(437) + rxt(438)) * y(148) + rxt(444)*y(150)) - mat(904) = -rxt(118)*y(2) - mat(1014) = -rxt(119)*y(2) - mat(1379) = -rxt(168)*y(2) - mat(653) = -rxt(175)*y(2) - mat(1110) = -rxt(176)*y(2) - mat(314) = -rxt(179)*y(2) - mat(1244) = -rxt(190)*y(2) - mat(1281) = -(rxt(193) + rxt(194)) * y(2) - mat(1423) = -rxt(201)*y(2) - mat(1041) = -rxt(214)*y(2) - mat(826) = -rxt(227)*y(2) - mat(488) = -rxt(228)*y(2) - mat(562) = -rxt(231)*y(2) - mat(1189) = -rxt(237)*y(2) - mat(454) = -rxt(247)*y(2) - mat(400) = -rxt(248)*y(2) - mat(283) = -rxt(249)*y(2) - mat(1495) = -rxt(271)*y(2) - mat(147) = -rxt(401)*y(2) - mat(351) = -(rxt(437) + rxt(438)) * y(2) - mat(207) = -rxt(444)*y(2) - mat(969) = (rxt(132)+rxt(133))*y(3) - mat(904) = mat(904) + (rxt(132)+rxt(133))*y(157) + rxt(185)*y(5) + rxt(443) *y(150) + rxt(435)& - *y(151) + rxt(404)*y(107) + rxt(407)*y(108) - mat(479) = rxt(185)*y(3) + rxt(186)*y(6) + rxt(187)*y(7) + rxt(440)*y(149) - mat(1244) = mat(1244) + rxt(186)*y(5) - mat(1281) = mat(1281) + rxt(187)*y(5) - mat(1379) = mat(1379) + 2.000_r8*rxt(171)*y(129) - mat(1165) = rxt(167)*y(130) - mat(1110) = mat(1110) + rxt(167)*y(19) - mat(410) = rxt(440)*y(5) + 1.150_r8*rxt(448)*y(153) - mat(207) = mat(207) + rxt(443)*y(3) - mat(302) = rxt(435)*y(3) - mat(418) = rxt(447)*y(153) - mat(429) = 1.150_r8*rxt(448)*y(149) + rxt(447)*y(152) - mat(382) = rxt(404)*y(3) - mat(808) = rxt(407)*y(3) - mat(970) = -((rxt(132) + rxt(133)) * y(3) + rxt(134)*y(158) + rxt(137)*y(1) + rxt(154)*y(100) + & - rxt(155)*y(101) + rxt(159)*y(18) + rxt(160) *y(27) + rxt(161)*y(32) + rxt(162)*y(35)) - mat(905) = -(rxt(132) + rxt(133)) * y(157) - mat(1472) = -rxt(134)*y(157) - mat(1015) = -rxt(137)*y(157) - mat(46) = -rxt(154)*y(157) - mat(67) = -rxt(155)*y(157) - mat(654) = -rxt(159)*y(157) - mat(827) = -rxt(160)*y(157) - mat(455) = -rxt(161)*y(157) - mat(58) = -rxt(162)*y(157) - mat(905) = mat(905) + rxt(182)*y(154) - mat(411) = .850_r8*rxt(448)*y(153) - mat(225) = rxt(182)*y(3) - mat(430) = .850_r8*rxt(448)*y(149) - mat(903) = -(rxt(118)*y(2) + rxt(128)*y(156) + rxt(132)*y(157) + rxt(163) *y(19) + rxt(182)*y(& - 154) + rxt(185)*y(5) + rxt(291)*y(135) + rxt(404)*y(107) + rxt(407)*y(108) + rxt(435)*y(151) + (& - rxt(442) + rxt(443)) * y(150) + rxt(445)*y(148)) - mat(942) = -rxt(118)*y(3) - mat(51) = -rxt(128)*y(3) - mat(968) = -rxt(132)*y(3) - mat(1164) = -rxt(163)*y(3) - mat(224) = -rxt(182)*y(3) - mat(478) = -rxt(185)*y(3) - mat(191) = -rxt(291)*y(3) - mat(381) = -rxt(404)*y(3) - mat(807) = -rxt(407)*y(3) - mat(301) = -rxt(435)*y(3) - mat(206) = -(rxt(442) + rxt(443)) * y(3) - mat(350) = -rxt(445)*y(3) - mat(1013) = 2.000_r8*rxt(119)*y(2) + 2.000_r8*rxt(137)*y(157) + rxt(192)*y(6) + rxt(195)*y(7) + & - rxt(169)*y(129) + rxt(164)*y(19) + 2.000_r8*rxt(177)*y(130) + rxt(207)*y(127) + rxt(234)*y(128) & - + rxt(405)*y(107) + rxt(408)*y(108) - mat(942) = mat(942) + 2.000_r8*rxt(119)*y(1) + 2.000_r8*rxt(120)*y(2) + rxt(127)*y(156) + rxt(& - 193)*y(7) + rxt(168)*y(129) + rxt(201) *y(8) + rxt(176)*y(130) + rxt(214)*y(24) + rxt(237)*y(31) - mat(968) = mat(968) + 2.000_r8*rxt(137)*y(1) - mat(903) = mat(903) + 2.000_r8*rxt(128)*y(156) - mat(51) = mat(51) + rxt(127)*y(2) + 2.000_r8*rxt(128)*y(3) - mat(478) = mat(478) + rxt(189)*y(7) - mat(1243) = rxt(192)*y(1) + rxt(441)*y(149) - mat(1280) = rxt(195)*y(1) + rxt(193)*y(2) + rxt(189)*y(5) - mat(1378) = rxt(169)*y(1) + rxt(168)*y(2) + rxt(205)*y(10) + rxt(170)*y(130) + rxt(216)*y(24) - mat(1422) = rxt(201)*y(2) + rxt(203)*y(130) - mat(216) = rxt(205)*y(129) - mat(873) = rxt(274)*y(130) - mat(1164) = mat(1164) + rxt(164)*y(1) + rxt(166)*y(130) - mat(1109) = 2.000_r8*rxt(177)*y(1) + rxt(176)*y(2) + rxt(170)*y(129) + rxt(203)*y(8) + rxt(274)& - *y(13) + rxt(166)*y(19) + 2.000_r8*rxt(178)*y(130) + rxt(210)*y(127) + rxt(217)*y(24) & - + rxt(235)*y(128) + rxt(239)*y(31) + rxt(322)*y(137) + .750_r8*rxt(352)*y(141) + & - rxt(296)*y(132) + rxt(317)*y(136) + rxt(326)*y(138) - mat(1144) = rxt(207)*y(1) + rxt(210)*y(130) - mat(1040) = rxt(214)*y(2) + rxt(216)*y(129) + rxt(217)*y(130) + (+ 2.000_r8*rxt(221)+2.000_r8*rxt(222))*y(24) + (rxt(& - 243) +rxt(244))*y(31) - mat(840) = rxt(234)*y(1) + rxt(235)*y(130) - mat(1188) = rxt(237)*y(2) + rxt(239)*y(130) + (rxt(243)+rxt(244))*y(24) + 2.000_r8*rxt(245)*y(& - 31) - mat(409) = rxt(441)*y(6) - mat(445) = rxt(322)*y(130) - mat(763) = .750_r8*rxt(352)*y(130) - mat(465) = rxt(296)*y(130) - mat(522) = rxt(317)*y(130) - mat(629) = rxt(326)*y(130) - mat(381) = mat(381) + rxt(405)*y(1) - mat(807) = mat(807) + rxt(408)*y(1) - mat(53) = -(rxt(121)*y(2) + rxt(122)*y(3) + rxt(124)*y(1)) - mat(918) = -rxt(121)*y(155) - mat(887) = -rxt(122)*y(155) - mat(985) = -rxt(124)*y(155) - mat(959) = rxt(132)*y(3) - mat(887) = mat(887) + rxt(132)*y(157) - mat(50) = -(rxt(127)*y(2) + rxt(128)*y(3)) - mat(917) = -rxt(127)*y(156) - mat(886) = -rxt(128)*y(156) - mat(984) = rxt(124)*y(155) - mat(917) = mat(917) + rxt(121)*y(155) - mat(886) = mat(886) + rxt(122)*y(155) - mat(52) = rxt(124)*y(1) + rxt(121)*y(2) + rxt(122)*y(3) - mat(650) = -(rxt(159)*y(157) + rxt(173)*y(129) + rxt(175)*y(2) + rxt(208) *y(127) + rxt(251)*y(& - 103)) - mat(964) = -rxt(159)*y(18) - mat(1366) = -rxt(173)*y(18) - mat(937) = -rxt(175)*y(18) - mat(1139) = -rxt(208)*y(18) - mat(434) = -rxt(251)*y(18) - mat(1160) = rxt(166)*y(130) - mat(1098) = rxt(166)*y(19) - mat(602) = -((rxt(267) + rxt(268)) * y(129)) - mat(1361) = -(rxt(267) + rxt(268)) * y(17) - mat(998) = .560_r8*rxt(314)*y(48) + .300_r8*rxt(360)*y(65) + .500_r8*rxt(293) *y(37) + & - .050_r8*rxt(336)*y(60) + .200_r8*rxt(342)*y(61) - mat(936) = rxt(271)*y(16) + rxt(401)*y(106) - mat(1229) = .220_r8*rxt(343)*y(142) + .500_r8*rxt(378)*y(145) - mat(1361) = mat(1361) + rxt(270)*y(16) + rxt(309)*y(44) + rxt(330)*y(54) + .350_r8*rxt(286)*y(& - 98) + rxt(402)*y(106) - mat(1407) = rxt(269)*y(16) + .220_r8*rxt(345)*y(142) + rxt(331)*y(54) + .500_r8*rxt(379)*y(145) - mat(860) = .110_r8*rxt(347)*y(142) + .200_r8*rxt(381)*y(145) - mat(1489) = rxt(271)*y(2) + rxt(270)*y(129) + rxt(269)*y(8) + rxt(212)*y(127) + rxt(236)*y(128) - mat(1137) = rxt(212)*y(16) - mat(838) = rxt(236)*y(16) - mat(588) = .560_r8*rxt(314)*y(1) - mat(497) = .300_r8*rxt(360)*y(1) - mat(780) = .220_r8*rxt(348)*y(142) + .500_r8*rxt(382)*y(145) - mat(236) = .500_r8*rxt(293)*y(1) - mat(376) = rxt(309)*y(129) - mat(735) = .050_r8*rxt(336)*y(1) - mat(636) = .200_r8*rxt(342)*y(1) - mat(717) = .220_r8*rxt(343)*y(6) + .220_r8*rxt(345)*y(8) + .110_r8*rxt(347) *y(13) + & - .220_r8*rxt(348)*y(133) - mat(661) = rxt(330)*y(129) + rxt(331)*y(8) - mat(674) = .500_r8*rxt(378)*y(6) + .500_r8*rxt(379)*y(8) + .200_r8*rxt(381) *y(13) + & - .500_r8*rxt(382)*y(133) - mat(93) = .350_r8*rxt(286)*y(129) - mat(145) = rxt(401)*y(2) + rxt(402)*y(129) - mat(476) = -(rxt(184)*y(129) + rxt(185)*y(3) + rxt(186)*y(6) + (rxt(187) + rxt(188) + rxt(189)) & - * y(7) + rxt(440)*y(149)) - mat(1350) = -rxt(184)*y(5) - mat(897) = -rxt(185)*y(5) - mat(1223) = -rxt(186)*y(5) - mat(1268) = -(rxt(187) + rxt(188) + rxt(189)) * y(5) - mat(408) = -rxt(440)*y(5) - mat(932) = rxt(444)*y(150) + rxt(183)*y(154) - mat(897) = mat(897) + rxt(442)*y(150) - mat(348) = 1.100_r8*rxt(449)*y(153) - mat(205) = rxt(444)*y(2) + rxt(442)*y(3) - mat(416) = .200_r8*rxt(447)*y(153) - mat(223) = rxt(183)*y(2) - mat(426) = 1.100_r8*rxt(449)*y(148) + .200_r8*rxt(447)*y(152) - END SUBROUTINE nlnmat01 - - SUBROUTINE nlnmat02(mat, y, rxt) - USE chem_mods, ONLY: nzcnt - USE chem_mods, ONLY: gas_pcnst - USE chem_mods, ONLY: rxntot - IMPLICIT NONE - !---------------------------------------------- - ! ... dummy arguments - !---------------------------------------------- - REAL(KIND=r8), intent(in) :: y(gas_pcnst) - REAL(KIND=r8), intent(in) :: rxt(rxntot) - REAL(KIND=r8), intent(inout) :: mat(nzcnt) - !---------------------------------------------- - ! ... local variables - !---------------------------------------------- - !---------------------------------------------- - ! ... complete matrix entries implicit species - !---------------------------------------------- - mat(1252) = -(rxt(186)*y(5) + rxt(190)*y(2) + rxt(191)*y(130) + rxt(192)*y(1) + rxt(200)*y(8) + & - rxt(219)*y(24) + rxt(240)*y(31) + rxt(273) *y(13) + rxt(281)*y(131) + rxt(289)*y(134) + rxt(295)& - *y(132) + rxt(302)*y(133) + rxt(316)*y(136) + rxt(321)*y(137) + rxt(325) & - *y(138) + rxt(334)*y(139) + rxt(338)*y(140) + (rxt(343) + rxt(344) ) * y(142) + rxt(350)*y(141) & - + rxt(362)*y(144) + rxt(368)*y(69) + rxt(375)*y(143) + rxt(378)*y(145) + rxt(386)*y(146) + rxt(& - 394) *y(147) + rxt(441)*y(149)) - mat(482) = -rxt(186)*y(6) - mat(951) = -rxt(190)*y(6) - mat(1118) = -rxt(191)*y(6) - mat(1022) = -rxt(192)*y(6) - mat(1431) = -rxt(200)*y(6) - mat(1049) = -rxt(219)*y(6) - mat(1197) = -rxt(240)*y(6) - mat(879) = -rxt(273)*y(6) - mat(181) = -rxt(281)*y(6) - mat(392) = -rxt(289)*y(6) - mat(467) = -rxt(295)*y(6) - mat(795) = -rxt(302)*y(6) - mat(524) = -rxt(316)*y(6) - mat(447) = -rxt(321)*y(6) - mat(631) = -rxt(325)*y(6) - mat(112) = -rxt(334)*y(6) - mat(339) = -rxt(338)*y(6) - mat(727) = -(rxt(343) + rxt(344)) * y(6) - mat(767) = -rxt(350)*y(6) - mat(706) = -rxt(362)*y(6) - mat(578) = -rxt(368)*y(6) - mat(365) = -rxt(375)*y(6) - mat(682) = -rxt(378)*y(6) - mat(251) = -rxt(386)*y(6) - mat(547) = -rxt(394)*y(6) - mat(412) = -rxt(441)*y(6) - mat(951) = mat(951) + rxt(193)*y(7) - mat(912) = rxt(185)*y(5) + rxt(182)*y(154) - mat(482) = mat(482) + rxt(185)*y(3) + 2.000_r8*rxt(188)*y(7) + rxt(184) *y(129) - mat(1289) = rxt(193)*y(2) + 2.000_r8*rxt(188)*y(5) + rxt(409)*y(108) - mat(1387) = rxt(184)*y(5) - mat(226) = rxt(182)*y(3) - mat(815) = rxt(409)*y(7) - mat(1290) = -((rxt(187) + rxt(188) + rxt(189)) * y(5) + (rxt(193) + rxt(194) ) * y(2) + rxt(195)& - *y(1) + rxt(196)*y(8) + rxt(198)*y(129) + rxt(204)*y(130) + rxt(220)*y(24) + rxt(241)*y(31) + & - rxt(303) *y(133) + rxt(356)*y(141) + rxt(390)*y(76) + rxt(409)*y(108)) - mat(483) = -(rxt(187) + rxt(188) + rxt(189)) * y(7) - mat(952) = -(rxt(193) + rxt(194)) * y(7) - mat(1023) = -rxt(195)*y(7) - mat(1432) = -rxt(196)*y(7) - mat(1388) = -rxt(198)*y(7) - mat(1119) = -rxt(204)*y(7) - mat(1050) = -rxt(220)*y(7) - mat(1198) = -rxt(241)*y(7) - mat(796) = -rxt(303)*y(7) - mat(768) = -rxt(356)*y(7) - mat(64) = -rxt(390)*y(7) - mat(816) = -rxt(409)*y(7) - mat(1023) = mat(1023) + rxt(192)*y(6) - mat(952) = mat(952) + rxt(190)*y(6) + rxt(201)*y(8) - mat(1253) = rxt(192)*y(1) + rxt(190)*y(2) + 2.000_r8*rxt(200)*y(8) + rxt(273) *y(13) + rxt(191)& - *y(130) + rxt(219)*y(24) + rxt(240)*y(31) + rxt(321)*y(137) + rxt(302)*y(133) + rxt(334)*y(139) & - + .900_r8*rxt(375)*y(143) + rxt(338)*y(140) + .900_r8*rxt(386) *y(146) + & - rxt(394)*y(147) + .920_r8*rxt(362)*y(144) + rxt(343) *y(142) + rxt(350)*y(141) + rxt(295)*y(132)& - + rxt(316)*y(136) + rxt(289)*y(134) + rxt(325)*y(138) + 1.206_r8*rxt(368)*y(69) & - + rxt(378)*y(145) + rxt(281)*y(131) - mat(1290) = mat(1290) + .700_r8*rxt(390)*y(76) - mat(1388) = mat(1388) + rxt(202)*y(8) + rxt(205)*y(10) + rxt(332)*y(64) + .400_r8*rxt(372)*y(70) - mat(1432) = mat(1432) + rxt(201)*y(2) + 2.000_r8*rxt(200)*y(6) + rxt(202) *y(129) + rxt(203)*y(& - 130) + rxt(363)*y(144) + rxt(345)*y(142) + rxt(351)*y(141) + rxt(393)*y(77) + 1.206_r8*rxt(369)& - *y(69) + rxt(373)*y(70) + rxt(379)*y(145) - mat(218) = rxt(205)*y(129) - mat(880) = rxt(273)*y(6) - mat(1119) = mat(1119) + rxt(191)*y(6) + rxt(203)*y(8) + .206_r8*rxt(370) *y(69) - mat(1050) = mat(1050) + rxt(219)*y(6) - mat(1198) = mat(1198) + rxt(240)*y(6) - mat(448) = rxt(321)*y(6) - mat(796) = mat(796) + rxt(302)*y(6) - mat(152) = rxt(332)*y(129) - mat(113) = rxt(334)*y(6) - mat(366) = .900_r8*rxt(375)*y(6) - mat(340) = rxt(338)*y(6) - mat(252) = .900_r8*rxt(386)*y(6) - mat(64) = mat(64) + .700_r8*rxt(390)*y(7) - mat(548) = rxt(394)*y(6) - mat(707) = .920_r8*rxt(362)*y(6) + rxt(363)*y(8) - mat(728) = rxt(343)*y(6) + rxt(345)*y(8) - mat(768) = mat(768) + rxt(350)*y(6) + rxt(351)*y(8) - mat(468) = rxt(295)*y(6) - mat(309) = rxt(393)*y(8) - mat(525) = rxt(316)*y(6) - mat(393) = rxt(289)*y(6) - mat(632) = rxt(325)*y(6) - mat(579) = 1.206_r8*rxt(368)*y(6) + 1.206_r8*rxt(369)*y(8) + .206_r8*rxt(370) *y(130) - mat(534) = .400_r8*rxt(372)*y(129) + rxt(373)*y(8) - mat(683) = rxt(378)*y(6) + rxt(379)*y(8) - mat(182) = rxt(281)*y(6) - mat(1389) = -(rxt(168)*y(2) + rxt(169)*y(1) + rxt(170)*y(130) + (4._r8*rxt(171) + 4._r8*rxt(172)& - ) * y(129) + rxt(173)*y(18) + rxt(174)*y(20) + rxt(180)*y(35) + rxt(181)*y(36) + rxt(184)*y(5) & - + rxt(198) *y(7) + rxt(199)*y(9) + rxt(202)*y(8) + rxt(205)*y(10) + (rxt(215) & - + rxt(216)) * y(24) + rxt(226)*y(27) + rxt(230)*y(28) + rxt(232) *y(29) + rxt(238)*y(31) + & - rxt(246)*y(32) + (rxt(267) + rxt(268) ) * y(17) + rxt(270)*y(16) + rxt(277)*y(15) + rxt(278)*y(& - 14) + rxt(279)*y(99) + rxt(286)*y(98) + rxt(287)*y(38) + rxt(288) *y(37) & - + rxt(294)*y(40) + rxt(299)*y(39) + rxt(300)*y(41) + rxt(307)*y(45) + rxt(308)*y(43) + rxt(309)& - *y(44) + rxt(310) *y(42) + rxt(312)*y(47) + rxt(313)*y(48) + rxt(319)*y(50) & - + rxt(320)*y(49) + rxt(323)*y(52) + rxt(324)*y(51) + rxt(328) *y(55) + rxt(329)*y(53) + rxt(& - 330)*y(54) + rxt(332)*y(64) + rxt(333)*y(56) + rxt(335)*y(60) + rxt(337)*y(58) + rxt(340) & - *y(59) + rxt(341)*y(61) + rxt(349)*y(62) + rxt(358)*y(63) + rxt(359)*y(65) + & - rxt(365)*y(72) + rxt(371)*y(57) + rxt(372) *y(70) + rxt(374)*y(68) + rxt(377)*y(66) + rxt(383)& - *y(71) + rxt(385)*y(73) + rxt(388)*y(75) + rxt(389)*y(74) + rxt(391) *y(& - 77) + rxt(396)*y(78) + rxt(402)*y(106) + rxt(403)*y(107) + rxt(406)*y(108) + rxt(413)*y(104) + (& - rxt(415) + rxt(416) ) * y(105)) - mat(953) = -rxt(168)*y(129) - mat(1024) = -rxt(169)*y(129) - mat(1120) = -rxt(170)*y(129) - mat(657) = -rxt(173)*y(129) - mat(317) = -rxt(174)*y(129) - mat(60) = -rxt(180)*y(129) - mat(19) = -rxt(181)*y(129) - mat(484) = -rxt(184)*y(129) - mat(1291) = -rxt(198)*y(129) - mat(1455) = -rxt(199)*y(129) - mat(1433) = -rxt(202)*y(129) - mat(219) = -rxt(205)*y(129) - mat(1051) = -(rxt(215) + rxt(216)) * y(129) - mat(833) = -rxt(226)*y(129) - mat(491) = -rxt(230)*y(129) - mat(566) = -rxt(232)*y(129) - mat(1199) = -rxt(238)*y(129) - mat(457) = -rxt(246)*y(129) - mat(605) = -(rxt(267) + rxt(268)) * y(129) - mat(1505) = -rxt(270)*y(129) - mat(270) = -rxt(277)*y(129) - mat(157) = -rxt(278)*y(129) - mat(243) = -rxt(279)*y(129) - mat(95) = -rxt(286)*y(129) - mat(88) = -rxt(287)*y(129) - mat(239) = -rxt(288)*y(129) - mat(321) = -rxt(294)*y(129) - mat(129) = -rxt(299)*y(129) - mat(612) = -rxt(300)*y(129) - mat(230) = -rxt(307)*y(129) - mat(513) = -rxt(308)*y(129) - mat(378) = -rxt(309)*y(129) - mat(78) = -rxt(310)*y(129) - mat(198) = -rxt(312)*y(129) - mat(598) = -rxt(313)*y(129) - mat(170) = -rxt(319)*y(129) - mat(31) = -rxt(320)*y(129) - mat(265) = -rxt(323)*y(129) - mat(373) = -rxt(324)*y(129) - mat(175) = -rxt(328)*y(129) - mat(620) = -rxt(329)*y(129) - mat(666) = -rxt(330)*y(129) - mat(153) = -rxt(332)*y(129) - mat(28) = -rxt(333)*y(129) - mat(750) = -rxt(335)*y(129) - mat(188) = -rxt(337)*y(129) - mat(119) = -rxt(340)*y(129) - mat(645) = -rxt(341)*y(129) - mat(124) = -rxt(349)*y(129) - mat(293) = -rxt(358)*y(129) - mat(505) = -rxt(359)*y(129) - mat(278) = -rxt(365)*y(129) - mat(25) = -rxt(371)*y(129) - mat(535) = -rxt(372)*y(129) - mat(141) = -rxt(374)*y(129) - mat(332) = -rxt(377)*y(129) - mat(132) = -rxt(383)*y(129) - mat(37) = -rxt(385)*y(129) - mat(165) = -rxt(388)*y(129) - mat(40) = -rxt(389)*y(129) - mat(310) = -rxt(391)*y(129) - mat(214) = -rxt(396)*y(129) - mat(149) = -rxt(402)*y(129) - mat(385) = -rxt(403)*y(129) - mat(817) = -rxt(406)*y(129) - mat(556) = -rxt(413)*y(129) - mat(99) = -(rxt(415) + rxt(416)) * y(129) - mat(1024) = mat(1024) + rxt(164)*y(19) + rxt(177)*y(130) + .330_r8*rxt(314) *y(48) + & - .270_r8*rxt(360)*y(65) + .120_r8*rxt(293)*y(37) + .080_r8*rxt(336)*y(60) + .215_r8*rxt(342)*y(& - 61) + .700_r8*rxt(392)*y(77) - mat(953) = mat(953) + rxt(175)*y(18) + rxt(271)*y(16) + rxt(176)*y(130) + rxt(179)*y(20) + rxt(& - 227)*y(27) + rxt(228)*y(28) + rxt(247) *y(32) + rxt(248)*y(33) - mat(979) = rxt(159)*y(18) + rxt(162)*y(35) + 2.000_r8*rxt(134)*y(158) + rxt(160)*y(27) + rxt(& - 161)*y(32) - mat(657) = mat(657) + rxt(175)*y(2) + rxt(159)*y(157) - mat(1254) = rxt(191)*y(130) - mat(1389) = mat(1389) + .300_r8*rxt(278)*y(14) + .500_r8*rxt(323)*y(52) + .100_r8*rxt(349)*y(62)& - + .500_r8*rxt(299)*y(39) + .650_r8*rxt(286)*y(98) - mat(1433) = mat(1433) + rxt(203)*y(130) - mat(157) = mat(157) + .300_r8*rxt(278)*y(129) - mat(60) = mat(60) + rxt(162)*y(157) - mat(1505) = mat(1505) + rxt(271)*y(2) - mat(1175) = rxt(164)*y(1) + 2.000_r8*rxt(165)*y(130) - mat(1120) = mat(1120) + rxt(177)*y(1) + rxt(176)*y(2) + rxt(191)*y(6) + rxt(203)*y(8) + & - 2.000_r8*rxt(165)*y(19) + rxt(211)*y(127) - mat(317) = mat(317) + rxt(179)*y(2) - mat(1481) = 2.000_r8*rxt(134)*y(157) + rxt(250)*y(103) - mat(1155) = rxt(211)*y(130) - mat(833) = mat(833) + rxt(227)*y(2) + rxt(160)*y(157) - mat(491) = mat(491) + rxt(228)*y(2) - mat(457) = mat(457) + rxt(247)*y(2) + rxt(161)*y(157) - mat(403) = rxt(248)*y(2) - mat(598) = mat(598) + .330_r8*rxt(314)*y(1) - mat(505) = mat(505) + .270_r8*rxt(360)*y(1) - mat(265) = mat(265) + .500_r8*rxt(323)*y(129) - mat(239) = mat(239) + .120_r8*rxt(293)*y(1) - mat(750) = mat(750) + .080_r8*rxt(336)*y(1) - mat(645) = mat(645) + .215_r8*rxt(342)*y(1) - mat(124) = mat(124) + .100_r8*rxt(349)*y(129) - mat(129) = mat(129) + .500_r8*rxt(299)*y(129) - mat(310) = mat(310) + .700_r8*rxt(392)*y(1) - mat(95) = mat(95) + .650_r8*rxt(286)*y(129) - mat(437) = rxt(250)*y(158) - END SUBROUTINE nlnmat02 - - SUBROUTINE nlnmat03(mat, y, rxt) - USE chem_mods, ONLY: nzcnt - USE chem_mods, ONLY: gas_pcnst - USE chem_mods, ONLY: rxntot - IMPLICIT NONE - !---------------------------------------------- - ! ... dummy arguments - !---------------------------------------------- - REAL(KIND=r8), intent(in) :: y(gas_pcnst) - REAL(KIND=r8), intent(in) :: rxt(rxntot) - REAL(KIND=r8), intent(inout) :: mat(nzcnt) - !---------------------------------------------- - ! ... local variables - !---------------------------------------------- - !---------------------------------------------- - ! ... complete matrix entries implicit species - !---------------------------------------------- - mat(1434) = -(rxt(196)*y(7) + rxt(200)*y(6) + rxt(201)*y(2) + rxt(202)*y(129) + rxt(203)*y(130) & - + rxt(269)*y(16) + rxt(301)*y(41) + rxt(315) *y(48) + rxt(331)*y(54) + rxt(345)*y(142) + rxt(& - 351)*y(141) + rxt(361)*y(65) + rxt(363)*y(144) + rxt(369)*y(69) + rxt(373) & - *y(70) + rxt(379)*y(145) + rxt(393)*y(77) + rxt(417)*y(105)) - mat(1292) = -rxt(196)*y(8) - mat(1255) = -rxt(200)*y(8) - mat(954) = -rxt(201)*y(8) - mat(1390) = -rxt(202)*y(8) - mat(1121) = -rxt(203)*y(8) - mat(1506) = -rxt(269)*y(8) - mat(613) = -rxt(301)*y(8) - mat(599) = -rxt(315)*y(8) - mat(667) = -rxt(331)*y(8) - mat(730) = -rxt(345)*y(8) - mat(770) = -rxt(351)*y(8) - mat(506) = -rxt(361)*y(8) - mat(709) = -rxt(363)*y(8) - mat(581) = -rxt(369)*y(8) - mat(536) = -rxt(373)*y(8) - mat(685) = -rxt(379)*y(8) - mat(311) = -rxt(393)*y(8) - mat(100) = -rxt(417)*y(8) - mat(1025) = rxt(195)*y(7) - mat(954) = mat(954) + rxt(194)*y(7) + rxt(231)*y(29) + rxt(249)*y(34) - mat(1292) = mat(1292) + rxt(195)*y(1) + rxt(194)*y(2) - mat(1390) = mat(1390) + rxt(199)*y(9) + rxt(232)*y(29) + rxt(312)*y(47) + .500_r8*rxt(358)*y(63) - mat(1456) = rxt(199)*y(129) + rxt(253)*y(103) - mat(1156) = rxt(233)*y(29) - mat(567) = rxt(231)*y(2) + rxt(232)*y(129) + rxt(233)*y(127) - mat(286) = rxt(249)*y(2) - mat(199) = rxt(312)*y(129) - mat(294) = .500_r8*rxt(358)*y(129) - mat(438) = rxt(253)*y(9) - mat(1457) = -(rxt(199)*y(129) + rxt(253)*y(103)) - mat(1391) = -rxt(199)*y(9) - mat(439) = -rxt(253)*y(9) - mat(1293) = rxt(198)*y(129) - mat(1391) = mat(1391) + rxt(198)*y(7) - mat(1435) = rxt(269)*y(16) + rxt(301)*y(41) + rxt(331)*y(54) + rxt(417) *y(105) - mat(1507) = rxt(269)*y(8) - mat(835) = (rxt(421)+rxt(426)+rxt(432))*y(29) - mat(568) = (rxt(421)+rxt(426)+rxt(432))*y(27) - mat(614) = rxt(301)*y(8) - mat(668) = rxt(331)*y(8) - mat(101) = rxt(417)*y(8) - mat(215) = -(rxt(205)*y(129)) - mat(1326) = -rxt(205)*y(10) - mat(1262) = rxt(204)*y(130) - mat(1068) = rxt(204)*y(7) - mat(1260) = rxt(196)*y(8) - mat(1395) = rxt(196)*y(7) - mat(872) = -(rxt(218)*y(24) + rxt(273)*y(6) + rxt(274)*y(130) + (4._r8*rxt(275) + 4._r8*rxt(276)& - ) * y(13) + rxt(297)*y(132) + rxt(305)*y(133) + rxt(318)*y(136) + rxt(327)*y(138) + rxt(347)*y(& - 142) + rxt(353) *y(141) + rxt(366)*y(144) + rxt(381)*y(145)) - mat(1039) = -rxt(218)*y(13) - mat(1242) = -rxt(273)*y(13) - mat(1108) = -rxt(274)*y(13) - mat(464) = -rxt(297)*y(13) - mat(790) = -rxt(305)*y(13) - mat(521) = -rxt(318)*y(13) - mat(628) = -rxt(327)*y(13) - mat(724) = -rxt(347)*y(13) - mat(762) = -rxt(353)*y(13) - mat(702) = -rxt(366)*y(13) - mat(679) = -rxt(381)*y(13) - mat(1012) = .310_r8*rxt(314)*y(48) - mat(1242) = mat(1242) + rxt(302)*y(133) - mat(1377) = .700_r8*rxt(278)*y(14) + rxt(294)*y(40) - mat(872) = mat(872) + .900_r8*rxt(305)*y(133) - mat(155) = .700_r8*rxt(278)*y(129) - mat(592) = .310_r8*rxt(314)*y(1) - mat(320) = rxt(294)*y(129) - mat(790) = mat(790) + rxt(302)*y(6) + .900_r8*rxt(305)*y(13) + 4.000_r8*rxt(306)*y(133) + rxt(& - 367)*y(144) + rxt(348)*y(142) + rxt(354)*y(141) + rxt(382)*y(145) - mat(702) = mat(702) + rxt(367)*y(133) - mat(724) = mat(724) + rxt(348)*y(133) - mat(762) = mat(762) + rxt(354)*y(133) - mat(679) = mat(679) + rxt(382)*y(133) - mat(154) = -(rxt(278)*y(129)) - mat(1319) = -rxt(278)*y(14) - mat(852) = rxt(274)*y(130) - mat(1061) = rxt(274)*y(13) - mat(57) = -(rxt(162)*y(157) + rxt(180)*y(129)) - mat(960) = -rxt(162)*y(35) - mat(1303) = -rxt(180)*y(35) - mat(17) = -(rxt(181)*y(129)) - mat(1296) = -rxt(181)*y(36) - mat(1509) = -(rxt(212)*y(127) + rxt(236)*y(128) + rxt(269)*y(8) + rxt(270) *y(129) + rxt(271)*y(& - 2) + rxt(272)*y(130)) - mat(1159) = -rxt(212)*y(16) - mat(849) = -rxt(236)*y(16) - mat(1437) = -rxt(269)*y(16) - mat(1393) = -rxt(270)*y(16) - mat(957) = -rxt(271)*y(16) - mat(1124) = -rxt(272)*y(16) - mat(1028) = .540_r8*rxt(314)*y(48) + .600_r8*rxt(360)*y(65) + rxt(293)*y(37) + .800_r8*rxt(336)& - *y(60) + .700_r8*rxt(342)*y(61) - mat(1258) = rxt(273)*y(13) + rxt(321)*y(137) + .500_r8*rxt(334)*y(139) + .100_r8*rxt(375)*y(143)& - + .510_r8*rxt(362)*y(144) + .250_r8*rxt(343)*y(142) + rxt(350)*y(141) + .500_r8*rxt(289) & - *y(134) + rxt(325)*y(138) + .072_r8*rxt(368)*y(69) - mat(1393) = mat(1393) + .300_r8*rxt(278)*y(14) + .500_r8*rxt(307)*y(45) + rxt(312)*y(47) + & - .500_r8*rxt(358)*y(63) + rxt(277)*y(15) + .800_r8*rxt(308)*y(43) - mat(1437) = mat(1437) + .600_r8*rxt(363)*y(144) + .250_r8*rxt(345)*y(142) + rxt(351)*y(141) + & - .072_r8*rxt(369)*y(69) - mat(885) = rxt(273)*y(6) + (4.000_r8*rxt(275)+2.000_r8*rxt(276))*y(13) + rxt(218)*y(24) + rxt(& - 305)*y(133) + 1.200_r8*rxt(366)*y(144) + .880_r8*rxt(347)*y(142) + 2.000_r8*rxt(353)*y(141) & - + .700_r8*rxt(297)*y(132) + rxt(318)*y(136) + .800_r8*rxt(327) *y(138) + & - .700_r8*rxt(381)*y(145) - mat(159) = .300_r8*rxt(278)*y(129) - mat(1124) = mat(1124) + .008_r8*rxt(370)*y(69) - mat(1055) = rxt(218)*y(13) - mat(601) = .540_r8*rxt(314)*y(1) - mat(508) = .600_r8*rxt(360)*y(1) - mat(451) = rxt(321)*y(6) - mat(801) = rxt(305)*y(13) + .600_r8*rxt(367)*y(144) + .250_r8*rxt(348)*y(142) + rxt(354)*y(141) - mat(232) = .500_r8*rxt(307)*y(129) - mat(200) = rxt(312)*y(129) - mat(240) = rxt(293)*y(1) - mat(295) = .500_r8*rxt(358)*y(129) - mat(114) = .500_r8*rxt(334)*y(6) - mat(368) = .100_r8*rxt(375)*y(6) - mat(712) = .510_r8*rxt(362)*y(6) + .600_r8*rxt(363)*y(8) + 1.200_r8*rxt(366) *y(13) + & - .600_r8*rxt(367)*y(133) - mat(754) = .800_r8*rxt(336)*y(1) - mat(647) = .700_r8*rxt(342)*y(1) - mat(733) = .250_r8*rxt(343)*y(6) + .250_r8*rxt(345)*y(8) + .880_r8*rxt(347) *y(13) + & - .250_r8*rxt(348)*y(133) - mat(773) = rxt(350)*y(6) + rxt(351)*y(8) + 2.000_r8*rxt(353)*y(13) + rxt(354) *y(133) + & - 4.000_r8*rxt(355)*y(141) - mat(470) = .700_r8*rxt(297)*y(13) - mat(528) = rxt(318)*y(13) - mat(271) = rxt(277)*y(129) - mat(514) = .800_r8*rxt(308)*y(129) - mat(395) = .500_r8*rxt(289)*y(6) - mat(635) = rxt(325)*y(6) + .800_r8*rxt(327)*y(13) - mat(583) = .072_r8*rxt(368)*y(6) + .072_r8*rxt(369)*y(8) + .008_r8*rxt(370) *y(130) - mat(688) = .700_r8*rxt(381)*y(13) - mat(1171) = -(rxt(163)*y(3) + rxt(164)*y(1) + (rxt(165) + rxt(166) + rxt(167) ) * y(130)) - mat(910) = -rxt(163)*y(19) - mat(1020) = -rxt(164)*y(19) - mat(1116) = -(rxt(165) + rxt(166) + rxt(167)) * y(19) - mat(949) = rxt(175)*y(18) + rxt(168)*y(129) - mat(975) = rxt(159)*y(18) - mat(656) = rxt(175)*y(2) + rxt(159)*y(157) + rxt(173)*y(129) + rxt(208) *y(127) + rxt(251)*y(& - 103) - mat(604) = rxt(267)*y(129) - mat(481) = rxt(184)*y(129) - mat(1385) = rxt(168)*y(2) + rxt(173)*y(18) + rxt(267)*y(17) + rxt(184)*y(5) + rxt(270)*y(16) + & - rxt(402)*y(106) + rxt(403)*y(107) + rxt(406) *y(108) - mat(1501) = rxt(270)*y(129) - mat(1151) = rxt(208)*y(18) - mat(436) = rxt(251)*y(18) - mat(148) = rxt(402)*y(129) - mat(384) = rxt(403)*y(129) - mat(813) = rxt(406)*y(129) - mat(1114) = -((rxt(165) + rxt(166) + rxt(167)) * y(19) + rxt(170)*y(129) + rxt(176)*y(2) + rxt(& - 177)*y(1) + 4._r8*rxt(178)*y(130) + rxt(191) *y(6) + rxt(203)*y(8) + rxt(204)*y(7) + (rxt(210) & - + rxt(211) ) * y(127) + rxt(217)*y(24) + rxt(235)*y(128) + rxt(239)*y(31) & - + rxt(272)*y(16) + rxt(274)*y(13) + rxt(282)*y(131) + rxt(290) *y(134) + rxt(296)*y(132) + rxt(& - 304)*y(133) + rxt(317)*y(136) + rxt(322)*y(137) + rxt(326)*y(138) + rxt(339)*y(140) + rxt(346) & - *y(142) + rxt(352)*y(141) + rxt(364)*y(144) + rxt(370)*y(69) + rxt(376)*y(& - 143) + rxt(380)*y(145) + rxt(387)*y(146) + rxt(395) *y(147)) - mat(1169) = -(rxt(165) + rxt(166) + rxt(167)) * y(130) - mat(1383) = -rxt(170)*y(130) - mat(947) = -rxt(176)*y(130) - mat(1018) = -rxt(177)*y(130) - mat(1248) = -rxt(191)*y(130) - mat(1427) = -rxt(203)*y(130) - mat(1285) = -rxt(204)*y(130) - mat(1149) = -(rxt(210) + rxt(211)) * y(130) - mat(1045) = -rxt(217)*y(130) - mat(844) = -rxt(235)*y(130) - mat(1193) = -rxt(239)*y(130) - mat(1499) = -rxt(272)*y(130) - mat(876) = -rxt(274)*y(130) - mat(180) = -rxt(282)*y(130) - mat(391) = -rxt(290)*y(130) - mat(466) = -rxt(296)*y(130) - mat(793) = -rxt(304)*y(130) - mat(523) = -rxt(317)*y(130) - mat(446) = -rxt(322)*y(130) - mat(630) = -rxt(326)*y(130) - mat(338) = -rxt(339)*y(130) - mat(725) = -rxt(346)*y(130) - mat(765) = -rxt(352)*y(130) - mat(704) = -rxt(364)*y(130) - mat(577) = -rxt(370)*y(130) - mat(364) = -rxt(376)*y(130) - mat(680) = -rxt(380)*y(130) - mat(250) = -rxt(387)*y(130) - mat(546) = -rxt(395)*y(130) - mat(1018) = mat(1018) + rxt(169)*y(129) + .190_r8*rxt(314)*y(48) + .060_r8*rxt(360)*y(65) + & - .120_r8*rxt(293)*y(37) + .060_r8*rxt(336)*y(60) + .275_r8*rxt(342)*y(61) + rxt(392) & - *y(77) - mat(947) = mat(947) + rxt(271)*y(16) + rxt(179)*y(20) - mat(908) = rxt(163)*y(19) + rxt(291)*y(135) - mat(603) = rxt(268)*y(129) - mat(1248) = mat(1248) + rxt(273)*y(13) + rxt(321)*y(137) + rxt(334)*y(139) + .900_r8*rxt(375)*y(& - 143) + .900_r8*rxt(386)*y(146) + rxt(394) *y(147) + rxt(362)*y(144) + .470_r8*rxt(343)*y(142) + & - rxt(295) *y(132) + rxt(316)*y(136) + .250_r8*rxt(289)*y(134) + & - .794_r8*rxt(368)*y(69) + rxt(378)*y(145) + rxt(281)*y(131) - mat(1285) = mat(1285) + .700_r8*rxt(390)*y(76) - mat(1383) = mat(1383) + rxt(169)*y(1) + rxt(268)*y(17) + rxt(202)*y(8) + rxt(180)*y(35) + rxt(& - 181)*y(36) + rxt(174)*y(20) + rxt(215) *y(24) + rxt(238)*y(31) + .500_r8*rxt(358)*y(63) & - + .250_r8*rxt(385)*y(73) + rxt(309)*y(44) + .200_r8*rxt(349) *y(62) + rxt(277)*y(& - 15) + rxt(310)*y(42) + rxt(308)*y(43) + rxt(329)*y(53) + rxt(372)*y(70) + .350_r8*rxt(286)*y(98)& - + rxt(279)*y(99) + rxt(413)*y(104) + .500_r8*rxt(416)*y(105) - mat(1427) = mat(1427) + rxt(202)*y(129) + rxt(269)*y(16) + rxt(363)*y(144) + .470_r8*rxt(345)*y(& - 142) + .794_r8*rxt(369)*y(69) + rxt(373) *y(70) + rxt(379)*y(145) - mat(876) = mat(876) + rxt(273)*y(6) + 4.000_r8*rxt(275)*y(13) + rxt(218) *y(24) + .900_r8*rxt(& - 305)*y(133) + rxt(366)*y(144) + .730_r8*rxt(347)*y(142) + rxt(353)*y(141) + rxt(297)*y(132) & - + rxt(318)*y(136) + .300_r8*rxt(327)*y(138) + .800_r8*rxt(381) *y(145) - mat(59) = rxt(180)*y(129) - mat(18) = rxt(181)*y(129) - mat(1499) = mat(1499) + rxt(271)*y(2) + rxt(269)*y(8) + rxt(212)*y(127) + rxt(236)*y(128) - mat(1169) = mat(1169) + rxt(163)*y(3) - mat(1114) = mat(1114) + .794_r8*rxt(370)*y(69) - mat(315) = rxt(179)*y(2) + rxt(174)*y(129) + rxt(209)*y(127) - mat(1149) = mat(1149) + rxt(212)*y(16) + rxt(209)*y(20) - mat(1045) = mat(1045) + rxt(215)*y(129) + rxt(218)*y(13) - mat(844) = mat(844) + rxt(236)*y(16) - mat(1193) = mat(1193) + rxt(238)*y(129) - mat(595) = .190_r8*rxt(314)*y(1) - mat(504) = .060_r8*rxt(360)*y(1) - mat(446) = mat(446) + rxt(321)*y(6) - mat(793) = mat(793) + .900_r8*rxt(305)*y(13) + rxt(367)*y(144) + .470_r8*rxt(348)*y(142) + rxt(& - 382)*y(145) - mat(238) = .120_r8*rxt(293)*y(1) - mat(291) = .500_r8*rxt(358)*y(129) - mat(111) = rxt(334)*y(6) - mat(364) = mat(364) + .900_r8*rxt(375)*y(6) - mat(36) = .250_r8*rxt(385)*y(129) - mat(250) = mat(250) + .900_r8*rxt(386)*y(6) - mat(63) = .700_r8*rxt(390)*y(7) - mat(546) = mat(546) + rxt(394)*y(6) - mat(377) = rxt(309)*y(129) - mat(704) = mat(704) + rxt(362)*y(6) + rxt(363)*y(8) + rxt(366)*y(13) + rxt(367)*y(133) - mat(746) = .060_r8*rxt(336)*y(1) - mat(643) = .275_r8*rxt(342)*y(1) - mat(725) = mat(725) + .470_r8*rxt(343)*y(6) + .470_r8*rxt(345)*y(8) + .730_r8*rxt(347)*y(13) + & - .470_r8*rxt(348)*y(133) - mat(123) = .200_r8*rxt(349)*y(129) - mat(765) = mat(765) + rxt(353)*y(13) - mat(466) = mat(466) + rxt(295)*y(6) + rxt(297)*y(13) + 2.400_r8*rxt(298) *y(132) - mat(308) = rxt(392)*y(1) - mat(523) = mat(523) + rxt(316)*y(6) + rxt(318)*y(13) - mat(269) = rxt(277)*y(129) - mat(77) = rxt(310)*y(129) - mat(512) = rxt(308)*y(129) - mat(619) = rxt(329)*y(129) - mat(391) = mat(391) + .250_r8*rxt(289)*y(6) - mat(192) = rxt(291)*y(3) - mat(630) = mat(630) + .300_r8*rxt(327)*y(13) - mat(577) = mat(577) + .794_r8*rxt(368)*y(6) + .794_r8*rxt(369)*y(8) + .794_r8*rxt(370)*y(130) - mat(533) = rxt(372)*y(129) + rxt(373)*y(8) - mat(680) = mat(680) + rxt(378)*y(6) + rxt(379)*y(8) + .800_r8*rxt(381)*y(13) + rxt(382)*y(133) - mat(94) = .350_r8*rxt(286)*y(129) - mat(242) = rxt(279)*y(129) - mat(180) = mat(180) + rxt(281)*y(6) - mat(555) = rxt(413)*y(129) - mat(98) = .500_r8*rxt(416)*y(129) - END SUBROUTINE nlnmat03 - - SUBROUTINE nlnmat04(mat, y, rxt) - USE chem_mods, ONLY: nzcnt - USE chem_mods, ONLY: gas_pcnst - USE chem_mods, ONLY: rxntot - IMPLICIT NONE - !---------------------------------------------- - ! ... dummy arguments - !---------------------------------------------- - REAL(KIND=r8), intent(in) :: y(gas_pcnst) - REAL(KIND=r8), intent(in) :: rxt(rxntot) - REAL(KIND=r8), intent(inout) :: mat(nzcnt) - !---------------------------------------------- - ! ... local variables - !---------------------------------------------- - !---------------------------------------------- - ! ... complete matrix entries implicit species - !---------------------------------------------- - mat(312) = -(rxt(174)*y(129) + rxt(179)*y(2) + rxt(209)*y(127)) - mat(1337) = -rxt(174)*y(20) - mat(924) = -rxt(179)*y(20) - mat(1130) = -rxt(209)*y(20) - mat(1337) = mat(1337) + 2.000_r8*rxt(172)*y(129) - mat(1075) = 2.000_r8*rxt(178)*y(130) - mat(1484) = -(rxt(134)*y(157) + rxt(250)*y(103) + rxt(414)*y(109)) - mat(982) = -rxt(134)*y(158) - mat(440) = -rxt(250)*y(158) - mat(83) = -rxt(414)*y(158) - mat(660) = rxt(173)*y(129) - mat(1392) = rxt(173)*y(18) + 2.000_r8*rxt(171)*y(129) + rxt(199)*y(9) + rxt(205)*y(10) + rxt(& - 278)*y(14) + rxt(270)*y(16) + rxt(170) *y(130) + rxt(174)*y(20) + rxt(226)*y(27) + rxt(230)*y(& - 28) + rxt(246)*y(32) + rxt(300)*y(41) + rxt(294)*y(40) + rxt(323) *y(52) & - + rxt(307)*y(45) + rxt(287)*y(38) + .500_r8*rxt(341) *y(61) + rxt(320)*y(49) + rxt(319)*y(50) + & - rxt(324)*y(51) + rxt(328)*y(55) + rxt(330)*y(54) + (rxt(383)+rxt(384))*y(71) & - + rxt(279)*y(99) - mat(1458) = rxt(199)*y(129) - mat(221) = rxt(205)*y(129) - mat(158) = rxt(278)*y(129) - mat(1508) = rxt(270)*y(129) - mat(1178) = rxt(167)*y(130) - mat(1123) = rxt(170)*y(129) + rxt(167)*y(19) - mat(318) = rxt(174)*y(129) - mat(836) = rxt(226)*y(129) + (rxt(422)+rxt(427)+rxt(433))*y(28) + (rxt(423) +rxt(434))*y(33) - mat(492) = rxt(230)*y(129) + (rxt(422)+rxt(427)+rxt(433))*y(27) - mat(458) = rxt(246)*y(129) - mat(404) = (rxt(423)+rxt(434))*y(27) - mat(615) = rxt(300)*y(129) - mat(322) = rxt(294)*y(129) - mat(266) = rxt(323)*y(129) - mat(231) = rxt(307)*y(129) - mat(89) = rxt(287)*y(129) - mat(646) = .500_r8*rxt(341)*y(129) - mat(32) = rxt(320)*y(129) - mat(171) = rxt(319)*y(129) - mat(374) = rxt(324)*y(129) - mat(176) = rxt(328)*y(129) - mat(669) = rxt(330)*y(129) - mat(133) = (rxt(383)+rxt(384))*y(129) - mat(244) = rxt(279)*y(129) - mat(1150) = -(rxt(207)*y(1) + rxt(208)*y(18) + rxt(209)*y(20) + (rxt(210) + rxt(211)) * y(130) & - + rxt(212)*y(16) + rxt(229)*y(28) + rxt(233) *y(29) + rxt(285)*y(38)) - mat(1019) = -rxt(207)*y(127) - mat(655) = -rxt(208)*y(127) - mat(316) = -rxt(209)*y(127) - mat(1115) = -(rxt(210) + rxt(211)) * y(127) - mat(1500) = -rxt(212)*y(127) - mat(490) = -rxt(229)*y(127) - mat(564) = -rxt(233)*y(127) - mat(87) = -rxt(285)*y(127) - mat(948) = rxt(214)*y(24) + rxt(227)*y(27) - mat(974) = rxt(160)*y(27) + rxt(155)*y(101) - mat(1249) = rxt(219)*y(24) - mat(1384) = rxt(215)*y(24) + rxt(226)*y(27) - mat(877) = rxt(218)*y(24) - mat(1046) = rxt(214)*y(2) + rxt(219)*y(6) + rxt(215)*y(129) + rxt(218)*y(13) + (+ 4.000_r8*rxt(221)+2.000_r8*rxt(223))& - *y(24) + rxt(243)*y(31) + rxt(410)*y(108) - mat(829) = rxt(227)*y(2) + rxt(160)*y(157) + rxt(226)*y(129) - mat(1194) = rxt(243)*y(24) - mat(68) = rxt(155)*y(157) - mat(812) = rxt(410)*y(24) - mat(1125) = rxt(233)*y(29) - mat(1030) = 2.000_r8*rxt(222)*y(24) - mat(819) = (rxt(422)+rxt(427)+rxt(433))*y(28) + (rxt(421)+rxt(426)+rxt(432)) *y(29) - mat(485) = (rxt(422)+rxt(427)+rxt(433))*y(27) - mat(558) = rxt(233)*y(127) + (rxt(421)+rxt(426)+rxt(432))*y(27) - mat(1044) = -(rxt(214)*y(2) + (rxt(215) + rxt(216)) * y(129) + rxt(217) *y(130) + rxt(218)*y(13)& - + rxt(219)*y(6) + rxt(220)*y(7) + (4._r8*rxt(221) + 4._r8*rxt(222) + 4._r8*rxt(223) & - + 4._r8*rxt(224)) * y(24) + (rxt(242) + rxt(243) + rxt(244) ) * y(31) + rxt(410)*y(& - 108)) - mat(946) = -rxt(214)*y(24) - mat(1382) = -(rxt(215) + rxt(216)) * y(24) - mat(1113) = -rxt(217)*y(24) - mat(875) = -rxt(218)*y(24) - mat(1247) = -rxt(219)*y(24) - mat(1284) = -rxt(220)*y(24) - mat(1192) = -(rxt(242) + rxt(243) + rxt(244)) * y(24) - mat(810) = -rxt(410)*y(24) - mat(1017) = rxt(207)*y(127) - mat(946) = mat(946) + rxt(228)*y(28) + rxt(231)*y(29) - mat(1382) = mat(1382) + rxt(230)*y(28) - mat(1113) = mat(1113) + rxt(211)*y(127) - mat(1148) = rxt(207)*y(1) + rxt(211)*y(130) + rxt(229)*y(28) - mat(138) = rxt(412)*y(108) - mat(489) = rxt(228)*y(2) + rxt(230)*y(129) + rxt(229)*y(127) - mat(563) = rxt(231)*y(2) - mat(810) = mat(810) + rxt(412)*y(25) - mat(134) = -(rxt(412)*y(108)) - mat(802) = -rxt(412)*y(25) - mat(1032) = 2.000_r8*rxt(223)*y(24) + rxt(242)*y(31) - mat(1181) = rxt(242)*y(24) - mat(1029) = 2.000_r8*rxt(224)*y(24) - mat(824) = -(rxt(160)*y(157) + rxt(226)*y(129) + rxt(227)*y(2) + (rxt(421) + rxt(426) + rxt(432)& - ) * y(29) + (rxt(422) + rxt(427) + rxt(433) ) * y(28) + (rxt(423) + rxt(434)) * y(33)) - mat(965) = -rxt(160)*y(27) - mat(1375) = -rxt(226)*y(27) - mat(939) = -rxt(227)*y(27) - mat(561) = -(rxt(421) + rxt(426) + rxt(432)) * y(27) - mat(487) = -(rxt(422) + rxt(427) + rxt(433)) * y(27) - mat(398) = -(rxt(423) + rxt(434)) * y(27) - mat(651) = rxt(208)*y(127) - mat(1375) = mat(1375) + rxt(216)*y(24) - mat(1491) = rxt(212)*y(127) - mat(1106) = rxt(210)*y(127) - mat(313) = rxt(209)*y(127) - mat(1141) = rxt(208)*y(18) + rxt(212)*y(16) + rxt(210)*y(130) + rxt(209) *y(20) + rxt(229)*y(28)& - + rxt(285)*y(38) - mat(1037) = rxt(216)*y(129) - mat(487) = mat(487) + rxt(229)*y(127) - mat(86) = rxt(285)*y(127) - mat(486) = -(rxt(228)*y(2) + rxt(229)*y(127) + rxt(230)*y(129) + (rxt(422) + rxt(427) + rxt(433)& - ) * y(27)) - mat(933) = -rxt(228)*y(28) - mat(1134) = -rxt(229)*y(28) - mat(1351) = -rxt(230)*y(28) - mat(822) = -(rxt(422) + rxt(427) + rxt(433)) * y(28) - mat(1351) = mat(1351) + rxt(232)*y(29) - mat(1087) = rxt(217)*y(24) - mat(1033) = rxt(217)*y(130) - mat(559) = rxt(232)*y(129) - mat(560) = -(rxt(231)*y(2) + rxt(232)*y(129) + rxt(233)*y(127) + (rxt(421) + rxt(426) + rxt(432)& - ) * y(27)) - mat(935) = -rxt(231)*y(29) - mat(1358) = -rxt(232)*y(29) - mat(1136) = -rxt(233)*y(29) - mat(823) = -(rxt(421) + rxt(426) + rxt(432)) * y(29) - mat(1270) = rxt(220)*y(24) - mat(1035) = rxt(220)*y(7) - mat(1031) = rxt(244)*y(31) - mat(820) = (rxt(423)+rxt(434))*y(33) - mat(1180) = rxt(244)*y(24) - mat(396) = (rxt(423)+rxt(434))*y(27) - mat(839) = -(rxt(234)*y(1) + rxt(235)*y(130) + rxt(236)*y(16)) - mat(1011) = -rxt(234)*y(128) - mat(1107) = -rxt(235)*y(128) - mat(1492) = -rxt(236)*y(128) - mat(940) = rxt(237)*y(31) + rxt(247)*y(32) - mat(966) = rxt(161)*y(32) - mat(1241) = rxt(240)*y(31) - mat(1376) = rxt(238)*y(31) + rxt(246)*y(32) - mat(1038) = (rxt(242)+rxt(243))*y(31) - mat(1187) = rxt(237)*y(2) + rxt(240)*y(6) + rxt(238)*y(129) + (rxt(242) +rxt(243))*y(24) + & - 4.000_r8*rxt(245)*y(31) + rxt(411)*y(108) - mat(453) = rxt(247)*y(2) + rxt(161)*y(157) + rxt(246)*y(129) - mat(806) = rxt(411)*y(31) - mat(1196) = -(rxt(237)*y(2) + rxt(238)*y(129) + rxt(239)*y(130) + rxt(240) *y(6) + rxt(241)*y(7)& - + (rxt(242) + rxt(243) + rxt(244)) * y(24) + 4._r8*rxt(245)*y(31) + rxt(411)*y(108)) - mat(950) = -rxt(237)*y(31) - mat(1386) = -rxt(238)*y(31) - mat(1117) = -rxt(239)*y(31) - mat(1251) = -rxt(240)*y(31) - mat(1288) = -rxt(241)*y(31) - mat(1048) = -(rxt(242) + rxt(243) + rxt(244)) * y(31) - mat(814) = -rxt(411)*y(31) - mat(1021) = rxt(234)*y(128) - mat(950) = mat(950) + rxt(248)*y(33) + rxt(249)*y(34) - mat(846) = rxt(234)*y(1) - mat(402) = rxt(248)*y(2) - mat(284) = rxt(249)*y(2) - mat(452) = -(rxt(161)*y(157) + rxt(246)*y(129) + rxt(247)*y(2)) - mat(963) = -rxt(161)*y(32) - mat(1348) = -rxt(246)*y(32) - mat(931) = -rxt(247)*y(32) - mat(1488) = rxt(236)*y(128) - mat(1085) = rxt(235)*y(128) - mat(837) = rxt(236)*y(16) + rxt(235)*y(130) - mat(397) = -(rxt(248)*y(2) + (rxt(423) + rxt(434)) * y(27)) - mat(927) = -rxt(248)*y(33) - mat(821) = -(rxt(423) + rxt(434)) * y(33) - mat(1083) = rxt(239)*y(31) - mat(1183) = rxt(239)*y(130) - mat(280) = -(rxt(249)*y(2)) - mat(922) = -rxt(249)*y(34) - mat(1264) = rxt(241)*y(31) - mat(1182) = rxt(241)*y(7) - mat(344) = -((rxt(437) + rxt(438)) * y(2) + rxt(445)*y(3) + rxt(449)*y(153)) - mat(925) = -(rxt(437) + rxt(438)) * y(148) - mat(892) = -rxt(445)*y(148) - mat(422) = -rxt(449)*y(148) - mat(405) = -(rxt(440)*y(5) + rxt(441)*y(6) + rxt(448)*y(153)) - mat(473) = -rxt(440)*y(149) - mat(1218) = -rxt(441)*y(149) - mat(423) = -rxt(448)*y(149) - mat(894) = rxt(445)*y(148) + rxt(442)*y(150) + rxt(435)*y(151) - mat(345) = rxt(445)*y(3) - mat(203) = rxt(442)*y(3) - mat(297) = rxt(435)*y(3) - mat(201) = -((rxt(442) + rxt(443)) * y(3) + rxt(444)*y(2)) - mat(889) = -(rxt(442) + rxt(443)) * y(150) - mat(920) = -rxt(444)*y(150) - mat(296) = -(rxt(435)*y(3)) - mat(891) = -rxt(435)*y(151) - mat(923) = rxt(438)*y(148) + rxt(444)*y(150) - mat(343) = rxt(438)*y(2) - mat(202) = rxt(444)*y(2) - END SUBROUTINE nlnmat04 - - SUBROUTINE nlnmat05(mat, y, rxt) - USE chem_mods, ONLY: nzcnt - USE chem_mods, ONLY: gas_pcnst - USE chem_mods, ONLY: rxntot - IMPLICIT NONE - !---------------------------------------------- - ! ... dummy arguments - !---------------------------------------------- - REAL(KIND=r8), intent(in) :: y(gas_pcnst) - REAL(KIND=r8), intent(in) :: rxt(rxntot) - REAL(KIND=r8), intent(inout) :: mat(nzcnt) - !---------------------------------------------- - ! ... local variables - !---------------------------------------------- - !---------------------------------------------- - ! ... complete matrix entries implicit species - !---------------------------------------------- - mat(414) = -(rxt(447)*y(153)) - mat(424) = -rxt(447)*y(152) - mat(929) = rxt(437)*y(148) - mat(895) = rxt(443)*y(150) - mat(474) = rxt(440)*y(149) - mat(1219) = rxt(441)*y(149) - mat(346) = rxt(437)*y(2) - mat(406) = rxt(440)*y(5) + rxt(441)*y(6) - mat(204) = rxt(443)*y(3) - mat(222) = -(rxt(182)*y(3) + rxt(183)*y(2)) - mat(890) = -rxt(182)*y(154) - mat(921) = -rxt(183)*y(154) - mat(921) = mat(921) + rxt(437)*y(148) - mat(342) = rxt(437)*y(2) + .900_r8*rxt(449)*y(153) - mat(413) = .800_r8*rxt(447)*y(153) - mat(421) = .900_r8*rxt(449)*y(148) + .800_r8*rxt(447)*y(152) - mat(425) = -(rxt(447)*y(152) + rxt(448)*y(149) + rxt(449)*y(148)) - mat(415) = -rxt(447)*y(153) - mat(407) = -rxt(448)*y(153) - mat(347) = -rxt(449)*y(153) - mat(587) = -(rxt(313)*y(129) + rxt(314)*y(1) + rxt(315)*y(8)) - mat(1360) = -rxt(313)*y(48) - mat(997) = -rxt(314)*y(48) - mat(1406) = -rxt(315)*y(48) - mat(997) = mat(997) + .070_r8*rxt(360)*y(65) - mat(496) = .070_r8*rxt(360)*y(1) - mat(494) = -(rxt(359)*y(129) + rxt(360)*y(1) + rxt(361)*y(8)) - mat(1352) = -rxt(359)*y(65) - mat(992) = -rxt(360)*y(65) - mat(1400) = -rxt(361)*y(65) - mat(442) = -(rxt(321)*y(6) + rxt(322)*y(130)) - mat(1221) = -rxt(321)*y(137) - mat(1084) = -rxt(322)*y(137) - mat(1347) = rxt(313)*y(48) + .500_r8*rxt(323)*y(52) - mat(586) = rxt(313)*y(129) - mat(261) = .500_r8*rxt(323)*y(129) - mat(607) = -(rxt(300)*y(129) + rxt(301)*y(8)) - mat(1362) = -rxt(300)*y(41) - mat(1408) = -rxt(301)*y(41) - mat(999) = .500_r8*rxt(314)*y(48) + .040_r8*rxt(336)*y(60) - mat(1230) = rxt(321)*y(137) + rxt(334)*y(139) + .400_r8*rxt(375)*y(143) + rxt(338)*y(140) + rxt(& - 295)*y(132) + .270_r8*rxt(316)*y(136) - mat(1362) = mat(1362) + .500_r8*rxt(299)*y(39) + rxt(310)*y(42) - mat(861) = .800_r8*rxt(297)*y(132) - mat(589) = .500_r8*rxt(314)*y(1) - mat(443) = rxt(321)*y(6) - mat(110) = rxt(334)*y(6) - mat(361) = .400_r8*rxt(375)*y(6) - mat(336) = rxt(338)*y(6) - mat(736) = .040_r8*rxt(336)*y(1) - mat(463) = rxt(295)*y(6) + .800_r8*rxt(297)*y(13) + 3.200_r8*rxt(298)*y(132) - mat(127) = .500_r8*rxt(299)*y(129) - mat(518) = .270_r8*rxt(316)*y(6) - mat(76) = rxt(310)*y(129) - mat(319) = -(rxt(294)*y(129)) - mat(1338) = -rxt(294)*y(40) - mat(989) = .250_r8*rxt(314)*y(48) + .200_r8*rxt(360)*y(65) - mat(854) = .100_r8*rxt(305)*y(133) - mat(1076) = .250_r8*rxt(304)*y(133) + .250_r8*rxt(352)*y(141) - mat(585) = .250_r8*rxt(314)*y(1) - mat(493) = .200_r8*rxt(360)*y(1) - mat(777) = .100_r8*rxt(305)*y(13) + .250_r8*rxt(304)*y(130) - mat(757) = .250_r8*rxt(352)*y(130) - mat(260) = -(rxt(323)*y(129)) - mat(1332) = -rxt(323)*y(52) - mat(1073) = rxt(322)*y(137) - mat(441) = rxt(322)*y(130) - mat(789) = -(rxt(302)*y(6) + rxt(303)*y(7) + rxt(304)*y(130) + rxt(305)*y(13) + 4._r8*rxt(306)& - *y(133) + rxt(348)*y(142) + rxt(367)*y(144) + rxt(382)*y(145)) - mat(1240) = -rxt(302)*y(133) - mat(1275) = -rxt(303)*y(133) - mat(1105) = -rxt(304)*y(133) - mat(871) = -rxt(305)*y(133) - mat(723) = -rxt(348)*y(133) - mat(701) = -rxt(367)*y(133) - mat(678) = -rxt(382)*y(133) - mat(1240) = mat(1240) + rxt(338)*y(140) + .530_r8*rxt(343)*y(142) + rxt(350) *y(141) + rxt(325)& - *y(138) - mat(1373) = rxt(300)*y(41) + .500_r8*rxt(307)*y(45) + rxt(330)*y(54) - mat(1418) = rxt(301)*y(41) + .530_r8*rxt(345)*y(142) + rxt(351)*y(141) + rxt(331)*y(54) - mat(871) = mat(871) + .260_r8*rxt(347)*y(142) + rxt(353)*y(141) + .300_r8*rxt(327)*y(138) - mat(608) = rxt(300)*y(129) + rxt(301)*y(8) - mat(789) = mat(789) + .530_r8*rxt(348)*y(142) - mat(228) = .500_r8*rxt(307)*y(129) - mat(337) = rxt(338)*y(6) - mat(723) = mat(723) + .530_r8*rxt(343)*y(6) + .530_r8*rxt(345)*y(8) + .260_r8*rxt(347)*y(13) + & - .530_r8*rxt(348)*y(133) - mat(761) = rxt(350)*y(6) + rxt(351)*y(8) + rxt(353)*y(13) + 4.000_r8*rxt(355) *y(141) - mat(627) = rxt(325)*y(6) + .300_r8*rxt(327)*y(13) - mat(663) = rxt(330)*y(129) + rxt(331)*y(8) - mat(227) = -(rxt(307)*y(129)) - mat(1327) = -rxt(307)*y(45) - mat(1069) = .750_r8*rxt(304)*y(133) + .750_r8*rxt(352)*y(141) - mat(776) = .750_r8*rxt(304)*y(130) - mat(755) = .750_r8*rxt(352)*y(130) - mat(194) = -(rxt(312)*y(129)) - mat(1324) = -rxt(312)*y(47) - mat(1261) = rxt(303)*y(133) - mat(775) = rxt(303)*y(7) - mat(150) = -(rxt(332)*y(129)) - mat(1318) = -rxt(332)*y(64) - mat(1206) = .100_r8*rxt(375)*y(143) - mat(1397) = rxt(315)*y(48) - mat(584) = rxt(315)*y(8) - mat(354) = .100_r8*rxt(375)*y(6) - mat(84) = -(rxt(285)*y(127) + rxt(287)*y(129)) - mat(1126) = -rxt(285)*y(38) - mat(1308) = -rxt(287)*y(38) - mat(233) = -(rxt(284)*y(127) + rxt(288)*y(129) + rxt(293)*y(1)) - mat(1128) = -rxt(284)*y(37) - mat(1328) = -rxt(288)*y(37) - mat(986) = -rxt(293)*y(37) - mat(23) = -(rxt(371)*y(129)) - mat(1297) = -rxt(371)*y(57) - mat(288) = -(rxt(358)*y(129)) - mat(1335) = -rxt(358)*y(63) - mat(1265) = rxt(356)*y(141) - mat(756) = rxt(356)*y(7) - mat(26) = -(rxt(333)*y(129)) - mat(1298) = -rxt(333)*y(56) - mat(108) = -(rxt(334)*y(6)) - mat(1204) = -rxt(334)*y(139) - mat(1311) = rxt(333)*y(56) - mat(27) = rxt(333)*y(129) - mat(358) = -(rxt(375)*y(6) + rxt(376)*y(130)) - mat(1214) = -rxt(375)*y(143) - mat(1079) = -rxt(376)*y(143) - mat(1341) = rxt(371)*y(57) + rxt(377)*y(66) - mat(24) = rxt(371)*y(129) - mat(326) = rxt(377)*y(129) - mat(324) = -(rxt(377)*y(129)) - mat(1339) = -rxt(377)*y(66) - mat(1077) = rxt(376)*y(143) - mat(356) = rxt(376)*y(130) - mat(184) = -(rxt(337)*y(129)) - mat(1323) = -rxt(337)*y(58) - mat(1208) = .800_r8*rxt(375)*y(143) - mat(355) = .800_r8*rxt(375)*y(6) - mat(335) = -(rxt(338)*y(6) + rxt(339)*y(130)) - mat(1213) = -rxt(338)*y(140) - mat(1078) = -rxt(339)*y(140) - mat(1340) = rxt(337)*y(58) + rxt(340)*y(59) - mat(185) = rxt(337)*y(129) - mat(116) = rxt(340)*y(129) - mat(115) = -(rxt(340)*y(129)) - mat(1312) = -rxt(340)*y(59) - mat(1057) = rxt(339)*y(140) - mat(334) = rxt(339)*y(130) - mat(33) = -(rxt(385)*y(129)) - mat(1300) = -rxt(385)*y(73) - mat(38) = -(rxt(389)*y(129)) - mat(1301) = -rxt(389)*y(74) - mat(1301) = mat(1301) + .250_r8*rxt(385)*y(73) - mat(34) = .250_r8*rxt(385)*y(129) - mat(246) = -(rxt(386)*y(6) + rxt(387)*y(130)) - mat(1211) = -rxt(386)*y(146) - mat(1071) = -rxt(387)*y(146) - mat(1330) = .700_r8*rxt(385)*y(73) + rxt(388)*y(75) - mat(35) = .700_r8*rxt(385)*y(129) - mat(161) = rxt(388)*y(129) - mat(160) = -(rxt(388)*y(129)) - mat(1320) = -rxt(388)*y(75) - mat(1062) = rxt(387)*y(146) - mat(245) = rxt(387)*y(130) - mat(61) = -(rxt(390)*y(7)) - mat(1259) = -rxt(390)*y(76) - mat(1304) = rxt(389)*y(74) - mat(39) = rxt(389)*y(129) - mat(540) = -(rxt(394)*y(6) + rxt(395)*y(130)) - mat(1227) = -rxt(394)*y(147) - mat(1091) = -rxt(395)*y(147) - mat(1356) = rxt(396)*y(78) + rxt(391)*y(77) - mat(1403) = rxt(393)*y(77) - mat(210) = rxt(396)*y(129) - mat(304) = rxt(391)*y(129) + rxt(393)*y(8) - mat(208) = -(rxt(396)*y(129)) - mat(1325) = -rxt(396)*y(78) - mat(1067) = rxt(395)*y(147) - mat(538) = rxt(395)*y(130) - mat(1212) = .900_r8*rxt(386)*y(146) - mat(1263) = .700_r8*rxt(390)*y(76) - mat(247) = .900_r8*rxt(386)*y(6) - mat(62) = .700_r8*rxt(390)*y(7) - mat(375) = -(rxt(309)*y(129)) - mat(1343) = -rxt(309)*y(44) - mat(1216) = .450_r8*rxt(386)*y(146) + .250_r8*rxt(378)*y(145) - mat(1343) = mat(1343) + .200_r8*rxt(308)*y(43) + .650_r8*rxt(286)*y(98) - mat(1399) = .250_r8*rxt(379)*y(145) - mat(856) = .100_r8*rxt(381)*y(145) - mat(778) = .250_r8*rxt(382)*y(145) - mat(248) = .450_r8*rxt(386)*y(6) - mat(509) = .200_r8*rxt(308)*y(129) - mat(672) = .250_r8*rxt(378)*y(6) + .250_r8*rxt(379)*y(8) + .100_r8*rxt(381) *y(13) + & - .250_r8*rxt(382)*y(133) - mat(92) = .650_r8*rxt(286)*y(129) - mat(697) = -(rxt(362)*y(6) + rxt(363)*y(8) + rxt(364)*y(130) + rxt(366)*y(13) + rxt(367)*y(133)) - mat(1236) = -rxt(362)*y(144) - mat(1414) = -rxt(363)*y(144) - mat(1101) = -rxt(364)*y(144) - mat(867) = -rxt(366)*y(144) - mat(785) = -rxt(367)*y(144) - mat(1369) = rxt(359)*y(65) + .200_r8*rxt(365)*y(72) - mat(499) = rxt(359)*y(129) - mat(275) = .200_r8*rxt(365)*y(129) - END SUBROUTINE nlnmat05 - - SUBROUTINE nlnmat06(mat, y, rxt) - USE chem_mods, ONLY: nzcnt - USE chem_mods, ONLY: gas_pcnst - USE chem_mods, ONLY: rxntot - IMPLICIT NONE - !---------------------------------------------- - ! ... dummy arguments - !---------------------------------------------- - REAL(KIND=r8), intent(in) :: y(gas_pcnst) - REAL(KIND=r8), intent(in) :: rxt(rxntot) - REAL(KIND=r8), intent(inout) :: mat(nzcnt) - !---------------------------------------------- - ! ... local variables - !---------------------------------------------- - !---------------------------------------------- - ! ... complete matrix entries implicit species - !---------------------------------------------- - mat(740) = -(rxt(335)*y(129) + rxt(336)*y(1)) - mat(1371) = -rxt(335)*y(60) - mat(1007) = -rxt(336)*y(60) - mat(1007) = mat(1007) + .200_r8*rxt(360)*y(65) + rxt(392)*y(77) - mat(1238) = rxt(394)*y(147) + .320_r8*rxt(362)*y(144) + .039_r8*rxt(368) *y(69) - mat(1416) = .350_r8*rxt(363)*y(144) + .039_r8*rxt(369)*y(69) - mat(869) = .260_r8*rxt(366)*y(144) - mat(1103) = .039_r8*rxt(370)*y(69) - mat(500) = .200_r8*rxt(360)*y(1) - mat(787) = .350_r8*rxt(367)*y(144) - mat(543) = rxt(394)*y(6) - mat(699) = .320_r8*rxt(362)*y(6) + .350_r8*rxt(363)*y(8) + .260_r8*rxt(366) *y(13) + & - .350_r8*rxt(367)*y(133) - mat(306) = rxt(392)*y(1) - mat(576) = .039_r8*rxt(368)*y(6) + .039_r8*rxt(369)*y(8) + .039_r8*rxt(370) *y(130) - mat(637) = -(rxt(341)*y(129) + rxt(342)*y(1)) - mat(1365) = -rxt(341)*y(61) - mat(1002) = -rxt(342)*y(61) - mat(1002) = mat(1002) + .400_r8*rxt(360)*y(65) + rxt(392)*y(77) - mat(1233) = rxt(394)*y(147) + .230_r8*rxt(362)*y(144) + .167_r8*rxt(368) *y(69) - mat(1411) = .250_r8*rxt(363)*y(144) + .167_r8*rxt(369)*y(69) - mat(864) = .190_r8*rxt(366)*y(144) - mat(1097) = .167_r8*rxt(370)*y(69) - mat(498) = .400_r8*rxt(360)*y(1) - mat(782) = .250_r8*rxt(367)*y(144) - mat(542) = rxt(394)*y(6) - mat(694) = .230_r8*rxt(362)*y(6) + .250_r8*rxt(363)*y(8) + .190_r8*rxt(366) *y(13) + & - .250_r8*rxt(367)*y(133) - mat(305) = rxt(392)*y(1) - mat(574) = .167_r8*rxt(368)*y(6) + .167_r8*rxt(369)*y(8) + .167_r8*rxt(370) *y(130) - mat(721) = -((rxt(343) + rxt(344)) * y(6) + rxt(345)*y(8) + rxt(346)*y(130) + rxt(347)*y(13) + & - rxt(348)*y(133)) - mat(1237) = -(rxt(343) + rxt(344)) * y(142) - mat(1415) = -rxt(345)*y(142) - mat(1102) = -rxt(346)*y(142) - mat(868) = -rxt(347)*y(142) - mat(786) = -rxt(348)*y(142) - mat(1370) = rxt(335)*y(60) + .500_r8*rxt(341)*y(61) + .200_r8*rxt(349)*y(62) - mat(739) = rxt(335)*y(129) - mat(639) = .500_r8*rxt(341)*y(129) - mat(121) = .200_r8*rxt(349)*y(129) - mat(120) = -(rxt(349)*y(129)) - mat(1313) = -rxt(349)*y(62) - mat(1058) = rxt(346)*y(142) - mat(713) = rxt(346)*y(130) - mat(760) = -(rxt(350)*y(6) + rxt(351)*y(8) + rxt(352)*y(130) + rxt(353)*y(13) + rxt(354)*y(133) & - + 4._r8*rxt(355)*y(141) + rxt(356)*y(7)) - mat(1239) = -rxt(350)*y(141) - mat(1417) = -rxt(351)*y(141) - mat(1104) = -rxt(352)*y(141) - mat(870) = -rxt(353)*y(141) - mat(788) = -rxt(354)*y(141) - mat(1274) = -rxt(356)*y(141) - mat(1008) = .200_r8*rxt(360)*y(65) - mat(1372) = .500_r8*rxt(341)*y(61) + .500_r8*rxt(349)*y(62) - mat(501) = .200_r8*rxt(360)*y(1) - mat(640) = .500_r8*rxt(341)*y(129) - mat(122) = .500_r8*rxt(349)*y(129) - mat(462) = -(rxt(295)*y(6) + rxt(296)*y(130) + rxt(297)*y(13) + 4._r8*rxt(298) *y(132)) - mat(1222) = -rxt(295)*y(132) - mat(1086) = -rxt(296)*y(132) - mat(857) = -rxt(297)*y(132) - mat(1349) = rxt(287)*y(38) + .500_r8*rxt(299)*y(39) - mat(1133) = rxt(285)*y(38) - mat(85) = rxt(287)*y(129) + rxt(285)*y(127) - mat(126) = .500_r8*rxt(299)*y(129) - mat(125) = -(rxt(299)*y(129)) - mat(1314) = -rxt(299)*y(39) - mat(1059) = rxt(296)*y(132) - mat(460) = rxt(296)*y(130) - mat(303) = -(rxt(391)*y(129) + rxt(392)*y(1) + rxt(393)*y(8)) - mat(1336) = -rxt(391)*y(77) - mat(988) = -rxt(392)*y(77) - mat(1398) = -rxt(393)*y(77) - mat(29) = -(rxt(320)*y(129)) - mat(1299) = -rxt(320)*y(49) - mat(517) = -(rxt(316)*y(6) + rxt(317)*y(130) + rxt(318)*y(13)) - mat(1225) = -rxt(316)*y(136) - mat(1089) = -rxt(317)*y(136) - mat(859) = -rxt(318)*y(136) - mat(1354) = rxt(320)*y(49) + rxt(319)*y(50) - mat(30) = rxt(320)*y(129) - mat(168) = rxt(319)*y(129) - mat(166) = -(rxt(319)*y(129)) - mat(1321) = -rxt(319)*y(50) - mat(1063) = rxt(317)*y(136) - mat(515) = rxt(317)*y(130) - mat(369) = -(rxt(324)*y(129)) - mat(1342) = -rxt(324)*y(51) - mat(1215) = .500_r8*rxt(334)*y(139) + .250_r8*rxt(375)*y(143) + .100_r8*rxt(394)*y(147) + & - .820_r8*rxt(316)*y(136) - mat(855) = .820_r8*rxt(318)*y(136) - mat(109) = .500_r8*rxt(334)*y(6) - mat(359) = .250_r8*rxt(375)*y(6) - mat(539) = .100_r8*rxt(394)*y(6) - mat(516) = .820_r8*rxt(316)*y(6) + .820_r8*rxt(318)*y(13) - mat(172) = -(rxt(328)*y(129)) - mat(1322) = -rxt(328)*y(55) - mat(1064) = rxt(326)*y(138) - mat(622) = rxt(326)*y(130) - mat(268) = -(rxt(277)*y(129)) - mat(1333) = -rxt(277)*y(15) - mat(853) = 2.000_r8*rxt(276)*y(13) + .250_r8*rxt(366)*y(144) + .250_r8*rxt(347)*y(142) + & - .300_r8*rxt(297)*y(132) + .500_r8*rxt(327)*y(138) + .300_r8*rxt(381)*y(145) - mat(690) = .250_r8*rxt(366)*y(13) - mat(714) = .250_r8*rxt(347)*y(13) - mat(461) = .300_r8*rxt(297)*y(13) - mat(623) = .500_r8*rxt(327)*y(13) - mat(671) = .300_r8*rxt(381)*y(13) - mat(75) = -(rxt(310)*y(129)) - mat(1306) = -rxt(310)*y(42) - mat(850) = .200_r8*rxt(297)*y(132) - mat(459) = .200_r8*rxt(297)*y(13) + .800_r8*rxt(298)*y(132) - mat(510) = -(rxt(308)*y(129)) - mat(1353) = -rxt(308)*y(43) - mat(898) = rxt(291)*y(135) - mat(1224) = .530_r8*rxt(343)*y(142) + .250_r8*rxt(378)*y(145) - mat(1401) = .530_r8*rxt(345)*y(142) + .250_r8*rxt(379)*y(145) - mat(858) = .260_r8*rxt(347)*y(142) + .100_r8*rxt(381)*y(145) - mat(779) = .530_r8*rxt(348)*y(142) + .250_r8*rxt(382)*y(145) - mat(715) = .530_r8*rxt(343)*y(6) + .530_r8*rxt(345)*y(8) + .260_r8*rxt(347) *y(13) + & - .530_r8*rxt(348)*y(133) - mat(190) = rxt(291)*y(3) - mat(673) = .250_r8*rxt(378)*y(6) + .250_r8*rxt(379)*y(8) + .100_r8*rxt(381) *y(13) + & - .250_r8*rxt(382)*y(133) - mat(616) = -(rxt(329)*y(129)) - mat(1363) = -rxt(329)*y(53) - mat(1231) = .220_r8*rxt(343)*y(142) + .250_r8*rxt(378)*y(145) - mat(1363) = mat(1363) + .500_r8*rxt(323)*y(52) + .500_r8*rxt(358)*y(63) - mat(1409) = .220_r8*rxt(345)*y(142) + .250_r8*rxt(379)*y(145) - mat(862) = .230_r8*rxt(347)*y(142) + .200_r8*rxt(327)*y(138) + .100_r8*rxt(381)*y(145) - mat(263) = .500_r8*rxt(323)*y(129) - mat(781) = .220_r8*rxt(348)*y(142) + .250_r8*rxt(382)*y(145) - mat(289) = .500_r8*rxt(358)*y(129) - mat(718) = .220_r8*rxt(343)*y(6) + .220_r8*rxt(345)*y(8) + .230_r8*rxt(347) *y(13) + & - .220_r8*rxt(348)*y(133) - mat(624) = .200_r8*rxt(327)*y(13) - mat(675) = .250_r8*rxt(378)*y(6) + .250_r8*rxt(379)*y(8) + .100_r8*rxt(381) *y(13) + & - .250_r8*rxt(382)*y(133) - mat(388) = -(rxt(289)*y(6) + rxt(290)*y(130)) - mat(1217) = -rxt(289)*y(134) - mat(1082) = -rxt(290)*y(134) - mat(1345) = rxt(288)*y(37) - mat(235) = rxt(288)*y(129) - mat(189) = -(rxt(291)*y(3)) - mat(888) = -rxt(291)*y(135) - mat(1209) = .750_r8*rxt(289)*y(134) - mat(387) = .750_r8*rxt(289)*y(6) - mat(1056) = rxt(290)*y(134) - mat(386) = rxt(290)*y(130) - mat(139) = -(rxt(374)*y(129)) - mat(1316) = -rxt(374)*y(68) - mat(1205) = .370_r8*rxt(362)*y(144) - mat(1316) = mat(1316) + rxt(372)*y(70) - mat(1396) = .400_r8*rxt(363)*y(144) + rxt(373)*y(70) - mat(851) = .300_r8*rxt(366)*y(144) - mat(774) = .400_r8*rxt(367)*y(144) - mat(689) = .370_r8*rxt(362)*y(6) + .400_r8*rxt(363)*y(8) + .300_r8*rxt(366) *y(13) + & - .400_r8*rxt(367)*y(133) - mat(529) = rxt(372)*y(129) + rxt(373)*y(8) - mat(625) = -(rxt(325)*y(6) + rxt(326)*y(130) + rxt(327)*y(13)) - mat(1232) = -rxt(325)*y(138) - mat(1096) = -rxt(326)*y(138) - mat(863) = -rxt(327)*y(138) - mat(1364) = rxt(324)*y(51) + rxt(328)*y(55) - mat(370) = rxt(324)*y(129) - mat(173) = rxt(328)*y(129) - mat(662) = -(rxt(330)*y(129) + rxt(331)*y(8)) - mat(1367) = -rxt(330)*y(54) - mat(1412) = -rxt(331)*y(54) - mat(1003) = .950_r8*rxt(336)*y(60) + .800_r8*rxt(342)*y(61) - mat(1234) = .450_r8*rxt(386)*y(146) + .250_r8*rxt(343)*y(142) + .250_r8*rxt(378)*y(145) - mat(1367) = mat(1367) + rxt(332)*y(64) + rxt(329)*y(53) - mat(1412) = mat(1412) + .250_r8*rxt(345)*y(142) + .250_r8*rxt(379)*y(145) - mat(865) = .240_r8*rxt(347)*y(142) + .500_r8*rxt(327)*y(138) + .100_r8*rxt(381)*y(145) - mat(783) = .250_r8*rxt(348)*y(142) + .250_r8*rxt(382)*y(145) - mat(151) = rxt(332)*y(129) - mat(249) = .450_r8*rxt(386)*y(6) - mat(738) = .950_r8*rxt(336)*y(1) - mat(638) = .800_r8*rxt(342)*y(1) - mat(719) = .250_r8*rxt(343)*y(6) + .250_r8*rxt(345)*y(8) + .240_r8*rxt(347) *y(13) + & - .250_r8*rxt(348)*y(133) - mat(617) = rxt(329)*y(129) - mat(626) = .500_r8*rxt(327)*y(13) - mat(676) = .250_r8*rxt(378)*y(6) + .250_r8*rxt(379)*y(8) + .100_r8*rxt(381) *y(13) + & - .250_r8*rxt(382)*y(133) - mat(572) = -(rxt(368)*y(6) + rxt(369)*y(8) + rxt(370)*y(130)) - mat(1228) = -rxt(368)*y(69) - mat(1405) = -rxt(369)*y(69) - mat(1092) = -rxt(370)*y(69) - mat(1405) = mat(1405) + rxt(361)*y(65) - mat(495) = rxt(361)*y(8) - END SUBROUTINE nlnmat06 - - SUBROUTINE nlnmat07(mat, y, rxt) - USE chem_mods, ONLY: nzcnt - USE chem_mods, ONLY: gas_pcnst - USE chem_mods, ONLY: rxntot - IMPLICIT NONE - !---------------------------------------------- - ! ... dummy arguments - !---------------------------------------------- - REAL(KIND=r8), intent(in) :: y(gas_pcnst) - REAL(KIND=r8), intent(in) :: rxt(rxntot) - REAL(KIND=r8), intent(inout) :: mat(nzcnt) - !---------------------------------------------- - ! ... local variables - !---------------------------------------------- - !---------------------------------------------- - ! ... complete matrix entries implicit species - !---------------------------------------------- - mat(530) = -(rxt(372)*y(129) + rxt(373)*y(8)) - mat(1355) = -rxt(372)*y(70) - mat(1402) = -rxt(373)*y(70) - mat(1226) = .080_r8*rxt(362)*y(144) + .800_r8*rxt(344)*y(142) + .794_r8*rxt(368)*y(69) - mat(1402) = mat(1402) + .794_r8*rxt(369)*y(69) - mat(1090) = .794_r8*rxt(370)*y(69) - mat(692) = .080_r8*rxt(362)*y(6) - mat(716) = .800_r8*rxt(344)*y(6) - mat(571) = .794_r8*rxt(368)*y(6) + .794_r8*rxt(369)*y(8) + .794_r8*rxt(370) *y(130) - mat(677) = -(rxt(378)*y(6) + rxt(379)*y(8) + rxt(380)*y(130) + rxt(381)*y(13) + rxt(382)*y(133)) - mat(1235) = -rxt(378)*y(145) - mat(1413) = -rxt(379)*y(145) - mat(1100) = -rxt(380)*y(145) - mat(866) = -rxt(381)*y(145) - mat(784) = -rxt(382)*y(145) - mat(1368) = rxt(374)*y(68) + rxt(383)*y(71) + .800_r8*rxt(365)*y(72) - mat(140) = rxt(374)*y(129) - mat(131) = rxt(383)*y(129) - mat(274) = .800_r8*rxt(365)*y(129) - mat(130) = -((rxt(383) + rxt(384)) * y(129)) - mat(1315) = -(rxt(383) + rxt(384)) * y(71) - mat(1060) = rxt(370)*y(69) + rxt(380)*y(145) - mat(570) = rxt(370)*y(130) - mat(670) = rxt(380)*y(130) - mat(272) = -(rxt(365)*y(129)) - mat(1334) = -rxt(365)*y(72) - mat(1074) = rxt(364)*y(144) - mat(691) = rxt(364)*y(130) - mat(90) = -(rxt(283)*y(127) + rxt(286)*y(129)) - mat(1127) = -rxt(283)*y(98) - mat(1309) = -rxt(286)*y(98) - mat(241) = -(rxt(279)*y(129)) - mat(1329) = -rxt(279)*y(99) - mat(987) = .500_r8*rxt(293)*y(37) - mat(1210) = rxt(281)*y(131) - mat(1329) = mat(1329) + .350_r8*rxt(286)*y(98) - mat(1070) = rxt(282)*y(131) - mat(234) = .500_r8*rxt(293)*y(1) - mat(91) = .350_r8*rxt(286)*y(129) - mat(179) = rxt(281)*y(6) + rxt(282)*y(130) - mat(178) = -(rxt(281)*y(6) + rxt(282)*y(130)) - mat(1207) = -rxt(281)*y(131) - mat(1065) = -rxt(282)*y(131) - mat(1486) = rxt(272)*y(130) - mat(1065) = mat(1065) + rxt(272)*y(16) - mat(44) = -(rxt(154)*y(157)) - mat(958) = -rxt(154)*y(100) - mat(65) = -(rxt(155)*y(157)) - mat(961) = -rxt(155)*y(101) - mat(648) = rxt(251)*y(103) - mat(1438) = rxt(253)*y(103) - mat(1461) = rxt(250)*y(103) - mat(432) = rxt(251)*y(18) + rxt(253)*y(9) + rxt(250)*y(158) - mat(433) = -(rxt(250)*y(158) + rxt(251)*y(18) + rxt(253)*y(9)) - mat(1463) = -rxt(250)*y(103) - mat(649) = -rxt(251)*y(103) - mat(1439) = -rxt(253)*y(103) - mat(962) = 2.000_r8*rxt(154)*y(100) + rxt(155)*y(101) - mat(45) = 2.000_r8*rxt(154)*y(157) - mat(66) = rxt(155)*y(157) - mat(552) = -(rxt(413)*y(129)) - mat(1357) = -rxt(413)*y(104) - mat(995) = rxt(408)*y(108) - mat(899) = rxt(407)*y(108) - mat(1269) = rxt(409)*y(108) - mat(1357) = mat(1357) + (rxt(415)+.500_r8*rxt(416))*y(105) + rxt(402)*y(106) + rxt(406)*y(108) - mat(1404) = rxt(417)*y(105) - mat(1034) = rxt(410)*y(108) - mat(135) = rxt(412)*y(108) - mat(1184) = rxt(411)*y(108) - mat(97) = (rxt(415)+.500_r8*rxt(416))*y(129) + rxt(417)*y(8) - mat(144) = rxt(402)*y(129) - mat(804) = rxt(408)*y(1) + rxt(407)*y(3) + rxt(409)*y(7) + rxt(406)*y(129) + rxt(410)*y(24) + & - rxt(412)*y(25) + rxt(411)*y(31) - mat(96) = -((rxt(415) + rxt(416)) * y(129) + rxt(417)*y(8)) - mat(1310) = -(rxt(415) + rxt(416)) * y(105) - mat(1394) = -rxt(417)*y(105) - mat(142) = -(rxt(401)*y(2) + rxt(402)*y(129)) - mat(919) = -rxt(401)*y(106) - mat(1317) = -rxt(402)*y(106) - mat(379) = -(rxt(403)*y(129) + rxt(404)*y(3) + rxt(405)*y(1)) - mat(1344) = -rxt(403)*y(107) - mat(893) = -rxt(404)*y(107) - mat(990) = -rxt(405)*y(107) - mat(805) = -(rxt(406)*y(129) + rxt(407)*y(3) + rxt(408)*y(1) + rxt(409)*y(7) + rxt(410)*y(24) + & - rxt(411)*y(31) + rxt(412)*y(25)) - mat(1374) = -rxt(406)*y(108) - mat(901) = -rxt(407)*y(108) - mat(1010) = -rxt(408)*y(108) - mat(1276) = -rxt(409)*y(108) - mat(1036) = -rxt(410)*y(108) - mat(1185) = -rxt(411)*y(108) - mat(136) = -rxt(412)*y(108) - mat(1010) = mat(1010) + rxt(405)*y(107) - mat(938) = rxt(401)*y(106) - mat(901) = mat(901) + rxt(404)*y(107) - mat(1374) = mat(1374) + rxt(403)*y(107) - mat(146) = rxt(401)*y(2) - mat(380) = rxt(405)*y(1) + rxt(404)*y(3) + rxt(403)*y(129) - mat(80) = -(rxt(414)*y(158)) - mat(1462) = -rxt(414)*y(109) - mat(1307) = rxt(413)*y(104) - mat(551) = rxt(413)*y(129) - mat(1460) = rxt(414)*y(109) - mat(79) = rxt(414)*y(158) - END SUBROUTINE nlnmat07 - - SUBROUTINE nlnmat_finit(mat, lmat, dti) - USE chem_mods, ONLY: nzcnt - IMPLICIT NONE - !---------------------------------------------- - ! ... dummy arguments - !---------------------------------------------- - REAL(KIND=r8), intent(in) :: dti - REAL(KIND=r8), intent(in) :: lmat(nzcnt) - REAL(KIND=r8), intent(inout) :: mat(nzcnt) - !---------------------------------------------- - ! ... local variables - !---------------------------------------------- - !---------------------------------------------- - ! ... complete matrix entries implicit species - !---------------------------------------------- - mat(1) = lmat( 1) - mat(2) = lmat( 2) - mat(3) = lmat( 3) - mat(4) = lmat( 4) - mat(5) = lmat( 5) - mat(6) = lmat( 6) - mat(7) = lmat( 7) - mat(8) = lmat( 8) - mat(9) = lmat( 9) - mat(10) = lmat( 10) - mat(11) = lmat( 11) - mat(12) = lmat( 12) - mat(13) = lmat( 13) - mat(14) = lmat( 14) - mat(15) = lmat( 15) - mat(16) = lmat( 16) - mat(17) = mat( 17) + lmat( 17) - mat(20) = lmat( 20) - mat(21) = lmat( 21) - mat(22) = lmat( 22) - mat(23) = mat( 23) + lmat( 23) - mat(26) = mat( 26) + lmat( 26) - mat(29) = mat( 29) + lmat( 29) - mat(33) = mat( 33) + lmat( 33) - mat(38) = mat( 38) + lmat( 38) - mat(41) = lmat( 41) - mat(42) = lmat( 42) - mat(43) = lmat( 43) - mat(44) = mat( 44) + lmat( 44) - mat(45) = mat( 45) + lmat( 45) - mat(47) = lmat( 47) - mat(48) = lmat( 48) - mat(49) = lmat( 49) - mat(50) = mat( 50) + lmat( 50) - mat(51) = mat( 51) + lmat( 51) - mat(52) = mat( 52) + lmat( 52) - mat(53) = mat( 53) + lmat( 53) - mat(54) = lmat( 54) - mat(55) = lmat( 55) - mat(56) = lmat( 56) - mat(57) = mat( 57) + lmat( 57) - mat(61) = mat( 61) + lmat( 61) - mat(65) = mat( 65) + lmat( 65) - mat(66) = mat( 66) + lmat( 66) - mat(68) = mat( 68) + lmat( 68) - mat(69) = lmat( 69) - mat(70) = lmat( 70) - mat(71) = lmat( 71) - mat(72) = lmat( 72) - mat(73) = lmat( 73) - mat(74) = lmat( 74) - mat(75) = mat( 75) + lmat( 75) - mat(80) = mat( 80) + lmat( 80) - mat(81) = lmat( 81) - mat(82) = lmat( 82) - mat(84) = mat( 84) + lmat( 84) - mat(90) = mat( 90) + lmat( 90) - mat(96) = mat( 96) + lmat( 96) - mat(102) = lmat( 102) - mat(103) = lmat( 103) - mat(104) = lmat( 104) - mat(105) = lmat( 105) - mat(106) = lmat( 106) - mat(107) = lmat( 107) - mat(108) = mat( 108) + lmat( 108) - mat(115) = mat( 115) + lmat( 115) - mat(117) = lmat( 117) - mat(118) = lmat( 118) - mat(119) = mat( 119) + lmat( 119) - mat(120) = mat( 120) + lmat( 120) - mat(125) = mat( 125) + lmat( 125) - mat(127) = mat( 127) + lmat( 127) - mat(128) = lmat( 128) - mat(129) = mat( 129) + lmat( 129) - mat(130) = mat( 130) + lmat( 130) - mat(132) = mat( 132) + lmat( 132) - mat(134) = mat( 134) + lmat( 134) - mat(137) = lmat( 137) - mat(138) = mat( 138) + lmat( 138) - mat(139) = mat( 139) + lmat( 139) - mat(142) = mat( 142) + lmat( 142) - mat(143) = lmat( 143) - mat(145) = mat( 145) + lmat( 145) - mat(150) = mat( 150) + lmat( 150) - mat(154) = mat( 154) + lmat( 154) - mat(156) = lmat( 156) - mat(157) = mat( 157) + lmat( 157) - mat(159) = mat( 159) + lmat( 159) - mat(160) = mat( 160) + lmat( 160) - mat(162) = lmat( 162) - mat(163) = lmat( 163) - mat(164) = lmat( 164) - mat(165) = mat( 165) + lmat( 165) - mat(166) = mat( 166) + lmat( 166) - mat(167) = lmat( 167) - mat(169) = lmat( 169) - mat(170) = mat( 170) + lmat( 170) - mat(172) = mat( 172) + lmat( 172) - mat(174) = lmat( 174) - mat(175) = mat( 175) + lmat( 175) - mat(177) = lmat( 177) - mat(178) = mat( 178) + lmat( 178) - mat(180) = mat( 180) + lmat( 180) - mat(183) = lmat( 183) - mat(184) = mat( 184) + lmat( 184) - mat(186) = lmat( 186) - mat(187) = lmat( 187) - mat(189) = mat( 189) + lmat( 189) - mat(192) = mat( 192) + lmat( 192) - mat(193) = lmat( 193) - mat(194) = mat( 194) + lmat( 194) - mat(195) = lmat( 195) - mat(196) = lmat( 196) - mat(197) = lmat( 197) - mat(199) = mat( 199) + lmat( 199) - mat(201) = mat( 201) + lmat( 201) - mat(208) = mat( 208) + lmat( 208) - mat(209) = lmat( 209) - mat(211) = lmat( 211) - mat(212) = lmat( 212) - mat(213) = lmat( 213) - mat(214) = mat( 214) + lmat( 214) - mat(215) = mat( 215) + lmat( 215) - mat(217) = lmat( 217) - mat(218) = mat( 218) + lmat( 218) - mat(219) = mat( 219) + lmat( 219) - mat(220) = lmat( 220) - mat(222) = mat( 222) + lmat( 222) - mat(227) = mat( 227) + lmat( 227) - mat(229) = lmat( 229) - mat(230) = mat( 230) + lmat( 230) - mat(233) = mat( 233) + lmat( 233) - mat(241) = mat( 241) + lmat( 241) - mat(246) = mat( 246) + lmat( 246) - mat(254) = lmat( 254) - mat(255) = lmat( 255) - mat(256) = lmat( 256) - mat(257) = lmat( 257) - mat(258) = lmat( 258) - mat(259) = lmat( 259) - mat(260) = mat( 260) + lmat( 260) - mat(262) = lmat( 262) - mat(264) = lmat( 264) - mat(265) = mat( 265) + lmat( 265) - mat(267) = lmat( 267) - mat(268) = mat( 268) + lmat( 268) - mat(272) = mat( 272) + lmat( 272) - mat(273) = lmat( 273) - mat(276) = lmat( 276) - mat(277) = lmat( 277) - mat(279) = lmat( 279) - mat(280) = mat( 280) + lmat( 280) - mat(281) = lmat( 281) - mat(282) = lmat( 282) - mat(284) = mat( 284) + lmat( 284) - mat(285) = lmat( 285) - mat(286) = mat( 286) + lmat( 286) - mat(287) = lmat( 287) - mat(288) = mat( 288) + lmat( 288) - mat(290) = lmat( 290) - mat(292) = lmat( 292) - mat(296) = mat( 296) + lmat( 296) - mat(297) = mat( 297) + lmat( 297) - mat(298) = lmat( 298) - mat(299) = lmat( 299) - mat(300) = lmat( 300) - mat(303) = mat( 303) + lmat( 303) - mat(312) = mat( 312) + lmat( 312) - mat(317) = mat( 317) + lmat( 317) - mat(319) = mat( 319) + lmat( 319) - mat(323) = lmat( 323) - mat(324) = mat( 324) + lmat( 324) - mat(327) = lmat( 327) - mat(329) = lmat( 329) - mat(331) = lmat( 331) - mat(332) = mat( 332) + lmat( 332) - mat(333) = lmat( 333) - mat(335) = mat( 335) + lmat( 335) - mat(344) = mat( 344) + lmat( 344) - mat(358) = mat( 358) + lmat( 358) - mat(369) = mat( 369) + lmat( 369) - mat(371) = lmat( 371) - mat(372) = lmat( 372) - mat(375) = mat( 375) + lmat( 375) - mat(376) = mat( 376) + lmat( 376) - mat(377) = mat( 377) + lmat( 377) - mat(379) = mat( 379) + lmat( 379) - mat(388) = mat( 388) + lmat( 388) - mat(397) = mat( 397) + lmat( 397) - mat(399) = lmat( 399) - mat(403) = mat( 403) + lmat( 403) - mat(405) = mat( 405) + lmat( 405) - mat(406) = mat( 406) + lmat( 406) - mat(412) = mat( 412) + lmat( 412) - mat(414) = mat( 414) + lmat( 414) - mat(425) = mat( 425) + lmat( 425) - mat(432) = mat( 432) + lmat( 432) - mat(433) = mat( 433) + lmat( 433) - mat(435) = lmat( 435) - mat(442) = mat( 442) + lmat( 442) - mat(452) = mat( 452) + lmat( 452) - mat(453) = mat( 453) + lmat( 453) - mat(456) = lmat( 456) - mat(462) = mat( 462) + lmat( 462) - mat(471) = lmat( 471) - mat(475) = lmat( 475) - mat(476) = mat( 476) + lmat( 476) - mat(486) = mat( 486) + lmat( 486) - mat(490) = mat( 490) + lmat( 490) - mat(491) = mat( 491) + lmat( 491) - mat(494) = mat( 494) + lmat( 494) - mat(510) = mat( 510) + lmat( 510) - mat(511) = lmat( 511) - mat(512) = mat( 512) + lmat( 512) - mat(514) = mat( 514) + lmat( 514) - mat(517) = mat( 517) + lmat( 517) - mat(530) = mat( 530) + lmat( 530) - mat(531) = lmat( 531) - mat(533) = mat( 533) + lmat( 533) - mat(534) = mat( 534) + lmat( 534) - mat(537) = lmat( 537) - mat(540) = mat( 540) + lmat( 540) - mat(552) = mat( 552) + lmat( 552) - mat(553) = lmat( 553) - mat(554) = lmat( 554) - mat(559) = mat( 559) + lmat( 559) - mat(560) = mat( 560) + lmat( 560) - mat(563) = mat( 563) + lmat( 563) - mat(564) = mat( 564) + lmat( 564) - mat(565) = lmat( 565) - mat(567) = mat( 567) + lmat( 567) - mat(568) = mat( 568) + lmat( 568) - mat(572) = mat( 572) + lmat( 572) - mat(587) = mat( 587) + lmat( 587) - mat(602) = mat( 602) + lmat( 602) - mat(606) = lmat( 606) - mat(607) = mat( 607) + lmat( 607) - mat(609) = lmat( 609) - mat(610) = lmat( 610) - mat(616) = mat( 616) + lmat( 616) - mat(618) = lmat( 618) - mat(619) = mat( 619) + lmat( 619) - mat(621) = lmat( 621) - mat(625) = mat( 625) + lmat( 625) - mat(636) = mat( 636) + lmat( 636) - mat(637) = mat( 637) + lmat( 637) - mat(640) = mat( 640) + lmat( 640) - mat(641) = lmat( 641) - mat(643) = mat( 643) + lmat( 643) - mat(647) = mat( 647) + lmat( 647) - mat(650) = mat( 650) + lmat( 650) - mat(661) = mat( 661) + lmat( 661) - mat(662) = mat( 662) + lmat( 662) - mat(663) = mat( 663) + lmat( 663) - mat(664) = lmat( 664) - mat(677) = mat( 677) + lmat( 677) - mat(697) = mat( 697) + lmat( 697) - mat(721) = mat( 721) + lmat( 721) - mat(734) = lmat( 734) - mat(735) = mat( 735) + lmat( 735) - mat(740) = mat( 740) + lmat( 740) - mat(742) = lmat( 742) - mat(743) = lmat( 743) - mat(760) = mat( 760) + lmat( 760) - mat(789) = mat( 789) + lmat( 789) - mat(803) = lmat( 803) - mat(805) = mat( 805) + lmat( 805) - mat(808) = mat( 808) + lmat( 808) - mat(824) = mat( 824) + lmat( 824) - mat(829) = mat( 829) + lmat( 829) - mat(830) = lmat( 830) - mat(839) = mat( 839) + lmat( 839) - mat(872) = mat( 872) + lmat( 872) - mat(891) = mat( 891) + lmat( 891) - mat(894) = mat( 894) + lmat( 894) - mat(896) = lmat( 896) - mat(903) = mat( 903) + lmat( 903) - mat(904) = mat( 904) + lmat( 904) - mat(905) = mat( 905) + lmat( 905) - mat(923) = mat( 923) + lmat( 923) - mat(930) = lmat( 930) - mat(943) = mat( 943) + lmat( 943) - mat(958) = mat( 958) + lmat( 958) - mat(961) = mat( 961) + lmat( 961) - mat(962) = mat( 962) + lmat( 962) - mat(964) = mat( 964) + lmat( 964) - mat(966) = mat( 966) + lmat( 966) - mat(967) = lmat( 967) - mat(968) = mat( 968) + lmat( 968) - mat(969) = mat( 969) + lmat( 969) - mat(970) = mat( 970) + lmat( 970) - mat(973) = lmat( 973) - mat(974) = mat( 974) + lmat( 974) - mat(975) = mat( 975) + lmat( 975) - mat(977) = lmat( 977) - mat(979) = mat( 979) + lmat( 979) - mat(983) = lmat( 983) - mat(984) = mat( 984) + lmat( 984) - mat(1013) = mat(1013) + lmat(1013) - mat(1014) = mat(1014) + lmat(1014) - mat(1015) = mat(1015) + lmat(1015) - mat(1016) = mat(1016) + lmat(1016) - mat(1041) = mat(1041) + lmat(1041) - mat(1044) = mat(1044) + lmat(1044) - mat(1046) = mat(1046) + lmat(1046) - mat(1075) = mat(1075) + lmat(1075) - mat(1114) = mat(1114) + lmat(1114) - mat(1137) = mat(1137) + lmat(1137) - mat(1141) = mat(1141) + lmat(1141) - mat(1142) = lmat(1142) - mat(1143) = lmat(1143) - mat(1149) = mat(1149) + lmat(1149) - mat(1150) = mat(1150) + lmat(1150) - mat(1171) = mat(1171) + lmat(1171) - mat(1187) = mat(1187) + lmat(1187) - mat(1189) = mat(1189) + lmat(1189) - mat(1196) = mat(1196) + lmat(1196) - mat(1219) = mat(1219) + lmat(1219) - mat(1220) = lmat(1220) - mat(1223) = mat(1223) + lmat(1223) - mat(1244) = mat(1244) + lmat(1244) - mat(1252) = mat(1252) + lmat(1252) - mat(1281) = mat(1281) + lmat(1281) - mat(1289) = mat(1289) + lmat(1289) - mat(1290) = mat(1290) + lmat(1290) - mat(1291) = mat(1291) + lmat(1291) - mat(1293) = mat(1293) + lmat(1293) - mat(1302) = lmat(1302) - mat(1305) = lmat(1305) - mat(1376) = mat(1376) + lmat(1376) - mat(1377) = mat(1377) + lmat(1377) - mat(1383) = mat(1383) + lmat(1383) - mat(1384) = mat(1384) + lmat(1384) - mat(1389) = mat(1389) + lmat(1389) - mat(1392) = mat(1392) + lmat(1392) - mat(1422) = mat(1422) + lmat(1422) - mat(1423) = mat(1423) + lmat(1423) - mat(1431) = mat(1431) + lmat(1431) - mat(1432) = mat(1432) + lmat(1432) - mat(1434) = mat(1434) + lmat(1434) - mat(1435) = mat(1435) + lmat(1435) - mat(1454) = lmat(1454) - mat(1455) = mat(1455) + lmat(1455) - mat(1457) = mat(1457) + lmat(1457) - mat(1465) = lmat(1465) - mat(1471) = lmat(1471) - mat(1472) = mat(1472) + lmat(1472) - mat(1477) = lmat(1477) - mat(1481) = mat(1481) + lmat(1481) - mat(1484) = mat(1484) + lmat(1484) - mat(1489) = mat(1489) + lmat(1489) - mat(1490) = lmat(1490) - mat(1501) = mat(1501) + lmat(1501) - mat(1509) = mat(1509) + lmat(1509) - mat(253) = 0._r8 - mat(325) = 0._r8 - mat(328) = 0._r8 - mat(330) = 0._r8 - mat(341) = 0._r8 - mat(349) = 0._r8 - mat(352) = 0._r8 - mat(353) = 0._r8 - mat(357) = 0._r8 - mat(360) = 0._r8 - mat(362) = 0._r8 - mat(363) = 0._r8 - mat(367) = 0._r8 - mat(389) = 0._r8 - mat(390) = 0._r8 - mat(394) = 0._r8 - mat(401) = 0._r8 - mat(417) = 0._r8 - mat(419) = 0._r8 - mat(420) = 0._r8 - mat(427) = 0._r8 - mat(428) = 0._r8 - mat(431) = 0._r8 - mat(444) = 0._r8 - mat(449) = 0._r8 - mat(450) = 0._r8 - mat(469) = 0._r8 - mat(472) = 0._r8 - mat(477) = 0._r8 - mat(480) = 0._r8 - mat(502) = 0._r8 - mat(507) = 0._r8 - mat(519) = 0._r8 - mat(520) = 0._r8 - mat(526) = 0._r8 - mat(527) = 0._r8 - mat(532) = 0._r8 - mat(541) = 0._r8 - mat(544) = 0._r8 - mat(545) = 0._r8 - mat(549) = 0._r8 - mat(550) = 0._r8 - mat(557) = 0._r8 - mat(569) = 0._r8 - mat(573) = 0._r8 - mat(575) = 0._r8 - mat(580) = 0._r8 - mat(582) = 0._r8 - mat(590) = 0._r8 - mat(591) = 0._r8 - mat(593) = 0._r8 - mat(596) = 0._r8 - mat(597) = 0._r8 - mat(600) = 0._r8 - mat(611) = 0._r8 - mat(633) = 0._r8 - mat(634) = 0._r8 - mat(644) = 0._r8 - mat(652) = 0._r8 - mat(658) = 0._r8 - mat(659) = 0._r8 - mat(665) = 0._r8 - mat(681) = 0._r8 - mat(684) = 0._r8 - mat(686) = 0._r8 - mat(687) = 0._r8 - mat(693) = 0._r8 - mat(695) = 0._r8 - mat(696) = 0._r8 - mat(698) = 0._r8 - mat(700) = 0._r8 - mat(703) = 0._r8 - mat(705) = 0._r8 - mat(708) = 0._r8 - mat(710) = 0._r8 - mat(711) = 0._r8 - mat(720) = 0._r8 - mat(722) = 0._r8 - mat(726) = 0._r8 - mat(729) = 0._r8 - mat(731) = 0._r8 - mat(732) = 0._r8 - mat(737) = 0._r8 - mat(741) = 0._r8 - mat(744) = 0._r8 - mat(747) = 0._r8 - mat(748) = 0._r8 - mat(749) = 0._r8 - mat(751) = 0._r8 - mat(752) = 0._r8 - mat(753) = 0._r8 - mat(758) = 0._r8 - mat(759) = 0._r8 - mat(766) = 0._r8 - mat(769) = 0._r8 - mat(771) = 0._r8 - mat(772) = 0._r8 - mat(791) = 0._r8 - mat(794) = 0._r8 - mat(797) = 0._r8 - mat(798) = 0._r8 - mat(799) = 0._r8 - mat(800) = 0._r8 - mat(811) = 0._r8 - mat(818) = 0._r8 - mat(825) = 0._r8 - mat(828) = 0._r8 - mat(831) = 0._r8 - mat(832) = 0._r8 - mat(834) = 0._r8 - mat(841) = 0._r8 - mat(842) = 0._r8 - mat(845) = 0._r8 - mat(847) = 0._r8 - mat(848) = 0._r8 - mat(874) = 0._r8 - mat(878) = 0._r8 - mat(881) = 0._r8 - mat(882) = 0._r8 - mat(883) = 0._r8 - mat(884) = 0._r8 - mat(900) = 0._r8 - mat(902) = 0._r8 - mat(907) = 0._r8 - mat(909) = 0._r8 - mat(911) = 0._r8 - mat(913) = 0._r8 - mat(914) = 0._r8 - mat(915) = 0._r8 - mat(916) = 0._r8 - mat(926) = 0._r8 - mat(928) = 0._r8 - mat(934) = 0._r8 - mat(941) = 0._r8 - mat(944) = 0._r8 - mat(955) = 0._r8 - mat(956) = 0._r8 - mat(972) = 0._r8 - mat(976) = 0._r8 - mat(978) = 0._r8 - mat(980) = 0._r8 - mat(981) = 0._r8 - mat(991) = 0._r8 - mat(993) = 0._r8 - mat(994) = 0._r8 - mat(996) = 0._r8 - mat(1000) = 0._r8 - mat(1001) = 0._r8 - mat(1004) = 0._r8 - mat(1005) = 0._r8 - mat(1006) = 0._r8 - mat(1009) = 0._r8 - mat(1026) = 0._r8 - mat(1027) = 0._r8 - mat(1042) = 0._r8 - mat(1043) = 0._r8 - mat(1047) = 0._r8 - mat(1052) = 0._r8 - mat(1053) = 0._r8 - mat(1054) = 0._r8 - mat(1066) = 0._r8 - mat(1072) = 0._r8 - mat(1080) = 0._r8 - mat(1081) = 0._r8 - mat(1088) = 0._r8 - mat(1093) = 0._r8 - mat(1094) = 0._r8 - mat(1095) = 0._r8 - mat(1099) = 0._r8 - mat(1111) = 0._r8 - mat(1122) = 0._r8 - mat(1129) = 0._r8 - mat(1131) = 0._r8 - mat(1132) = 0._r8 - mat(1135) = 0._r8 - mat(1138) = 0._r8 - mat(1140) = 0._r8 - mat(1145) = 0._r8 - mat(1146) = 0._r8 - mat(1152) = 0._r8 - mat(1153) = 0._r8 - mat(1154) = 0._r8 - mat(1157) = 0._r8 - mat(1158) = 0._r8 - mat(1161) = 0._r8 - mat(1162) = 0._r8 - mat(1163) = 0._r8 - mat(1166) = 0._r8 - mat(1168) = 0._r8 - mat(1170) = 0._r8 - mat(1172) = 0._r8 - mat(1173) = 0._r8 - mat(1174) = 0._r8 - mat(1176) = 0._r8 - mat(1177) = 0._r8 - mat(1179) = 0._r8 - mat(1186) = 0._r8 - mat(1190) = 0._r8 - mat(1191) = 0._r8 - mat(1195) = 0._r8 - mat(1200) = 0._r8 - mat(1201) = 0._r8 - mat(1202) = 0._r8 - mat(1203) = 0._r8 - mat(1245) = 0._r8 - mat(1250) = 0._r8 - mat(1256) = 0._r8 - mat(1257) = 0._r8 - mat(1266) = 0._r8 - mat(1267) = 0._r8 - mat(1271) = 0._r8 - mat(1272) = 0._r8 - mat(1273) = 0._r8 - mat(1277) = 0._r8 - mat(1278) = 0._r8 - mat(1279) = 0._r8 - mat(1282) = 0._r8 - mat(1286) = 0._r8 - mat(1287) = 0._r8 - mat(1294) = 0._r8 - mat(1295) = 0._r8 - mat(1331) = 0._r8 - mat(1346) = 0._r8 - mat(1359) = 0._r8 - mat(1380) = 0._r8 - mat(1410) = 0._r8 - mat(1419) = 0._r8 - mat(1420) = 0._r8 - mat(1421) = 0._r8 - mat(1424) = 0._r8 - mat(1425) = 0._r8 - mat(1426) = 0._r8 - mat(1428) = 0._r8 - mat(1429) = 0._r8 - mat(1430) = 0._r8 - mat(1436) = 0._r8 - mat(1440) = 0._r8 - mat(1441) = 0._r8 - mat(1442) = 0._r8 - mat(1443) = 0._r8 - mat(1444) = 0._r8 - mat(1445) = 0._r8 - mat(1446) = 0._r8 - mat(1447) = 0._r8 - mat(1448) = 0._r8 - mat(1449) = 0._r8 - mat(1450) = 0._r8 - mat(1451) = 0._r8 - mat(1452) = 0._r8 - mat(1453) = 0._r8 - mat(1459) = 0._r8 - mat(1464) = 0._r8 - mat(1466) = 0._r8 - mat(1467) = 0._r8 - mat(1468) = 0._r8 - mat(1469) = 0._r8 - mat(1470) = 0._r8 - mat(1473) = 0._r8 - mat(1474) = 0._r8 - mat(1475) = 0._r8 - mat(1476) = 0._r8 - mat(1478) = 0._r8 - mat(1479) = 0._r8 - mat(1480) = 0._r8 - mat(1482) = 0._r8 - mat(1483) = 0._r8 - mat(1485) = 0._r8 - mat(1487) = 0._r8 - mat(1493) = 0._r8 - mat(1494) = 0._r8 - mat(1496) = 0._r8 - mat(1497) = 0._r8 - mat(1498) = 0._r8 - mat(1502) = 0._r8 - mat(1503) = 0._r8 - mat(1504) = 0._r8 - mat(1) = mat( 1) - dti - mat(2) = mat( 2) - dti - mat(3) = mat( 3) - dti - mat(4) = mat( 4) - dti - mat(5) = mat( 5) - dti - mat(6) = mat( 6) - dti - mat(7) = mat( 7) - dti - mat(8) = mat( 8) - dti - mat(9) = mat( 9) - dti - mat(10) = mat( 10) - dti - mat(11) = mat( 11) - dti - mat(12) = mat( 12) - dti - mat(13) = mat( 13) - dti - mat(14) = mat( 14) - dti - mat(15) = mat( 15) - dti - mat(16) = mat( 16) - dti - mat(17) = mat( 17) - dti - mat(20) = mat( 20) - dti - mat(23) = mat( 23) - dti - mat(26) = mat( 26) - dti - mat(29) = mat( 29) - dti - mat(33) = mat( 33) - dti - mat(38) = mat( 38) - dti - mat(41) = mat( 41) - dti - mat(44) = mat( 44) - dti - mat(47) = mat( 47) - dti - mat(50) = mat( 50) - dti - mat(53) = mat( 53) - dti - mat(55) = mat( 55) - dti - mat(57) = mat( 57) - dti - mat(61) = mat( 61) - dti - mat(65) = mat( 65) - dti - mat(69) = mat( 69) - dti - mat(72) = mat( 72) - dti - mat(75) = mat( 75) - dti - mat(80) = mat( 80) - dti - mat(84) = mat( 84) - dti - mat(90) = mat( 90) - dti - mat(96) = mat( 96) - dti - mat(102) = mat( 102) - dti - mat(108) = mat( 108) - dti - mat(115) = mat( 115) - dti - mat(120) = mat( 120) - dti - mat(125) = mat( 125) - dti - mat(130) = mat( 130) - dti - mat(134) = mat( 134) - dti - mat(139) = mat( 139) - dti - mat(142) = mat( 142) - dti - mat(150) = mat( 150) - dti - mat(154) = mat( 154) - dti - mat(160) = mat( 160) - dti - mat(166) = mat( 166) - dti - mat(172) = mat( 172) - dti - mat(178) = mat( 178) - dti - mat(184) = mat( 184) - dti - mat(189) = mat( 189) - dti - mat(194) = mat( 194) - dti - mat(201) = mat( 201) - dti - mat(208) = mat( 208) - dti - mat(215) = mat( 215) - dti - mat(222) = mat( 222) - dti - mat(227) = mat( 227) - dti - mat(233) = mat( 233) - dti - mat(241) = mat( 241) - dti - mat(246) = mat( 246) - dti - mat(254) = mat( 254) - dti - mat(260) = mat( 260) - dti - mat(268) = mat( 268) - dti - mat(272) = mat( 272) - dti - mat(280) = mat( 280) - dti - mat(288) = mat( 288) - dti - mat(296) = mat( 296) - dti - mat(303) = mat( 303) - dti - mat(312) = mat( 312) - dti - mat(319) = mat( 319) - dti - mat(324) = mat( 324) - dti - mat(335) = mat( 335) - dti - mat(344) = mat( 344) - dti - mat(358) = mat( 358) - dti - mat(369) = mat( 369) - dti - mat(375) = mat( 375) - dti - mat(379) = mat( 379) - dti - mat(388) = mat( 388) - dti - mat(397) = mat( 397) - dti - mat(405) = mat( 405) - dti - mat(414) = mat( 414) - dti - mat(425) = mat( 425) - dti - mat(433) = mat( 433) - dti - mat(442) = mat( 442) - dti - mat(452) = mat( 452) - dti - mat(462) = mat( 462) - dti - mat(476) = mat( 476) - dti - mat(486) = mat( 486) - dti - mat(494) = mat( 494) - dti - mat(510) = mat( 510) - dti - mat(517) = mat( 517) - dti - mat(530) = mat( 530) - dti - mat(540) = mat( 540) - dti - mat(552) = mat( 552) - dti - mat(560) = mat( 560) - dti - mat(572) = mat( 572) - dti - mat(587) = mat( 587) - dti - mat(602) = mat( 602) - dti - mat(607) = mat( 607) - dti - mat(616) = mat( 616) - dti - mat(625) = mat( 625) - dti - mat(637) = mat( 637) - dti - mat(650) = mat( 650) - dti - mat(662) = mat( 662) - dti - mat(677) = mat( 677) - dti - mat(697) = mat( 697) - dti - mat(721) = mat( 721) - dti - mat(740) = mat( 740) - dti - mat(760) = mat( 760) - dti - mat(789) = mat( 789) - dti - mat(805) = mat( 805) - dti - mat(824) = mat( 824) - dti - mat(839) = mat( 839) - dti - mat(872) = mat( 872) - dti - mat(903) = mat( 903) - dti - mat(943) = mat( 943) - dti - mat(970) = mat( 970) - dti - mat(1016) = mat(1016) - dti - mat(1044) = mat(1044) - dti - mat(1114) = mat(1114) - dti - mat(1150) = mat(1150) - dti - mat(1171) = mat(1171) - dti - mat(1196) = mat(1196) - dti - mat(1252) = mat(1252) - dti - mat(1290) = mat(1290) - dti - mat(1389) = mat(1389) - dti - mat(1434) = mat(1434) - dti - mat(1457) = mat(1457) - dti - mat(1484) = mat(1484) - dti - mat(1509) = mat(1509) - dti - END SUBROUTINE nlnmat_finit - - SUBROUTINE nlnmat(mat, y, rxt, lmat, dti) - USE chem_mods, ONLY: nzcnt - USE chem_mods, ONLY: gas_pcnst - USE chem_mods, ONLY: rxntot - IMPLICIT NONE - !---------------------------------------------- - ! ... dummy arguments - !---------------------------------------------- - REAL(KIND=r8), intent(in) :: dti - REAL(KIND=r8), intent(in) :: lmat(nzcnt) - REAL(KIND=r8), intent(in) :: y(gas_pcnst) - REAL(KIND=r8), intent(in) :: rxt(rxntot) - REAL(KIND=r8), intent(inout) :: mat(nzcnt) - CALL nlnmat01(mat, y, rxt) - CALL nlnmat02(mat, y, rxt) - CALL nlnmat03(mat, y, rxt) - CALL nlnmat04(mat, y, rxt) - CALL nlnmat05(mat, y, rxt) - CALL nlnmat06(mat, y, rxt) - CALL nlnmat07(mat, y, rxt) - CALL nlnmat_finit(mat, lmat, dti) - END SUBROUTINE nlnmat - END MODULE mo_nln_matrix diff --git a/test/ncar_kernels/WACCM_imp_sol/src/mo_prod_loss.F90 b/test/ncar_kernels/WACCM_imp_sol/src/mo_prod_loss.F90 deleted file mode 100644 index 93afcca443..0000000000 --- a/test/ncar_kernels/WACCM_imp_sol/src/mo_prod_loss.F90 +++ /dev/null @@ -1,548 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_prod_loss.F90 -! Generated at: 2015-05-13 11:02:22 -! KGEN version: 0.4.10 - - - - MODULE mo_prod_loss - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - PRIVATE - PUBLIC imp_prod_loss - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - - - SUBROUTINE imp_prod_loss(prod, loss, y, rxt, het_rates) - IMPLICIT NONE - !-------------------------------------------------------------------- - ! ... dummy args - !-------------------------------------------------------------------- - REAL(KIND=r8), dimension(:), intent(out) :: prod - REAL(KIND=r8), dimension(:), intent(out) :: loss - REAL(KIND=r8), intent(in) :: y(:) - REAL(KIND=r8), intent(in) :: rxt(:) - REAL(KIND=r8), intent(in) :: het_rates(:) - !-------------------------------------------------------------------- - ! ... loss and production for Implicit method - !-------------------------------------------------------------------- - loss(123) = (rxt(119)* y(2) +rxt(192)* y(6) +rxt(195)* y(7) +rxt(164)* y(19) +rxt(293)* y(37) +rxt(& - 314)* y(48) +rxt(336)* y(60) +rxt(342)* y(61) +rxt(360)* y(65) +rxt(392)* y(77) +rxt(405)* y(107) & - +rxt(408) * y(108) +rxt(207)* y(127) +rxt(234)* y(128) +rxt(169)* y(129) +rxt(177)& - * y(130) +rxt(137)* y(157) + rxt(3) + rxt(4) + het_rates(1))* y(1) - prod(123) = (.200_r8*rxt(336)*y(60) +.200_r8*rxt(342)*y(61) + .100_r8*rxt(360)*y(65))*y(1) + (& - .250_r8*rxt(304)*y(133) + .250_r8*rxt(352)*y(141))*y(130) +rxt(118)*y(3)*y(2) - loss(121) = (rxt(119)* y(1) + 2._r8*rxt(120)* y(2) +rxt(118)* y(3) +rxt(190) * y(6) + (rxt(193) +rxt(& - 194))* y(7) +rxt(201)* y(8) +rxt(271)* y(16) +rxt(175)* y(18) +rxt(179)* y(20) +rxt(214)* y(24) & - +rxt(227)* y(27) +rxt(228)* y(28) +rxt(231)* y(29) +rxt(237)* y(31) +rxt(247)* y(32) & - +rxt(248)* y(33) +rxt(249)* y(34) +rxt(401)* y(106) +rxt(168) * y(129) +rxt(176)* y(130) + (rxt(& - 437) +rxt(438))* y(148) +rxt(444) * y(150) + rxt(92) + rxt(93) + rxt(94) + rxt(105) + rxt(106) & - + rxt(107) + het_rates(2))* y(2) - prod(121) = (rxt(1) +2.000_r8*rxt(2) +rxt(98) +rxt(99) +rxt(100) + 2.000_r8*rxt(103) +rxt(110) +rxt(& - 111) +rxt(112) +2.000_r8*rxt(115) + rxt(132)*y(157) +rxt(133)*y(157) +rxt(185)*y(5) +rxt(404)*y(107) & - + rxt(407)*y(108) +rxt(435)*y(151) +rxt(443)*y(150))*y(3) + (rxt(186)*y(6) +rxt(& - 187)*y(7) +rxt(440)*y(149))*y(5) + (rxt(447)*y(152) +1.150_r8*rxt(448)*y(149))*y(153) +rxt(4)*y(1) & - +rxt(6)*y(6) +rxt(8)*y(7) +rxt(12)*y(8) +rxt(10)*y(11) +rxt(167)*y(130)*y(19) +rxt(& - 24)*y(24) +rxt(25)*y(25) +rxt(32)*y(31) +rxt(88)*y(104) +rxt(91)*y(108) +rxt(89)*y(109) +rxt(171)*y(& - 129) *y(129) +rxt(131)*y(157) +rxt(21)*y(158) - loss(122) = (rxt(137)* y(1) + (rxt(132) +rxt(133))* y(3) + (rxt(135) + rxt(136))* y(4) + (rxt(156) & - +rxt(157) +rxt(158))* y(12) +rxt(159) * y(18) +rxt(160)* y(27) +rxt(161)* y(32) +rxt(162)* y(35) & - +rxt(147) * y(80) +rxt(138)* y(81) +rxt(139)* y(82) +rxt(140)* y(83) +rxt(143) * y(& - 84) +rxt(146)* y(85) +rxt(149)* y(87) +rxt(148)* y(88) +rxt(144) * y(89) +rxt(145)* y(90) +rxt(141)* & - y(91) +rxt(142)* y(92) +rxt(150) * y(93) +rxt(151)* y(94) +rxt(152)* y(95) +rxt(153)* y(96) +rxt(154)& - * y(100) +rxt(155)* y(101) +rxt(134)* y(158) + rxt(131) + het_rates(157))* y(157) - prod(122) = (rxt(1) +rxt(182)*y(154))*y(3) +rxt(3)*y(1) +.850_r8*rxt(448)*y(153)*y(149) +rxt(20)*y(& - 158) - loss(120) = (rxt(118)* y(2) +rxt(185)* y(5) +rxt(163)* y(19) +rxt(404) * y(107) +rxt(407)* y(108) & - +rxt(291)* y(135) +rxt(445)* y(148) + (rxt(442) +rxt(443))* y(150) +rxt(435)* y(151) +rxt(182)* y(& - 154) +rxt(128)* y(156) +rxt(132)* y(157) + rxt(1) + rxt(2) + rxt(96) + rxt(98) + & - rxt(99) + rxt(100) + rxt(103) + rxt(108) + rxt(110) + rxt(111) + rxt(112) + rxt(115) + het_rates(3))& - * y(3) - prod(120) = (rxt(166)*y(19) +rxt(170)*y(129) +rxt(176)*y(2) + 2.000_r8*rxt(177)*y(1) +rxt(178)*y(130)& - +rxt(203)*y(8) + rxt(210)*y(127) +rxt(217)*y(24) +rxt(235)*y(128) +rxt(239)*y(31) + & - rxt(274)*y(13) +rxt(296)*y(132) +rxt(317)*y(136) +rxt(322)*y(137) + rxt(326)*y(138) +.750_r8*rxt(& - 352)*y(141))*y(130) + (rxt(4) + 2.000_r8*rxt(119)*y(2) +2.000_r8*rxt(137)*y(157) +rxt(164)*y(19) + & - rxt(169)*y(129) +rxt(192)*y(6) +rxt(195)*y(7) +rxt(207)*y(127) + rxt(234)*y(128) +rxt(& - 405)*y(107) +rxt(408)*y(108))*y(1) + (rxt(120)*y(2) +rxt(127)*y(156) +rxt(168)*y(129) +rxt(193)*y(7)& - + rxt(201)*y(8) +rxt(214)*y(24) +rxt(237)*y(31))*y(2) + (rxt(216)*y(129) +rxt(221)& - *y(24) +rxt(222)*y(24) +rxt(243)*y(31) + rxt(244)*y(31))*y(24) + (rxt(129) +rxt(130) +2.000_r8*rxt(& - 128)*y(3)) *y(156) +rxt(136)*y(157)*y(4) +rxt(189)*y(7)*y(5) +rxt(441)*y(149) *y(6) & - +rxt(13)*y(8) +rxt(205)*y(129)*y(10) +rxt(245)*y(31)*y(31) +rxt(126)*y(155) - loss(28) = (rxt(124)* y(1) +rxt(121)* y(2) +rxt(122)* y(3) +rxt(125)* y(97) + rxt(123) + rxt(126) + & - het_rates(155))* y(155) - prod(28) = rxt(132)*y(157)*y(3) - loss(27) = (rxt(127)* y(2) +rxt(128)* y(3) + rxt(129) + rxt(130) + het_rates(156))* y(156) - prod(27) = (rxt(123) +rxt(125)*y(97) +rxt(121)*y(2) +rxt(122)*y(3) + rxt(124)*y(1))*y(155) +rxt(3)*y(& - 1) - loss(108) = (rxt(175)* y(2) +rxt(251)* y(103) +rxt(208)* y(127) +rxt(173) * y(129) +rxt(159)* y(157) & - + het_rates(18))* y(18) - prod(108) = rxt(158)*y(157)*y(12) +rxt(18)*y(16) +rxt(166)*y(130)*y(19) +rxt(20)*y(158) - loss(103) = ((rxt(267) +rxt(268))* y(129) + het_rates(17))* y(17) - prod(103) = (rxt(17) +rxt(18) +rxt(212)*y(127) +rxt(236)*y(128) + rxt(269)*y(8) +rxt(270)*y(129) & - +rxt(271)*y(2))*y(16) + (.500_r8*rxt(293)*y(37) +.560_r8*rxt(314)*y(48) + & - .050_r8*rxt(336)*y(60) +.200_r8*rxt(342)*y(61) + .300_r8*rxt(360)*y(65))*y(1) + (.350_r8*rxt(286)*y(& - 98) + rxt(309)*y(44) +rxt(330)*y(54) +rxt(402)*y(106))*y(129) + (.220_r8*rxt(343)& - *y(6) +.220_r8*rxt(345)*y(8) + .110_r8*rxt(347)*y(13) +.220_r8*rxt(348)*y(133))*y(142) & - + (.500_r8*rxt(378)*y(6) +.500_r8*rxt(379)*y(8) + .200_r8*rxt(381)*y(13) +.500_r8*rxt(382)*y(133)& - )*y(145) + (rxt(74) + rxt(331)*y(8))*y(54) + (rxt(90) +rxt(401)*y(2))*y(106) +rxt(61)*y(41) & - +rxt(79)*y(43) +2.000_r8*rxt(82)*y(44) +.700_r8*rxt(68)*y(60) +1.340_r8*rxt(67)*y(61) & - +.450_r8*rxt(81)*y(67) +rxt(76)*y(70) +rxt(254)*y(127)*y(79) +rxt(439)*y(151)*y(97) - loss(92) = (rxt(185)* y(3) +rxt(186)* y(6) + (rxt(187) +rxt(188) +rxt(189)) * y(7) +rxt(184)* y(129) & - +rxt(440)* y(149) + rxt(95) + het_rates(5)) * y(5) - prod(92) = (rxt(183)*y(154) +rxt(444)*y(150))*y(2) + (.200_r8*rxt(447)*y(152) +1.100_r8*rxt(449)*y(& - 148))*y(153) +rxt(442)*y(150)*y(3) +rxt(6)*y(6) +rxt(436)*y(151) - loss(129) = (rxt(192)* y(1) +rxt(190)* y(2) +rxt(186)* y(5) +rxt(200)* y(8) +rxt(273)* y(13) +rxt(& - 219)* y(24) +rxt(240)* y(31) +rxt(368)* y(69) +rxt(191)* y(130) +rxt(281)* y(131) +rxt(295)* y(132) & - +rxt(302) * y(133) +rxt(289)* y(134) +rxt(316)* y(136) +rxt(321)* y(137) +rxt(325)& - * y(138) +rxt(334)* y(139) +rxt(338)* y(140) +rxt(350) * y(141) + (rxt(343) +rxt(344))* y(142) +rxt(& - 375)* y(143) +rxt(362) * y(144) +rxt(378)* y(145) +rxt(386)* y(146) +rxt(394)* y(147) & - +rxt(441)* y(149) + rxt(6) + rxt(7) + het_rates(6))* y(6) - prod(129) = (rxt(8) +.500_r8*rxt(399) +2.000_r8*rxt(188)*y(5) + rxt(193)*y(2) +rxt(409)*y(108))*y(7) & - + (rxt(182)*y(154) + rxt(185)*y(5))*y(3) +2.000_r8*rxt(135)*y(157)*y(4) +rxt(184)*y(129) & - *y(5) +rxt(13)*y(8) +rxt(10)*y(11) +rxt(446)*y(149) - loss(130) = (rxt(195)* y(1) + (rxt(193) +rxt(194))* y(2) + (rxt(187) + rxt(188) +rxt(189))* y(5) & - +rxt(196)* y(8) +rxt(220)* y(24) +rxt(241) * y(31) +rxt(390)* y(76) +rxt(409)* y(108) +rxt(198)* y(& - 129) +rxt(204)* y(130) +rxt(303)* y(133) +rxt(356)* y(141) + rxt(8) + rxt(399) + & - het_rates(7))* y(7) - prod(130) = (rxt(190)*y(2) +rxt(191)*y(130) +rxt(192)*y(1) + 2.000_r8*rxt(200)*y(8) +rxt(219)*y(24) & - +rxt(240)*y(31) + rxt(273)*y(13) +rxt(281)*y(131) +rxt(289)*y(134) +rxt(295)*y(132) + & - rxt(302)*y(133) +rxt(316)*y(136) +rxt(321)*y(137) +rxt(325)*y(138) + rxt(334)*y(139) +rxt(338)*y(& - 140) +rxt(343)*y(142) +rxt(350)*y(141) + .920_r8*rxt(362)*y(144) +1.206_r8*rxt(368)*y(69) + & - .900_r8*rxt(375)*y(143) +rxt(378)*y(145) +.900_r8*rxt(386)*y(146) + rxt(394)*y(147))*y(6) + (& - rxt(12) +rxt(201)*y(2) +rxt(202)*y(129) + rxt(203)*y(130) +rxt(345)*y(142) +rxt(351)*y(141) +rxt(363)& - *y(144) + 1.206_r8*rxt(369)*y(69) +rxt(373)*y(70) +rxt(379)*y(145) + rxt(393)*y(77))& - *y(8) + (rxt(15) +rxt(206) +rxt(205)*y(129))*y(10) + (rxt(9) +rxt(197))*y(11) + (.600_r8*rxt(64) & - +rxt(311))*y(47) + (rxt(65) +rxt(357))*y(63) + (rxt(76) +.400_r8*rxt(372)*y(129)) & - *y(70) +.700_r8*rxt(390)*y(76)*y(7) +rxt(11)*y(9) +rxt(30)*y(29) +rxt(36)*y(34) +rxt(332)*y(129)*y(& - 64) +.206_r8*rxt(370)*y(130)*y(69) - loss(131) = (rxt(169)* y(1) +rxt(168)* y(2) +rxt(184)* y(5) +rxt(198)* y(7) +rxt(202)* y(8) +rxt(& - 199)* y(9) +rxt(205)* y(10) +rxt(266)* y(12) +rxt(278)* y(14) +rxt(277)* y(15) +rxt(270)* y(16) + (& - rxt(267) + rxt(268))* y(17) +rxt(173)* y(18) +rxt(174)* y(20) + (rxt(215) + rxt(216)& - )* y(24) +rxt(226)* y(27) +rxt(230)* y(28) +rxt(232)* y(29) +rxt(238)* y(31) +rxt(246)* y(32) +rxt(& - 180)* y(35) +rxt(181)* y(36) +rxt(288)* y(37) +rxt(287)* y(38) +rxt(299)* y(39) +rxt(294)* y(40) & - +rxt(300)* y(41) +rxt(310)* y(42) +rxt(308)* y(43) +rxt(309)* y(44) +rxt(307)* y(45) & - +rxt(312)* y(47) +rxt(313)* y(48) +rxt(320)* y(49) +rxt(319)* y(50) +rxt(324)* y(51) +rxt(323)* y(& - 52) +rxt(329)* y(53) +rxt(330)* y(54) +rxt(328)* y(55) +rxt(333)* y(56) +rxt(371)* y(57) & - +rxt(337)* y(58) +rxt(340)* y(59) +rxt(335)* y(60) +rxt(341)* y(61) +rxt(349)* y(62) +rxt(& - 358)* y(63) +rxt(332)* y(64) +rxt(359)* y(65) +rxt(377)* y(66) +rxt(374)* y(68) +rxt(372)* y(70) & - +rxt(383)* y(71) +rxt(365)* y(72) +rxt(385)* y(73) +rxt(389)* y(74) +rxt(388)* y(75) & - +rxt(391)* y(77) +rxt(396)* y(78) +rxt(255)* y(79) +rxt(258)* y(80) +rxt(257)* y(84) +rxt(256)* & - y(86) +rxt(260)* y(89) +rxt(261)* y(90) +rxt(263)* y(95) +rxt(262)* y(96) +rxt(286)* y(98) +rxt(279)& - * y(99) +rxt(413)* y(104) + (rxt(415) +rxt(416))* y(105) +rxt(402)* y(106) +rxt(& - 403)* y(107) +rxt(406)* y(108) + 2._r8*(rxt(171) +rxt(172)) * y(129) +rxt(170)* y(130) + het_rates(& - 129))* y(129) - prod(131) = (rxt(164)*y(19) +rxt(177)*y(130) +.120_r8*rxt(293)*y(37) + .330_r8*rxt(314)*y(48) & - +.080_r8*rxt(336)*y(60) + .215_r8*rxt(342)*y(61) +.270_r8*rxt(360)*y(65) + & - .700_r8*rxt(392)*y(77))*y(1) + (rxt(175)*y(18) +rxt(176)*y(130) + rxt(179)*y(20) +rxt(227)*y(27) & - +rxt(228)*y(28) +rxt(247)*y(32) + rxt(248)*y(33) +rxt(271)*y(16))*y(2) + (rxt(156)*y(12) + & - 2.000_r8*rxt(134)*y(158) +rxt(159)*y(18) +rxt(160)*y(27) + rxt(161)*y(32) +rxt(162)*y(35))*y(& - 157) + (.300_r8*rxt(278)*y(14) + .650_r8*rxt(286)*y(98) +.500_r8*rxt(299)*y(39) + & - .500_r8*rxt(323)*y(52) +.100_r8*rxt(349)*y(62))*y(129) + (2.000_r8*rxt(165)*y(19) +rxt(191)*y(6) & - +rxt(203)*y(8) + rxt(211)*y(127))*y(130) + (rxt(19) +rxt(250)*y(103))*y(158) & - +.500_r8*rxt(399)*y(7) +rxt(11)*y(9) +rxt(14)*y(10) +rxt(16)*y(14) +2.000_r8*rxt(22)*y(20) +rxt(27)& - *y(28) +rxt(33)*y(33) +rxt(69)*y(39) +rxt(63)*y(45) +rxt(70)*y(46) +rxt(71)*y(50) +rxt(62)*y(52) & - +rxt(72) *y(55) +rxt(84)*y(59) +rxt(83)*y(66) +rxt(75)*y(71) +rxt(85)*y(75) +rxt(& - 86)*y(78) - loss(132) = (rxt(201)* y(2) +rxt(200)* y(6) +rxt(196)* y(7) +rxt(269)* y(16) +rxt(301)* y(41) +rxt(& - 315)* y(48) +rxt(331)* y(54) +rxt(361)* y(65) +rxt(369)* y(69) +rxt(373)* y(70) +rxt(393)* y(77) & - +rxt(417)* y(105) +rxt(202)* y(129) +rxt(203)* y(130) +rxt(351)* y(141) +rxt(345) & - * y(142) +rxt(363)* y(144) +rxt(379)* y(145) + rxt(12) + rxt(13) + rxt(398) + het_rates(8))* y(8) - prod(132) = (rxt(29) +rxt(231)*y(2) +rxt(232)*y(129) +rxt(233)*y(127))*y(29) + (rxt(9) +rxt(10) & - +rxt(197))*y(11) + (rxt(199)*y(9) + rxt(312)*y(47) +.500_r8*rxt(358)*y(63))*y(129) + (rxt(194)*y(7) & - + rxt(249)*y(34))*y(2) +rxt(195)*y(7)*y(1) +rxt(253)*y(103)*y(9) +rxt(14)*y(10) & - +rxt(35)*y(34) +.400_r8*rxt(64)*y(47) - loss(133) = (rxt(253)* y(103) +rxt(199)* y(129) + rxt(11) + het_rates(9)) * y(9) - prod(133) = (rxt(419) +rxt(425) +rxt(430) +rxt(421)*y(27) +rxt(426)*y(27) + rxt(432)*y(27))*y(29) + (& - rxt(398) +rxt(269)*y(16) +rxt(301)*y(41) + rxt(331)*y(54) +rxt(417)*y(105))*y(8) + (2.000_r8*rxt(397)& - + 2.000_r8*rxt(418) +2.000_r8*rxt(424) +2.000_r8*rxt(429))*y(11) + (rxt(420) +rxt(& - 428) +rxt(431))*y(34) + (.500_r8*rxt(399) + rxt(198)*y(129))*y(7) - loss(60) = (rxt(205)* y(129) + rxt(14) + rxt(15) + rxt(206) + het_rates(10)) * y(10) - prod(60) = rxt(204)*y(130)*y(7) - loss(40) = (+ rxt(9) + rxt(10) + rxt(197) + rxt(397) + rxt(418) + rxt(424) + rxt(429) + het_rates(& - 11))* y(11) - prod(40) = rxt(196)*y(8)*y(7) - loss(119) = (rxt(273)* y(6) + 2._r8*(rxt(275) +rxt(276))* y(13) +rxt(218) * y(24) +rxt(274)* y(130) & - +rxt(297)* y(132) +rxt(305)* y(133) +rxt(318)* y(136) +rxt(327)* y(138) +rxt(353)* y(141) +rxt(347) & - * y(142) +rxt(366)* y(144) +rxt(381)* y(145) + het_rates(13))* y(13) - prod(119) = (rxt(302)*y(6) +.900_r8*rxt(305)*y(13) + 2.000_r8*rxt(306)*y(133) +rxt(348)*y(142) +rxt(& - 354)*y(141) + rxt(367)*y(144) +rxt(382)*y(145))*y(133) + (rxt(156)*y(157) + rxt(213)& - *y(127) +rxt(252)*y(103) +rxt(266)*y(129))*y(12) + (.700_r8*rxt(278)*y(14) +rxt(294)*y(40))*y(129) & - +.310_r8*rxt(314)*y(48)*y(1) +rxt(61)*y(41) +rxt(63)*y(45) +.400_r8*rxt(64)*y(47) & - +rxt(73)*y(51) +.300_r8*rxt(68)*y(60) - loss(50) = (rxt(278)* y(129) + rxt(16) + het_rates(14))* y(14) - prod(50) = rxt(274)*y(130)*y(13) - loss(30) = (rxt(180)* y(129) +rxt(162)* y(157) + het_rates(35))* y(35) - prod(30) = 0._r8 - loss(17) = (rxt(181)* y(129) + het_rates(36))* y(36) - prod(17) = 0._r8 - loss(135) = (rxt(271)* y(2) +rxt(269)* y(8) +rxt(212)* y(127) +rxt(236) * y(128) +rxt(270)* y(129) & - +rxt(272)* y(130) + rxt(17) + rxt(18) + het_rates(16))* y(16) - prod(135) = (rxt(218)*y(24) +rxt(273)*y(6) +2.000_r8*rxt(275)*y(13) + rxt(276)*y(13) +.700_r8*rxt(& - 297)*y(132) +rxt(305)*y(133) + rxt(318)*y(136) +.800_r8*rxt(327)*y(138) +.880_r8*rxt(347)*y(142) + & - 2.000_r8*rxt(353)*y(141) +1.200_r8*rxt(366)*y(144) + .700_r8*rxt(381)*y(145))*y(13) + & - (.500_r8*rxt(289)*y(134) + rxt(321)*y(137) +rxt(325)*y(138) +.500_r8*rxt(334)*y(139) + & - .250_r8*rxt(343)*y(142) +rxt(350)*y(141) +.510_r8*rxt(362)*y(144) + .072_r8*rxt(368)*y(69) & - +.100_r8*rxt(375)*y(143))*y(6) + (rxt(277)*y(15) +.300_r8*rxt(278)*y(14) +.500_r8*rxt(307)*y(45) + & - .800_r8*rxt(308)*y(43) +rxt(312)*y(47) +.500_r8*rxt(358)*y(63)) *y(129) + (rxt(293)& - *y(37) +.540_r8*rxt(314)*y(48) + .800_r8*rxt(336)*y(60) +.700_r8*rxt(342)*y(61) + & - .600_r8*rxt(360)*y(65))*y(1) + (.250_r8*rxt(345)*y(142) + rxt(351)*y(141) +.600_r8*rxt(363)*y(144) & - +.072_r8*rxt(369)*y(69)) *y(8) + (.250_r8*rxt(348)*y(142) +rxt(354)*y(141) + & - .600_r8*rxt(367)*y(144))*y(133) + (rxt(157)*y(157) +rxt(158)*y(157)) *y(12) +rxt(16)*y(14) +rxt(79)& - *y(43) +rxt(62)*y(52) +rxt(78)*y(53) +rxt(72)*y(55) +1.340_r8*rxt(66)*y(61) +.100_r8*rxt(83)*y(66) & - +.008_r8*rxt(370)*y(130)*y(69) +rxt(76)*y(70) +.690_r8*rxt(77)*y(72) +rxt(280)*y(& - 131) +2.000_r8*rxt(292)*y(135) +2.000_r8*rxt(355)*y(141) *y(141) - loss(127) = (rxt(164)* y(1) +rxt(163)* y(3) + (rxt(165) +rxt(166) +rxt(167)) * y(130) + het_rates(19)& - )* y(19) - prod(127) = (rxt(168)*y(2) +rxt(173)*y(18) +rxt(184)*y(5) +rxt(267)*y(17) + rxt(270)*y(16) +rxt(402)& - *y(106) +rxt(403)*y(107) +rxt(406)*y(108)) *y(129) + (rxt(159)*y(157) +rxt(175)*y(2) +rxt(208)*y(127)& - + rxt(251)*y(103))*y(18) + (rxt(19) +2.000_r8*rxt(21))*y(158) +rxt(157)*y(157)*y(& - 12) +rxt(16)*y(14) +2.000_r8*rxt(17)*y(16) +rxt(28)*y(27) +rxt(34)*y(32) +rxt(57)*y(102) - loss(125) = (rxt(177)* y(1) +rxt(176)* y(2) +rxt(191)* y(6) +rxt(204)* y(7) +rxt(203)* y(8) +rxt(& - 274)* y(13) +rxt(272)* y(16) + (rxt(165) + rxt(166) +rxt(167))* y(19) +rxt(217)* y(24) +rxt(239)* y(& - 31) +rxt(370)* y(69) + (rxt(210) +rxt(211))* y(127) +rxt(235)* y(128) +rxt(170)* & - y(129) + 2._r8*rxt(178)* y(130) +rxt(282)* y(131) +rxt(296)* y(132) +rxt(304)* y(133) +rxt(290)* y(& - 134) +rxt(317) * y(136) +rxt(322)* y(137) +rxt(326)* y(138) +rxt(339)* y(140) +rxt(& - 352)* y(141) +rxt(346)* y(142) +rxt(376)* y(143) +rxt(364) * y(144) +rxt(380)* y(145) +rxt(387)* y(& - 146) +rxt(395)* y(147) + rxt(400) + het_rates(130))* y(130) - prod(125) = (rxt(255)*y(79) +rxt(258)*y(80) +rxt(169)*y(1) +rxt(174)*y(20) + rxt(180)*y(35) +rxt(181)& - *y(36) +rxt(202)*y(8) +rxt(215)*y(24) + rxt(238)*y(31) +rxt(268)*y(17) +rxt(277)*y(15) +rxt(279)*y(& - 99) + .350_r8*rxt(286)*y(98) +rxt(308)*y(43) +rxt(309)*y(44) + rxt(310)*y(42) +rxt(& - 329)*y(53) +.200_r8*rxt(349)*y(62) + .500_r8*rxt(358)*y(63) +rxt(372)*y(70) +.250_r8*rxt(385)*y(73) & - + rxt(413)*y(104) +.500_r8*rxt(416)*y(105))*y(129) + (rxt(273)*y(13) + rxt(281)*y(& - 131) +.250_r8*rxt(289)*y(134) +rxt(295)*y(132) + rxt(316)*y(136) +rxt(321)*y(137) +rxt(334)*y(139) + & - .470_r8*rxt(343)*y(142) +rxt(362)*y(144) +.794_r8*rxt(368)*y(69) + .900_r8*rxt(375)& - *y(143) +rxt(378)*y(145) +.900_r8*rxt(386)*y(146) + rxt(394)*y(147))*y(6) + (rxt(218)*y(24) & - +2.000_r8*rxt(275)*y(13) + rxt(297)*y(132) +.900_r8*rxt(305)*y(133) +rxt(318)*y(136) + & - .300_r8*rxt(327)*y(138) +.730_r8*rxt(347)*y(142) +rxt(353)*y(141) + rxt(366)*y(144) +.800_r8*rxt(& - 381)*y(145))*y(13) + (.120_r8*rxt(293)*y(37) +.190_r8*rxt(314)*y(48) + .060_r8*rxt(& - 336)*y(60) +.275_r8*rxt(342)*y(61) + .060_r8*rxt(360)*y(65) +rxt(392)*y(77))*y(1) + (rxt(269)*y(16) & - + .470_r8*rxt(345)*y(142) +rxt(363)*y(144) +.794_r8*rxt(369)*y(69) + rxt(373)*y(70) & - +rxt(379)*y(145))*y(8) + (rxt(254)*y(79) + rxt(259)*y(80) +rxt(209)*y(20) +rxt(212)*y(16))*y(127) & - + (.470_r8*rxt(348)*y(142) +rxt(367)*y(144) +rxt(382)*y(145))*y(133) + (rxt(179)*y(& - 20) +rxt(271)*y(16))*y(2) + (rxt(163)*y(19) + rxt(291)*y(135))*y(3) + (rxt(15) +rxt(206))*y(10) & - + (1.340_r8*rxt(66) +.660_r8*rxt(67))*y(61) +.700_r8*rxt(390)*y(76) *y(7) +rxt(157)*y(& - 157)*y(12) +rxt(236)*y(128)*y(16) +rxt(69)*y(39) +rxt(61)*y(41) +2.000_r8*rxt(79)*y(43) & - +2.000_r8*rxt(82)*y(44) +rxt(71)*y(50) +rxt(62)*y(52) +rxt(78)*y(53) +rxt(74)*y(54) & - +.900_r8*rxt(83)*y(66) +.560_r8*rxt(81)*y(67) +.794_r8*rxt(370)*y(130)*y(69) +rxt(76)*y(70) +rxt(& - 77)*y(72) +rxt(86)*y(78) +rxt(280)*y(131) +1.200_r8*rxt(298)*y(132)*y(132) +rxt(& - 292)*y(135) - loss(74) = (rxt(179)* y(2) +rxt(209)* y(127) +rxt(174)* y(129) + rxt(22) + het_rates(20))* y(20) - prod(74) = (.500_r8*rxt(400) +rxt(178)*y(130))*y(130) +rxt(172)*y(129)*y(129) - loss(134) = (rxt(250)* y(103) +rxt(414)* y(109) +rxt(134)* y(157) + rxt(19) + rxt(20) + rxt(21) + & - het_rates(158))* y(158) - prod(134) = (rxt(255)*y(79) +rxt(256)*y(86) +rxt(257)*y(84) +rxt(258)*y(80) + rxt(262)*y(96) +rxt(& - 266)*y(12) +rxt(170)*y(130) +rxt(171)*y(129) + rxt(173)*y(18) +rxt(174)*y(20) +rxt(199)*y(9) +rxt(& - 205)*y(10) + rxt(226)*y(27) +rxt(230)*y(28) +rxt(246)*y(32) +rxt(270)*y(16) + rxt(& - 278)*y(14) +rxt(279)*y(99) +rxt(287)*y(38) +rxt(294)*y(40) + rxt(300)*y(41) +rxt(307)*y(45) +rxt(319)& - *y(50) +rxt(320)*y(49) + rxt(323)*y(52) +rxt(324)*y(51) +rxt(328)*y(55) +rxt(330)*y(54) + & - .500_r8*rxt(341)*y(61) +rxt(383)*y(71) +rxt(384)*y(71))*y(129) + (rxt(422)*y(28) +rxt(423)*y(& - 33) +rxt(427)*y(28) +rxt(433)*y(28) + rxt(434)*y(33))*y(27) +rxt(167)*y(130)*y(19) +rxt(87)*y(110) - loss(126) = (rxt(207)* y(1) +rxt(213)* y(12) +rxt(212)* y(16) +rxt(208) * y(18) +rxt(209)* y(20) & - +rxt(229)* y(28) +rxt(233)* y(29) +rxt(285) * y(38) +rxt(254)* y(79) +rxt(259)* y(80) +rxt(265)* y(& - 95) +rxt(264) * y(96) + (rxt(210) +rxt(211))* y(130) + het_rates(127))* y(127) - prod(126) = (2.000_r8*rxt(138)*y(81) +2.000_r8*rxt(139)*y(82) + 2.000_r8*rxt(140)*y(83) & - +2.000_r8*rxt(141)*y(91) +rxt(142)*y(92) + rxt(143)*y(84) +rxt(144)*y(89) +rxt(145)*y(90) + & - 4.000_r8*rxt(146)*y(85) +rxt(148)*y(88) +rxt(155)*y(101) + rxt(160)*y(27))*y(157) + (rxt(24) & - +rxt(214)*y(2) +rxt(215)*y(129) + rxt(218)*y(13) +rxt(219)*y(6) +2.000_r8*rxt(221)*y(24) + & - rxt(223)*y(24) +rxt(243)*y(31) +rxt(410)*y(108))*y(24) + (rxt(255)*y(79) +3.000_r8*rxt(256)& - *y(86) +rxt(257)*y(84) + rxt(260)*y(89) +rxt(261)*y(90) +rxt(226)*y(27))*y(129) + (rxt(28) + & - rxt(227)*y(2))*y(27) +2.000_r8*rxt(23)*y(23) +2.000_r8*rxt(26)*y(26) +rxt(27)*y(28) +rxt(& - 29)*y(29) +rxt(31)*y(30) +rxt(56)*y(101) - loss(29) = (+ rxt(23) + het_rates(23))* y(23) - prod(29) = (rxt(421)*y(29) +rxt(422)*y(28) +rxt(426)*y(29) +rxt(427)*y(28) + rxt(432)*y(29) +rxt(433)& - *y(28))*y(27) +rxt(222)*y(24)*y(24) +rxt(233)*y(127)*y(29) - loss(124) = (rxt(214)* y(2) +rxt(219)* y(6) +rxt(220)* y(7) +rxt(218)* y(13) + 2._r8*(rxt(221) +rxt(& - 222) +rxt(223) +rxt(224))* y(24) + (rxt(242) +rxt(243) +rxt(244))* y(31) +rxt(410)* y(108) & - + (rxt(215) +rxt(216))* y(129) +rxt(217)* y(130) + rxt(24) + het_rates(24))* y(24) - prod(124) = (rxt(228)*y(2) +rxt(229)*y(127) +rxt(230)*y(129))*y(28) + (rxt(25) +rxt(412)*y(108))*y(& - 25) + (rxt(30) +rxt(231)*y(2))*y(29) + (rxt(207)*y(1) +rxt(211)*y(130))*y(127) +2.000_r8*rxt(225)*y(& - 26) - loss(46) = (rxt(412)* y(108) + rxt(25) + het_rates(25))* y(25) - prod(46) = (rxt(223)*y(24) +rxt(242)*y(31))*y(24) - loss(18) = (+ rxt(26) + rxt(225) + het_rates(26))* y(26) - prod(18) = rxt(224)*y(24)*y(24) - loss(117) = (rxt(227)* y(2) + (rxt(422) +rxt(427) +rxt(433))* y(28) + (rxt(421) +rxt(426) +rxt(432))& - * y(29) + (rxt(423) +rxt(434)) * y(33) +rxt(226)* y(129) +rxt(160)* y(157) + rxt(28) & - + het_rates(27))* y(27) - prod(117) = (rxt(213)*y(12) +2.000_r8*rxt(254)*y(79) +rxt(259)*y(80) + rxt(264)*y(96) +rxt(265)*y(95)& - +rxt(208)*y(18) +rxt(209)*y(20) + rxt(210)*y(130) +rxt(212)*y(16) +rxt(229)*y(28) +rxt(285)*y(38)) & - *y(127) +rxt(216)*y(129)*y(24) - loss(93) = (rxt(228)* y(2) + (rxt(422) +rxt(427) +rxt(433))* y(27) +rxt(229) * y(127) +rxt(230)* y(& - 129) + rxt(27) + het_rates(28))* y(28) - prod(93) = (rxt(419) +rxt(425) +rxt(430) +rxt(232)*y(129))*y(29) +rxt(217)*y(130)*y(24) - loss(100) = (rxt(231)* y(2) + (rxt(421) +rxt(426) +rxt(432))* y(27) +rxt(233) * y(127) +rxt(232)* y(& - 129) + rxt(29) + rxt(30) + rxt(419) + rxt(425) + rxt(430) + het_rates(29))* y(29) - prod(100) = rxt(220)*y(24)*y(7) - loss(33) = (+ rxt(31) + het_rates(30))* y(30) - prod(33) = (rxt(423)*y(33) +rxt(434)*y(33))*y(27) +rxt(244)*y(31)*y(24) - loss(118) = (rxt(234)* y(1) +rxt(236)* y(16) +rxt(235)* y(130) + het_rates(128))* y(128) - prod(118) = (rxt(32) +rxt(237)*y(2) +rxt(238)*y(129) +rxt(240)*y(6) + rxt(242)*y(24) +rxt(243)*y(24) & - +2.000_r8*rxt(245)*y(31) + rxt(411)*y(108))*y(31) + (rxt(147)*y(80) +rxt(148)*y(88) + & - rxt(149)*y(87) +2.000_r8*rxt(150)*y(93) +2.000_r8*rxt(151)*y(94) + 3.000_r8*rxt(152)*y(95) & - +2.000_r8*rxt(153)*y(96) +rxt(161)*y(32)) *y(157) + (rxt(258)*y(80) +2.000_r8*rxt(262)*y(96) + & - 3.000_r8*rxt(263)*y(95) +rxt(246)*y(32))*y(129) + (rxt(259)*y(80) + 2.000_r8*rxt(264)*y(& - 96) +3.000_r8*rxt(265)*y(95))*y(127) + (rxt(34) + rxt(247)*y(2))*y(32) +rxt(31)*y(30) +rxt(33)*y(33) & - +rxt(35)*y(34) - loss(128) = (rxt(237)* y(2) +rxt(240)* y(6) +rxt(241)* y(7) + (rxt(242) + rxt(243) +rxt(244))* y(24) & - + 2._r8*rxt(245)* y(31) +rxt(411)* y(108) +rxt(238)* y(129) +rxt(239)* y(130) + rxt(32) + het_rates(& - 31)) * y(31) - prod(128) = (rxt(248)*y(33) +rxt(249)*y(34))*y(2) +rxt(234)*y(128)*y(1) +rxt(36)*y(34) - loss(90) = (rxt(247)* y(2) +rxt(246)* y(129) +rxt(161)* y(157) + rxt(34) + het_rates(32))* y(32) - prod(90) = (rxt(235)*y(130) +rxt(236)*y(16))*y(128) - loss(84) = (rxt(248)* y(2) + (rxt(423) +rxt(434))* y(27) + rxt(33) + het_rates(33))* y(33) - prod(84) = (rxt(420) +rxt(428) +rxt(431))*y(34) +rxt(239)*y(130)*y(31) - loss(70) = (rxt(249)* y(2) + rxt(35) + rxt(36) + rxt(420) + rxt(428) + rxt(431) + het_rates(34))* y(& - 34) - prod(70) = rxt(241)*y(31)*y(7) - loss(78) = ((rxt(437) +rxt(438))* y(2) +rxt(445)* y(3) +rxt(449)* y(153) + het_rates(148))* y(148) - prod(78) = 0._r8 - loss(85) = (rxt(440)* y(5) +rxt(441)* y(6) +rxt(448)* y(153) + rxt(446) + het_rates(149))* y(149) - prod(85) = (rxt(96) +rxt(108) +rxt(435)*y(151) +rxt(442)*y(150) + rxt(445)*y(148))*y(3) +rxt(439)*y(& - 151)*y(97) - loss(58) = (rxt(444)* y(2) + (rxt(442) +rxt(443))* y(3) + het_rates(150)) * y(150) - prod(58) = rxt(95)*y(5) - loss(72) = (rxt(435)* y(3) +rxt(439)* y(97) + rxt(436) + het_rates(151)) * y(151) - prod(72) = (rxt(92) +rxt(93) +rxt(94) +rxt(105) +rxt(106) +rxt(107) + rxt(438)*y(148) +rxt(444)*y(& - 150))*y(2) + (rxt(98) +rxt(99) + rxt(100) +rxt(110) +rxt(111) +rxt(112))*y(3) - loss(86) = (rxt(447)* y(153) + het_rates(152))* y(152) - prod(86) = (rxt(446) +rxt(440)*y(5) +rxt(441)*y(6))*y(149) +rxt(437)*y(148) *y(2) +rxt(443)*y(150)*y(& - 3) +rxt(7)*y(6) +rxt(436)*y(151) - loss(61) = (rxt(183)* y(2) +rxt(182)* y(3) + het_rates(154))* y(154) - prod(61) = (rxt(437)*y(2) +.900_r8*rxt(449)*y(153))*y(148) +.800_r8*rxt(447)*y(153)*y(152) - loss(87) = (rxt(449)* y(148) +rxt(448)* y(149) +rxt(447)* y(152) + het_rates(153))* y(153) - prod(87) = (rxt(96) +rxt(98) +rxt(99) +rxt(100) +rxt(108) +rxt(110) + rxt(111) +rxt(112))*y(3) + (& - rxt(92) +rxt(93) +rxt(94) +rxt(105) + rxt(106) +rxt(107))*y(2) +rxt(95)*y(5) +rxt(7)*y(6) - loss(102) = (rxt(314)* y(1) +rxt(315)* y(8) +rxt(313)* y(129) + het_rates(48))* y(48) - prod(102) = .070_r8*rxt(360)*y(65)*y(1) +.700_r8*rxt(68)*y(60) - loss(94) = (rxt(360)* y(1) +rxt(361)* y(8) +rxt(359)* y(129) + het_rates(65)) * y(65) - prod(94) = 0._r8 - loss(89) = (rxt(321)* y(6) +rxt(322)* y(130) + het_rates(137))* y(137) - prod(89) = (rxt(313)*y(48) +.500_r8*rxt(323)*y(52))*y(129) - loss(104) = (rxt(301)* y(8) +rxt(300)* y(129) + rxt(61) + het_rates(41)) * y(41) - prod(104) = (rxt(295)*y(132) +.270_r8*rxt(316)*y(136) +rxt(321)*y(137) + rxt(334)*y(139) +rxt(338)*y(& - 140) +.400_r8*rxt(375)*y(143))*y(6) + (.500_r8*rxt(314)*y(48) +.040_r8*rxt(336)*y(60))*y(1) + (rxt(& - 69) + .500_r8*rxt(299)*y(129))*y(39) + (.800_r8*rxt(297)*y(13) + 1.600_r8*rxt(298)& - *y(132))*y(132) +rxt(310)*y(129)*y(42) +rxt(62) *y(52) +rxt(84)*y(59) +.400_r8*rxt(83)*y(66) - loss(75) = (rxt(294)* y(129) + het_rates(40))* y(40) - prod(75) = (.250_r8*rxt(314)*y(48) +.200_r8*rxt(360)*y(65))*y(1) + (.250_r8*rxt(304)*y(133) & - +.250_r8*rxt(352)*y(141))*y(130) +.100_r8*rxt(305)*y(133)*y(13) - loss(67) = (rxt(323)* y(129) + rxt(62) + het_rates(52))* y(52) - prod(67) = rxt(322)*y(137)*y(130) - loss(115) = (rxt(302)* y(6) +rxt(303)* y(7) +rxt(305)* y(13) +rxt(304) * y(130) + 2._r8*rxt(306)* y(& - 133) +rxt(348)* y(142) +rxt(367)* y(144) +rxt(382)* y(145) + het_rates(133))* y(133) - prod(115) = (rxt(325)*y(138) +rxt(338)*y(140) +.530_r8*rxt(343)*y(142) + rxt(350)*y(141))*y(6) + (& - rxt(301)*y(41) +rxt(331)*y(54) + .530_r8*rxt(345)*y(142) +rxt(351)*y(141))*y(8) + (& - .300_r8*rxt(327)*y(138) +.260_r8*rxt(347)*y(142) + rxt(353)*y(141))*y(13) + (rxt(300)*y(41) & - +.500_r8*rxt(307)*y(45) + rxt(330)*y(54))*y(129) + (.600_r8*rxt(64) +rxt(311))*y(47) +rxt(73) & - *y(51) +rxt(78)*y(53) +rxt(74)*y(54) +rxt(72)*y(55) +rxt(80)*y(58) +rxt(84)*y(59) & - +.300_r8*rxt(68)*y(60) +1.340_r8*rxt(66)*y(61) +.130_r8*rxt(81)*y(67) +.530_r8*rxt(348)*y(142)*y(& - 133) +2.000_r8*rxt(355)*y(141)*y(141) - loss(62) = (rxt(307)* y(129) + rxt(63) + het_rates(45))* y(45) - prod(62) = (.750_r8*rxt(304)*y(133) +.750_r8*rxt(352)*y(141))*y(130) - loss(57) = (rxt(312)* y(129) + rxt(64) + rxt(311) + het_rates(47))* y(47) - prod(57) = rxt(303)*y(133)*y(7) - loss(49) = (rxt(332)* y(129) + het_rates(64))* y(64) - prod(49) = .100_r8*rxt(375)*y(143)*y(6) +rxt(315)*y(48)*y(8) - loss(37) = (rxt(285)* y(127) +rxt(287)* y(129) + het_rates(38))* y(38) - prod(37) = 0._r8 - loss(63) = (rxt(293)* y(1) +rxt(284)* y(127) +rxt(288)* y(129) + het_rates(37))* y(37) - prod(63) = 0._r8 - loss(19) = (rxt(371)* y(129) + het_rates(57))* y(57) - prod(19) = 0._r8 - loss(71) = (rxt(358)* y(129) + rxt(65) + rxt(357) + het_rates(63))* y(63) - prod(71) = rxt(356)*y(141)*y(7) - loss(20) = (rxt(333)* y(129) + het_rates(56))* y(56) - prod(20) = 0._r8 - loss(41) = (rxt(334)* y(6) + het_rates(139))* y(139) - prod(41) = rxt(333)*y(129)*y(56) - loss(79) = (rxt(375)* y(6) +rxt(376)* y(130) + het_rates(143))* y(143) - prod(79) = (rxt(371)*y(57) +rxt(377)*y(66))*y(129) - loss(76) = (rxt(377)* y(129) + rxt(83) + het_rates(66))* y(66) - prod(76) = rxt(376)*y(143)*y(130) - loss(55) = (rxt(337)* y(129) + rxt(80) + het_rates(58))* y(58) - prod(55) = .800_r8*rxt(375)*y(143)*y(6) +.800_r8*rxt(83)*y(66) - loss(77) = (rxt(338)* y(6) +rxt(339)* y(130) + het_rates(140))* y(140) - prod(77) = (rxt(337)*y(58) +rxt(340)*y(59))*y(129) - loss(42) = (rxt(340)* y(129) + rxt(84) + het_rates(59))* y(59) - prod(42) = rxt(339)*y(140)*y(130) - loss(22) = (rxt(385)* y(129) + het_rates(73))* y(73) - prod(22) = 0._r8 - loss(23) = (rxt(389)* y(129) + het_rates(74))* y(74) - prod(23) = .250_r8*rxt(385)*y(129)*y(73) - loss(65) = (rxt(386)* y(6) +rxt(387)* y(130) + het_rates(146))* y(146) - prod(65) = (.700_r8*rxt(385)*y(73) +rxt(388)*y(75))*y(129) - loss(51) = (rxt(388)* y(129) + rxt(85) + het_rates(75))* y(75) - prod(51) = rxt(387)*y(146)*y(130) - loss(31) = (rxt(390)* y(7) + het_rates(76))* y(76) - prod(31) = rxt(389)*y(129)*y(74) - loss(98) = (rxt(394)* y(6) +rxt(395)* y(130) + het_rates(147))* y(147) - prod(98) = (rxt(391)*y(129) +rxt(393)*y(8))*y(77) +rxt(396)*y(129)*y(78) - loss(59) = (rxt(396)* y(129) + rxt(86) + het_rates(78))* y(78) - prod(59) = rxt(395)*y(147)*y(130) - loss(66) = (+ rxt(81) + het_rates(67))* y(67) - prod(66) = .900_r8*rxt(386)*y(146)*y(6) +.700_r8*rxt(390)*y(76)*y(7) +.900_r8*rxt(85)*y(75) - loss(81) = (rxt(309)* y(129) + rxt(82) + het_rates(44))* y(44) - prod(81) = (.250_r8*rxt(378)*y(6) +.250_r8*rxt(379)*y(8) + .100_r8*rxt(381)*y(13) +.250_r8*rxt(382)& - *y(133))*y(145) + (.650_r8*rxt(286)*y(98) +.200_r8*rxt(308)*y(43))*y(129) & - +.450_r8*rxt(386)*y(146)*y(6) +.130_r8*rxt(81)*y(67) +.450_r8*rxt(85)*y(75) - loss(111) = (rxt(362)* y(6) +rxt(363)* y(8) +rxt(366)* y(13) +rxt(364) * y(130) +rxt(367)* y(133) + & - het_rates(144))* y(144) - prod(111) = (rxt(359)*y(65) +.200_r8*rxt(365)*y(72))*y(129) - loss(113) = (rxt(336)* y(1) +rxt(335)* y(129) + rxt(68) + het_rates(60)) * y(60) - prod(113) = (.320_r8*rxt(362)*y(6) +.350_r8*rxt(363)*y(8) + .260_r8*rxt(366)*y(13) +.350_r8*rxt(367)& - *y(133))*y(144) + (.039_r8*rxt(368)*y(6) +.039_r8*rxt(369)*y(8) + .039_r8*rxt(370)& - *y(130))*y(69) + (.200_r8*rxt(360)*y(65) + rxt(392)*y(77))*y(1) +rxt(394)*y(147)*y(6) +.402_r8*rxt(& - 77)*y(72) +rxt(86)*y(78) - loss(107) = (rxt(342)* y(1) +rxt(341)* y(129) + rxt(66) + rxt(67) + het_rates(61))* y(61) - prod(107) = (.230_r8*rxt(362)*y(6) +.250_r8*rxt(363)*y(8) + .190_r8*rxt(366)*y(13) +.250_r8*rxt(367)& - *y(133))*y(144) + (.167_r8*rxt(368)*y(6) +.167_r8*rxt(369)*y(8) + .167_r8*rxt(370)& - *y(130))*y(69) + (.400_r8*rxt(360)*y(65) + rxt(392)*y(77))*y(1) +rxt(394)*y(147)*y(6) +.288_r8*rxt(& - 77)*y(72) +rxt(86)*y(78) - loss(112) = ((rxt(343) +rxt(344))* y(6) +rxt(345)* y(8) +rxt(347)* y(13) +rxt(346)* y(130) +rxt(348)& - * y(133) + het_rates(142))* y(142) - prod(112) = (rxt(335)*y(60) +.500_r8*rxt(341)*y(61) +.200_r8*rxt(349)*y(62)) *y(129) - loss(43) = (rxt(349)* y(129) + het_rates(62))* y(62) - prod(43) = rxt(346)*y(142)*y(130) - loss(114) = (rxt(350)* y(6) +rxt(356)* y(7) +rxt(351)* y(8) +rxt(353)* y(13) +rxt(352)* y(130) +rxt(& - 354)* y(133) + 2._r8*rxt(355)* y(141) + het_rates(141))* y(141) - prod(114) = (.660_r8*rxt(66) +.500_r8*rxt(341)*y(129))*y(61) + (rxt(65) + rxt(357))*y(63) & - +.200_r8*rxt(360)*y(65)*y(1) +.500_r8*rxt(349)*y(129) *y(62) - loss(91) = (rxt(295)* y(6) +rxt(297)* y(13) +rxt(296)* y(130) + 2._r8*rxt(298)* y(132) + het_rates(& - 132))* y(132) - prod(91) = (rxt(285)*y(127) +rxt(287)*y(129))*y(38) +.500_r8*rxt(299)*y(129) *y(39) +rxt(80)*y(58) - loss(44) = (rxt(299)* y(129) + rxt(69) + het_rates(39))* y(39) - prod(44) = rxt(296)*y(132)*y(130) - loss(73) = (rxt(392)* y(1) +rxt(393)* y(8) +rxt(391)* y(129) + het_rates(77)) * y(77) - prod(73) = 0._r8 - loss(21) = (rxt(320)* y(129) + het_rates(49))* y(49) - prod(21) = 0._r8 - loss(96) = (rxt(316)* y(6) +rxt(318)* y(13) +rxt(317)* y(130) + het_rates(136))* y(136) - prod(96) = (rxt(319)*y(50) +rxt(320)*y(49))*y(129) - loss(52) = (rxt(319)* y(129) + rxt(71) + het_rates(50))* y(50) - prod(52) = rxt(317)*y(136)*y(130) - loss(80) = (rxt(324)* y(129) + rxt(73) + het_rates(51))* y(51) - prod(80) = (.820_r8*rxt(316)*y(136) +.500_r8*rxt(334)*y(139) + .250_r8*rxt(375)*y(143) +.100_r8*rxt(& - 394)*y(147))*y(6) +.820_r8*rxt(318)*y(136)*y(13) +.820_r8*rxt(71)*y(50) & - +.250_r8*rxt(83)*y(66) +.100_r8*rxt(86)*y(78) - loss(53) = (rxt(328)* y(129) + rxt(72) + het_rates(55))* y(55) - prod(53) = rxt(326)*y(138)*y(130) - loss(68) = (rxt(277)* y(129) + het_rates(15))* y(15) - prod(68) = (rxt(276)*y(13) +.300_r8*rxt(297)*y(132) + .500_r8*rxt(327)*y(138) +.250_r8*rxt(347)*y(& - 142) + .250_r8*rxt(366)*y(144) +.300_r8*rxt(381)*y(145))*y(13) - loss(35) = (rxt(310)* y(129) + het_rates(42))* y(42) - prod(35) = (.200_r8*rxt(297)*y(13) +.400_r8*rxt(298)*y(132))*y(132) - loss(95) = (rxt(308)* y(129) + rxt(79) + het_rates(43))* y(43) - prod(95) = (.530_r8*rxt(343)*y(6) +.530_r8*rxt(345)*y(8) + .260_r8*rxt(347)*y(13) +.530_r8*rxt(348)& - *y(133))*y(142) + (.250_r8*rxt(378)*y(6) +.250_r8*rxt(379)*y(8) + .100_r8*rxt(381)& - *y(13) +.250_r8*rxt(382)*y(133))*y(145) +rxt(291)*y(135)*y(3) - loss(105) = (rxt(329)* y(129) + rxt(78) + het_rates(53))* y(53) - prod(105) = (.220_r8*rxt(343)*y(6) +.220_r8*rxt(345)*y(8) + .230_r8*rxt(347)*y(13) +.220_r8*rxt(348)& - *y(133))*y(142) + (.250_r8*rxt(378)*y(6) +.250_r8*rxt(379)*y(8) + .100_r8*rxt(381)& - *y(13) +.250_r8*rxt(382)*y(133))*y(145) + (.500_r8*rxt(323)*y(52) +.500_r8*rxt(358)*y(63))*y(129) & - +.200_r8*rxt(327)*y(138)*y(13) - loss(83) = (rxt(289)* y(6) +rxt(290)* y(130) + het_rates(134))* y(134) - prod(83) = rxt(288)*y(129)*y(37) - loss(56) = (rxt(291)* y(3) + rxt(292) + het_rates(135))* y(135) - prod(56) = .750_r8*rxt(289)*y(134)*y(6) +rxt(70)*y(46) - loss(24) = (+ rxt(70) + het_rates(46))* y(46) - prod(24) = rxt(290)*y(134)*y(130) - loss(47) = (rxt(374)* y(129) + het_rates(68))* y(68) - prod(47) = (.370_r8*rxt(362)*y(6) +.400_r8*rxt(363)*y(8) + .300_r8*rxt(366)*y(13) +.400_r8*rxt(367)& - *y(133))*y(144) + (rxt(372)*y(129) +rxt(373)*y(8))*y(70) - loss(106) = (rxt(325)* y(6) +rxt(327)* y(13) +rxt(326)* y(130) + het_rates(138))* y(138) - prod(106) = (rxt(324)*y(51) +rxt(328)*y(55))*y(129) - loss(109) = (rxt(331)* y(8) +rxt(330)* y(129) + rxt(74) + het_rates(54)) * y(54) - prod(109) = (.250_r8*rxt(343)*y(6) +.250_r8*rxt(345)*y(8) + .240_r8*rxt(347)*y(13) +.250_r8*rxt(348)& - *y(133))*y(142) + (.250_r8*rxt(378)*y(6) +.250_r8*rxt(379)*y(8) + .100_r8*rxt(381)& - *y(13) +.250_r8*rxt(382)*y(133))*y(145) + (.950_r8*rxt(336)*y(60) +.800_r8*rxt(342)*y(61))*y(1) & - + (rxt(329)*y(53) +rxt(332)*y(64))*y(129) +.450_r8*rxt(386)*y(146) *y(6) +.500_r8*rxt(& - 327)*y(138)*y(13) +.180_r8*rxt(81)*y(67) +.450_r8*rxt(85)*y(75) - loss(101) = (rxt(368)* y(6) +rxt(369)* y(8) +rxt(370)* y(130) + het_rates(69))* y(69) - prod(101) = rxt(361)*y(65)*y(8) - loss(97) = (rxt(373)* y(8) +rxt(372)* y(129) + rxt(76) + het_rates(70)) * y(70) - prod(97) = (.800_r8*rxt(344)*y(142) +.080_r8*rxt(362)*y(144) + .794_r8*rxt(368)*y(69))*y(6) + (& - .794_r8*rxt(369)*y(8) + .794_r8*rxt(370)*y(130))*y(69) - loss(110) = (rxt(378)* y(6) +rxt(379)* y(8) +rxt(381)* y(13) +rxt(380) * y(130) +rxt(382)* y(133) + & - het_rates(145))* y(145) - prod(110) = (.800_r8*rxt(365)*y(72) +rxt(374)*y(68) +rxt(383)*y(71))*y(129) - loss(45) = ((rxt(383) +rxt(384))* y(129) + rxt(75) + het_rates(71))* y(71) - prod(45) = (rxt(370)*y(69) +rxt(380)*y(145))*y(130) - loss(69) = (rxt(365)* y(129) + rxt(77) + het_rates(72))* y(72) - prod(69) = rxt(364)*y(144)*y(130) - loss(38) = (rxt(283)* y(127) +rxt(286)* y(129) + het_rates(98))* y(98) - prod(38) = 0._r8 - loss(64) = (rxt(279)* y(129) + het_rates(99))* y(99) - prod(64) = (rxt(281)*y(6) +rxt(282)*y(130))*y(131) +.500_r8*rxt(293)*y(37) *y(1) +.350_r8*rxt(286)*y(& - 129)*y(98) - loss(54) = (rxt(281)* y(6) +rxt(282)* y(130) + rxt(280) + het_rates(131)) * y(131) - prod(54) = rxt(272)*y(130)*y(16) - loss(25) = (rxt(154)* y(157) + rxt(55) + het_rates(100))* y(100) - prod(25) = (rxt(139)*y(82) +rxt(140)*y(83) +2.000_r8*rxt(141)*y(91) + 2.000_r8*rxt(142)*y(92) +rxt(& - 143)*y(84) +rxt(145)*y(90) + rxt(148)*y(88) +rxt(149)*y(87) +rxt(150)*y(93) + & - 2.000_r8*rxt(151)*y(94))*y(157) + (rxt(257)*y(84) +rxt(261)*y(90)) *y(129) - loss(32) = (rxt(155)* y(157) + rxt(56) + het_rates(101))* y(101) - prod(32) = (rxt(138)*y(81) +rxt(140)*y(83) +rxt(144)*y(89))*y(157) +rxt(260)*y(129)*y(89) - loss(34) = (+ rxt(57) + het_rates(102))* y(102) - prod(34) = (rxt(252)*y(12) +rxt(250)*y(158) +rxt(251)*y(18) +rxt(253)*y(9)) *y(103) - loss(88) = (rxt(253)* y(9) +rxt(252)* y(12) +rxt(251)* y(18) +rxt(250) * y(158) + het_rates(103))* y(& - 103) - prod(88) = (rxt(142)*y(92) +rxt(149)*y(87) +2.000_r8*rxt(154)*y(100) + rxt(155)*y(101))*y(157) & - +2.000_r8*rxt(55)*y(100) +rxt(56)*y(101) +rxt(57)*y(102) - loss(99) = (rxt(413)* y(129) + rxt(88) + het_rates(104))* y(104) - prod(99) = (rxt(406)*y(129) +rxt(407)*y(3) +rxt(408)*y(1) +rxt(409)*y(7) + rxt(410)*y(24) +rxt(411)& - *y(31) +rxt(412)*y(25))*y(108) + (rxt(415)*y(129) +.500_r8*rxt(416)*y(129) +rxt(417)*y(8))*y(105) & - +rxt(402)*y(129)*y(106) +rxt(89)*y(109) - loss(39) = (rxt(417)* y(8) + (rxt(415) +rxt(416))* y(129) + het_rates(105)) * y(105) - prod(39) = 0._r8 - loss(48) = (rxt(401)* y(2) +rxt(402)* y(129) + rxt(90) + het_rates(106)) * y(106) - prod(48) = 0._r8 - loss(82) = (rxt(405)* y(1) +rxt(404)* y(3) +rxt(403)* y(129) + het_rates(107))* y(107) - prod(82) = rxt(90)*y(106) +rxt(91)*y(108) - loss(116) = (rxt(408)* y(1) +rxt(407)* y(3) +rxt(409)* y(7) +rxt(410)* y(24) +rxt(412)* y(25) +rxt(& - 411)* y(31) +rxt(406)* y(129) + rxt(91) + het_rates(108))* y(108) - prod(116) = (rxt(403)*y(129) +rxt(404)*y(3) +rxt(405)*y(1))*y(107) +rxt(401)*y(106)*y(2) +rxt(88)*y(& - 104) - loss(36) = (rxt(414)* y(158) + rxt(89) + het_rates(109))* y(109) - prod(36) = rxt(413)*y(129)*y(104) +rxt(87)*y(110) - loss(26) = (+ rxt(87) + het_rates(110))* y(110) - prod(26) = rxt(414)*y(158)*y(109) - loss(1) = (+ het_rates(111))* y(111) - prod(1) = 0._r8 - loss(2) = (+ het_rates(112))* y(112) - prod(2) = 0._r8 - loss(3) = (+ het_rates(113))* y(113) - prod(3) = 0._r8 - loss(4) = (+ het_rates(114))* y(114) - prod(4) = 0._r8 - loss(5) = (+ het_rates(115))* y(115) - prod(5) = 0._r8 - loss(6) = (+ het_rates(116))* y(116) - prod(6) = 0._r8 - loss(7) = (+ het_rates(117))* y(117) - prod(7) = 0._r8 - loss(8) = (+ het_rates(118))* y(118) - prod(8) = 0._r8 - loss(9) = (+ het_rates(119))* y(119) - prod(9) = 0._r8 - loss(10) = (+ het_rates(120))* y(120) - prod(10) = 0._r8 - loss(11) = (+ het_rates(121))* y(121) - prod(11) = 0._r8 - loss(12) = (+ het_rates(122))* y(122) - prod(12) = 0._r8 - loss(13) = (+ het_rates(123))* y(123) - prod(13) = 0._r8 - loss(14) = (+ het_rates(124))* y(124) - prod(14) = 0._r8 - loss(15) = (+ het_rates(125))* y(125) - prod(15) = 0._r8 - loss(16) = (+ het_rates(126))* y(126) - prod(16) = 0._r8 - END SUBROUTINE imp_prod_loss - END MODULE mo_prod_loss diff --git a/test/ncar_kernels/WACCM_imp_sol/src/mo_tracname.F90 b/test/ncar_kernels/WACCM_imp_sol/src/mo_tracname.F90 deleted file mode 100644 index 5c8e3b9309..0000000000 --- a/test/ncar_kernels/WACCM_imp_sol/src/mo_tracname.F90 +++ /dev/null @@ -1,31 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_tracname.F90 -! Generated at: 2015-05-13 11:02:21 -! KGEN version: 0.4.10 - - - - MODULE mo_tracname - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !----------------------------------------------------------- - ! ... List of advected and non-advected trace species, and - ! surface fluxes for the advected species. - !----------------------------------------------------------- - USE chem_mods, ONLY: gas_pcnst - IMPLICIT NONE - CHARACTER(LEN=16) :: solsym(gas_pcnst) ! species names - PUBLIC kgen_read_externs_mo_tracname - CONTAINS - - ! write subroutines - - ! module extern variables - - SUBROUTINE kgen_read_externs_mo_tracname(kgen_unit) - INTEGER, INTENT(IN) :: kgen_unit - READ(UNIT=kgen_unit) solsym - END SUBROUTINE kgen_read_externs_mo_tracname - - END MODULE mo_tracname diff --git a/test/ncar_kernels/WACCM_imp_sol/src/ppgrid.F90 b/test/ncar_kernels/WACCM_imp_sol/src/ppgrid.F90 deleted file mode 100644 index ccfaf4d934..0000000000 --- a/test/ncar_kernels/WACCM_imp_sol/src/ppgrid.F90 +++ /dev/null @@ -1,42 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : ppgrid.F90 -! Generated at: 2015-05-13 11:02:22 -! KGEN version: 0.4.10 - - - - MODULE ppgrid - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !----------------------------------------------------------------------- - ! - ! Purpose: - ! Initialize physics grid resolution parameters - ! for a chunked data structure - ! - ! Author: - ! - !----------------------------------------------------------------------- - IMPLICIT NONE - PRIVATE - PUBLIC pcols - PUBLIC pver - ! Grid point resolution parameters - INTEGER :: pcols ! number of columns (max) - ! number of sub-columns (max) - INTEGER :: pver ! number of vertical levels - ! pver + 1 - PARAMETER (pcols = 16) - PARAMETER (pver = 70) - ! - ! start, end indices for chunks owned by a given MPI task - ! (set in phys_grid_init). - ! - ! - ! - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE ppgrid diff --git a/test/ncar_kernels/WACCM_imp_sol/src/shr_kind_mod.F90 b/test/ncar_kernels/WACCM_imp_sol/src/shr_kind_mod.F90 deleted file mode 100644 index 10b5aa63f2..0000000000 --- a/test/ncar_kernels/WACCM_imp_sol/src/shr_kind_mod.F90 +++ /dev/null @@ -1,31 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : shr_kind_mod.F90 -! Generated at: 2015-05-13 11:02:22 -! KGEN version: 0.4.10 - - - - MODULE shr_kind_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - PUBLIC - INTEGER, parameter :: shr_kind_r8 = selected_real_kind(12) ! 8 byte real - ! 4 byte real - ! native real - ! 8 byte integer - ! 4 byte integer - ! native integer - ! short char - ! mid-sized char - ! long char - ! extra-long char - ! extra-extra-long char - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE shr_kind_mod diff --git a/test/ncar_kernels/WACCM_lu_fac/CESM_license.txt b/test/ncar_kernels/WACCM_lu_fac/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/WACCM_lu_fac/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/WACCM_lu_fac/data/lu_fac.10.0 b/test/ncar_kernels/WACCM_lu_fac/data/lu_fac.10.0 deleted file mode 100644 index 440d026e1c..0000000000 Binary files a/test/ncar_kernels/WACCM_lu_fac/data/lu_fac.10.0 and /dev/null differ diff --git a/test/ncar_kernels/WACCM_lu_fac/data/lu_fac.10.100 b/test/ncar_kernels/WACCM_lu_fac/data/lu_fac.10.100 deleted file mode 100644 index 77df5ec778..0000000000 Binary files a/test/ncar_kernels/WACCM_lu_fac/data/lu_fac.10.100 and /dev/null differ diff --git a/test/ncar_kernels/WACCM_lu_fac/data/lu_fac.10.300 b/test/ncar_kernels/WACCM_lu_fac/data/lu_fac.10.300 deleted file mode 100644 index 6610b09b07..0000000000 Binary files a/test/ncar_kernels/WACCM_lu_fac/data/lu_fac.10.300 and /dev/null differ diff --git a/test/ncar_kernels/WACCM_lu_fac/data/lu_fac.5.0 b/test/ncar_kernels/WACCM_lu_fac/data/lu_fac.5.0 deleted file mode 100644 index f3467d1ceb..0000000000 Binary files a/test/ncar_kernels/WACCM_lu_fac/data/lu_fac.5.0 and /dev/null differ diff --git a/test/ncar_kernels/WACCM_lu_fac/data/lu_fac.5.100 b/test/ncar_kernels/WACCM_lu_fac/data/lu_fac.5.100 deleted file mode 100644 index 72f9c2cbec..0000000000 Binary files a/test/ncar_kernels/WACCM_lu_fac/data/lu_fac.5.100 and /dev/null differ diff --git a/test/ncar_kernels/WACCM_lu_fac/data/lu_fac.5.300 b/test/ncar_kernels/WACCM_lu_fac/data/lu_fac.5.300 deleted file mode 100644 index dee4e7b5f1..0000000000 Binary files a/test/ncar_kernels/WACCM_lu_fac/data/lu_fac.5.300 and /dev/null differ diff --git a/test/ncar_kernels/WACCM_lu_fac/inc/t1.mk b/test/ncar_kernels/WACCM_lu_fac/inc/t1.mk deleted file mode 100644 index 6fce829f28..0000000000 --- a/test/ncar_kernels/WACCM_lu_fac/inc/t1.mk +++ /dev/null @@ -1,54 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# Makefile for KGEN-generated kernel - -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# Intel default flags -# -# FC_FLAGS := -no-opt-dynamic-align -convert big_endian -assume byterecl -ftz -traceback -assume realloc_lhs -fp-model source -xHost -O2 -# - -FC_FLAGS := $(OPT) - -ALL_OBJS := kernel_driver.o mo_imp_sol.o kgen_utils.o chem_mods.o mo_lu_factor.o shr_kind_mod.o - -all: build run verify - -verify: - @(grep "verification.FAIL" $(TEST).rslt && echo "FAILED") || (grep "verification.PASS" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 mo_imp_sol.o kgen_utils.o chem_mods.o mo_lu_factor.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_imp_sol.o: $(SRC_DIR)/mo_imp_sol.F90 kgen_utils.o mo_lu_factor.o shr_kind_mod.o chem_mods.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -chem_mods.o: $(SRC_DIR)/chem_mods.F90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_lu_factor.o: $(SRC_DIR)/mo_lu_factor.F90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_kind_mod.o: $(SRC_DIR)/shr_kind_mod.F90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -kgen_utils.o: $(SRC_DIR)/kgen_utils.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.oo *.rslt diff --git a/test/ncar_kernels/WACCM_lu_fac/lit/runmake b/test/ncar_kernels/WACCM_lu_fac/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/WACCM_lu_fac/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/WACCM_lu_fac/lit/t1.sh b/test/ncar_kernels/WACCM_lu_fac/lit/t1.sh deleted file mode 100644 index 33c953a156..0000000000 --- a/test/ncar_kernels/WACCM_lu_fac/lit/t1.sh +++ /dev/null @@ -1,9 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -# Shared lit script for each tests. Run bash commands that run tests with make. - -# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t -# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/WACCM_lu_fac/makefile b/test/ncar_kernels/WACCM_lu_fac/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/WACCM_lu_fac/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/WACCM_lu_fac/src/chem_mods.F90 b/test/ncar_kernels/WACCM_lu_fac/src/chem_mods.F90 deleted file mode 100644 index 808a676f42..0000000000 --- a/test/ncar_kernels/WACCM_lu_fac/src/chem_mods.F90 +++ /dev/null @@ -1,38 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : chem_mods.F90 -! Generated at: 2015-07-15 10:35:30 -! KGEN version: 0.4.13 - - - - MODULE chem_mods - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !-------------------------------------------------------------- - ! ... Basic chemistry parameters and arrays - !-------------------------------------------------------------- - IMPLICIT NONE - INTEGER, parameter :: nzcnt = 1509 ! number of photolysis reactions - ! number of total reactions - ! number of gas phase reactions - ! number of absorbing column densities - ! number of "gas phase" species - ! number of "fixed" species - ! number of relationship species - ! number of group members - ! number of non-zero matrix entries - ! number of species with external forcing - ! number of species in explicit class - ! number of species in hov class - ! number of species in ebi class - ! number of species in implicit class - ! number of species in rodas class - ! index of total atm density in invariant array - ! index of water vapor density - ! loop length for implicit chemistry - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE chem_mods diff --git a/test/ncar_kernels/WACCM_lu_fac/src/kernel_driver.f90 b/test/ncar_kernels/WACCM_lu_fac/src/kernel_driver.f90 deleted file mode 100644 index 192d9401b0..0000000000 --- a/test/ncar_kernels/WACCM_lu_fac/src/kernel_driver.f90 +++ /dev/null @@ -1,76 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-07-15 10:35:30 -! KGEN version: 0.4.13 - - -PROGRAM kernel_driver - USE mo_imp_sol, ONLY : imp_sol - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - - IMPLICIT NONE - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_mpi_rank_at = (/ 0, 100, 300 /) - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(2), PARAMETER :: kgen_counter_at = (/ 10, 5 /) - CHARACTER(LEN=1024) :: kgen_filepath - - DO kgen_repeat_counter = 0, 11 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 2)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - kgen_filepath = "../data/lu_fac." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "** Verification against '" // trim(adjustl(kgen_filepath)) // "' **" - - - ! driver variables - ! Not kernel driver input - - call imp_sol(kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! write subroutines - ! No subroutines - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/WACCM_lu_fac/src/kgen_utils.f90 b/test/ncar_kernels/WACCM_lu_fac/src/kgen_utils.f90 deleted file mode 100644 index cfa8d114e0..0000000000 --- a/test/ncar_kernels/WACCM_lu_fac/src/kgen_utils.f90 +++ /dev/null @@ -1,61 +0,0 @@ -module kgen_utils_mod - -INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - -type check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - real(kind=kgen_dp) :: minvalue -end type check_t - -public kgen_dp, check_t, kgen_init_check, kgen_print_check - -contains - -subroutine kgen_init_check(check, tolerance, minvalue) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - real(kind=kgen_dp), intent(in), optional :: minvalue - - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.0D-15 - endif - if(present(minvalue)) then - check%minvalue = minvalue - else - check%minvalue = 1.0D-15 - endif -end subroutine kgen_init_check - -subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif -end subroutine kgen_print_check - -end module diff --git a/test/ncar_kernels/WACCM_lu_fac/src/mo_imp_sol.F90 b/test/ncar_kernels/WACCM_lu_fac/src/mo_imp_sol.F90 deleted file mode 100644 index 0617e49c86..0000000000 --- a/test/ncar_kernels/WACCM_lu_fac/src/mo_imp_sol.F90 +++ /dev/null @@ -1,169 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_imp_sol.F90 -! Generated at: 2015-07-15 10:35:30 -! KGEN version: 0.4.13 - - - - MODULE mo_imp_sol - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - PRIVATE - PUBLIC imp_sol - !----------------------------------------------------------------------- - ! Newton-Raphson iteration limits - !----------------------------------------------------------------------- - ! for xnox ozone chemistry diagnostics - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - - - SUBROUTINE imp_sol(kgen_unit) - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !----------------------------------------------------------------------- - ! ... imp_sol advances the volumetric mixing ratio - ! forward one time step via the fully implicit euler scheme. - ! this source is meant for small l1 cache machines such as - ! the intel pentium and itanium cpus - !----------------------------------------------------------------------- - USE chem_mods, ONLY: nzcnt - USE mo_lu_factor, ONLY: lu_fac - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - integer, intent(in) :: kgen_unit - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock,maxiter=1000 - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - ! columns in chunck - ! chunk id - ! time step (s) - ! rxt rates (1/cm^3/s) - ! external in-situ forcing (1/cm^3/s) - ! washout rates (1/s) - ! species mixing ratios (vmr) - ! chemistry troposphere boundary (index) - !----------------------------------------------------------------------- - ! ... local variables - !----------------------------------------------------------------------- - REAL(KIND=r8) :: sys_jac(max(1,nzcnt)) - REAL(KIND=r8) :: ref_sys_jac(max(1,nzcnt)) - !----------------------------------------------------------------------- - ! ... class independent forcing - !----------------------------------------------------------------------- - tolerance = 1.E-13 - CALL kgen_init_check(check_status, tolerance) - READ(UNIT=kgen_unit) sys_jac - - READ(UNIT=kgen_unit) ref_sys_jac - - - ! call to kernel - call lu_fac( sys_jac ) - ! kernel verification for output variables - CALL kgen_verify_real_r8_dim1( "sys_jac", check_status, sys_jac, ref_sys_jac) - CALL kgen_print_check("lu_fac", check_status) - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,maxiter - CALL lu_fac(sys_jac) - END DO - CALL system_clock(stop_clock, rate_clock) - WRITE(*,*) - PRINT *, "Elapsed time (sec): ", (stop_clock - start_clock)/REAL(rate_clock*10) - PRINT *, "Elapsed time per lu_fac call (usec): ", (stop_clock - start_clock)*1e6/REAL(rate_clock*maxiter) - ! - ! - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_r8_dim1(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim1 - - - ! verify subroutines - SUBROUTINE kgen_verify_real_r8_dim1( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1))) - allocate(temp2(SIZE(var,dim=1))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim1 - - END SUBROUTINE imp_sol - END MODULE mo_imp_sol diff --git a/test/ncar_kernels/WACCM_lu_fac/src/mo_lu_factor.F90 b/test/ncar_kernels/WACCM_lu_fac/src/mo_lu_factor.F90 deleted file mode 100644 index 2031c37e6e..0000000000 --- a/test/ncar_kernels/WACCM_lu_fac/src/mo_lu_factor.F90 +++ /dev/null @@ -1,5823 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_lu_factor.F90 -! Generated at: 2015-07-15 10:35:30 -! KGEN version: 0.4.13 - - - - MODULE mo_lu_factor - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - PRIVATE - PUBLIC lu_fac - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - - SUBROUTINE lu_fac01(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(1) = 1._r8 / lu(1) - lu(2) = 1._r8 / lu(2) - lu(3) = 1._r8 / lu(3) - lu(4) = 1._r8 / lu(4) - lu(5) = 1._r8 / lu(5) - lu(6) = 1._r8 / lu(6) - lu(7) = 1._r8 / lu(7) - lu(8) = 1._r8 / lu(8) - lu(9) = 1._r8 / lu(9) - lu(10) = 1._r8 / lu(10) - lu(11) = 1._r8 / lu(11) - lu(12) = 1._r8 / lu(12) - lu(13) = 1._r8 / lu(13) - lu(14) = 1._r8 / lu(14) - lu(15) = 1._r8 / lu(15) - lu(16) = 1._r8 / lu(16) - lu(17) = 1._r8 / lu(17) - lu(18) = lu(18) * lu(17) - lu(19) = lu(19) * lu(17) - lu(1383) = lu(1383) - lu(18) * lu(1296) - lu(1389) = lu(1389) - lu(19) * lu(1296) - lu(20) = 1._r8 / lu(20) - lu(21) = lu(21) * lu(20) - lu(22) = lu(22) * lu(20) - lu(1044) = lu(1044) - lu(21) * lu(1029) - lu(1046) = lu(1046) - lu(22) * lu(1029) - lu(23) = 1._r8 / lu(23) - lu(24) = lu(24) * lu(23) - lu(25) = lu(25) * lu(23) - lu(1341) = lu(1341) - lu(24) * lu(1297) - lu(1389) = lu(1389) - lu(25) * lu(1297) - lu(26) = 1._r8 / lu(26) - lu(27) = lu(27) * lu(26) - lu(28) = lu(28) * lu(26) - lu(1311) = lu(1311) - lu(27) * lu(1298) - lu(1389) = lu(1389) - lu(28) * lu(1298) - lu(29) = 1._r8 / lu(29) - lu(30) = lu(30) * lu(29) - lu(31) = lu(31) * lu(29) - lu(32) = lu(32) * lu(29) - lu(1354) = lu(1354) - lu(30) * lu(1299) - lu(1389) = lu(1389) - lu(31) * lu(1299) - lu(1392) = lu(1392) - lu(32) * lu(1299) - lu(33) = 1._r8 / lu(33) - lu(34) = lu(34) * lu(33) - lu(35) = lu(35) * lu(33) - lu(36) = lu(36) * lu(33) - lu(37) = lu(37) * lu(33) - lu(1301) = lu(1301) - lu(34) * lu(1300) - lu(1330) = lu(1330) - lu(35) * lu(1300) - lu(1383) = lu(1383) - lu(36) * lu(1300) - lu(1389) = lu(1389) - lu(37) * lu(1300) - lu(38) = 1._r8 / lu(38) - lu(39) = lu(39) * lu(38) - lu(40) = lu(40) * lu(38) - lu(1304) = lu(1304) - lu(39) * lu(1301) - lu(1389) = lu(1389) - lu(40) * lu(1301) - lu(41) = 1._r8 / lu(41) - lu(42) = lu(42) * lu(41) - lu(43) = lu(43) * lu(41) - lu(387) = lu(387) - lu(42) * lu(386) - lu(394) = - lu(43) * lu(386) - lu(1066) = - lu(42) * lu(1056) - lu(1120) = lu(1120) - lu(43) * lu(1056) - lu(44) = 1._r8 / lu(44) - lu(45) = lu(45) * lu(44) - lu(46) = lu(46) * lu(44) - lu(962) = lu(962) - lu(45) * lu(958) - lu(970) = lu(970) - lu(46) * lu(958) - lu(1346) = - lu(45) * lu(1302) - lu(1380) = - lu(46) * lu(1302) - lu(47) = 1._r8 / lu(47) - lu(48) = lu(48) * lu(47) - lu(49) = lu(49) * lu(47) - lu(80) = lu(80) - lu(48) * lu(79) - lu(83) = lu(83) - lu(49) * lu(79) - lu(1462) = lu(1462) - lu(48) * lu(1460) - lu(1484) = lu(1484) - lu(49) * lu(1460) - END SUBROUTINE lu_fac01 - - SUBROUTINE lu_fac02(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(50) = 1._r8 / lu(50) - lu(51) = lu(51) * lu(50) - lu(54) = lu(54) - lu(51) * lu(52) - lu(903) = lu(903) - lu(51) * lu(886) - lu(942) = lu(942) - lu(51) * lu(917) - lu(1013) = lu(1013) - lu(51) * lu(984) - lu(53) = 1._r8 / lu(53) - lu(54) = lu(54) * lu(53) - lu(903) = lu(903) - lu(54) * lu(887) - lu(942) = lu(942) - lu(54) * lu(918) - lu(968) = lu(968) - lu(54) * lu(959) - lu(1013) = lu(1013) - lu(54) * lu(985) - lu(55) = 1._r8 / lu(55) - lu(56) = lu(56) * lu(55) - lu(490) = lu(490) - lu(56) * lu(485) - lu(564) = lu(564) - lu(56) * lu(558) - lu(829) = lu(829) - lu(56) * lu(819) - lu(1046) = lu(1046) - lu(56) * lu(1030) - lu(1150) = lu(1150) - lu(56) * lu(1125) - lu(57) = 1._r8 / lu(57) - lu(58) = lu(58) * lu(57) - lu(59) = lu(59) * lu(57) - lu(60) = lu(60) * lu(57) - lu(970) = lu(970) - lu(58) * lu(960) - lu(973) = lu(973) - lu(59) * lu(960) - lu(979) = lu(979) - lu(60) * lu(960) - lu(1380) = lu(1380) - lu(58) * lu(1303) - lu(1383) = lu(1383) - lu(59) * lu(1303) - lu(1389) = lu(1389) - lu(60) * lu(1303) - lu(61) = 1._r8 / lu(61) - lu(62) = lu(62) * lu(61) - lu(63) = lu(63) * lu(61) - lu(64) = lu(64) * lu(61) - lu(1263) = lu(1263) - lu(62) * lu(1259) - lu(1285) = lu(1285) - lu(63) * lu(1259) - lu(1290) = lu(1290) - lu(64) * lu(1259) - lu(1331) = - lu(62) * lu(1304) - lu(1383) = lu(1383) - lu(63) * lu(1304) - lu(1388) = lu(1388) - lu(64) * lu(1304) - lu(65) = 1._r8 / lu(65) - lu(66) = lu(66) * lu(65) - lu(67) = lu(67) * lu(65) - lu(68) = lu(68) * lu(65) - lu(962) = lu(962) - lu(66) * lu(961) - lu(970) = lu(970) - lu(67) * lu(961) - lu(974) = lu(974) - lu(68) * lu(961) - lu(1346) = lu(1346) - lu(66) * lu(1305) - lu(1380) = lu(1380) - lu(67) * lu(1305) - lu(1384) = lu(1384) - lu(68) * lu(1305) - lu(69) = 1._r8 / lu(69) - lu(70) = lu(70) * lu(69) - lu(71) = lu(71) * lu(69) - lu(399) = lu(399) - lu(70) * lu(396) - lu(401) = - lu(71) * lu(396) - lu(825) = - lu(70) * lu(820) - lu(829) = lu(829) - lu(71) * lu(820) - lu(1038) = lu(1038) - lu(70) * lu(1031) - lu(1046) = lu(1046) - lu(71) * lu(1031) - lu(1187) = lu(1187) - lu(70) * lu(1180) - lu(1194) = lu(1194) - lu(71) * lu(1180) - lu(72) = 1._r8 / lu(72) - lu(73) = lu(73) * lu(72) - lu(74) = lu(74) * lu(72) - lu(433) = lu(433) - lu(73) * lu(432) - lu(436) = lu(436) - lu(74) * lu(432) - lu(649) = lu(649) - lu(73) * lu(648) - lu(656) = lu(656) - lu(74) * lu(648) - lu(1439) = lu(1439) - lu(73) * lu(1438) - lu(1451) = - lu(74) * lu(1438) - lu(1463) = lu(1463) - lu(73) * lu(1461) - lu(1477) = lu(1477) - lu(74) * lu(1461) - lu(75) = 1._r8 / lu(75) - lu(76) = lu(76) * lu(75) - lu(77) = lu(77) * lu(75) - lu(78) = lu(78) * lu(75) - lu(463) = lu(463) - lu(76) * lu(459) - lu(466) = lu(466) - lu(77) * lu(459) - lu(469) = - lu(78) * lu(459) - lu(861) = lu(861) - lu(76) * lu(850) - lu(876) = lu(876) - lu(77) * lu(850) - lu(881) = - lu(78) * lu(850) - lu(1362) = lu(1362) - lu(76) * lu(1306) - lu(1383) = lu(1383) - lu(77) * lu(1306) - lu(1389) = lu(1389) - lu(78) * lu(1306) - lu(80) = 1._r8 / lu(80) - lu(81) = lu(81) * lu(80) - lu(82) = lu(82) * lu(80) - lu(83) = lu(83) * lu(80) - lu(552) = lu(552) - lu(81) * lu(551) - lu(554) = lu(554) - lu(82) * lu(551) - lu(557) = - lu(83) * lu(551) - lu(1357) = lu(1357) - lu(81) * lu(1307) - lu(1379) = lu(1379) - lu(82) * lu(1307) - lu(1392) = lu(1392) - lu(83) * lu(1307) - lu(1464) = - lu(81) * lu(1462) - lu(1471) = lu(1471) - lu(82) * lu(1462) - lu(1484) = lu(1484) - lu(83) * lu(1462) - lu(84) = 1._r8 / lu(84) - lu(85) = lu(85) * lu(84) - lu(86) = lu(86) * lu(84) - lu(87) = lu(87) * lu(84) - lu(88) = lu(88) * lu(84) - lu(89) = lu(89) * lu(84) - lu(1133) = lu(1133) - lu(85) * lu(1126) - lu(1141) = lu(1141) - lu(86) * lu(1126) - lu(1150) = lu(1150) - lu(87) * lu(1126) - lu(1155) = lu(1155) - lu(88) * lu(1126) - lu(1158) = - lu(89) * lu(1126) - lu(1349) = lu(1349) - lu(85) * lu(1308) - lu(1375) = lu(1375) - lu(86) * lu(1308) - lu(1384) = lu(1384) - lu(87) * lu(1308) - lu(1389) = lu(1389) - lu(88) * lu(1308) - lu(1392) = lu(1392) - lu(89) * lu(1308) - lu(90) = 1._r8 / lu(90) - lu(91) = lu(91) * lu(90) - lu(92) = lu(92) * lu(90) - lu(93) = lu(93) * lu(90) - lu(94) = lu(94) * lu(90) - lu(95) = lu(95) * lu(90) - lu(1129) = - lu(91) * lu(1127) - lu(1131) = - lu(92) * lu(1127) - lu(1137) = lu(1137) - lu(93) * lu(1127) - lu(1149) = lu(1149) - lu(94) * lu(1127) - lu(1155) = lu(1155) - lu(95) * lu(1127) - lu(1329) = lu(1329) - lu(91) * lu(1309) - lu(1343) = lu(1343) - lu(92) * lu(1309) - lu(1361) = lu(1361) - lu(93) * lu(1309) - lu(1383) = lu(1383) - lu(94) * lu(1309) - lu(1389) = lu(1389) - lu(95) * lu(1309) - END SUBROUTINE lu_fac02 - - SUBROUTINE lu_fac03(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(96) = 1._r8 / lu(96) - lu(97) = lu(97) * lu(96) - lu(98) = lu(98) * lu(96) - lu(99) = lu(99) * lu(96) - lu(100) = lu(100) * lu(96) - lu(101) = lu(101) * lu(96) - lu(1357) = lu(1357) - lu(97) * lu(1310) - lu(1383) = lu(1383) - lu(98) * lu(1310) - lu(1389) = lu(1389) - lu(99) * lu(1310) - lu(1390) = lu(1390) - lu(100) * lu(1310) - lu(1391) = lu(1391) - lu(101) * lu(1310) - lu(1404) = lu(1404) - lu(97) * lu(1394) - lu(1427) = lu(1427) - lu(98) * lu(1394) - lu(1433) = lu(1433) - lu(99) * lu(1394) - lu(1434) = lu(1434) - lu(100) * lu(1394) - lu(1435) = lu(1435) - lu(101) * lu(1394) - lu(102) = 1._r8 / lu(102) - lu(103) = lu(103) * lu(102) - lu(104) = lu(104) * lu(102) - lu(105) = lu(105) * lu(102) - lu(106) = lu(106) * lu(102) - lu(107) = lu(107) * lu(102) - lu(1281) = lu(1281) - lu(103) * lu(1260) - lu(1289) = lu(1289) - lu(104) * lu(1260) - lu(1290) = lu(1290) - lu(105) * lu(1260) - lu(1292) = lu(1292) - lu(106) * lu(1260) - lu(1293) = lu(1293) - lu(107) * lu(1260) - lu(1423) = lu(1423) - lu(103) * lu(1395) - lu(1431) = lu(1431) - lu(104) * lu(1395) - lu(1432) = lu(1432) - lu(105) * lu(1395) - lu(1434) = lu(1434) - lu(106) * lu(1395) - lu(1435) = lu(1435) - lu(107) * lu(1395) - lu(108) = 1._r8 / lu(108) - lu(109) = lu(109) * lu(108) - lu(110) = lu(110) * lu(108) - lu(111) = lu(111) * lu(108) - lu(112) = lu(112) * lu(108) - lu(113) = lu(113) * lu(108) - lu(114) = lu(114) * lu(108) - lu(1215) = lu(1215) - lu(109) * lu(1204) - lu(1230) = lu(1230) - lu(110) * lu(1204) - lu(1248) = lu(1248) - lu(111) * lu(1204) - lu(1252) = lu(1252) - lu(112) * lu(1204) - lu(1253) = lu(1253) - lu(113) * lu(1204) - lu(1258) = lu(1258) - lu(114) * lu(1204) - lu(1342) = lu(1342) - lu(109) * lu(1311) - lu(1362) = lu(1362) - lu(110) * lu(1311) - lu(1383) = lu(1383) - lu(111) * lu(1311) - lu(1387) = lu(1387) - lu(112) * lu(1311) - lu(1388) = lu(1388) - lu(113) * lu(1311) - lu(1393) = lu(1393) - lu(114) * lu(1311) - lu(115) = 1._r8 / lu(115) - lu(116) = lu(116) * lu(115) - lu(117) = lu(117) * lu(115) - lu(118) = lu(118) * lu(115) - lu(119) = lu(119) * lu(115) - lu(335) = lu(335) - lu(116) * lu(334) - lu(336) = lu(336) - lu(117) * lu(334) - lu(337) = lu(337) - lu(118) * lu(334) - lu(341) = - lu(119) * lu(334) - lu(1078) = lu(1078) - lu(116) * lu(1057) - lu(1094) = - lu(117) * lu(1057) - lu(1105) = lu(1105) - lu(118) * lu(1057) - lu(1120) = lu(1120) - lu(119) * lu(1057) - lu(1340) = lu(1340) - lu(116) * lu(1312) - lu(1362) = lu(1362) - lu(117) * lu(1312) - lu(1373) = lu(1373) - lu(118) * lu(1312) - lu(1389) = lu(1389) - lu(119) * lu(1312) - lu(120) = 1._r8 / lu(120) - lu(121) = lu(121) * lu(120) - lu(122) = lu(122) * lu(120) - lu(123) = lu(123) * lu(120) - lu(124) = lu(124) * lu(120) - lu(721) = lu(721) - lu(121) * lu(713) - lu(722) = - lu(122) * lu(713) - lu(725) = lu(725) - lu(123) * lu(713) - lu(729) = - lu(124) * lu(713) - lu(1102) = lu(1102) - lu(121) * lu(1058) - lu(1104) = lu(1104) - lu(122) * lu(1058) - lu(1114) = lu(1114) - lu(123) * lu(1058) - lu(1120) = lu(1120) - lu(124) * lu(1058) - lu(1370) = lu(1370) - lu(121) * lu(1313) - lu(1372) = lu(1372) - lu(122) * lu(1313) - lu(1383) = lu(1383) - lu(123) * lu(1313) - lu(1389) = lu(1389) - lu(124) * lu(1313) - lu(125) = 1._r8 / lu(125) - lu(126) = lu(126) * lu(125) - lu(127) = lu(127) * lu(125) - lu(128) = lu(128) * lu(125) - lu(129) = lu(129) * lu(125) - lu(462) = lu(462) - lu(126) * lu(460) - lu(463) = lu(463) - lu(127) * lu(460) - lu(466) = lu(466) - lu(128) * lu(460) - lu(469) = lu(469) - lu(129) * lu(460) - lu(1086) = lu(1086) - lu(126) * lu(1059) - lu(1094) = lu(1094) - lu(127) * lu(1059) - lu(1114) = lu(1114) - lu(128) * lu(1059) - lu(1120) = lu(1120) - lu(129) * lu(1059) - lu(1349) = lu(1349) - lu(126) * lu(1314) - lu(1362) = lu(1362) - lu(127) * lu(1314) - lu(1383) = lu(1383) - lu(128) * lu(1314) - lu(1389) = lu(1389) - lu(129) * lu(1314) - lu(130) = 1._r8 / lu(130) - lu(131) = lu(131) * lu(130) - lu(132) = lu(132) * lu(130) - lu(133) = lu(133) * lu(130) - lu(575) = - lu(131) * lu(570) - lu(580) = - lu(132) * lu(570) - lu(582) = - lu(133) * lu(570) - lu(677) = lu(677) - lu(131) * lu(670) - lu(684) = - lu(132) * lu(670) - lu(687) = - lu(133) * lu(670) - lu(1100) = lu(1100) - lu(131) * lu(1060) - lu(1120) = lu(1120) - lu(132) * lu(1060) - lu(1123) = lu(1123) - lu(133) * lu(1060) - lu(1368) = lu(1368) - lu(131) * lu(1315) - lu(1389) = lu(1389) - lu(132) * lu(1315) - lu(1392) = lu(1392) - lu(133) * lu(1315) - lu(134) = 1._r8 / lu(134) - lu(135) = lu(135) * lu(134) - lu(136) = lu(136) * lu(134) - lu(137) = lu(137) * lu(134) - lu(138) = lu(138) * lu(134) - lu(804) = lu(804) - lu(135) * lu(802) - lu(805) = lu(805) - lu(136) * lu(802) - lu(808) = lu(808) - lu(137) * lu(802) - lu(810) = lu(810) - lu(138) * lu(802) - lu(1034) = lu(1034) - lu(135) * lu(1032) - lu(1036) = lu(1036) - lu(136) * lu(1032) - lu(1041) = lu(1041) - lu(137) * lu(1032) - lu(1044) = lu(1044) - lu(138) * lu(1032) - lu(1184) = lu(1184) - lu(135) * lu(1181) - lu(1185) = lu(1185) - lu(136) * lu(1181) - lu(1189) = lu(1189) - lu(137) * lu(1181) - lu(1192) = lu(1192) - lu(138) * lu(1181) - END SUBROUTINE lu_fac03 - - SUBROUTINE lu_fac04(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(139) = 1._r8 / lu(139) - lu(140) = lu(140) * lu(139) - lu(141) = lu(141) * lu(139) - lu(532) = - lu(140) * lu(529) - lu(535) = lu(535) - lu(141) * lu(529) - lu(696) = - lu(140) * lu(689) - lu(708) = - lu(141) * lu(689) - lu(784) = lu(784) - lu(140) * lu(774) - lu(797) = - lu(141) * lu(774) - lu(866) = lu(866) - lu(140) * lu(851) - lu(881) = lu(881) - lu(141) * lu(851) - lu(1235) = lu(1235) - lu(140) * lu(1205) - lu(1254) = lu(1254) - lu(141) * lu(1205) - lu(1368) = lu(1368) - lu(140) * lu(1316) - lu(1389) = lu(1389) - lu(141) * lu(1316) - lu(1413) = lu(1413) - lu(140) * lu(1396) - lu(1433) = lu(1433) - lu(141) * lu(1396) - lu(142) = 1._r8 / lu(142) - lu(143) = lu(143) * lu(142) - lu(144) = lu(144) * lu(142) - lu(145) = lu(145) * lu(142) - lu(146) = lu(146) * lu(142) - lu(147) = lu(147) * lu(142) - lu(148) = lu(148) * lu(142) - lu(149) = lu(149) * lu(142) - lu(926) = - lu(143) * lu(919) - lu(934) = - lu(144) * lu(919) - lu(936) = lu(936) - lu(145) * lu(919) - lu(938) = lu(938) - lu(146) * lu(919) - lu(943) = lu(943) - lu(147) * lu(919) - lu(949) = lu(949) - lu(148) * lu(919) - lu(953) = lu(953) - lu(149) * lu(919) - lu(1344) = lu(1344) - lu(143) * lu(1317) - lu(1357) = lu(1357) - lu(144) * lu(1317) - lu(1361) = lu(1361) - lu(145) * lu(1317) - lu(1374) = lu(1374) - lu(146) * lu(1317) - lu(1379) = lu(1379) - lu(147) * lu(1317) - lu(1385) = lu(1385) - lu(148) * lu(1317) - lu(1389) = lu(1389) - lu(149) * lu(1317) - lu(150) = 1._r8 / lu(150) - lu(151) = lu(151) * lu(150) - lu(152) = lu(152) * lu(150) - lu(153) = lu(153) * lu(150) - lu(362) = - lu(151) * lu(354) - lu(366) = lu(366) - lu(152) * lu(354) - lu(367) = - lu(153) * lu(354) - lu(591) = - lu(151) * lu(584) - lu(597) = - lu(152) * lu(584) - lu(598) = lu(598) - lu(153) * lu(584) - lu(1234) = lu(1234) - lu(151) * lu(1206) - lu(1253) = lu(1253) - lu(152) * lu(1206) - lu(1254) = lu(1254) - lu(153) * lu(1206) - lu(1367) = lu(1367) - lu(151) * lu(1318) - lu(1388) = lu(1388) - lu(152) * lu(1318) - lu(1389) = lu(1389) - lu(153) * lu(1318) - lu(1412) = lu(1412) - lu(151) * lu(1397) - lu(1432) = lu(1432) - lu(152) * lu(1397) - lu(1433) = lu(1433) - lu(153) * lu(1397) - lu(154) = 1._r8 / lu(154) - lu(155) = lu(155) * lu(154) - lu(156) = lu(156) * lu(154) - lu(157) = lu(157) * lu(154) - lu(158) = lu(158) * lu(154) - lu(159) = lu(159) * lu(154) - lu(872) = lu(872) - lu(155) * lu(852) - lu(878) = - lu(156) * lu(852) - lu(881) = lu(881) - lu(157) * lu(852) - lu(884) = - lu(158) * lu(852) - lu(885) = lu(885) - lu(159) * lu(852) - lu(1108) = lu(1108) - lu(155) * lu(1061) - lu(1116) = lu(1116) - lu(156) * lu(1061) - lu(1120) = lu(1120) - lu(157) * lu(1061) - lu(1123) = lu(1123) - lu(158) * lu(1061) - lu(1124) = lu(1124) - lu(159) * lu(1061) - lu(1377) = lu(1377) - lu(155) * lu(1319) - lu(1385) = lu(1385) - lu(156) * lu(1319) - lu(1389) = lu(1389) - lu(157) * lu(1319) - lu(1392) = lu(1392) - lu(158) * lu(1319) - lu(1393) = lu(1393) - lu(159) * lu(1319) - lu(160) = 1._r8 / lu(160) - lu(161) = lu(161) * lu(160) - lu(162) = lu(162) * lu(160) - lu(163) = lu(163) * lu(160) - lu(164) = lu(164) * lu(160) - lu(165) = lu(165) * lu(160) - lu(246) = lu(246) - lu(161) * lu(245) - lu(247) = lu(247) - lu(162) * lu(245) - lu(248) = lu(248) - lu(163) * lu(245) - lu(249) = lu(249) - lu(164) * lu(245) - lu(253) = - lu(165) * lu(245) - lu(1071) = lu(1071) - lu(161) * lu(1062) - lu(1072) = - lu(162) * lu(1062) - lu(1081) = - lu(163) * lu(1062) - lu(1099) = - lu(164) * lu(1062) - lu(1120) = lu(1120) - lu(165) * lu(1062) - lu(1330) = lu(1330) - lu(161) * lu(1320) - lu(1331) = lu(1331) - lu(162) * lu(1320) - lu(1343) = lu(1343) - lu(163) * lu(1320) - lu(1367) = lu(1367) - lu(164) * lu(1320) - lu(1389) = lu(1389) - lu(165) * lu(1320) - lu(166) = 1._r8 / lu(166) - lu(167) = lu(167) * lu(166) - lu(168) = lu(168) * lu(166) - lu(169) = lu(169) * lu(166) - lu(170) = lu(170) * lu(166) - lu(171) = lu(171) * lu(166) - lu(516) = lu(516) - lu(167) * lu(515) - lu(517) = lu(517) - lu(168) * lu(515) - lu(523) = lu(523) - lu(169) * lu(515) - lu(526) = - lu(170) * lu(515) - lu(527) = - lu(171) * lu(515) - lu(1080) = - lu(167) * lu(1063) - lu(1089) = lu(1089) - lu(168) * lu(1063) - lu(1114) = lu(1114) - lu(169) * lu(1063) - lu(1120) = lu(1120) - lu(170) * lu(1063) - lu(1123) = lu(1123) - lu(171) * lu(1063) - lu(1342) = lu(1342) - lu(167) * lu(1321) - lu(1354) = lu(1354) - lu(168) * lu(1321) - lu(1383) = lu(1383) - lu(169) * lu(1321) - lu(1389) = lu(1389) - lu(170) * lu(1321) - lu(1392) = lu(1392) - lu(171) * lu(1321) - END SUBROUTINE lu_fac04 - - SUBROUTINE lu_fac05(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(172) = 1._r8 / lu(172) - lu(173) = lu(173) * lu(172) - lu(174) = lu(174) * lu(172) - lu(175) = lu(175) * lu(172) - lu(176) = lu(176) * lu(172) - lu(177) = lu(177) * lu(172) - lu(625) = lu(625) - lu(173) * lu(622) - lu(627) = lu(627) - lu(174) * lu(622) - lu(633) = - lu(175) * lu(622) - lu(634) = - lu(176) * lu(622) - lu(635) = lu(635) - lu(177) * lu(622) - lu(1096) = lu(1096) - lu(173) * lu(1064) - lu(1105) = lu(1105) - lu(174) * lu(1064) - lu(1120) = lu(1120) - lu(175) * lu(1064) - lu(1123) = lu(1123) - lu(176) * lu(1064) - lu(1124) = lu(1124) - lu(177) * lu(1064) - lu(1364) = lu(1364) - lu(173) * lu(1322) - lu(1373) = lu(1373) - lu(174) * lu(1322) - lu(1389) = lu(1389) - lu(175) * lu(1322) - lu(1392) = lu(1392) - lu(176) * lu(1322) - lu(1393) = lu(1393) - lu(177) * lu(1322) - lu(178) = 1._r8 / lu(178) - lu(179) = lu(179) * lu(178) - lu(180) = lu(180) * lu(178) - lu(181) = lu(181) * lu(178) - lu(182) = lu(182) * lu(178) - lu(183) = lu(183) * lu(178) - lu(1070) = lu(1070) - lu(179) * lu(1065) - lu(1114) = lu(1114) - lu(180) * lu(1065) - lu(1118) = lu(1118) - lu(181) * lu(1065) - lu(1119) = lu(1119) - lu(182) * lu(1065) - lu(1124) = lu(1124) - lu(183) * lu(1065) - lu(1210) = lu(1210) - lu(179) * lu(1207) - lu(1248) = lu(1248) - lu(180) * lu(1207) - lu(1252) = lu(1252) - lu(181) * lu(1207) - lu(1253) = lu(1253) - lu(182) * lu(1207) - lu(1258) = lu(1258) - lu(183) * lu(1207) - lu(1487) = - lu(179) * lu(1486) - lu(1499) = lu(1499) - lu(180) * lu(1486) - lu(1503) = - lu(181) * lu(1486) - lu(1504) = - lu(182) * lu(1486) - lu(1509) = lu(1509) - lu(183) * lu(1486) - lu(184) = 1._r8 / lu(184) - lu(185) = lu(185) * lu(184) - lu(186) = lu(186) * lu(184) - lu(187) = lu(187) * lu(184) - lu(188) = lu(188) * lu(184) - lu(325) = - lu(185) * lu(323) - lu(328) = - lu(186) * lu(323) - lu(330) = - lu(187) * lu(323) - lu(332) = lu(332) - lu(188) * lu(323) - lu(357) = - lu(185) * lu(355) - lu(360) = - lu(186) * lu(355) - lu(363) = - lu(187) * lu(355) - lu(367) = lu(367) - lu(188) * lu(355) - lu(1213) = lu(1213) - lu(185) * lu(1208) - lu(1222) = lu(1222) - lu(186) * lu(1208) - lu(1240) = lu(1240) - lu(187) * lu(1208) - lu(1254) = lu(1254) - lu(188) * lu(1208) - lu(1340) = lu(1340) - lu(185) * lu(1323) - lu(1349) = lu(1349) - lu(186) * lu(1323) - lu(1373) = lu(1373) - lu(187) * lu(1323) - lu(1389) = lu(1389) - lu(188) * lu(1323) - lu(189) = 1._r8 / lu(189) - lu(190) = lu(190) * lu(189) - lu(191) = lu(191) * lu(189) - lu(192) = lu(192) * lu(189) - lu(193) = lu(193) * lu(189) - lu(389) = - lu(190) * lu(387) - lu(390) = - lu(191) * lu(387) - lu(391) = lu(391) - lu(192) * lu(387) - lu(395) = lu(395) - lu(193) * lu(387) - lu(898) = lu(898) - lu(190) * lu(888) - lu(903) = lu(903) - lu(191) * lu(888) - lu(908) = lu(908) - lu(192) * lu(888) - lu(916) = - lu(193) * lu(888) - lu(1088) = - lu(190) * lu(1066) - lu(1109) = lu(1109) - lu(191) * lu(1066) - lu(1114) = lu(1114) - lu(192) * lu(1066) - lu(1124) = lu(1124) - lu(193) * lu(1066) - lu(1224) = lu(1224) - lu(190) * lu(1209) - lu(1243) = lu(1243) - lu(191) * lu(1209) - lu(1248) = lu(1248) - lu(192) * lu(1209) - lu(1258) = lu(1258) - lu(193) * lu(1209) - lu(194) = 1._r8 / lu(194) - lu(195) = lu(195) * lu(194) - lu(196) = lu(196) * lu(194) - lu(197) = lu(197) * lu(194) - lu(198) = lu(198) * lu(194) - lu(199) = lu(199) * lu(194) - lu(200) = lu(200) * lu(194) - lu(789) = lu(789) - lu(195) * lu(775) - lu(790) = lu(790) - lu(196) * lu(775) - lu(796) = lu(796) - lu(197) * lu(775) - lu(797) = lu(797) - lu(198) * lu(775) - lu(798) = - lu(199) * lu(775) - lu(801) = lu(801) - lu(200) * lu(775) - lu(1275) = lu(1275) - lu(195) * lu(1261) - lu(1279) = - lu(196) * lu(1261) - lu(1290) = lu(1290) - lu(197) * lu(1261) - lu(1291) = lu(1291) - lu(198) * lu(1261) - lu(1292) = lu(1292) - lu(199) * lu(1261) - lu(1295) = - lu(200) * lu(1261) - lu(1373) = lu(1373) - lu(195) * lu(1324) - lu(1377) = lu(1377) - lu(196) * lu(1324) - lu(1388) = lu(1388) - lu(197) * lu(1324) - lu(1389) = lu(1389) - lu(198) * lu(1324) - lu(1390) = lu(1390) - lu(199) * lu(1324) - lu(1393) = lu(1393) - lu(200) * lu(1324) - lu(201) = 1._r8 / lu(201) - lu(202) = lu(202) * lu(201) - lu(203) = lu(203) * lu(201) - lu(204) = lu(204) * lu(201) - lu(205) = lu(205) * lu(201) - lu(206) = lu(206) * lu(201) - lu(207) = lu(207) * lu(201) - lu(472) = - lu(202) * lu(471) - lu(473) = lu(473) - lu(203) * lu(471) - lu(474) = lu(474) - lu(204) * lu(471) - lu(476) = lu(476) - lu(205) * lu(471) - lu(478) = lu(478) - lu(206) * lu(471) - lu(479) = lu(479) - lu(207) * lu(471) - lu(891) = lu(891) - lu(202) * lu(889) - lu(894) = lu(894) - lu(203) * lu(889) - lu(895) = lu(895) - lu(204) * lu(889) - lu(897) = lu(897) - lu(205) * lu(889) - lu(903) = lu(903) - lu(206) * lu(889) - lu(904) = lu(904) - lu(207) * lu(889) - lu(923) = lu(923) - lu(202) * lu(920) - lu(928) = - lu(203) * lu(920) - lu(929) = lu(929) - lu(204) * lu(920) - lu(932) = lu(932) - lu(205) * lu(920) - lu(942) = lu(942) - lu(206) * lu(920) - lu(943) = lu(943) - lu(207) * lu(920) - END SUBROUTINE lu_fac05 - - SUBROUTINE lu_fac06(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(208) = 1._r8 / lu(208) - lu(209) = lu(209) * lu(208) - lu(210) = lu(210) * lu(208) - lu(211) = lu(211) * lu(208) - lu(212) = lu(212) * lu(208) - lu(213) = lu(213) * lu(208) - lu(214) = lu(214) * lu(208) - lu(539) = lu(539) - lu(209) * lu(538) - lu(540) = lu(540) - lu(210) * lu(538) - lu(542) = lu(542) - lu(211) * lu(538) - lu(543) = lu(543) - lu(212) * lu(538) - lu(546) = lu(546) - lu(213) * lu(538) - lu(549) = - lu(214) * lu(538) - lu(1080) = lu(1080) - lu(209) * lu(1067) - lu(1091) = lu(1091) - lu(210) * lu(1067) - lu(1097) = lu(1097) - lu(211) * lu(1067) - lu(1103) = lu(1103) - lu(212) * lu(1067) - lu(1114) = lu(1114) - lu(213) * lu(1067) - lu(1120) = lu(1120) - lu(214) * lu(1067) - lu(1342) = lu(1342) - lu(209) * lu(1325) - lu(1356) = lu(1356) - lu(210) * lu(1325) - lu(1365) = lu(1365) - lu(211) * lu(1325) - lu(1371) = lu(1371) - lu(212) * lu(1325) - lu(1383) = lu(1383) - lu(213) * lu(1325) - lu(1389) = lu(1389) - lu(214) * lu(1325) - lu(215) = 1._r8 / lu(215) - lu(216) = lu(216) * lu(215) - lu(217) = lu(217) * lu(215) - lu(218) = lu(218) * lu(215) - lu(219) = lu(219) * lu(215) - lu(220) = lu(220) * lu(215) - lu(221) = lu(221) * lu(215) - lu(1109) = lu(1109) - lu(216) * lu(1068) - lu(1114) = lu(1114) - lu(217) * lu(1068) - lu(1119) = lu(1119) - lu(218) * lu(1068) - lu(1120) = lu(1120) - lu(219) * lu(1068) - lu(1121) = lu(1121) - lu(220) * lu(1068) - lu(1123) = lu(1123) - lu(221) * lu(1068) - lu(1280) = lu(1280) - lu(216) * lu(1262) - lu(1285) = lu(1285) - lu(217) * lu(1262) - lu(1290) = lu(1290) - lu(218) * lu(1262) - lu(1291) = lu(1291) - lu(219) * lu(1262) - lu(1292) = lu(1292) - lu(220) * lu(1262) - lu(1294) = - lu(221) * lu(1262) - lu(1378) = lu(1378) - lu(216) * lu(1326) - lu(1383) = lu(1383) - lu(217) * lu(1326) - lu(1388) = lu(1388) - lu(218) * lu(1326) - lu(1389) = lu(1389) - lu(219) * lu(1326) - lu(1390) = lu(1390) - lu(220) * lu(1326) - lu(1392) = lu(1392) - lu(221) * lu(1326) - lu(222) = 1._r8 / lu(222) - lu(223) = lu(223) * lu(222) - lu(224) = lu(224) * lu(222) - lu(225) = lu(225) * lu(222) - lu(226) = lu(226) * lu(222) - lu(348) = lu(348) - lu(223) * lu(342) - lu(350) = lu(350) - lu(224) * lu(342) - lu(352) = - lu(225) * lu(342) - lu(353) = - lu(226) * lu(342) - lu(416) = lu(416) - lu(223) * lu(413) - lu(417) = - lu(224) * lu(413) - lu(419) = - lu(225) * lu(413) - lu(420) = - lu(226) * lu(413) - lu(426) = lu(426) - lu(223) * lu(421) - lu(428) = - lu(224) * lu(421) - lu(430) = lu(430) - lu(225) * lu(421) - lu(431) = - lu(226) * lu(421) - lu(897) = lu(897) - lu(223) * lu(890) - lu(903) = lu(903) - lu(224) * lu(890) - lu(905) = lu(905) - lu(225) * lu(890) - lu(912) = lu(912) - lu(226) * lu(890) - lu(932) = lu(932) - lu(223) * lu(921) - lu(942) = lu(942) - lu(224) * lu(921) - lu(944) = - lu(225) * lu(921) - lu(951) = lu(951) - lu(226) * lu(921) - lu(227) = 1._r8 / lu(227) - lu(228) = lu(228) * lu(227) - lu(229) = lu(229) * lu(227) - lu(230) = lu(230) * lu(227) - lu(231) = lu(231) * lu(227) - lu(232) = lu(232) * lu(227) - lu(761) = lu(761) - lu(228) * lu(755) - lu(762) = lu(762) - lu(229) * lu(755) - lu(769) = - lu(230) * lu(755) - lu(772) = - lu(231) * lu(755) - lu(773) = lu(773) - lu(232) * lu(755) - lu(789) = lu(789) - lu(228) * lu(776) - lu(790) = lu(790) - lu(229) * lu(776) - lu(797) = lu(797) - lu(230) * lu(776) - lu(800) = - lu(231) * lu(776) - lu(801) = lu(801) - lu(232) * lu(776) - lu(1105) = lu(1105) - lu(228) * lu(1069) - lu(1108) = lu(1108) - lu(229) * lu(1069) - lu(1120) = lu(1120) - lu(230) * lu(1069) - lu(1123) = lu(1123) - lu(231) * lu(1069) - lu(1124) = lu(1124) - lu(232) * lu(1069) - lu(1373) = lu(1373) - lu(228) * lu(1327) - lu(1377) = lu(1377) - lu(229) * lu(1327) - lu(1389) = lu(1389) - lu(230) * lu(1327) - lu(1392) = lu(1392) - lu(231) * lu(1327) - lu(1393) = lu(1393) - lu(232) * lu(1327) - lu(233) = 1._r8 / lu(233) - lu(234) = lu(234) * lu(233) - lu(235) = lu(235) * lu(233) - lu(236) = lu(236) * lu(233) - lu(237) = lu(237) * lu(233) - lu(238) = lu(238) * lu(233) - lu(239) = lu(239) * lu(233) - lu(240) = lu(240) * lu(233) - lu(987) = lu(987) - lu(234) * lu(986) - lu(991) = - lu(235) * lu(986) - lu(998) = lu(998) - lu(236) * lu(986) - lu(1016) = lu(1016) - lu(237) * lu(986) - lu(1018) = lu(1018) - lu(238) * lu(986) - lu(1024) = lu(1024) - lu(239) * lu(986) - lu(1028) = lu(1028) - lu(240) * lu(986) - lu(1129) = lu(1129) - lu(234) * lu(1128) - lu(1132) = - lu(235) * lu(1128) - lu(1137) = lu(1137) - lu(236) * lu(1128) - lu(1147) = lu(1147) - lu(237) * lu(1128) - lu(1149) = lu(1149) - lu(238) * lu(1128) - lu(1155) = lu(1155) - lu(239) * lu(1128) - lu(1159) = lu(1159) - lu(240) * lu(1128) - lu(1329) = lu(1329) - lu(234) * lu(1328) - lu(1345) = lu(1345) - lu(235) * lu(1328) - lu(1361) = lu(1361) - lu(236) * lu(1328) - lu(1381) = lu(1381) - lu(237) * lu(1328) - lu(1383) = lu(1383) - lu(238) * lu(1328) - lu(1389) = lu(1389) - lu(239) * lu(1328) - lu(1393) = lu(1393) - lu(240) * lu(1328) - lu(241) = 1._r8 / lu(241) - lu(242) = lu(242) * lu(241) - lu(243) = lu(243) * lu(241) - lu(244) = lu(244) * lu(241) - lu(1018) = lu(1018) - lu(242) * lu(987) - lu(1024) = lu(1024) - lu(243) * lu(987) - lu(1027) = - lu(244) * lu(987) - lu(1114) = lu(1114) - lu(242) * lu(1070) - lu(1120) = lu(1120) - lu(243) * lu(1070) - lu(1123) = lu(1123) - lu(244) * lu(1070) - lu(1149) = lu(1149) - lu(242) * lu(1129) - lu(1155) = lu(1155) - lu(243) * lu(1129) - lu(1158) = lu(1158) - lu(244) * lu(1129) - lu(1248) = lu(1248) - lu(242) * lu(1210) - lu(1254) = lu(1254) - lu(243) * lu(1210) - lu(1257) = - lu(244) * lu(1210) - lu(1383) = lu(1383) - lu(242) * lu(1329) - lu(1389) = lu(1389) - lu(243) * lu(1329) - lu(1392) = lu(1392) - lu(244) * lu(1329) - lu(1499) = lu(1499) - lu(242) * lu(1487) - lu(1505) = lu(1505) - lu(243) * lu(1487) - lu(1508) = lu(1508) - lu(244) * lu(1487) - END SUBROUTINE lu_fac06 - - SUBROUTINE lu_fac07(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(246) = 1._r8 / lu(246) - lu(247) = lu(247) * lu(246) - lu(248) = lu(248) * lu(246) - lu(249) = lu(249) * lu(246) - lu(250) = lu(250) * lu(246) - lu(251) = lu(251) * lu(246) - lu(252) = lu(252) * lu(246) - lu(253) = lu(253) * lu(246) - lu(1072) = lu(1072) - lu(247) * lu(1071) - lu(1081) = lu(1081) - lu(248) * lu(1071) - lu(1099) = lu(1099) - lu(249) * lu(1071) - lu(1114) = lu(1114) - lu(250) * lu(1071) - lu(1118) = lu(1118) - lu(251) * lu(1071) - lu(1119) = lu(1119) - lu(252) * lu(1071) - lu(1120) = lu(1120) - lu(253) * lu(1071) - lu(1212) = lu(1212) - lu(247) * lu(1211) - lu(1216) = lu(1216) - lu(248) * lu(1211) - lu(1234) = lu(1234) - lu(249) * lu(1211) - lu(1248) = lu(1248) - lu(250) * lu(1211) - lu(1252) = lu(1252) - lu(251) * lu(1211) - lu(1253) = lu(1253) - lu(252) * lu(1211) - lu(1254) = lu(1254) - lu(253) * lu(1211) - lu(1331) = lu(1331) - lu(247) * lu(1330) - lu(1343) = lu(1343) - lu(248) * lu(1330) - lu(1367) = lu(1367) - lu(249) * lu(1330) - lu(1383) = lu(1383) - lu(250) * lu(1330) - lu(1387) = lu(1387) - lu(251) * lu(1330) - lu(1388) = lu(1388) - lu(252) * lu(1330) - lu(1389) = lu(1389) - lu(253) * lu(1330) - lu(254) = 1._r8 / lu(254) - lu(255) = lu(255) * lu(254) - lu(256) = lu(256) * lu(254) - lu(257) = lu(257) * lu(254) - lu(258) = lu(258) * lu(254) - lu(259) = lu(259) * lu(254) - lu(1081) = lu(1081) - lu(255) * lu(1072) - lu(1093) = - lu(256) * lu(1072) - lu(1099) = lu(1099) - lu(257) * lu(1072) - lu(1105) = lu(1105) - lu(258) * lu(1072) - lu(1114) = lu(1114) - lu(259) * lu(1072) - lu(1216) = lu(1216) - lu(255) * lu(1212) - lu(1229) = lu(1229) - lu(256) * lu(1212) - lu(1234) = lu(1234) - lu(257) * lu(1212) - lu(1240) = lu(1240) - lu(258) * lu(1212) - lu(1248) = lu(1248) - lu(259) * lu(1212) - lu(1266) = - lu(255) * lu(1263) - lu(1271) = - lu(256) * lu(1263) - lu(1273) = - lu(257) * lu(1263) - lu(1275) = lu(1275) - lu(258) * lu(1263) - lu(1285) = lu(1285) - lu(259) * lu(1263) - lu(1343) = lu(1343) - lu(255) * lu(1331) - lu(1361) = lu(1361) - lu(256) * lu(1331) - lu(1367) = lu(1367) - lu(257) * lu(1331) - lu(1373) = lu(1373) - lu(258) * lu(1331) - lu(1383) = lu(1383) - lu(259) * lu(1331) - lu(260) = 1._r8 / lu(260) - lu(261) = lu(261) * lu(260) - lu(262) = lu(262) * lu(260) - lu(263) = lu(263) * lu(260) - lu(264) = lu(264) * lu(260) - lu(265) = lu(265) * lu(260) - lu(266) = lu(266) * lu(260) - lu(267) = lu(267) * lu(260) - lu(442) = lu(442) - lu(261) * lu(441) - lu(443) = lu(443) - lu(262) * lu(441) - lu(444) = - lu(263) * lu(441) - lu(446) = lu(446) - lu(264) * lu(441) - lu(449) = - lu(265) * lu(441) - lu(450) = - lu(266) * lu(441) - lu(451) = lu(451) - lu(267) * lu(441) - lu(1084) = lu(1084) - lu(261) * lu(1073) - lu(1094) = lu(1094) - lu(262) * lu(1073) - lu(1095) = - lu(263) * lu(1073) - lu(1114) = lu(1114) - lu(264) * lu(1073) - lu(1120) = lu(1120) - lu(265) * lu(1073) - lu(1123) = lu(1123) - lu(266) * lu(1073) - lu(1124) = lu(1124) - lu(267) * lu(1073) - lu(1347) = lu(1347) - lu(261) * lu(1332) - lu(1362) = lu(1362) - lu(262) * lu(1332) - lu(1363) = lu(1363) - lu(263) * lu(1332) - lu(1383) = lu(1383) - lu(264) * lu(1332) - lu(1389) = lu(1389) - lu(265) * lu(1332) - lu(1392) = lu(1392) - lu(266) * lu(1332) - lu(1393) = lu(1393) - lu(267) * lu(1332) - lu(268) = 1._r8 / lu(268) - lu(269) = lu(269) * lu(268) - lu(270) = lu(270) * lu(268) - lu(271) = lu(271) * lu(268) - lu(466) = lu(466) - lu(269) * lu(461) - lu(469) = lu(469) - lu(270) * lu(461) - lu(470) = lu(470) - lu(271) * lu(461) - lu(630) = lu(630) - lu(269) * lu(623) - lu(633) = lu(633) - lu(270) * lu(623) - lu(635) = lu(635) - lu(271) * lu(623) - lu(680) = lu(680) - lu(269) * lu(671) - lu(684) = lu(684) - lu(270) * lu(671) - lu(688) = lu(688) - lu(271) * lu(671) - lu(704) = lu(704) - lu(269) * lu(690) - lu(708) = lu(708) - lu(270) * lu(690) - lu(712) = lu(712) - lu(271) * lu(690) - lu(725) = lu(725) - lu(269) * lu(714) - lu(729) = lu(729) - lu(270) * lu(714) - lu(733) = lu(733) - lu(271) * lu(714) - lu(876) = lu(876) - lu(269) * lu(853) - lu(881) = lu(881) - lu(270) * lu(853) - lu(885) = lu(885) - lu(271) * lu(853) - lu(1383) = lu(1383) - lu(269) * lu(1333) - lu(1389) = lu(1389) - lu(270) * lu(1333) - lu(1393) = lu(1393) - lu(271) * lu(1333) - lu(272) = 1._r8 / lu(272) - lu(273) = lu(273) * lu(272) - lu(274) = lu(274) * lu(272) - lu(275) = lu(275) * lu(272) - lu(276) = lu(276) * lu(272) - lu(277) = lu(277) * lu(272) - lu(278) = lu(278) * lu(272) - lu(279) = lu(279) * lu(272) - lu(694) = lu(694) - lu(273) * lu(691) - lu(696) = lu(696) - lu(274) * lu(691) - lu(697) = lu(697) - lu(275) * lu(691) - lu(699) = lu(699) - lu(276) * lu(691) - lu(704) = lu(704) - lu(277) * lu(691) - lu(708) = lu(708) - lu(278) * lu(691) - lu(712) = lu(712) - lu(279) * lu(691) - lu(1097) = lu(1097) - lu(273) * lu(1074) - lu(1100) = lu(1100) - lu(274) * lu(1074) - lu(1101) = lu(1101) - lu(275) * lu(1074) - lu(1103) = lu(1103) - lu(276) * lu(1074) - lu(1114) = lu(1114) - lu(277) * lu(1074) - lu(1120) = lu(1120) - lu(278) * lu(1074) - lu(1124) = lu(1124) - lu(279) * lu(1074) - lu(1365) = lu(1365) - lu(273) * lu(1334) - lu(1368) = lu(1368) - lu(274) * lu(1334) - lu(1369) = lu(1369) - lu(275) * lu(1334) - lu(1371) = lu(1371) - lu(276) * lu(1334) - lu(1383) = lu(1383) - lu(277) * lu(1334) - lu(1389) = lu(1389) - lu(278) * lu(1334) - lu(1393) = lu(1393) - lu(279) * lu(1334) - lu(280) = 1._r8 / lu(280) - lu(281) = lu(281) * lu(280) - lu(282) = lu(282) * lu(280) - lu(283) = lu(283) * lu(280) - lu(284) = lu(284) * lu(280) - lu(285) = lu(285) * lu(280) - lu(286) = lu(286) * lu(280) - lu(287) = lu(287) * lu(280) - lu(927) = lu(927) - lu(281) * lu(922) - lu(940) = lu(940) - lu(282) * lu(922) - lu(943) = lu(943) - lu(283) * lu(922) - lu(950) = lu(950) - lu(284) * lu(922) - lu(952) = lu(952) - lu(285) * lu(922) - lu(954) = lu(954) - lu(286) * lu(922) - lu(955) = - lu(287) * lu(922) - lu(1183) = lu(1183) - lu(281) * lu(1182) - lu(1187) = lu(1187) - lu(282) * lu(1182) - lu(1189) = lu(1189) - lu(283) * lu(1182) - lu(1196) = lu(1196) - lu(284) * lu(1182) - lu(1198) = lu(1198) - lu(285) * lu(1182) - lu(1200) = - lu(286) * lu(1182) - lu(1201) = - lu(287) * lu(1182) - lu(1267) = - lu(281) * lu(1264) - lu(1278) = - lu(282) * lu(1264) - lu(1281) = lu(1281) - lu(283) * lu(1264) - lu(1288) = lu(1288) - lu(284) * lu(1264) - lu(1290) = lu(1290) - lu(285) * lu(1264) - lu(1292) = lu(1292) - lu(286) * lu(1264) - lu(1293) = lu(1293) - lu(287) * lu(1264) - END SUBROUTINE lu_fac07 - - SUBROUTINE lu_fac08(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(288) = 1._r8 / lu(288) - lu(289) = lu(289) * lu(288) - lu(290) = lu(290) * lu(288) - lu(291) = lu(291) * lu(288) - lu(292) = lu(292) * lu(288) - lu(293) = lu(293) * lu(288) - lu(294) = lu(294) * lu(288) - lu(295) = lu(295) * lu(288) - lu(758) = - lu(289) * lu(756) - lu(760) = lu(760) - lu(290) * lu(756) - lu(765) = lu(765) - lu(291) * lu(756) - lu(768) = lu(768) - lu(292) * lu(756) - lu(769) = lu(769) - lu(293) * lu(756) - lu(770) = lu(770) - lu(294) * lu(756) - lu(773) = lu(773) - lu(295) * lu(756) - lu(1272) = - lu(289) * lu(1265) - lu(1274) = lu(1274) - lu(290) * lu(1265) - lu(1285) = lu(1285) - lu(291) * lu(1265) - lu(1290) = lu(1290) - lu(292) * lu(1265) - lu(1291) = lu(1291) - lu(293) * lu(1265) - lu(1292) = lu(1292) - lu(294) * lu(1265) - lu(1295) = lu(1295) - lu(295) * lu(1265) - lu(1363) = lu(1363) - lu(289) * lu(1335) - lu(1372) = lu(1372) - lu(290) * lu(1335) - lu(1383) = lu(1383) - lu(291) * lu(1335) - lu(1388) = lu(1388) - lu(292) * lu(1335) - lu(1389) = lu(1389) - lu(293) * lu(1335) - lu(1390) = lu(1390) - lu(294) * lu(1335) - lu(1393) = lu(1393) - lu(295) * lu(1335) - lu(296) = 1._r8 / lu(296) - lu(297) = lu(297) * lu(296) - lu(298) = lu(298) * lu(296) - lu(299) = lu(299) * lu(296) - lu(300) = lu(300) * lu(296) - lu(301) = lu(301) * lu(296) - lu(302) = lu(302) * lu(296) - lu(345) = lu(345) - lu(297) * lu(343) - lu(346) = lu(346) - lu(298) * lu(343) - lu(348) = lu(348) - lu(299) * lu(343) - lu(349) = - lu(300) * lu(343) - lu(350) = lu(350) - lu(301) * lu(343) - lu(351) = lu(351) - lu(302) * lu(343) - lu(473) = lu(473) - lu(297) * lu(472) - lu(474) = lu(474) - lu(298) * lu(472) - lu(476) = lu(476) - lu(299) * lu(472) - lu(477) = - lu(300) * lu(472) - lu(478) = lu(478) - lu(301) * lu(472) - lu(479) = lu(479) - lu(302) * lu(472) - lu(894) = lu(894) - lu(297) * lu(891) - lu(895) = lu(895) - lu(298) * lu(891) - lu(897) = lu(897) - lu(299) * lu(891) - lu(900) = - lu(300) * lu(891) - lu(903) = lu(903) - lu(301) * lu(891) - lu(904) = lu(904) - lu(302) * lu(891) - lu(928) = lu(928) - lu(297) * lu(923) - lu(929) = lu(929) - lu(298) * lu(923) - lu(932) = lu(932) - lu(299) * lu(923) - lu(936) = lu(936) - lu(300) * lu(923) - lu(942) = lu(942) - lu(301) * lu(923) - lu(943) = lu(943) - lu(302) * lu(923) - lu(303) = 1._r8 / lu(303) - lu(304) = lu(304) * lu(303) - lu(305) = lu(305) * lu(303) - lu(306) = lu(306) * lu(303) - lu(307) = lu(307) * lu(303) - lu(308) = lu(308) * lu(303) - lu(309) = lu(309) * lu(303) - lu(310) = lu(310) * lu(303) - lu(311) = lu(311) * lu(303) - lu(994) = - lu(304) * lu(988) - lu(1002) = lu(1002) - lu(305) * lu(988) - lu(1007) = lu(1007) - lu(306) * lu(988) - lu(1016) = lu(1016) - lu(307) * lu(988) - lu(1018) = lu(1018) - lu(308) * lu(988) - lu(1023) = lu(1023) - lu(309) * lu(988) - lu(1024) = lu(1024) - lu(310) * lu(988) - lu(1025) = lu(1025) - lu(311) * lu(988) - lu(1356) = lu(1356) - lu(304) * lu(1336) - lu(1365) = lu(1365) - lu(305) * lu(1336) - lu(1371) = lu(1371) - lu(306) * lu(1336) - lu(1381) = lu(1381) - lu(307) * lu(1336) - lu(1383) = lu(1383) - lu(308) * lu(1336) - lu(1388) = lu(1388) - lu(309) * lu(1336) - lu(1389) = lu(1389) - lu(310) * lu(1336) - lu(1390) = lu(1390) - lu(311) * lu(1336) - lu(1403) = lu(1403) - lu(304) * lu(1398) - lu(1411) = lu(1411) - lu(305) * lu(1398) - lu(1416) = lu(1416) - lu(306) * lu(1398) - lu(1425) = - lu(307) * lu(1398) - lu(1427) = lu(1427) - lu(308) * lu(1398) - lu(1432) = lu(1432) - lu(309) * lu(1398) - lu(1433) = lu(1433) - lu(310) * lu(1398) - lu(1434) = lu(1434) - lu(311) * lu(1398) - lu(312) = 1._r8 / lu(312) - lu(313) = lu(313) * lu(312) - lu(314) = lu(314) * lu(312) - lu(315) = lu(315) * lu(312) - lu(316) = lu(316) * lu(312) - lu(317) = lu(317) * lu(312) - lu(318) = lu(318) * lu(312) - lu(939) = lu(939) - lu(313) * lu(924) - lu(943) = lu(943) - lu(314) * lu(924) - lu(947) = lu(947) - lu(315) * lu(924) - lu(948) = lu(948) - lu(316) * lu(924) - lu(953) = lu(953) - lu(317) * lu(924) - lu(956) = - lu(318) * lu(924) - lu(1106) = lu(1106) - lu(313) * lu(1075) - lu(1110) = lu(1110) - lu(314) * lu(1075) - lu(1114) = lu(1114) - lu(315) * lu(1075) - lu(1115) = lu(1115) - lu(316) * lu(1075) - lu(1120) = lu(1120) - lu(317) * lu(1075) - lu(1123) = lu(1123) - lu(318) * lu(1075) - lu(1141) = lu(1141) - lu(313) * lu(1130) - lu(1145) = - lu(314) * lu(1130) - lu(1149) = lu(1149) - lu(315) * lu(1130) - lu(1150) = lu(1150) - lu(316) * lu(1130) - lu(1155) = lu(1155) - lu(317) * lu(1130) - lu(1158) = lu(1158) - lu(318) * lu(1130) - lu(1375) = lu(1375) - lu(313) * lu(1337) - lu(1379) = lu(1379) - lu(314) * lu(1337) - lu(1383) = lu(1383) - lu(315) * lu(1337) - lu(1384) = lu(1384) - lu(316) * lu(1337) - lu(1389) = lu(1389) - lu(317) * lu(1337) - lu(1392) = lu(1392) - lu(318) * lu(1337) - lu(319) = 1._r8 / lu(319) - lu(320) = lu(320) * lu(319) - lu(321) = lu(321) * lu(319) - lu(322) = lu(322) * lu(319) - lu(502) = - lu(320) * lu(493) - lu(505) = lu(505) - lu(321) * lu(493) - lu(507) = - lu(322) * lu(493) - lu(592) = lu(592) - lu(320) * lu(585) - lu(598) = lu(598) - lu(321) * lu(585) - lu(600) = - lu(322) * lu(585) - lu(762) = lu(762) - lu(320) * lu(757) - lu(769) = lu(769) - lu(321) * lu(757) - lu(772) = lu(772) - lu(322) * lu(757) - lu(790) = lu(790) - lu(320) * lu(777) - lu(797) = lu(797) - lu(321) * lu(777) - lu(800) = lu(800) - lu(322) * lu(777) - lu(872) = lu(872) - lu(320) * lu(854) - lu(881) = lu(881) - lu(321) * lu(854) - lu(884) = lu(884) - lu(322) * lu(854) - lu(1012) = lu(1012) - lu(320) * lu(989) - lu(1024) = lu(1024) - lu(321) * lu(989) - lu(1027) = lu(1027) - lu(322) * lu(989) - lu(1108) = lu(1108) - lu(320) * lu(1076) - lu(1120) = lu(1120) - lu(321) * lu(1076) - lu(1123) = lu(1123) - lu(322) * lu(1076) - lu(1377) = lu(1377) - lu(320) * lu(1338) - lu(1389) = lu(1389) - lu(321) * lu(1338) - lu(1392) = lu(1392) - lu(322) * lu(1338) - lu(324) = 1._r8 / lu(324) - lu(325) = lu(325) * lu(324) - lu(326) = lu(326) * lu(324) - lu(327) = lu(327) * lu(324) - lu(328) = lu(328) * lu(324) - lu(329) = lu(329) * lu(324) - lu(330) = lu(330) * lu(324) - lu(331) = lu(331) * lu(324) - lu(332) = lu(332) * lu(324) - lu(333) = lu(333) * lu(324) - lu(357) = lu(357) - lu(325) * lu(356) - lu(358) = lu(358) - lu(326) * lu(356) - lu(359) = lu(359) - lu(327) * lu(356) - lu(360) = lu(360) - lu(328) * lu(356) - lu(361) = lu(361) - lu(329) * lu(356) - lu(363) = lu(363) - lu(330) * lu(356) - lu(364) = lu(364) - lu(331) * lu(356) - lu(367) = lu(367) - lu(332) * lu(356) - lu(368) = lu(368) - lu(333) * lu(356) - lu(1078) = lu(1078) - lu(325) * lu(1077) - lu(1079) = lu(1079) - lu(326) * lu(1077) - lu(1080) = lu(1080) - lu(327) * lu(1077) - lu(1086) = lu(1086) - lu(328) * lu(1077) - lu(1094) = lu(1094) - lu(329) * lu(1077) - lu(1105) = lu(1105) - lu(330) * lu(1077) - lu(1114) = lu(1114) - lu(331) * lu(1077) - lu(1120) = lu(1120) - lu(332) * lu(1077) - lu(1124) = lu(1124) - lu(333) * lu(1077) - lu(1340) = lu(1340) - lu(325) * lu(1339) - lu(1341) = lu(1341) - lu(326) * lu(1339) - lu(1342) = lu(1342) - lu(327) * lu(1339) - lu(1349) = lu(1349) - lu(328) * lu(1339) - lu(1362) = lu(1362) - lu(329) * lu(1339) - lu(1373) = lu(1373) - lu(330) * lu(1339) - lu(1383) = lu(1383) - lu(331) * lu(1339) - lu(1389) = lu(1389) - lu(332) * lu(1339) - lu(1393) = lu(1393) - lu(333) * lu(1339) - END SUBROUTINE lu_fac08 - - SUBROUTINE lu_fac09(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(335) = 1._r8 / lu(335) - lu(336) = lu(336) * lu(335) - lu(337) = lu(337) * lu(335) - lu(338) = lu(338) * lu(335) - lu(339) = lu(339) * lu(335) - lu(340) = lu(340) * lu(335) - lu(341) = lu(341) * lu(335) - lu(361) = lu(361) - lu(336) * lu(357) - lu(363) = lu(363) - lu(337) * lu(357) - lu(364) = lu(364) - lu(338) * lu(357) - lu(365) = lu(365) - lu(339) * lu(357) - lu(366) = lu(366) - lu(340) * lu(357) - lu(367) = lu(367) - lu(341) * lu(357) - lu(1094) = lu(1094) - lu(336) * lu(1078) - lu(1105) = lu(1105) - lu(337) * lu(1078) - lu(1114) = lu(1114) - lu(338) * lu(1078) - lu(1118) = lu(1118) - lu(339) * lu(1078) - lu(1119) = lu(1119) - lu(340) * lu(1078) - lu(1120) = lu(1120) - lu(341) * lu(1078) - lu(1230) = lu(1230) - lu(336) * lu(1213) - lu(1240) = lu(1240) - lu(337) * lu(1213) - lu(1248) = lu(1248) - lu(338) * lu(1213) - lu(1252) = lu(1252) - lu(339) * lu(1213) - lu(1253) = lu(1253) - lu(340) * lu(1213) - lu(1254) = lu(1254) - lu(341) * lu(1213) - lu(1362) = lu(1362) - lu(336) * lu(1340) - lu(1373) = lu(1373) - lu(337) * lu(1340) - lu(1383) = lu(1383) - lu(338) * lu(1340) - lu(1387) = lu(1387) - lu(339) * lu(1340) - lu(1388) = lu(1388) - lu(340) * lu(1340) - lu(1389) = lu(1389) - lu(341) * lu(1340) - lu(344) = 1._r8 / lu(344) - lu(345) = lu(345) * lu(344) - lu(346) = lu(346) * lu(344) - lu(347) = lu(347) * lu(344) - lu(348) = lu(348) * lu(344) - lu(349) = lu(349) * lu(344) - lu(350) = lu(350) * lu(344) - lu(351) = lu(351) * lu(344) - lu(352) = lu(352) * lu(344) - lu(353) = lu(353) * lu(344) - lu(423) = lu(423) - lu(345) * lu(422) - lu(424) = lu(424) - lu(346) * lu(422) - lu(425) = lu(425) - lu(347) * lu(422) - lu(426) = lu(426) - lu(348) * lu(422) - lu(427) = - lu(349) * lu(422) - lu(428) = lu(428) - lu(350) * lu(422) - lu(429) = lu(429) - lu(351) * lu(422) - lu(430) = lu(430) - lu(352) * lu(422) - lu(431) = lu(431) - lu(353) * lu(422) - lu(894) = lu(894) - lu(345) * lu(892) - lu(895) = lu(895) - lu(346) * lu(892) - lu(896) = lu(896) - lu(347) * lu(892) - lu(897) = lu(897) - lu(348) * lu(892) - lu(900) = lu(900) - lu(349) * lu(892) - lu(903) = lu(903) - lu(350) * lu(892) - lu(904) = lu(904) - lu(351) * lu(892) - lu(905) = lu(905) - lu(352) * lu(892) - lu(912) = lu(912) - lu(353) * lu(892) - lu(928) = lu(928) - lu(345) * lu(925) - lu(929) = lu(929) - lu(346) * lu(925) - lu(930) = lu(930) - lu(347) * lu(925) - lu(932) = lu(932) - lu(348) * lu(925) - lu(936) = lu(936) - lu(349) * lu(925) - lu(942) = lu(942) - lu(350) * lu(925) - lu(943) = lu(943) - lu(351) * lu(925) - lu(944) = lu(944) - lu(352) * lu(925) - lu(951) = lu(951) - lu(353) * lu(925) - lu(358) = 1._r8 / lu(358) - lu(359) = lu(359) * lu(358) - lu(360) = lu(360) * lu(358) - lu(361) = lu(361) * lu(358) - lu(362) = lu(362) * lu(358) - lu(363) = lu(363) * lu(358) - lu(364) = lu(364) * lu(358) - lu(365) = lu(365) * lu(358) - lu(366) = lu(366) * lu(358) - lu(367) = lu(367) * lu(358) - lu(368) = lu(368) * lu(358) - lu(1080) = lu(1080) - lu(359) * lu(1079) - lu(1086) = lu(1086) - lu(360) * lu(1079) - lu(1094) = lu(1094) - lu(361) * lu(1079) - lu(1099) = lu(1099) - lu(362) * lu(1079) - lu(1105) = lu(1105) - lu(363) * lu(1079) - lu(1114) = lu(1114) - lu(364) * lu(1079) - lu(1118) = lu(1118) - lu(365) * lu(1079) - lu(1119) = lu(1119) - lu(366) * lu(1079) - lu(1120) = lu(1120) - lu(367) * lu(1079) - lu(1124) = lu(1124) - lu(368) * lu(1079) - lu(1215) = lu(1215) - lu(359) * lu(1214) - lu(1222) = lu(1222) - lu(360) * lu(1214) - lu(1230) = lu(1230) - lu(361) * lu(1214) - lu(1234) = lu(1234) - lu(362) * lu(1214) - lu(1240) = lu(1240) - lu(363) * lu(1214) - lu(1248) = lu(1248) - lu(364) * lu(1214) - lu(1252) = lu(1252) - lu(365) * lu(1214) - lu(1253) = lu(1253) - lu(366) * lu(1214) - lu(1254) = lu(1254) - lu(367) * lu(1214) - lu(1258) = lu(1258) - lu(368) * lu(1214) - lu(1342) = lu(1342) - lu(359) * lu(1341) - lu(1349) = lu(1349) - lu(360) * lu(1341) - lu(1362) = lu(1362) - lu(361) * lu(1341) - lu(1367) = lu(1367) - lu(362) * lu(1341) - lu(1373) = lu(1373) - lu(363) * lu(1341) - lu(1383) = lu(1383) - lu(364) * lu(1341) - lu(1387) = lu(1387) - lu(365) * lu(1341) - lu(1388) = lu(1388) - lu(366) * lu(1341) - lu(1389) = lu(1389) - lu(367) * lu(1341) - lu(1393) = lu(1393) - lu(368) * lu(1341) - lu(369) = 1._r8 / lu(369) - lu(370) = lu(370) * lu(369) - lu(371) = lu(371) * lu(369) - lu(372) = lu(372) * lu(369) - lu(373) = lu(373) * lu(369) - lu(374) = lu(374) * lu(369) - lu(519) = - lu(370) * lu(516) - lu(520) = - lu(371) * lu(516) - lu(521) = lu(521) - lu(372) * lu(516) - lu(526) = lu(526) - lu(373) * lu(516) - lu(527) = lu(527) - lu(374) * lu(516) - lu(541) = - lu(370) * lu(539) - lu(544) = - lu(371) * lu(539) - lu(545) = - lu(372) * lu(539) - lu(549) = lu(549) - lu(373) * lu(539) - lu(550) = - lu(374) * lu(539) - lu(863) = lu(863) - lu(370) * lu(855) - lu(871) = lu(871) - lu(371) * lu(855) - lu(872) = lu(872) - lu(372) * lu(855) - lu(881) = lu(881) - lu(373) * lu(855) - lu(884) = lu(884) - lu(374) * lu(855) - lu(1096) = lu(1096) - lu(370) * lu(1080) - lu(1105) = lu(1105) - lu(371) * lu(1080) - lu(1108) = lu(1108) - lu(372) * lu(1080) - lu(1120) = lu(1120) - lu(373) * lu(1080) - lu(1123) = lu(1123) - lu(374) * lu(1080) - lu(1232) = lu(1232) - lu(370) * lu(1215) - lu(1240) = lu(1240) - lu(371) * lu(1215) - lu(1242) = lu(1242) - lu(372) * lu(1215) - lu(1254) = lu(1254) - lu(373) * lu(1215) - lu(1257) = lu(1257) - lu(374) * lu(1215) - lu(1364) = lu(1364) - lu(370) * lu(1342) - lu(1373) = lu(1373) - lu(371) * lu(1342) - lu(1377) = lu(1377) - lu(372) * lu(1342) - lu(1389) = lu(1389) - lu(373) * lu(1342) - lu(1392) = lu(1392) - lu(374) * lu(1342) - lu(375) = 1._r8 / lu(375) - lu(376) = lu(376) * lu(375) - lu(377) = lu(377) * lu(375) - lu(378) = lu(378) * lu(375) - lu(511) = lu(511) - lu(376) * lu(509) - lu(512) = lu(512) - lu(377) * lu(509) - lu(513) = lu(513) - lu(378) * lu(509) - lu(674) = lu(674) - lu(376) * lu(672) - lu(680) = lu(680) - lu(377) * lu(672) - lu(684) = lu(684) - lu(378) * lu(672) - lu(780) = lu(780) - lu(376) * lu(778) - lu(793) = lu(793) - lu(377) * lu(778) - lu(797) = lu(797) - lu(378) * lu(778) - lu(860) = lu(860) - lu(376) * lu(856) - lu(876) = lu(876) - lu(377) * lu(856) - lu(881) = lu(881) - lu(378) * lu(856) - lu(1093) = lu(1093) - lu(376) * lu(1081) - lu(1114) = lu(1114) - lu(377) * lu(1081) - lu(1120) = lu(1120) - lu(378) * lu(1081) - lu(1137) = lu(1137) - lu(376) * lu(1131) - lu(1149) = lu(1149) - lu(377) * lu(1131) - lu(1155) = lu(1155) - lu(378) * lu(1131) - lu(1229) = lu(1229) - lu(376) * lu(1216) - lu(1248) = lu(1248) - lu(377) * lu(1216) - lu(1254) = lu(1254) - lu(378) * lu(1216) - lu(1271) = lu(1271) - lu(376) * lu(1266) - lu(1285) = lu(1285) - lu(377) * lu(1266) - lu(1291) = lu(1291) - lu(378) * lu(1266) - lu(1361) = lu(1361) - lu(376) * lu(1343) - lu(1383) = lu(1383) - lu(377) * lu(1343) - lu(1389) = lu(1389) - lu(378) * lu(1343) - lu(1407) = lu(1407) - lu(376) * lu(1399) - lu(1427) = lu(1427) - lu(377) * lu(1399) - lu(1433) = lu(1433) - lu(378) * lu(1399) - lu(379) = 1._r8 / lu(379) - lu(380) = lu(380) * lu(379) - lu(381) = lu(381) * lu(379) - lu(382) = lu(382) * lu(379) - lu(383) = lu(383) * lu(379) - lu(384) = lu(384) * lu(379) - lu(385) = lu(385) * lu(379) - lu(805) = lu(805) - lu(380) * lu(803) - lu(807) = lu(807) - lu(381) * lu(803) - lu(808) = lu(808) - lu(382) * lu(803) - lu(809) = lu(809) - lu(383) * lu(803) - lu(813) = lu(813) - lu(384) * lu(803) - lu(817) = lu(817) - lu(385) * lu(803) - lu(901) = lu(901) - lu(380) * lu(893) - lu(903) = lu(903) - lu(381) * lu(893) - lu(904) = lu(904) - lu(382) * lu(893) - lu(906) = lu(906) - lu(383) * lu(893) - lu(910) = lu(910) - lu(384) * lu(893) - lu(914) = - lu(385) * lu(893) - lu(938) = lu(938) - lu(380) * lu(926) - lu(942) = lu(942) - lu(381) * lu(926) - lu(943) = lu(943) - lu(382) * lu(926) - lu(945) = lu(945) - lu(383) * lu(926) - lu(949) = lu(949) - lu(384) * lu(926) - lu(953) = lu(953) - lu(385) * lu(926) - lu(1010) = lu(1010) - lu(380) * lu(990) - lu(1013) = lu(1013) - lu(381) * lu(990) - lu(1014) = lu(1014) - lu(382) * lu(990) - lu(1016) = lu(1016) - lu(383) * lu(990) - lu(1020) = lu(1020) - lu(384) * lu(990) - lu(1024) = lu(1024) - lu(385) * lu(990) - lu(1374) = lu(1374) - lu(380) * lu(1344) - lu(1378) = lu(1378) - lu(381) * lu(1344) - lu(1379) = lu(1379) - lu(382) * lu(1344) - lu(1381) = lu(1381) - lu(383) * lu(1344) - lu(1385) = lu(1385) - lu(384) * lu(1344) - lu(1389) = lu(1389) - lu(385) * lu(1344) - END SUBROUTINE lu_fac09 - - SUBROUTINE lu_fac10(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(388) = 1._r8 / lu(388) - lu(389) = lu(389) * lu(388) - lu(390) = lu(390) * lu(388) - lu(391) = lu(391) * lu(388) - lu(392) = lu(392) * lu(388) - lu(393) = lu(393) * lu(388) - lu(394) = lu(394) * lu(388) - lu(395) = lu(395) * lu(388) - lu(993) = - lu(389) * lu(991) - lu(1013) = lu(1013) - lu(390) * lu(991) - lu(1018) = lu(1018) - lu(391) * lu(991) - lu(1022) = lu(1022) - lu(392) * lu(991) - lu(1023) = lu(1023) - lu(393) * lu(991) - lu(1024) = lu(1024) - lu(394) * lu(991) - lu(1028) = lu(1028) - lu(395) * lu(991) - lu(1088) = lu(1088) - lu(389) * lu(1082) - lu(1109) = lu(1109) - lu(390) * lu(1082) - lu(1114) = lu(1114) - lu(391) * lu(1082) - lu(1118) = lu(1118) - lu(392) * lu(1082) - lu(1119) = lu(1119) - lu(393) * lu(1082) - lu(1120) = lu(1120) - lu(394) * lu(1082) - lu(1124) = lu(1124) - lu(395) * lu(1082) - lu(1135) = - lu(389) * lu(1132) - lu(1144) = lu(1144) - lu(390) * lu(1132) - lu(1149) = lu(1149) - lu(391) * lu(1132) - lu(1153) = - lu(392) * lu(1132) - lu(1154) = - lu(393) * lu(1132) - lu(1155) = lu(1155) - lu(394) * lu(1132) - lu(1159) = lu(1159) - lu(395) * lu(1132) - lu(1224) = lu(1224) - lu(389) * lu(1217) - lu(1243) = lu(1243) - lu(390) * lu(1217) - lu(1248) = lu(1248) - lu(391) * lu(1217) - lu(1252) = lu(1252) - lu(392) * lu(1217) - lu(1253) = lu(1253) - lu(393) * lu(1217) - lu(1254) = lu(1254) - lu(394) * lu(1217) - lu(1258) = lu(1258) - lu(395) * lu(1217) - lu(1353) = lu(1353) - lu(389) * lu(1345) - lu(1378) = lu(1378) - lu(390) * lu(1345) - lu(1383) = lu(1383) - lu(391) * lu(1345) - lu(1387) = lu(1387) - lu(392) * lu(1345) - lu(1388) = lu(1388) - lu(393) * lu(1345) - lu(1389) = lu(1389) - lu(394) * lu(1345) - lu(1393) = lu(1393) - lu(395) * lu(1345) - lu(397) = 1._r8 / lu(397) - lu(398) = lu(398) * lu(397) - lu(399) = lu(399) * lu(397) - lu(400) = lu(400) * lu(397) - lu(401) = lu(401) * lu(397) - lu(402) = lu(402) * lu(397) - lu(403) = lu(403) * lu(397) - lu(404) = lu(404) * lu(397) - lu(824) = lu(824) - lu(398) * lu(821) - lu(825) = lu(825) - lu(399) * lu(821) - lu(826) = lu(826) - lu(400) * lu(821) - lu(829) = lu(829) - lu(401) * lu(821) - lu(831) = - lu(402) * lu(821) - lu(833) = lu(833) - lu(403) * lu(821) - lu(836) = lu(836) - lu(404) * lu(821) - lu(939) = lu(939) - lu(398) * lu(927) - lu(940) = lu(940) - lu(399) * lu(927) - lu(943) = lu(943) - lu(400) * lu(927) - lu(948) = lu(948) - lu(401) * lu(927) - lu(950) = lu(950) - lu(402) * lu(927) - lu(953) = lu(953) - lu(403) * lu(927) - lu(956) = lu(956) - lu(404) * lu(927) - lu(1106) = lu(1106) - lu(398) * lu(1083) - lu(1107) = lu(1107) - lu(399) * lu(1083) - lu(1110) = lu(1110) - lu(400) * lu(1083) - lu(1115) = lu(1115) - lu(401) * lu(1083) - lu(1117) = lu(1117) - lu(402) * lu(1083) - lu(1120) = lu(1120) - lu(403) * lu(1083) - lu(1123) = lu(1123) - lu(404) * lu(1083) - lu(1186) = - lu(398) * lu(1183) - lu(1187) = lu(1187) - lu(399) * lu(1183) - lu(1189) = lu(1189) - lu(400) * lu(1183) - lu(1194) = lu(1194) - lu(401) * lu(1183) - lu(1196) = lu(1196) - lu(402) * lu(1183) - lu(1199) = lu(1199) - lu(403) * lu(1183) - lu(1202) = - lu(404) * lu(1183) - lu(1277) = - lu(398) * lu(1267) - lu(1278) = lu(1278) - lu(399) * lu(1267) - lu(1281) = lu(1281) - lu(400) * lu(1267) - lu(1286) = - lu(401) * lu(1267) - lu(1288) = lu(1288) - lu(402) * lu(1267) - lu(1291) = lu(1291) - lu(403) * lu(1267) - lu(1294) = lu(1294) - lu(404) * lu(1267) - lu(405) = 1._r8 / lu(405) - lu(406) = lu(406) * lu(405) - lu(407) = lu(407) * lu(405) - lu(408) = lu(408) * lu(405) - lu(409) = lu(409) * lu(405) - lu(410) = lu(410) * lu(405) - lu(411) = lu(411) * lu(405) - lu(412) = lu(412) * lu(405) - lu(424) = lu(424) - lu(406) * lu(423) - lu(425) = lu(425) - lu(407) * lu(423) - lu(426) = lu(426) - lu(408) * lu(423) - lu(428) = lu(428) - lu(409) * lu(423) - lu(429) = lu(429) - lu(410) * lu(423) - lu(430) = lu(430) - lu(411) * lu(423) - lu(431) = lu(431) - lu(412) * lu(423) - lu(474) = lu(474) - lu(406) * lu(473) - lu(475) = lu(475) - lu(407) * lu(473) - lu(476) = lu(476) - lu(408) * lu(473) - lu(478) = lu(478) - lu(409) * lu(473) - lu(479) = lu(479) - lu(410) * lu(473) - lu(480) = - lu(411) * lu(473) - lu(482) = lu(482) - lu(412) * lu(473) - lu(895) = lu(895) - lu(406) * lu(894) - lu(896) = lu(896) - lu(407) * lu(894) - lu(897) = lu(897) - lu(408) * lu(894) - lu(903) = lu(903) - lu(409) * lu(894) - lu(904) = lu(904) - lu(410) * lu(894) - lu(905) = lu(905) - lu(411) * lu(894) - lu(912) = lu(912) - lu(412) * lu(894) - lu(929) = lu(929) - lu(406) * lu(928) - lu(930) = lu(930) - lu(407) * lu(928) - lu(932) = lu(932) - lu(408) * lu(928) - lu(942) = lu(942) - lu(409) * lu(928) - lu(943) = lu(943) - lu(410) * lu(928) - lu(944) = lu(944) - lu(411) * lu(928) - lu(951) = lu(951) - lu(412) * lu(928) - lu(1219) = lu(1219) - lu(406) * lu(1218) - lu(1220) = lu(1220) - lu(407) * lu(1218) - lu(1223) = lu(1223) - lu(408) * lu(1218) - lu(1243) = lu(1243) - lu(409) * lu(1218) - lu(1244) = lu(1244) - lu(410) * lu(1218) - lu(1245) = - lu(411) * lu(1218) - lu(1252) = lu(1252) - lu(412) * lu(1218) - lu(414) = 1._r8 / lu(414) - lu(415) = lu(415) * lu(414) - lu(416) = lu(416) * lu(414) - lu(417) = lu(417) * lu(414) - lu(418) = lu(418) * lu(414) - lu(419) = lu(419) * lu(414) - lu(420) = lu(420) * lu(414) - lu(425) = lu(425) - lu(415) * lu(424) - lu(426) = lu(426) - lu(416) * lu(424) - lu(428) = lu(428) - lu(417) * lu(424) - lu(429) = lu(429) - lu(418) * lu(424) - lu(430) = lu(430) - lu(419) * lu(424) - lu(431) = lu(431) - lu(420) * lu(424) - lu(475) = lu(475) - lu(415) * lu(474) - lu(476) = lu(476) - lu(416) * lu(474) - lu(478) = lu(478) - lu(417) * lu(474) - lu(479) = lu(479) - lu(418) * lu(474) - lu(480) = lu(480) - lu(419) * lu(474) - lu(482) = lu(482) - lu(420) * lu(474) - lu(896) = lu(896) - lu(415) * lu(895) - lu(897) = lu(897) - lu(416) * lu(895) - lu(903) = lu(903) - lu(417) * lu(895) - lu(904) = lu(904) - lu(418) * lu(895) - lu(905) = lu(905) - lu(419) * lu(895) - lu(912) = lu(912) - lu(420) * lu(895) - lu(930) = lu(930) - lu(415) * lu(929) - lu(932) = lu(932) - lu(416) * lu(929) - lu(942) = lu(942) - lu(417) * lu(929) - lu(943) = lu(943) - lu(418) * lu(929) - lu(944) = lu(944) - lu(419) * lu(929) - lu(951) = lu(951) - lu(420) * lu(929) - lu(1220) = lu(1220) - lu(415) * lu(1219) - lu(1223) = lu(1223) - lu(416) * lu(1219) - lu(1243) = lu(1243) - lu(417) * lu(1219) - lu(1244) = lu(1244) - lu(418) * lu(1219) - lu(1245) = lu(1245) - lu(419) * lu(1219) - lu(1252) = lu(1252) - lu(420) * lu(1219) - lu(425) = 1._r8 / lu(425) - lu(426) = lu(426) * lu(425) - lu(427) = lu(427) * lu(425) - lu(428) = lu(428) * lu(425) - lu(429) = lu(429) * lu(425) - lu(430) = lu(430) * lu(425) - lu(431) = lu(431) * lu(425) - lu(476) = lu(476) - lu(426) * lu(475) - lu(477) = lu(477) - lu(427) * lu(475) - lu(478) = lu(478) - lu(428) * lu(475) - lu(479) = lu(479) - lu(429) * lu(475) - lu(480) = lu(480) - lu(430) * lu(475) - lu(482) = lu(482) - lu(431) * lu(475) - lu(897) = lu(897) - lu(426) * lu(896) - lu(900) = lu(900) - lu(427) * lu(896) - lu(903) = lu(903) - lu(428) * lu(896) - lu(904) = lu(904) - lu(429) * lu(896) - lu(905) = lu(905) - lu(430) * lu(896) - lu(912) = lu(912) - lu(431) * lu(896) - lu(932) = lu(932) - lu(426) * lu(930) - lu(936) = lu(936) - lu(427) * lu(930) - lu(942) = lu(942) - lu(428) * lu(930) - lu(943) = lu(943) - lu(429) * lu(930) - lu(944) = lu(944) - lu(430) * lu(930) - lu(951) = lu(951) - lu(431) * lu(930) - lu(1223) = lu(1223) - lu(426) * lu(1220) - lu(1229) = lu(1229) - lu(427) * lu(1220) - lu(1243) = lu(1243) - lu(428) * lu(1220) - lu(1244) = lu(1244) - lu(429) * lu(1220) - lu(1245) = lu(1245) - lu(430) * lu(1220) - lu(1252) = lu(1252) - lu(431) * lu(1220) - lu(433) = 1._r8 / lu(433) - lu(434) = lu(434) * lu(433) - lu(435) = lu(435) * lu(433) - lu(436) = lu(436) * lu(433) - lu(437) = lu(437) * lu(433) - lu(438) = lu(438) * lu(433) - lu(439) = lu(439) * lu(433) - lu(440) = lu(440) * lu(433) - lu(650) = lu(650) - lu(434) * lu(649) - lu(652) = - lu(435) * lu(649) - lu(656) = lu(656) - lu(436) * lu(649) - lu(657) = lu(657) - lu(437) * lu(649) - lu(658) = - lu(438) * lu(649) - lu(659) = - lu(439) * lu(649) - lu(660) = lu(660) - lu(440) * lu(649) - lu(964) = lu(964) - lu(434) * lu(962) - lu(967) = lu(967) - lu(435) * lu(962) - lu(975) = lu(975) - lu(436) * lu(962) - lu(979) = lu(979) - lu(437) * lu(962) - lu(980) = - lu(438) * lu(962) - lu(981) = - lu(439) * lu(962) - lu(982) = lu(982) - lu(440) * lu(962) - lu(1366) = lu(1366) - lu(434) * lu(1346) - lu(1377) = lu(1377) - lu(435) * lu(1346) - lu(1385) = lu(1385) - lu(436) * lu(1346) - lu(1389) = lu(1389) - lu(437) * lu(1346) - lu(1390) = lu(1390) - lu(438) * lu(1346) - lu(1391) = lu(1391) - lu(439) * lu(1346) - lu(1392) = lu(1392) - lu(440) * lu(1346) - lu(1440) = - lu(434) * lu(1439) - lu(1443) = - lu(435) * lu(1439) - lu(1451) = lu(1451) - lu(436) * lu(1439) - lu(1455) = lu(1455) - lu(437) * lu(1439) - lu(1456) = lu(1456) - lu(438) * lu(1439) - lu(1457) = lu(1457) - lu(439) * lu(1439) - lu(1458) = lu(1458) - lu(440) * lu(1439) - lu(1465) = lu(1465) - lu(434) * lu(1463) - lu(1469) = - lu(435) * lu(1463) - lu(1477) = lu(1477) - lu(436) * lu(1463) - lu(1481) = lu(1481) - lu(437) * lu(1463) - lu(1482) = - lu(438) * lu(1463) - lu(1483) = - lu(439) * lu(1463) - lu(1484) = lu(1484) - lu(440) * lu(1463) - END SUBROUTINE lu_fac10 - - SUBROUTINE lu_fac11(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(442) = 1._r8 / lu(442) - lu(443) = lu(443) * lu(442) - lu(444) = lu(444) * lu(442) - lu(445) = lu(445) * lu(442) - lu(446) = lu(446) * lu(442) - lu(447) = lu(447) * lu(442) - lu(448) = lu(448) * lu(442) - lu(449) = lu(449) * lu(442) - lu(450) = lu(450) * lu(442) - lu(451) = lu(451) * lu(442) - lu(589) = lu(589) - lu(443) * lu(586) - lu(590) = - lu(444) * lu(586) - lu(593) = - lu(445) * lu(586) - lu(595) = lu(595) - lu(446) * lu(586) - lu(596) = - lu(447) * lu(586) - lu(597) = lu(597) - lu(448) * lu(586) - lu(598) = lu(598) - lu(449) * lu(586) - lu(600) = lu(600) - lu(450) * lu(586) - lu(601) = lu(601) - lu(451) * lu(586) - lu(1094) = lu(1094) - lu(443) * lu(1084) - lu(1095) = lu(1095) - lu(444) * lu(1084) - lu(1109) = lu(1109) - lu(445) * lu(1084) - lu(1114) = lu(1114) - lu(446) * lu(1084) - lu(1118) = lu(1118) - lu(447) * lu(1084) - lu(1119) = lu(1119) - lu(448) * lu(1084) - lu(1120) = lu(1120) - lu(449) * lu(1084) - lu(1123) = lu(1123) - lu(450) * lu(1084) - lu(1124) = lu(1124) - lu(451) * lu(1084) - lu(1230) = lu(1230) - lu(443) * lu(1221) - lu(1231) = lu(1231) - lu(444) * lu(1221) - lu(1243) = lu(1243) - lu(445) * lu(1221) - lu(1248) = lu(1248) - lu(446) * lu(1221) - lu(1252) = lu(1252) - lu(447) * lu(1221) - lu(1253) = lu(1253) - lu(448) * lu(1221) - lu(1254) = lu(1254) - lu(449) * lu(1221) - lu(1257) = lu(1257) - lu(450) * lu(1221) - lu(1258) = lu(1258) - lu(451) * lu(1221) - lu(1362) = lu(1362) - lu(443) * lu(1347) - lu(1363) = lu(1363) - lu(444) * lu(1347) - lu(1378) = lu(1378) - lu(445) * lu(1347) - lu(1383) = lu(1383) - lu(446) * lu(1347) - lu(1387) = lu(1387) - lu(447) * lu(1347) - lu(1388) = lu(1388) - lu(448) * lu(1347) - lu(1389) = lu(1389) - lu(449) * lu(1347) - lu(1392) = lu(1392) - lu(450) * lu(1347) - lu(1393) = lu(1393) - lu(451) * lu(1347) - lu(452) = 1._r8 / lu(452) - lu(453) = lu(453) * lu(452) - lu(454) = lu(454) * lu(452) - lu(455) = lu(455) * lu(452) - lu(456) = lu(456) * lu(452) - lu(457) = lu(457) * lu(452) - lu(458) = lu(458) * lu(452) - lu(839) = lu(839) - lu(453) * lu(837) - lu(841) = - lu(454) * lu(837) - lu(842) = - lu(455) * lu(837) - lu(845) = - lu(456) * lu(837) - lu(847) = - lu(457) * lu(837) - lu(848) = - lu(458) * lu(837) - lu(940) = lu(940) - lu(453) * lu(931) - lu(943) = lu(943) - lu(454) * lu(931) - lu(944) = lu(944) - lu(455) * lu(931) - lu(949) = lu(949) - lu(456) * lu(931) - lu(953) = lu(953) - lu(457) * lu(931) - lu(956) = lu(956) - lu(458) * lu(931) - lu(966) = lu(966) - lu(453) * lu(963) - lu(969) = lu(969) - lu(454) * lu(963) - lu(970) = lu(970) - lu(455) * lu(963) - lu(975) = lu(975) - lu(456) * lu(963) - lu(979) = lu(979) - lu(457) * lu(963) - lu(982) = lu(982) - lu(458) * lu(963) - lu(1107) = lu(1107) - lu(453) * lu(1085) - lu(1110) = lu(1110) - lu(454) * lu(1085) - lu(1111) = - lu(455) * lu(1085) - lu(1116) = lu(1116) - lu(456) * lu(1085) - lu(1120) = lu(1120) - lu(457) * lu(1085) - lu(1123) = lu(1123) - lu(458) * lu(1085) - lu(1376) = lu(1376) - lu(453) * lu(1348) - lu(1379) = lu(1379) - lu(454) * lu(1348) - lu(1380) = lu(1380) - lu(455) * lu(1348) - lu(1385) = lu(1385) - lu(456) * lu(1348) - lu(1389) = lu(1389) - lu(457) * lu(1348) - lu(1392) = lu(1392) - lu(458) * lu(1348) - lu(1492) = lu(1492) - lu(453) * lu(1488) - lu(1495) = lu(1495) - lu(454) * lu(1488) - lu(1496) = - lu(455) * lu(1488) - lu(1501) = lu(1501) - lu(456) * lu(1488) - lu(1505) = lu(1505) - lu(457) * lu(1488) - lu(1508) = lu(1508) - lu(458) * lu(1488) - lu(462) = 1._r8 / lu(462) - lu(463) = lu(463) * lu(462) - lu(464) = lu(464) * lu(462) - lu(465) = lu(465) * lu(462) - lu(466) = lu(466) * lu(462) - lu(467) = lu(467) * lu(462) - lu(468) = lu(468) * lu(462) - lu(469) = lu(469) * lu(462) - lu(470) = lu(470) * lu(462) - lu(861) = lu(861) - lu(463) * lu(857) - lu(872) = lu(872) - lu(464) * lu(857) - lu(873) = lu(873) - lu(465) * lu(857) - lu(876) = lu(876) - lu(466) * lu(857) - lu(879) = lu(879) - lu(467) * lu(857) - lu(880) = lu(880) - lu(468) * lu(857) - lu(881) = lu(881) - lu(469) * lu(857) - lu(885) = lu(885) - lu(470) * lu(857) - lu(1094) = lu(1094) - lu(463) * lu(1086) - lu(1108) = lu(1108) - lu(464) * lu(1086) - lu(1109) = lu(1109) - lu(465) * lu(1086) - lu(1114) = lu(1114) - lu(466) * lu(1086) - lu(1118) = lu(1118) - lu(467) * lu(1086) - lu(1119) = lu(1119) - lu(468) * lu(1086) - lu(1120) = lu(1120) - lu(469) * lu(1086) - lu(1124) = lu(1124) - lu(470) * lu(1086) - lu(1138) = - lu(463) * lu(1133) - lu(1143) = lu(1143) - lu(464) * lu(1133) - lu(1144) = lu(1144) - lu(465) * lu(1133) - lu(1149) = lu(1149) - lu(466) * lu(1133) - lu(1153) = lu(1153) - lu(467) * lu(1133) - lu(1154) = lu(1154) - lu(468) * lu(1133) - lu(1155) = lu(1155) - lu(469) * lu(1133) - lu(1159) = lu(1159) - lu(470) * lu(1133) - lu(1230) = lu(1230) - lu(463) * lu(1222) - lu(1242) = lu(1242) - lu(464) * lu(1222) - lu(1243) = lu(1243) - lu(465) * lu(1222) - lu(1248) = lu(1248) - lu(466) * lu(1222) - lu(1252) = lu(1252) - lu(467) * lu(1222) - lu(1253) = lu(1253) - lu(468) * lu(1222) - lu(1254) = lu(1254) - lu(469) * lu(1222) - lu(1258) = lu(1258) - lu(470) * lu(1222) - lu(1362) = lu(1362) - lu(463) * lu(1349) - lu(1377) = lu(1377) - lu(464) * lu(1349) - lu(1378) = lu(1378) - lu(465) * lu(1349) - lu(1383) = lu(1383) - lu(466) * lu(1349) - lu(1387) = lu(1387) - lu(467) * lu(1349) - lu(1388) = lu(1388) - lu(468) * lu(1349) - lu(1389) = lu(1389) - lu(469) * lu(1349) - lu(1393) = lu(1393) - lu(470) * lu(1349) - lu(476) = 1._r8 / lu(476) - lu(477) = lu(477) * lu(476) - lu(478) = lu(478) * lu(476) - lu(479) = lu(479) * lu(476) - lu(480) = lu(480) * lu(476) - lu(481) = lu(481) * lu(476) - lu(482) = lu(482) * lu(476) - lu(483) = lu(483) * lu(476) - lu(484) = lu(484) * lu(476) - lu(900) = lu(900) - lu(477) * lu(897) - lu(903) = lu(903) - lu(478) * lu(897) - lu(904) = lu(904) - lu(479) * lu(897) - lu(905) = lu(905) - lu(480) * lu(897) - lu(910) = lu(910) - lu(481) * lu(897) - lu(912) = lu(912) - lu(482) * lu(897) - lu(913) = - lu(483) * lu(897) - lu(914) = lu(914) - lu(484) * lu(897) - lu(936) = lu(936) - lu(477) * lu(932) - lu(942) = lu(942) - lu(478) * lu(932) - lu(943) = lu(943) - lu(479) * lu(932) - lu(944) = lu(944) - lu(480) * lu(932) - lu(949) = lu(949) - lu(481) * lu(932) - lu(951) = lu(951) - lu(482) * lu(932) - lu(952) = lu(952) - lu(483) * lu(932) - lu(953) = lu(953) - lu(484) * lu(932) - lu(1229) = lu(1229) - lu(477) * lu(1223) - lu(1243) = lu(1243) - lu(478) * lu(1223) - lu(1244) = lu(1244) - lu(479) * lu(1223) - lu(1245) = lu(1245) - lu(480) * lu(1223) - lu(1250) = - lu(481) * lu(1223) - lu(1252) = lu(1252) - lu(482) * lu(1223) - lu(1253) = lu(1253) - lu(483) * lu(1223) - lu(1254) = lu(1254) - lu(484) * lu(1223) - lu(1271) = lu(1271) - lu(477) * lu(1268) - lu(1280) = lu(1280) - lu(478) * lu(1268) - lu(1281) = lu(1281) - lu(479) * lu(1268) - lu(1282) = - lu(480) * lu(1268) - lu(1287) = - lu(481) * lu(1268) - lu(1289) = lu(1289) - lu(482) * lu(1268) - lu(1290) = lu(1290) - lu(483) * lu(1268) - lu(1291) = lu(1291) - lu(484) * lu(1268) - lu(1361) = lu(1361) - lu(477) * lu(1350) - lu(1378) = lu(1378) - lu(478) * lu(1350) - lu(1379) = lu(1379) - lu(479) * lu(1350) - lu(1380) = lu(1380) - lu(480) * lu(1350) - lu(1385) = lu(1385) - lu(481) * lu(1350) - lu(1387) = lu(1387) - lu(482) * lu(1350) - lu(1388) = lu(1388) - lu(483) * lu(1350) - lu(1389) = lu(1389) - lu(484) * lu(1350) - lu(486) = 1._r8 / lu(486) - lu(487) = lu(487) * lu(486) - lu(488) = lu(488) * lu(486) - lu(489) = lu(489) * lu(486) - lu(490) = lu(490) * lu(486) - lu(491) = lu(491) * lu(486) - lu(492) = lu(492) * lu(486) - lu(561) = lu(561) - lu(487) * lu(559) - lu(562) = lu(562) - lu(488) * lu(559) - lu(563) = lu(563) - lu(489) * lu(559) - lu(564) = lu(564) - lu(490) * lu(559) - lu(566) = lu(566) - lu(491) * lu(559) - lu(569) = - lu(492) * lu(559) - lu(824) = lu(824) - lu(487) * lu(822) - lu(826) = lu(826) - lu(488) * lu(822) - lu(828) = - lu(489) * lu(822) - lu(829) = lu(829) - lu(490) * lu(822) - lu(833) = lu(833) - lu(491) * lu(822) - lu(836) = lu(836) - lu(492) * lu(822) - lu(939) = lu(939) - lu(487) * lu(933) - lu(943) = lu(943) - lu(488) * lu(933) - lu(946) = lu(946) - lu(489) * lu(933) - lu(948) = lu(948) - lu(490) * lu(933) - lu(953) = lu(953) - lu(491) * lu(933) - lu(956) = lu(956) - lu(492) * lu(933) - lu(1037) = lu(1037) - lu(487) * lu(1033) - lu(1041) = lu(1041) - lu(488) * lu(1033) - lu(1044) = lu(1044) - lu(489) * lu(1033) - lu(1046) = lu(1046) - lu(490) * lu(1033) - lu(1051) = lu(1051) - lu(491) * lu(1033) - lu(1054) = - lu(492) * lu(1033) - lu(1106) = lu(1106) - lu(487) * lu(1087) - lu(1110) = lu(1110) - lu(488) * lu(1087) - lu(1113) = lu(1113) - lu(489) * lu(1087) - lu(1115) = lu(1115) - lu(490) * lu(1087) - lu(1120) = lu(1120) - lu(491) * lu(1087) - lu(1123) = lu(1123) - lu(492) * lu(1087) - lu(1141) = lu(1141) - lu(487) * lu(1134) - lu(1145) = lu(1145) - lu(488) * lu(1134) - lu(1148) = lu(1148) - lu(489) * lu(1134) - lu(1150) = lu(1150) - lu(490) * lu(1134) - lu(1155) = lu(1155) - lu(491) * lu(1134) - lu(1158) = lu(1158) - lu(492) * lu(1134) - lu(1375) = lu(1375) - lu(487) * lu(1351) - lu(1379) = lu(1379) - lu(488) * lu(1351) - lu(1382) = lu(1382) - lu(489) * lu(1351) - lu(1384) = lu(1384) - lu(490) * lu(1351) - lu(1389) = lu(1389) - lu(491) * lu(1351) - lu(1392) = lu(1392) - lu(492) * lu(1351) - END SUBROUTINE lu_fac11 - - SUBROUTINE lu_fac12(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(494) = 1._r8 / lu(494) - lu(495) = lu(495) * lu(494) - lu(496) = lu(496) * lu(494) - lu(497) = lu(497) * lu(494) - lu(498) = lu(498) * lu(494) - lu(499) = lu(499) * lu(494) - lu(500) = lu(500) * lu(494) - lu(501) = lu(501) * lu(494) - lu(502) = lu(502) * lu(494) - lu(503) = lu(503) * lu(494) - lu(504) = lu(504) * lu(494) - lu(505) = lu(505) * lu(494) - lu(506) = lu(506) * lu(494) - lu(507) = lu(507) * lu(494) - lu(508) = lu(508) * lu(494) - lu(996) = - lu(495) * lu(992) - lu(997) = lu(997) - lu(496) * lu(992) - lu(998) = lu(998) - lu(497) * lu(992) - lu(1002) = lu(1002) - lu(498) * lu(992) - lu(1005) = - lu(499) * lu(992) - lu(1007) = lu(1007) - lu(500) * lu(992) - lu(1008) = lu(1008) - lu(501) * lu(992) - lu(1012) = lu(1012) - lu(502) * lu(992) - lu(1016) = lu(1016) - lu(503) * lu(992) - lu(1018) = lu(1018) - lu(504) * lu(992) - lu(1024) = lu(1024) - lu(505) * lu(992) - lu(1025) = lu(1025) - lu(506) * lu(992) - lu(1027) = lu(1027) - lu(507) * lu(992) - lu(1028) = lu(1028) - lu(508) * lu(992) - lu(1359) = - lu(495) * lu(1352) - lu(1360) = lu(1360) - lu(496) * lu(1352) - lu(1361) = lu(1361) - lu(497) * lu(1352) - lu(1365) = lu(1365) - lu(498) * lu(1352) - lu(1369) = lu(1369) - lu(499) * lu(1352) - lu(1371) = lu(1371) - lu(500) * lu(1352) - lu(1372) = lu(1372) - lu(501) * lu(1352) - lu(1377) = lu(1377) - lu(502) * lu(1352) - lu(1381) = lu(1381) - lu(503) * lu(1352) - lu(1383) = lu(1383) - lu(504) * lu(1352) - lu(1389) = lu(1389) - lu(505) * lu(1352) - lu(1390) = lu(1390) - lu(506) * lu(1352) - lu(1392) = lu(1392) - lu(507) * lu(1352) - lu(1393) = lu(1393) - lu(508) * lu(1352) - lu(1405) = lu(1405) - lu(495) * lu(1400) - lu(1406) = lu(1406) - lu(496) * lu(1400) - lu(1407) = lu(1407) - lu(497) * lu(1400) - lu(1411) = lu(1411) - lu(498) * lu(1400) - lu(1414) = lu(1414) - lu(499) * lu(1400) - lu(1416) = lu(1416) - lu(500) * lu(1400) - lu(1417) = lu(1417) - lu(501) * lu(1400) - lu(1421) = - lu(502) * lu(1400) - lu(1425) = lu(1425) - lu(503) * lu(1400) - lu(1427) = lu(1427) - lu(504) * lu(1400) - lu(1433) = lu(1433) - lu(505) * lu(1400) - lu(1434) = lu(1434) - lu(506) * lu(1400) - lu(1436) = - lu(507) * lu(1400) - lu(1437) = lu(1437) - lu(508) * lu(1400) - lu(510) = 1._r8 / lu(510) - lu(511) = lu(511) * lu(510) - lu(512) = lu(512) * lu(510) - lu(513) = lu(513) * lu(510) - lu(514) = lu(514) * lu(510) - lu(674) = lu(674) - lu(511) * lu(673) - lu(680) = lu(680) - lu(512) * lu(673) - lu(684) = lu(684) - lu(513) * lu(673) - lu(688) = lu(688) - lu(514) * lu(673) - lu(717) = lu(717) - lu(511) * lu(715) - lu(725) = lu(725) - lu(512) * lu(715) - lu(729) = lu(729) - lu(513) * lu(715) - lu(733) = lu(733) - lu(514) * lu(715) - lu(780) = lu(780) - lu(511) * lu(779) - lu(793) = lu(793) - lu(512) * lu(779) - lu(797) = lu(797) - lu(513) * lu(779) - lu(801) = lu(801) - lu(514) * lu(779) - lu(860) = lu(860) - lu(511) * lu(858) - lu(876) = lu(876) - lu(512) * lu(858) - lu(881) = lu(881) - lu(513) * lu(858) - lu(885) = lu(885) - lu(514) * lu(858) - lu(900) = lu(900) - lu(511) * lu(898) - lu(908) = lu(908) - lu(512) * lu(898) - lu(914) = lu(914) - lu(513) * lu(898) - lu(916) = lu(916) - lu(514) * lu(898) - lu(998) = lu(998) - lu(511) * lu(993) - lu(1018) = lu(1018) - lu(512) * lu(993) - lu(1024) = lu(1024) - lu(513) * lu(993) - lu(1028) = lu(1028) - lu(514) * lu(993) - lu(1093) = lu(1093) - lu(511) * lu(1088) - lu(1114) = lu(1114) - lu(512) * lu(1088) - lu(1120) = lu(1120) - lu(513) * lu(1088) - lu(1124) = lu(1124) - lu(514) * lu(1088) - lu(1137) = lu(1137) - lu(511) * lu(1135) - lu(1149) = lu(1149) - lu(512) * lu(1135) - lu(1155) = lu(1155) - lu(513) * lu(1135) - lu(1159) = lu(1159) - lu(514) * lu(1135) - lu(1229) = lu(1229) - lu(511) * lu(1224) - lu(1248) = lu(1248) - lu(512) * lu(1224) - lu(1254) = lu(1254) - lu(513) * lu(1224) - lu(1258) = lu(1258) - lu(514) * lu(1224) - lu(1361) = lu(1361) - lu(511) * lu(1353) - lu(1383) = lu(1383) - lu(512) * lu(1353) - lu(1389) = lu(1389) - lu(513) * lu(1353) - lu(1393) = lu(1393) - lu(514) * lu(1353) - lu(1407) = lu(1407) - lu(511) * lu(1401) - lu(1427) = lu(1427) - lu(512) * lu(1401) - lu(1433) = lu(1433) - lu(513) * lu(1401) - lu(1437) = lu(1437) - lu(514) * lu(1401) - lu(517) = 1._r8 / lu(517) - lu(518) = lu(518) * lu(517) - lu(519) = lu(519) * lu(517) - lu(520) = lu(520) * lu(517) - lu(521) = lu(521) * lu(517) - lu(522) = lu(522) * lu(517) - lu(523) = lu(523) * lu(517) - lu(524) = lu(524) * lu(517) - lu(525) = lu(525) * lu(517) - lu(526) = lu(526) * lu(517) - lu(527) = lu(527) * lu(517) - lu(528) = lu(528) * lu(517) - lu(861) = lu(861) - lu(518) * lu(859) - lu(863) = lu(863) - lu(519) * lu(859) - lu(871) = lu(871) - lu(520) * lu(859) - lu(872) = lu(872) - lu(521) * lu(859) - lu(873) = lu(873) - lu(522) * lu(859) - lu(876) = lu(876) - lu(523) * lu(859) - lu(879) = lu(879) - lu(524) * lu(859) - lu(880) = lu(880) - lu(525) * lu(859) - lu(881) = lu(881) - lu(526) * lu(859) - lu(884) = lu(884) - lu(527) * lu(859) - lu(885) = lu(885) - lu(528) * lu(859) - lu(1094) = lu(1094) - lu(518) * lu(1089) - lu(1096) = lu(1096) - lu(519) * lu(1089) - lu(1105) = lu(1105) - lu(520) * lu(1089) - lu(1108) = lu(1108) - lu(521) * lu(1089) - lu(1109) = lu(1109) - lu(522) * lu(1089) - lu(1114) = lu(1114) - lu(523) * lu(1089) - lu(1118) = lu(1118) - lu(524) * lu(1089) - lu(1119) = lu(1119) - lu(525) * lu(1089) - lu(1120) = lu(1120) - lu(526) * lu(1089) - lu(1123) = lu(1123) - lu(527) * lu(1089) - lu(1124) = lu(1124) - lu(528) * lu(1089) - lu(1230) = lu(1230) - lu(518) * lu(1225) - lu(1232) = lu(1232) - lu(519) * lu(1225) - lu(1240) = lu(1240) - lu(520) * lu(1225) - lu(1242) = lu(1242) - lu(521) * lu(1225) - lu(1243) = lu(1243) - lu(522) * lu(1225) - lu(1248) = lu(1248) - lu(523) * lu(1225) - lu(1252) = lu(1252) - lu(524) * lu(1225) - lu(1253) = lu(1253) - lu(525) * lu(1225) - lu(1254) = lu(1254) - lu(526) * lu(1225) - lu(1257) = lu(1257) - lu(527) * lu(1225) - lu(1258) = lu(1258) - lu(528) * lu(1225) - lu(1362) = lu(1362) - lu(518) * lu(1354) - lu(1364) = lu(1364) - lu(519) * lu(1354) - lu(1373) = lu(1373) - lu(520) * lu(1354) - lu(1377) = lu(1377) - lu(521) * lu(1354) - lu(1378) = lu(1378) - lu(522) * lu(1354) - lu(1383) = lu(1383) - lu(523) * lu(1354) - lu(1387) = lu(1387) - lu(524) * lu(1354) - lu(1388) = lu(1388) - lu(525) * lu(1354) - lu(1389) = lu(1389) - lu(526) * lu(1354) - lu(1392) = lu(1392) - lu(527) * lu(1354) - lu(1393) = lu(1393) - lu(528) * lu(1354) - lu(530) = 1._r8 / lu(530) - lu(531) = lu(531) * lu(530) - lu(532) = lu(532) * lu(530) - lu(533) = lu(533) * lu(530) - lu(534) = lu(534) * lu(530) - lu(535) = lu(535) * lu(530) - lu(536) = lu(536) * lu(530) - lu(537) = lu(537) * lu(530) - lu(573) = - lu(531) * lu(571) - lu(575) = lu(575) - lu(532) * lu(571) - lu(577) = lu(577) - lu(533) * lu(571) - lu(579) = lu(579) - lu(534) * lu(571) - lu(580) = lu(580) - lu(535) * lu(571) - lu(581) = lu(581) - lu(536) * lu(571) - lu(583) = lu(583) - lu(537) * lu(571) - lu(693) = - lu(531) * lu(692) - lu(696) = lu(696) - lu(532) * lu(692) - lu(704) = lu(704) - lu(533) * lu(692) - lu(707) = lu(707) - lu(534) * lu(692) - lu(708) = lu(708) - lu(535) * lu(692) - lu(709) = lu(709) - lu(536) * lu(692) - lu(712) = lu(712) - lu(537) * lu(692) - lu(717) = lu(717) - lu(531) * lu(716) - lu(720) = - lu(532) * lu(716) - lu(725) = lu(725) - lu(533) * lu(716) - lu(728) = lu(728) - lu(534) * lu(716) - lu(729) = lu(729) - lu(535) * lu(716) - lu(730) = lu(730) - lu(536) * lu(716) - lu(733) = lu(733) - lu(537) * lu(716) - lu(1093) = lu(1093) - lu(531) * lu(1090) - lu(1100) = lu(1100) - lu(532) * lu(1090) - lu(1114) = lu(1114) - lu(533) * lu(1090) - lu(1119) = lu(1119) - lu(534) * lu(1090) - lu(1120) = lu(1120) - lu(535) * lu(1090) - lu(1121) = lu(1121) - lu(536) * lu(1090) - lu(1124) = lu(1124) - lu(537) * lu(1090) - lu(1229) = lu(1229) - lu(531) * lu(1226) - lu(1235) = lu(1235) - lu(532) * lu(1226) - lu(1248) = lu(1248) - lu(533) * lu(1226) - lu(1253) = lu(1253) - lu(534) * lu(1226) - lu(1254) = lu(1254) - lu(535) * lu(1226) - lu(1255) = lu(1255) - lu(536) * lu(1226) - lu(1258) = lu(1258) - lu(537) * lu(1226) - lu(1361) = lu(1361) - lu(531) * lu(1355) - lu(1368) = lu(1368) - lu(532) * lu(1355) - lu(1383) = lu(1383) - lu(533) * lu(1355) - lu(1388) = lu(1388) - lu(534) * lu(1355) - lu(1389) = lu(1389) - lu(535) * lu(1355) - lu(1390) = lu(1390) - lu(536) * lu(1355) - lu(1393) = lu(1393) - lu(537) * lu(1355) - lu(1407) = lu(1407) - lu(531) * lu(1402) - lu(1413) = lu(1413) - lu(532) * lu(1402) - lu(1427) = lu(1427) - lu(533) * lu(1402) - lu(1432) = lu(1432) - lu(534) * lu(1402) - lu(1433) = lu(1433) - lu(535) * lu(1402) - lu(1434) = lu(1434) - lu(536) * lu(1402) - lu(1437) = lu(1437) - lu(537) * lu(1402) - lu(540) = 1._r8 / lu(540) - lu(541) = lu(541) * lu(540) - lu(542) = lu(542) * lu(540) - lu(543) = lu(543) * lu(540) - lu(544) = lu(544) * lu(540) - lu(545) = lu(545) * lu(540) - lu(546) = lu(546) * lu(540) - lu(547) = lu(547) * lu(540) - lu(548) = lu(548) * lu(540) - lu(549) = lu(549) * lu(540) - lu(550) = lu(550) * lu(540) - lu(1001) = - lu(541) * lu(994) - lu(1002) = lu(1002) - lu(542) * lu(994) - lu(1007) = lu(1007) - lu(543) * lu(994) - lu(1009) = - lu(544) * lu(994) - lu(1012) = lu(1012) - lu(545) * lu(994) - lu(1018) = lu(1018) - lu(546) * lu(994) - lu(1022) = lu(1022) - lu(547) * lu(994) - lu(1023) = lu(1023) - lu(548) * lu(994) - lu(1024) = lu(1024) - lu(549) * lu(994) - lu(1027) = lu(1027) - lu(550) * lu(994) - lu(1096) = lu(1096) - lu(541) * lu(1091) - lu(1097) = lu(1097) - lu(542) * lu(1091) - lu(1103) = lu(1103) - lu(543) * lu(1091) - lu(1105) = lu(1105) - lu(544) * lu(1091) - lu(1108) = lu(1108) - lu(545) * lu(1091) - lu(1114) = lu(1114) - lu(546) * lu(1091) - lu(1118) = lu(1118) - lu(547) * lu(1091) - lu(1119) = lu(1119) - lu(548) * lu(1091) - lu(1120) = lu(1120) - lu(549) * lu(1091) - lu(1123) = lu(1123) - lu(550) * lu(1091) - lu(1232) = lu(1232) - lu(541) * lu(1227) - lu(1233) = lu(1233) - lu(542) * lu(1227) - lu(1238) = lu(1238) - lu(543) * lu(1227) - lu(1240) = lu(1240) - lu(544) * lu(1227) - lu(1242) = lu(1242) - lu(545) * lu(1227) - lu(1248) = lu(1248) - lu(546) * lu(1227) - lu(1252) = lu(1252) - lu(547) * lu(1227) - lu(1253) = lu(1253) - lu(548) * lu(1227) - lu(1254) = lu(1254) - lu(549) * lu(1227) - lu(1257) = lu(1257) - lu(550) * lu(1227) - lu(1364) = lu(1364) - lu(541) * lu(1356) - lu(1365) = lu(1365) - lu(542) * lu(1356) - lu(1371) = lu(1371) - lu(543) * lu(1356) - lu(1373) = lu(1373) - lu(544) * lu(1356) - lu(1377) = lu(1377) - lu(545) * lu(1356) - lu(1383) = lu(1383) - lu(546) * lu(1356) - lu(1387) = lu(1387) - lu(547) * lu(1356) - lu(1388) = lu(1388) - lu(548) * lu(1356) - lu(1389) = lu(1389) - lu(549) * lu(1356) - lu(1392) = lu(1392) - lu(550) * lu(1356) - lu(1410) = - lu(541) * lu(1403) - lu(1411) = lu(1411) - lu(542) * lu(1403) - lu(1416) = lu(1416) - lu(543) * lu(1403) - lu(1418) = lu(1418) - lu(544) * lu(1403) - lu(1421) = lu(1421) - lu(545) * lu(1403) - lu(1427) = lu(1427) - lu(546) * lu(1403) - lu(1431) = lu(1431) - lu(547) * lu(1403) - lu(1432) = lu(1432) - lu(548) * lu(1403) - lu(1433) = lu(1433) - lu(549) * lu(1403) - lu(1436) = lu(1436) - lu(550) * lu(1403) - END SUBROUTINE lu_fac12 - - SUBROUTINE lu_fac13(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(552) = 1._r8 / lu(552) - lu(553) = lu(553) * lu(552) - lu(554) = lu(554) * lu(552) - lu(555) = lu(555) * lu(552) - lu(556) = lu(556) * lu(552) - lu(557) = lu(557) * lu(552) - lu(805) = lu(805) - lu(553) * lu(804) - lu(808) = lu(808) - lu(554) * lu(804) - lu(811) = - lu(555) * lu(804) - lu(817) = lu(817) - lu(556) * lu(804) - lu(818) = - lu(557) * lu(804) - lu(901) = lu(901) - lu(553) * lu(899) - lu(904) = lu(904) - lu(554) * lu(899) - lu(908) = lu(908) - lu(555) * lu(899) - lu(914) = lu(914) - lu(556) * lu(899) - lu(915) = - lu(557) * lu(899) - lu(938) = lu(938) - lu(553) * lu(934) - lu(943) = lu(943) - lu(554) * lu(934) - lu(947) = lu(947) - lu(555) * lu(934) - lu(953) = lu(953) - lu(556) * lu(934) - lu(956) = lu(956) - lu(557) * lu(934) - lu(1010) = lu(1010) - lu(553) * lu(995) - lu(1014) = lu(1014) - lu(554) * lu(995) - lu(1018) = lu(1018) - lu(555) * lu(995) - lu(1024) = lu(1024) - lu(556) * lu(995) - lu(1027) = lu(1027) - lu(557) * lu(995) - lu(1036) = lu(1036) - lu(553) * lu(1034) - lu(1041) = lu(1041) - lu(554) * lu(1034) - lu(1045) = lu(1045) - lu(555) * lu(1034) - lu(1051) = lu(1051) - lu(556) * lu(1034) - lu(1054) = lu(1054) - lu(557) * lu(1034) - lu(1185) = lu(1185) - lu(553) * lu(1184) - lu(1189) = lu(1189) - lu(554) * lu(1184) - lu(1193) = lu(1193) - lu(555) * lu(1184) - lu(1199) = lu(1199) - lu(556) * lu(1184) - lu(1202) = lu(1202) - lu(557) * lu(1184) - lu(1276) = lu(1276) - lu(553) * lu(1269) - lu(1281) = lu(1281) - lu(554) * lu(1269) - lu(1285) = lu(1285) - lu(555) * lu(1269) - lu(1291) = lu(1291) - lu(556) * lu(1269) - lu(1294) = lu(1294) - lu(557) * lu(1269) - lu(1374) = lu(1374) - lu(553) * lu(1357) - lu(1379) = lu(1379) - lu(554) * lu(1357) - lu(1383) = lu(1383) - lu(555) * lu(1357) - lu(1389) = lu(1389) - lu(556) * lu(1357) - lu(1392) = lu(1392) - lu(557) * lu(1357) - lu(1419) = - lu(553) * lu(1404) - lu(1423) = lu(1423) - lu(554) * lu(1404) - lu(1427) = lu(1427) - lu(555) * lu(1404) - lu(1433) = lu(1433) - lu(556) * lu(1404) - lu(1436) = lu(1436) - lu(557) * lu(1404) - lu(1466) = - lu(553) * lu(1464) - lu(1471) = lu(1471) - lu(554) * lu(1464) - lu(1475) = - lu(555) * lu(1464) - lu(1481) = lu(1481) - lu(556) * lu(1464) - lu(1484) = lu(1484) - lu(557) * lu(1464) - lu(560) = 1._r8 / lu(560) - lu(561) = lu(561) * lu(560) - lu(562) = lu(562) * lu(560) - lu(563) = lu(563) * lu(560) - lu(564) = lu(564) * lu(560) - lu(565) = lu(565) * lu(560) - lu(566) = lu(566) * lu(560) - lu(567) = lu(567) * lu(560) - lu(568) = lu(568) * lu(560) - lu(569) = lu(569) * lu(560) - lu(824) = lu(824) - lu(561) * lu(823) - lu(826) = lu(826) - lu(562) * lu(823) - lu(828) = lu(828) - lu(563) * lu(823) - lu(829) = lu(829) - lu(564) * lu(823) - lu(832) = - lu(565) * lu(823) - lu(833) = lu(833) - lu(566) * lu(823) - lu(834) = - lu(567) * lu(823) - lu(835) = lu(835) - lu(568) * lu(823) - lu(836) = lu(836) - lu(569) * lu(823) - lu(939) = lu(939) - lu(561) * lu(935) - lu(943) = lu(943) - lu(562) * lu(935) - lu(946) = lu(946) - lu(563) * lu(935) - lu(948) = lu(948) - lu(564) * lu(935) - lu(952) = lu(952) - lu(565) * lu(935) - lu(953) = lu(953) - lu(566) * lu(935) - lu(954) = lu(954) - lu(567) * lu(935) - lu(955) = lu(955) - lu(568) * lu(935) - lu(956) = lu(956) - lu(569) * lu(935) - lu(1037) = lu(1037) - lu(561) * lu(1035) - lu(1041) = lu(1041) - lu(562) * lu(1035) - lu(1044) = lu(1044) - lu(563) * lu(1035) - lu(1046) = lu(1046) - lu(564) * lu(1035) - lu(1050) = lu(1050) - lu(565) * lu(1035) - lu(1051) = lu(1051) - lu(566) * lu(1035) - lu(1052) = - lu(567) * lu(1035) - lu(1053) = - lu(568) * lu(1035) - lu(1054) = lu(1054) - lu(569) * lu(1035) - lu(1141) = lu(1141) - lu(561) * lu(1136) - lu(1145) = lu(1145) - lu(562) * lu(1136) - lu(1148) = lu(1148) - lu(563) * lu(1136) - lu(1150) = lu(1150) - lu(564) * lu(1136) - lu(1154) = lu(1154) - lu(565) * lu(1136) - lu(1155) = lu(1155) - lu(566) * lu(1136) - lu(1156) = lu(1156) - lu(567) * lu(1136) - lu(1157) = - lu(568) * lu(1136) - lu(1158) = lu(1158) - lu(569) * lu(1136) - lu(1277) = lu(1277) - lu(561) * lu(1270) - lu(1281) = lu(1281) - lu(562) * lu(1270) - lu(1284) = lu(1284) - lu(563) * lu(1270) - lu(1286) = lu(1286) - lu(564) * lu(1270) - lu(1290) = lu(1290) - lu(565) * lu(1270) - lu(1291) = lu(1291) - lu(566) * lu(1270) - lu(1292) = lu(1292) - lu(567) * lu(1270) - lu(1293) = lu(1293) - lu(568) * lu(1270) - lu(1294) = lu(1294) - lu(569) * lu(1270) - lu(1375) = lu(1375) - lu(561) * lu(1358) - lu(1379) = lu(1379) - lu(562) * lu(1358) - lu(1382) = lu(1382) - lu(563) * lu(1358) - lu(1384) = lu(1384) - lu(564) * lu(1358) - lu(1388) = lu(1388) - lu(565) * lu(1358) - lu(1389) = lu(1389) - lu(566) * lu(1358) - lu(1390) = lu(1390) - lu(567) * lu(1358) - lu(1391) = lu(1391) - lu(568) * lu(1358) - lu(1392) = lu(1392) - lu(569) * lu(1358) - lu(572) = 1._r8 / lu(572) - lu(573) = lu(573) * lu(572) - lu(574) = lu(574) * lu(572) - lu(575) = lu(575) * lu(572) - lu(576) = lu(576) * lu(572) - lu(577) = lu(577) * lu(572) - lu(578) = lu(578) * lu(572) - lu(579) = lu(579) * lu(572) - lu(580) = lu(580) * lu(572) - lu(581) = lu(581) * lu(572) - lu(582) = lu(582) * lu(572) - lu(583) = lu(583) * lu(572) - lu(998) = lu(998) - lu(573) * lu(996) - lu(1002) = lu(1002) - lu(574) * lu(996) - lu(1004) = - lu(575) * lu(996) - lu(1007) = lu(1007) - lu(576) * lu(996) - lu(1018) = lu(1018) - lu(577) * lu(996) - lu(1022) = lu(1022) - lu(578) * lu(996) - lu(1023) = lu(1023) - lu(579) * lu(996) - lu(1024) = lu(1024) - lu(580) * lu(996) - lu(1025) = lu(1025) - lu(581) * lu(996) - lu(1027) = lu(1027) - lu(582) * lu(996) - lu(1028) = lu(1028) - lu(583) * lu(996) - lu(1093) = lu(1093) - lu(573) * lu(1092) - lu(1097) = lu(1097) - lu(574) * lu(1092) - lu(1100) = lu(1100) - lu(575) * lu(1092) - lu(1103) = lu(1103) - lu(576) * lu(1092) - lu(1114) = lu(1114) - lu(577) * lu(1092) - lu(1118) = lu(1118) - lu(578) * lu(1092) - lu(1119) = lu(1119) - lu(579) * lu(1092) - lu(1120) = lu(1120) - lu(580) * lu(1092) - lu(1121) = lu(1121) - lu(581) * lu(1092) - lu(1123) = lu(1123) - lu(582) * lu(1092) - lu(1124) = lu(1124) - lu(583) * lu(1092) - lu(1229) = lu(1229) - lu(573) * lu(1228) - lu(1233) = lu(1233) - lu(574) * lu(1228) - lu(1235) = lu(1235) - lu(575) * lu(1228) - lu(1238) = lu(1238) - lu(576) * lu(1228) - lu(1248) = lu(1248) - lu(577) * lu(1228) - lu(1252) = lu(1252) - lu(578) * lu(1228) - lu(1253) = lu(1253) - lu(579) * lu(1228) - lu(1254) = lu(1254) - lu(580) * lu(1228) - lu(1255) = lu(1255) - lu(581) * lu(1228) - lu(1257) = lu(1257) - lu(582) * lu(1228) - lu(1258) = lu(1258) - lu(583) * lu(1228) - lu(1361) = lu(1361) - lu(573) * lu(1359) - lu(1365) = lu(1365) - lu(574) * lu(1359) - lu(1368) = lu(1368) - lu(575) * lu(1359) - lu(1371) = lu(1371) - lu(576) * lu(1359) - lu(1383) = lu(1383) - lu(577) * lu(1359) - lu(1387) = lu(1387) - lu(578) * lu(1359) - lu(1388) = lu(1388) - lu(579) * lu(1359) - lu(1389) = lu(1389) - lu(580) * lu(1359) - lu(1390) = lu(1390) - lu(581) * lu(1359) - lu(1392) = lu(1392) - lu(582) * lu(1359) - lu(1393) = lu(1393) - lu(583) * lu(1359) - lu(1407) = lu(1407) - lu(573) * lu(1405) - lu(1411) = lu(1411) - lu(574) * lu(1405) - lu(1413) = lu(1413) - lu(575) * lu(1405) - lu(1416) = lu(1416) - lu(576) * lu(1405) - lu(1427) = lu(1427) - lu(577) * lu(1405) - lu(1431) = lu(1431) - lu(578) * lu(1405) - lu(1432) = lu(1432) - lu(579) * lu(1405) - lu(1433) = lu(1433) - lu(580) * lu(1405) - lu(1434) = lu(1434) - lu(581) * lu(1405) - lu(1436) = lu(1436) - lu(582) * lu(1405) - lu(1437) = lu(1437) - lu(583) * lu(1405) - lu(587) = 1._r8 / lu(587) - lu(588) = lu(588) * lu(587) - lu(589) = lu(589) * lu(587) - lu(590) = lu(590) * lu(587) - lu(591) = lu(591) * lu(587) - lu(592) = lu(592) * lu(587) - lu(593) = lu(593) * lu(587) - lu(594) = lu(594) * lu(587) - lu(595) = lu(595) * lu(587) - lu(596) = lu(596) * lu(587) - lu(597) = lu(597) * lu(587) - lu(598) = lu(598) * lu(587) - lu(599) = lu(599) * lu(587) - lu(600) = lu(600) * lu(587) - lu(601) = lu(601) * lu(587) - lu(735) = lu(735) - lu(588) * lu(734) - lu(736) = lu(736) - lu(589) * lu(734) - lu(737) = - lu(590) * lu(734) - lu(738) = lu(738) - lu(591) * lu(734) - lu(743) = lu(743) - lu(592) * lu(734) - lu(744) = - lu(593) * lu(734) - lu(745) = lu(745) - lu(594) * lu(734) - lu(746) = lu(746) - lu(595) * lu(734) - lu(748) = - lu(596) * lu(734) - lu(749) = - lu(597) * lu(734) - lu(750) = lu(750) - lu(598) * lu(734) - lu(751) = - lu(599) * lu(734) - lu(753) = - lu(600) * lu(734) - lu(754) = lu(754) - lu(601) * lu(734) - lu(998) = lu(998) - lu(588) * lu(997) - lu(999) = lu(999) - lu(589) * lu(997) - lu(1000) = - lu(590) * lu(997) - lu(1003) = lu(1003) - lu(591) * lu(997) - lu(1012) = lu(1012) - lu(592) * lu(997) - lu(1013) = lu(1013) - lu(593) * lu(997) - lu(1016) = lu(1016) - lu(594) * lu(997) - lu(1018) = lu(1018) - lu(595) * lu(997) - lu(1022) = lu(1022) - lu(596) * lu(997) - lu(1023) = lu(1023) - lu(597) * lu(997) - lu(1024) = lu(1024) - lu(598) * lu(997) - lu(1025) = lu(1025) - lu(599) * lu(997) - lu(1027) = lu(1027) - lu(600) * lu(997) - lu(1028) = lu(1028) - lu(601) * lu(997) - lu(1361) = lu(1361) - lu(588) * lu(1360) - lu(1362) = lu(1362) - lu(589) * lu(1360) - lu(1363) = lu(1363) - lu(590) * lu(1360) - lu(1367) = lu(1367) - lu(591) * lu(1360) - lu(1377) = lu(1377) - lu(592) * lu(1360) - lu(1378) = lu(1378) - lu(593) * lu(1360) - lu(1381) = lu(1381) - lu(594) * lu(1360) - lu(1383) = lu(1383) - lu(595) * lu(1360) - lu(1387) = lu(1387) - lu(596) * lu(1360) - lu(1388) = lu(1388) - lu(597) * lu(1360) - lu(1389) = lu(1389) - lu(598) * lu(1360) - lu(1390) = lu(1390) - lu(599) * lu(1360) - lu(1392) = lu(1392) - lu(600) * lu(1360) - lu(1393) = lu(1393) - lu(601) * lu(1360) - lu(1407) = lu(1407) - lu(588) * lu(1406) - lu(1408) = lu(1408) - lu(589) * lu(1406) - lu(1409) = lu(1409) - lu(590) * lu(1406) - lu(1412) = lu(1412) - lu(591) * lu(1406) - lu(1421) = lu(1421) - lu(592) * lu(1406) - lu(1422) = lu(1422) - lu(593) * lu(1406) - lu(1425) = lu(1425) - lu(594) * lu(1406) - lu(1427) = lu(1427) - lu(595) * lu(1406) - lu(1431) = lu(1431) - lu(596) * lu(1406) - lu(1432) = lu(1432) - lu(597) * lu(1406) - lu(1433) = lu(1433) - lu(598) * lu(1406) - lu(1434) = lu(1434) - lu(599) * lu(1406) - lu(1436) = lu(1436) - lu(600) * lu(1406) - lu(1437) = lu(1437) - lu(601) * lu(1406) - END SUBROUTINE lu_fac13 - - SUBROUTINE lu_fac14(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(602) = 1._r8 / lu(602) - lu(603) = lu(603) * lu(602) - lu(604) = lu(604) * lu(602) - lu(605) = lu(605) * lu(602) - lu(610) = lu(610) - lu(603) * lu(606) - lu(611) = - lu(604) * lu(606) - lu(612) = lu(612) - lu(605) * lu(606) - lu(643) = lu(643) - lu(603) * lu(636) - lu(644) = - lu(604) * lu(636) - lu(645) = lu(645) - lu(605) * lu(636) - lu(664) = lu(664) - lu(603) * lu(661) - lu(665) = - lu(604) * lu(661) - lu(666) = lu(666) - lu(605) * lu(661) - lu(680) = lu(680) - lu(603) * lu(674) - lu(681) = - lu(604) * lu(674) - lu(684) = lu(684) - lu(605) * lu(674) - lu(704) = lu(704) - lu(603) * lu(693) - lu(705) = - lu(604) * lu(693) - lu(708) = lu(708) - lu(605) * lu(693) - lu(725) = lu(725) - lu(603) * lu(717) - lu(726) = - lu(604) * lu(717) - lu(729) = lu(729) - lu(605) * lu(717) - lu(746) = lu(746) - lu(603) * lu(735) - lu(747) = - lu(604) * lu(735) - lu(750) = lu(750) - lu(605) * lu(735) - lu(793) = lu(793) - lu(603) * lu(780) - lu(794) = - lu(604) * lu(780) - lu(797) = lu(797) - lu(605) * lu(780) - lu(844) = lu(844) - lu(603) * lu(838) - lu(845) = lu(845) - lu(604) * lu(838) - lu(847) = lu(847) - lu(605) * lu(838) - lu(876) = lu(876) - lu(603) * lu(860) - lu(878) = lu(878) - lu(604) * lu(860) - lu(881) = lu(881) - lu(605) * lu(860) - lu(908) = lu(908) - lu(603) * lu(900) - lu(910) = lu(910) - lu(604) * lu(900) - lu(914) = lu(914) - lu(605) * lu(900) - lu(947) = lu(947) - lu(603) * lu(936) - lu(949) = lu(949) - lu(604) * lu(936) - lu(953) = lu(953) - lu(605) * lu(936) - lu(1018) = lu(1018) - lu(603) * lu(998) - lu(1020) = lu(1020) - lu(604) * lu(998) - lu(1024) = lu(1024) - lu(605) * lu(998) - lu(1114) = lu(1114) - lu(603) * lu(1093) - lu(1116) = lu(1116) - lu(604) * lu(1093) - lu(1120) = lu(1120) - lu(605) * lu(1093) - lu(1149) = lu(1149) - lu(603) * lu(1137) - lu(1151) = lu(1151) - lu(604) * lu(1137) - lu(1155) = lu(1155) - lu(605) * lu(1137) - lu(1248) = lu(1248) - lu(603) * lu(1229) - lu(1250) = lu(1250) - lu(604) * lu(1229) - lu(1254) = lu(1254) - lu(605) * lu(1229) - lu(1285) = lu(1285) - lu(603) * lu(1271) - lu(1287) = lu(1287) - lu(604) * lu(1271) - lu(1291) = lu(1291) - lu(605) * lu(1271) - lu(1383) = lu(1383) - lu(603) * lu(1361) - lu(1385) = lu(1385) - lu(604) * lu(1361) - lu(1389) = lu(1389) - lu(605) * lu(1361) - lu(1427) = lu(1427) - lu(603) * lu(1407) - lu(1429) = - lu(604) * lu(1407) - lu(1433) = lu(1433) - lu(605) * lu(1407) - lu(1499) = lu(1499) - lu(603) * lu(1489) - lu(1501) = lu(1501) - lu(604) * lu(1489) - lu(1505) = lu(1505) - lu(605) * lu(1489) - lu(607) = 1._r8 / lu(607) - lu(608) = lu(608) * lu(607) - lu(609) = lu(609) * lu(607) - lu(610) = lu(610) * lu(607) - lu(611) = lu(611) * lu(607) - lu(612) = lu(612) * lu(607) - lu(613) = lu(613) * lu(607) - lu(614) = lu(614) * lu(607) - lu(615) = lu(615) * lu(607) - lu(742) = lu(742) - lu(608) * lu(736) - lu(743) = lu(743) - lu(609) * lu(736) - lu(746) = lu(746) - lu(610) * lu(736) - lu(747) = lu(747) - lu(611) * lu(736) - lu(750) = lu(750) - lu(612) * lu(736) - lu(751) = lu(751) - lu(613) * lu(736) - lu(752) = - lu(614) * lu(736) - lu(753) = lu(753) - lu(615) * lu(736) - lu(871) = lu(871) - lu(608) * lu(861) - lu(872) = lu(872) - lu(609) * lu(861) - lu(876) = lu(876) - lu(610) * lu(861) - lu(878) = lu(878) - lu(611) * lu(861) - lu(881) = lu(881) - lu(612) * lu(861) - lu(882) = - lu(613) * lu(861) - lu(883) = - lu(614) * lu(861) - lu(884) = lu(884) - lu(615) * lu(861) - lu(1009) = lu(1009) - lu(608) * lu(999) - lu(1012) = lu(1012) - lu(609) * lu(999) - lu(1018) = lu(1018) - lu(610) * lu(999) - lu(1020) = lu(1020) - lu(611) * lu(999) - lu(1024) = lu(1024) - lu(612) * lu(999) - lu(1025) = lu(1025) - lu(613) * lu(999) - lu(1026) = - lu(614) * lu(999) - lu(1027) = lu(1027) - lu(615) * lu(999) - lu(1105) = lu(1105) - lu(608) * lu(1094) - lu(1108) = lu(1108) - lu(609) * lu(1094) - lu(1114) = lu(1114) - lu(610) * lu(1094) - lu(1116) = lu(1116) - lu(611) * lu(1094) - lu(1120) = lu(1120) - lu(612) * lu(1094) - lu(1121) = lu(1121) - lu(613) * lu(1094) - lu(1122) = - lu(614) * lu(1094) - lu(1123) = lu(1123) - lu(615) * lu(1094) - lu(1140) = - lu(608) * lu(1138) - lu(1143) = lu(1143) - lu(609) * lu(1138) - lu(1149) = lu(1149) - lu(610) * lu(1138) - lu(1151) = lu(1151) - lu(611) * lu(1138) - lu(1155) = lu(1155) - lu(612) * lu(1138) - lu(1156) = lu(1156) - lu(613) * lu(1138) - lu(1157) = lu(1157) - lu(614) * lu(1138) - lu(1158) = lu(1158) - lu(615) * lu(1138) - lu(1240) = lu(1240) - lu(608) * lu(1230) - lu(1242) = lu(1242) - lu(609) * lu(1230) - lu(1248) = lu(1248) - lu(610) * lu(1230) - lu(1250) = lu(1250) - lu(611) * lu(1230) - lu(1254) = lu(1254) - lu(612) * lu(1230) - lu(1255) = lu(1255) - lu(613) * lu(1230) - lu(1256) = - lu(614) * lu(1230) - lu(1257) = lu(1257) - lu(615) * lu(1230) - lu(1373) = lu(1373) - lu(608) * lu(1362) - lu(1377) = lu(1377) - lu(609) * lu(1362) - lu(1383) = lu(1383) - lu(610) * lu(1362) - lu(1385) = lu(1385) - lu(611) * lu(1362) - lu(1389) = lu(1389) - lu(612) * lu(1362) - lu(1390) = lu(1390) - lu(613) * lu(1362) - lu(1391) = lu(1391) - lu(614) * lu(1362) - lu(1392) = lu(1392) - lu(615) * lu(1362) - lu(1418) = lu(1418) - lu(608) * lu(1408) - lu(1421) = lu(1421) - lu(609) * lu(1408) - lu(1427) = lu(1427) - lu(610) * lu(1408) - lu(1429) = lu(1429) - lu(611) * lu(1408) - lu(1433) = lu(1433) - lu(612) * lu(1408) - lu(1434) = lu(1434) - lu(613) * lu(1408) - lu(1435) = lu(1435) - lu(614) * lu(1408) - lu(1436) = lu(1436) - lu(615) * lu(1408) - lu(616) = 1._r8 / lu(616) - lu(617) = lu(617) * lu(616) - lu(618) = lu(618) * lu(616) - lu(619) = lu(619) * lu(616) - lu(620) = lu(620) * lu(616) - lu(621) = lu(621) * lu(616) - lu(626) = lu(626) - lu(617) * lu(624) - lu(627) = lu(627) - lu(618) * lu(624) - lu(630) = lu(630) - lu(619) * lu(624) - lu(633) = lu(633) - lu(620) * lu(624) - lu(635) = lu(635) - lu(621) * lu(624) - lu(676) = lu(676) - lu(617) * lu(675) - lu(678) = lu(678) - lu(618) * lu(675) - lu(680) = lu(680) - lu(619) * lu(675) - lu(684) = lu(684) - lu(620) * lu(675) - lu(688) = lu(688) - lu(621) * lu(675) - lu(719) = lu(719) - lu(617) * lu(718) - lu(723) = lu(723) - lu(618) * lu(718) - lu(725) = lu(725) - lu(619) * lu(718) - lu(729) = lu(729) - lu(620) * lu(718) - lu(733) = lu(733) - lu(621) * lu(718) - lu(738) = lu(738) - lu(617) * lu(737) - lu(742) = lu(742) - lu(618) * lu(737) - lu(746) = lu(746) - lu(619) * lu(737) - lu(750) = lu(750) - lu(620) * lu(737) - lu(754) = lu(754) - lu(621) * lu(737) - lu(759) = - lu(617) * lu(758) - lu(761) = lu(761) - lu(618) * lu(758) - lu(765) = lu(765) - lu(619) * lu(758) - lu(769) = lu(769) - lu(620) * lu(758) - lu(773) = lu(773) - lu(621) * lu(758) - lu(783) = lu(783) - lu(617) * lu(781) - lu(789) = lu(789) - lu(618) * lu(781) - lu(793) = lu(793) - lu(619) * lu(781) - lu(797) = lu(797) - lu(620) * lu(781) - lu(801) = lu(801) - lu(621) * lu(781) - lu(865) = lu(865) - lu(617) * lu(862) - lu(871) = lu(871) - lu(618) * lu(862) - lu(876) = lu(876) - lu(619) * lu(862) - lu(881) = lu(881) - lu(620) * lu(862) - lu(885) = lu(885) - lu(621) * lu(862) - lu(1003) = lu(1003) - lu(617) * lu(1000) - lu(1009) = lu(1009) - lu(618) * lu(1000) - lu(1018) = lu(1018) - lu(619) * lu(1000) - lu(1024) = lu(1024) - lu(620) * lu(1000) - lu(1028) = lu(1028) - lu(621) * lu(1000) - lu(1099) = lu(1099) - lu(617) * lu(1095) - lu(1105) = lu(1105) - lu(618) * lu(1095) - lu(1114) = lu(1114) - lu(619) * lu(1095) - lu(1120) = lu(1120) - lu(620) * lu(1095) - lu(1124) = lu(1124) - lu(621) * lu(1095) - lu(1234) = lu(1234) - lu(617) * lu(1231) - lu(1240) = lu(1240) - lu(618) * lu(1231) - lu(1248) = lu(1248) - lu(619) * lu(1231) - lu(1254) = lu(1254) - lu(620) * lu(1231) - lu(1258) = lu(1258) - lu(621) * lu(1231) - lu(1273) = lu(1273) - lu(617) * lu(1272) - lu(1275) = lu(1275) - lu(618) * lu(1272) - lu(1285) = lu(1285) - lu(619) * lu(1272) - lu(1291) = lu(1291) - lu(620) * lu(1272) - lu(1295) = lu(1295) - lu(621) * lu(1272) - lu(1367) = lu(1367) - lu(617) * lu(1363) - lu(1373) = lu(1373) - lu(618) * lu(1363) - lu(1383) = lu(1383) - lu(619) * lu(1363) - lu(1389) = lu(1389) - lu(620) * lu(1363) - lu(1393) = lu(1393) - lu(621) * lu(1363) - lu(1412) = lu(1412) - lu(617) * lu(1409) - lu(1418) = lu(1418) - lu(618) * lu(1409) - lu(1427) = lu(1427) - lu(619) * lu(1409) - lu(1433) = lu(1433) - lu(620) * lu(1409) - lu(1437) = lu(1437) - lu(621) * lu(1409) - lu(625) = 1._r8 / lu(625) - lu(626) = lu(626) * lu(625) - lu(627) = lu(627) * lu(625) - lu(628) = lu(628) * lu(625) - lu(629) = lu(629) * lu(625) - lu(630) = lu(630) * lu(625) - lu(631) = lu(631) * lu(625) - lu(632) = lu(632) * lu(625) - lu(633) = lu(633) * lu(625) - lu(634) = lu(634) * lu(625) - lu(635) = lu(635) * lu(625) - lu(865) = lu(865) - lu(626) * lu(863) - lu(871) = lu(871) - lu(627) * lu(863) - lu(872) = lu(872) - lu(628) * lu(863) - lu(873) = lu(873) - lu(629) * lu(863) - lu(876) = lu(876) - lu(630) * lu(863) - lu(879) = lu(879) - lu(631) * lu(863) - lu(880) = lu(880) - lu(632) * lu(863) - lu(881) = lu(881) - lu(633) * lu(863) - lu(884) = lu(884) - lu(634) * lu(863) - lu(885) = lu(885) - lu(635) * lu(863) - lu(1003) = lu(1003) - lu(626) * lu(1001) - lu(1009) = lu(1009) - lu(627) * lu(1001) - lu(1012) = lu(1012) - lu(628) * lu(1001) - lu(1013) = lu(1013) - lu(629) * lu(1001) - lu(1018) = lu(1018) - lu(630) * lu(1001) - lu(1022) = lu(1022) - lu(631) * lu(1001) - lu(1023) = lu(1023) - lu(632) * lu(1001) - lu(1024) = lu(1024) - lu(633) * lu(1001) - lu(1027) = lu(1027) - lu(634) * lu(1001) - lu(1028) = lu(1028) - lu(635) * lu(1001) - lu(1099) = lu(1099) - lu(626) * lu(1096) - lu(1105) = lu(1105) - lu(627) * lu(1096) - lu(1108) = lu(1108) - lu(628) * lu(1096) - lu(1109) = lu(1109) - lu(629) * lu(1096) - lu(1114) = lu(1114) - lu(630) * lu(1096) - lu(1118) = lu(1118) - lu(631) * lu(1096) - lu(1119) = lu(1119) - lu(632) * lu(1096) - lu(1120) = lu(1120) - lu(633) * lu(1096) - lu(1123) = lu(1123) - lu(634) * lu(1096) - lu(1124) = lu(1124) - lu(635) * lu(1096) - lu(1234) = lu(1234) - lu(626) * lu(1232) - lu(1240) = lu(1240) - lu(627) * lu(1232) - lu(1242) = lu(1242) - lu(628) * lu(1232) - lu(1243) = lu(1243) - lu(629) * lu(1232) - lu(1248) = lu(1248) - lu(630) * lu(1232) - lu(1252) = lu(1252) - lu(631) * lu(1232) - lu(1253) = lu(1253) - lu(632) * lu(1232) - lu(1254) = lu(1254) - lu(633) * lu(1232) - lu(1257) = lu(1257) - lu(634) * lu(1232) - lu(1258) = lu(1258) - lu(635) * lu(1232) - lu(1367) = lu(1367) - lu(626) * lu(1364) - lu(1373) = lu(1373) - lu(627) * lu(1364) - lu(1377) = lu(1377) - lu(628) * lu(1364) - lu(1378) = lu(1378) - lu(629) * lu(1364) - lu(1383) = lu(1383) - lu(630) * lu(1364) - lu(1387) = lu(1387) - lu(631) * lu(1364) - lu(1388) = lu(1388) - lu(632) * lu(1364) - lu(1389) = lu(1389) - lu(633) * lu(1364) - lu(1392) = lu(1392) - lu(634) * lu(1364) - lu(1393) = lu(1393) - lu(635) * lu(1364) - lu(1412) = lu(1412) - lu(626) * lu(1410) - lu(1418) = lu(1418) - lu(627) * lu(1410) - lu(1421) = lu(1421) - lu(628) * lu(1410) - lu(1422) = lu(1422) - lu(629) * lu(1410) - lu(1427) = lu(1427) - lu(630) * lu(1410) - lu(1431) = lu(1431) - lu(631) * lu(1410) - lu(1432) = lu(1432) - lu(632) * lu(1410) - lu(1433) = lu(1433) - lu(633) * lu(1410) - lu(1436) = lu(1436) - lu(634) * lu(1410) - lu(1437) = lu(1437) - lu(635) * lu(1410) - lu(637) = 1._r8 / lu(637) - lu(638) = lu(638) * lu(637) - lu(639) = lu(639) * lu(637) - lu(640) = lu(640) * lu(637) - lu(641) = lu(641) * lu(637) - lu(642) = lu(642) * lu(637) - lu(643) = lu(643) * lu(637) - lu(644) = lu(644) * lu(637) - lu(645) = lu(645) * lu(637) - lu(646) = lu(646) * lu(637) - lu(647) = lu(647) * lu(637) - lu(695) = - lu(638) * lu(694) - lu(698) = - lu(639) * lu(694) - lu(700) = - lu(640) * lu(694) - lu(701) = lu(701) - lu(641) * lu(694) - lu(703) = - lu(642) * lu(694) - lu(704) = lu(704) - lu(643) * lu(694) - lu(705) = lu(705) - lu(644) * lu(694) - lu(708) = lu(708) - lu(645) * lu(694) - lu(711) = - lu(646) * lu(694) - lu(712) = lu(712) - lu(647) * lu(694) - lu(783) = lu(783) - lu(638) * lu(782) - lu(786) = lu(786) - lu(639) * lu(782) - lu(788) = lu(788) - lu(640) * lu(782) - lu(789) = lu(789) - lu(641) * lu(782) - lu(792) = lu(792) - lu(642) * lu(782) - lu(793) = lu(793) - lu(643) * lu(782) - lu(794) = lu(794) - lu(644) * lu(782) - lu(797) = lu(797) - lu(645) * lu(782) - lu(800) = lu(800) - lu(646) * lu(782) - lu(801) = lu(801) - lu(647) * lu(782) - lu(865) = lu(865) - lu(638) * lu(864) - lu(868) = lu(868) - lu(639) * lu(864) - lu(870) = lu(870) - lu(640) * lu(864) - lu(871) = lu(871) - lu(641) * lu(864) - lu(874) = - lu(642) * lu(864) - lu(876) = lu(876) - lu(643) * lu(864) - lu(878) = lu(878) - lu(644) * lu(864) - lu(881) = lu(881) - lu(645) * lu(864) - lu(884) = lu(884) - lu(646) * lu(864) - lu(885) = lu(885) - lu(647) * lu(864) - lu(1003) = lu(1003) - lu(638) * lu(1002) - lu(1006) = - lu(639) * lu(1002) - lu(1008) = lu(1008) - lu(640) * lu(1002) - lu(1009) = lu(1009) - lu(641) * lu(1002) - lu(1016) = lu(1016) - lu(642) * lu(1002) - lu(1018) = lu(1018) - lu(643) * lu(1002) - lu(1020) = lu(1020) - lu(644) * lu(1002) - lu(1024) = lu(1024) - lu(645) * lu(1002) - lu(1027) = lu(1027) - lu(646) * lu(1002) - lu(1028) = lu(1028) - lu(647) * lu(1002) - lu(1099) = lu(1099) - lu(638) * lu(1097) - lu(1102) = lu(1102) - lu(639) * lu(1097) - lu(1104) = lu(1104) - lu(640) * lu(1097) - lu(1105) = lu(1105) - lu(641) * lu(1097) - lu(1112) = lu(1112) - lu(642) * lu(1097) - lu(1114) = lu(1114) - lu(643) * lu(1097) - lu(1116) = lu(1116) - lu(644) * lu(1097) - lu(1120) = lu(1120) - lu(645) * lu(1097) - lu(1123) = lu(1123) - lu(646) * lu(1097) - lu(1124) = lu(1124) - lu(647) * lu(1097) - lu(1234) = lu(1234) - lu(638) * lu(1233) - lu(1237) = lu(1237) - lu(639) * lu(1233) - lu(1239) = lu(1239) - lu(640) * lu(1233) - lu(1240) = lu(1240) - lu(641) * lu(1233) - lu(1246) = lu(1246) - lu(642) * lu(1233) - lu(1248) = lu(1248) - lu(643) * lu(1233) - lu(1250) = lu(1250) - lu(644) * lu(1233) - lu(1254) = lu(1254) - lu(645) * lu(1233) - lu(1257) = lu(1257) - lu(646) * lu(1233) - lu(1258) = lu(1258) - lu(647) * lu(1233) - lu(1367) = lu(1367) - lu(638) * lu(1365) - lu(1370) = lu(1370) - lu(639) * lu(1365) - lu(1372) = lu(1372) - lu(640) * lu(1365) - lu(1373) = lu(1373) - lu(641) * lu(1365) - lu(1381) = lu(1381) - lu(642) * lu(1365) - lu(1383) = lu(1383) - lu(643) * lu(1365) - lu(1385) = lu(1385) - lu(644) * lu(1365) - lu(1389) = lu(1389) - lu(645) * lu(1365) - lu(1392) = lu(1392) - lu(646) * lu(1365) - lu(1393) = lu(1393) - lu(647) * lu(1365) - lu(1412) = lu(1412) - lu(638) * lu(1411) - lu(1415) = lu(1415) - lu(639) * lu(1411) - lu(1417) = lu(1417) - lu(640) * lu(1411) - lu(1418) = lu(1418) - lu(641) * lu(1411) - lu(1425) = lu(1425) - lu(642) * lu(1411) - lu(1427) = lu(1427) - lu(643) * lu(1411) - lu(1429) = lu(1429) - lu(644) * lu(1411) - lu(1433) = lu(1433) - lu(645) * lu(1411) - lu(1436) = lu(1436) - lu(646) * lu(1411) - lu(1437) = lu(1437) - lu(647) * lu(1411) - END SUBROUTINE lu_fac14 - - SUBROUTINE lu_fac15(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(650) = 1._r8 / lu(650) - lu(651) = lu(651) * lu(650) - lu(652) = lu(652) * lu(650) - lu(653) = lu(653) * lu(650) - lu(654) = lu(654) * lu(650) - lu(655) = lu(655) * lu(650) - lu(656) = lu(656) * lu(650) - lu(657) = lu(657) * lu(650) - lu(658) = lu(658) * lu(650) - lu(659) = lu(659) * lu(650) - lu(660) = lu(660) * lu(650) - lu(939) = lu(939) - lu(651) * lu(937) - lu(941) = - lu(652) * lu(937) - lu(943) = lu(943) - lu(653) * lu(937) - lu(944) = lu(944) - lu(654) * lu(937) - lu(948) = lu(948) - lu(655) * lu(937) - lu(949) = lu(949) - lu(656) * lu(937) - lu(953) = lu(953) - lu(657) * lu(937) - lu(954) = lu(954) - lu(658) * lu(937) - lu(955) = lu(955) - lu(659) * lu(937) - lu(956) = lu(956) - lu(660) * lu(937) - lu(965) = lu(965) - lu(651) * lu(964) - lu(967) = lu(967) - lu(652) * lu(964) - lu(969) = lu(969) - lu(653) * lu(964) - lu(970) = lu(970) - lu(654) * lu(964) - lu(974) = lu(974) - lu(655) * lu(964) - lu(975) = lu(975) - lu(656) * lu(964) - lu(979) = lu(979) - lu(657) * lu(964) - lu(980) = lu(980) - lu(658) * lu(964) - lu(981) = lu(981) - lu(659) * lu(964) - lu(982) = lu(982) - lu(660) * lu(964) - lu(1106) = lu(1106) - lu(651) * lu(1098) - lu(1108) = lu(1108) - lu(652) * lu(1098) - lu(1110) = lu(1110) - lu(653) * lu(1098) - lu(1111) = lu(1111) - lu(654) * lu(1098) - lu(1115) = lu(1115) - lu(655) * lu(1098) - lu(1116) = lu(1116) - lu(656) * lu(1098) - lu(1120) = lu(1120) - lu(657) * lu(1098) - lu(1121) = lu(1121) - lu(658) * lu(1098) - lu(1122) = lu(1122) - lu(659) * lu(1098) - lu(1123) = lu(1123) - lu(660) * lu(1098) - lu(1141) = lu(1141) - lu(651) * lu(1139) - lu(1143) = lu(1143) - lu(652) * lu(1139) - lu(1145) = lu(1145) - lu(653) * lu(1139) - lu(1146) = - lu(654) * lu(1139) - lu(1150) = lu(1150) - lu(655) * lu(1139) - lu(1151) = lu(1151) - lu(656) * lu(1139) - lu(1155) = lu(1155) - lu(657) * lu(1139) - lu(1156) = lu(1156) - lu(658) * lu(1139) - lu(1157) = lu(1157) - lu(659) * lu(1139) - lu(1158) = lu(1158) - lu(660) * lu(1139) - lu(1161) = - lu(651) * lu(1160) - lu(1163) = - lu(652) * lu(1160) - lu(1165) = lu(1165) - lu(653) * lu(1160) - lu(1166) = - lu(654) * lu(1160) - lu(1170) = - lu(655) * lu(1160) - lu(1171) = lu(1171) - lu(656) * lu(1160) - lu(1175) = lu(1175) - lu(657) * lu(1160) - lu(1176) = - lu(658) * lu(1160) - lu(1177) = - lu(659) * lu(1160) - lu(1178) = lu(1178) - lu(660) * lu(1160) - lu(1375) = lu(1375) - lu(651) * lu(1366) - lu(1377) = lu(1377) - lu(652) * lu(1366) - lu(1379) = lu(1379) - lu(653) * lu(1366) - lu(1380) = lu(1380) - lu(654) * lu(1366) - lu(1384) = lu(1384) - lu(655) * lu(1366) - lu(1385) = lu(1385) - lu(656) * lu(1366) - lu(1389) = lu(1389) - lu(657) * lu(1366) - lu(1390) = lu(1390) - lu(658) * lu(1366) - lu(1391) = lu(1391) - lu(659) * lu(1366) - lu(1392) = lu(1392) - lu(660) * lu(1366) - lu(1441) = - lu(651) * lu(1440) - lu(1443) = lu(1443) - lu(652) * lu(1440) - lu(1445) = - lu(653) * lu(1440) - lu(1446) = - lu(654) * lu(1440) - lu(1450) = - lu(655) * lu(1440) - lu(1451) = lu(1451) - lu(656) * lu(1440) - lu(1455) = lu(1455) - lu(657) * lu(1440) - lu(1456) = lu(1456) - lu(658) * lu(1440) - lu(1457) = lu(1457) - lu(659) * lu(1440) - lu(1458) = lu(1458) - lu(660) * lu(1440) - lu(1467) = - lu(651) * lu(1465) - lu(1469) = lu(1469) - lu(652) * lu(1465) - lu(1471) = lu(1471) - lu(653) * lu(1465) - lu(1472) = lu(1472) - lu(654) * lu(1465) - lu(1476) = - lu(655) * lu(1465) - lu(1477) = lu(1477) - lu(656) * lu(1465) - lu(1481) = lu(1481) - lu(657) * lu(1465) - lu(1482) = lu(1482) - lu(658) * lu(1465) - lu(1483) = lu(1483) - lu(659) * lu(1465) - lu(1484) = lu(1484) - lu(660) * lu(1465) - lu(1491) = lu(1491) - lu(651) * lu(1490) - lu(1493) = - lu(652) * lu(1490) - lu(1495) = lu(1495) - lu(653) * lu(1490) - lu(1496) = lu(1496) - lu(654) * lu(1490) - lu(1500) = lu(1500) - lu(655) * lu(1490) - lu(1501) = lu(1501) - lu(656) * lu(1490) - lu(1505) = lu(1505) - lu(657) * lu(1490) - lu(1506) = lu(1506) - lu(658) * lu(1490) - lu(1507) = lu(1507) - lu(659) * lu(1490) - lu(1508) = lu(1508) - lu(660) * lu(1490) - lu(662) = 1._r8 / lu(662) - lu(663) = lu(663) * lu(662) - lu(664) = lu(664) * lu(662) - lu(665) = lu(665) * lu(662) - lu(666) = lu(666) * lu(662) - lu(667) = lu(667) * lu(662) - lu(668) = lu(668) * lu(662) - lu(669) = lu(669) * lu(662) - lu(678) = lu(678) - lu(663) * lu(676) - lu(680) = lu(680) - lu(664) * lu(676) - lu(681) = lu(681) - lu(665) * lu(676) - lu(684) = lu(684) - lu(666) * lu(676) - lu(685) = lu(685) - lu(667) * lu(676) - lu(686) = - lu(668) * lu(676) - lu(687) = lu(687) - lu(669) * lu(676) - lu(701) = lu(701) - lu(663) * lu(695) - lu(704) = lu(704) - lu(664) * lu(695) - lu(705) = lu(705) - lu(665) * lu(695) - lu(708) = lu(708) - lu(666) * lu(695) - lu(709) = lu(709) - lu(667) * lu(695) - lu(710) = - lu(668) * lu(695) - lu(711) = lu(711) - lu(669) * lu(695) - lu(723) = lu(723) - lu(663) * lu(719) - lu(725) = lu(725) - lu(664) * lu(719) - lu(726) = lu(726) - lu(665) * lu(719) - lu(729) = lu(729) - lu(666) * lu(719) - lu(730) = lu(730) - lu(667) * lu(719) - lu(731) = - lu(668) * lu(719) - lu(732) = - lu(669) * lu(719) - lu(742) = lu(742) - lu(663) * lu(738) - lu(746) = lu(746) - lu(664) * lu(738) - lu(747) = lu(747) - lu(665) * lu(738) - lu(750) = lu(750) - lu(666) * lu(738) - lu(751) = lu(751) - lu(667) * lu(738) - lu(752) = lu(752) - lu(668) * lu(738) - lu(753) = lu(753) - lu(669) * lu(738) - lu(761) = lu(761) - lu(663) * lu(759) - lu(765) = lu(765) - lu(664) * lu(759) - lu(766) = - lu(665) * lu(759) - lu(769) = lu(769) - lu(666) * lu(759) - lu(770) = lu(770) - lu(667) * lu(759) - lu(771) = - lu(668) * lu(759) - lu(772) = lu(772) - lu(669) * lu(759) - lu(789) = lu(789) - lu(663) * lu(783) - lu(793) = lu(793) - lu(664) * lu(783) - lu(794) = lu(794) - lu(665) * lu(783) - lu(797) = lu(797) - lu(666) * lu(783) - lu(798) = lu(798) - lu(667) * lu(783) - lu(799) = - lu(668) * lu(783) - lu(800) = lu(800) - lu(669) * lu(783) - lu(871) = lu(871) - lu(663) * lu(865) - lu(876) = lu(876) - lu(664) * lu(865) - lu(878) = lu(878) - lu(665) * lu(865) - lu(881) = lu(881) - lu(666) * lu(865) - lu(882) = lu(882) - lu(667) * lu(865) - lu(883) = lu(883) - lu(668) * lu(865) - lu(884) = lu(884) - lu(669) * lu(865) - lu(1009) = lu(1009) - lu(663) * lu(1003) - lu(1018) = lu(1018) - lu(664) * lu(1003) - lu(1020) = lu(1020) - lu(665) * lu(1003) - lu(1024) = lu(1024) - lu(666) * lu(1003) - lu(1025) = lu(1025) - lu(667) * lu(1003) - lu(1026) = lu(1026) - lu(668) * lu(1003) - lu(1027) = lu(1027) - lu(669) * lu(1003) - lu(1105) = lu(1105) - lu(663) * lu(1099) - lu(1114) = lu(1114) - lu(664) * lu(1099) - lu(1116) = lu(1116) - lu(665) * lu(1099) - lu(1120) = lu(1120) - lu(666) * lu(1099) - lu(1121) = lu(1121) - lu(667) * lu(1099) - lu(1122) = lu(1122) - lu(668) * lu(1099) - lu(1123) = lu(1123) - lu(669) * lu(1099) - lu(1240) = lu(1240) - lu(663) * lu(1234) - lu(1248) = lu(1248) - lu(664) * lu(1234) - lu(1250) = lu(1250) - lu(665) * lu(1234) - lu(1254) = lu(1254) - lu(666) * lu(1234) - lu(1255) = lu(1255) - lu(667) * lu(1234) - lu(1256) = lu(1256) - lu(668) * lu(1234) - lu(1257) = lu(1257) - lu(669) * lu(1234) - lu(1275) = lu(1275) - lu(663) * lu(1273) - lu(1285) = lu(1285) - lu(664) * lu(1273) - lu(1287) = lu(1287) - lu(665) * lu(1273) - lu(1291) = lu(1291) - lu(666) * lu(1273) - lu(1292) = lu(1292) - lu(667) * lu(1273) - lu(1293) = lu(1293) - lu(668) * lu(1273) - lu(1294) = lu(1294) - lu(669) * lu(1273) - lu(1373) = lu(1373) - lu(663) * lu(1367) - lu(1383) = lu(1383) - lu(664) * lu(1367) - lu(1385) = lu(1385) - lu(665) * lu(1367) - lu(1389) = lu(1389) - lu(666) * lu(1367) - lu(1390) = lu(1390) - lu(667) * lu(1367) - lu(1391) = lu(1391) - lu(668) * lu(1367) - lu(1392) = lu(1392) - lu(669) * lu(1367) - lu(1418) = lu(1418) - lu(663) * lu(1412) - lu(1427) = lu(1427) - lu(664) * lu(1412) - lu(1429) = lu(1429) - lu(665) * lu(1412) - lu(1433) = lu(1433) - lu(666) * lu(1412) - lu(1434) = lu(1434) - lu(667) * lu(1412) - lu(1435) = lu(1435) - lu(668) * lu(1412) - lu(1436) = lu(1436) - lu(669) * lu(1412) - lu(677) = 1._r8 / lu(677) - lu(678) = lu(678) * lu(677) - lu(679) = lu(679) * lu(677) - lu(680) = lu(680) * lu(677) - lu(681) = lu(681) * lu(677) - lu(682) = lu(682) * lu(677) - lu(683) = lu(683) * lu(677) - lu(684) = lu(684) * lu(677) - lu(685) = lu(685) * lu(677) - lu(686) = lu(686) * lu(677) - lu(687) = lu(687) * lu(677) - lu(688) = lu(688) * lu(677) - lu(701) = lu(701) - lu(678) * lu(696) - lu(702) = lu(702) - lu(679) * lu(696) - lu(704) = lu(704) - lu(680) * lu(696) - lu(705) = lu(705) - lu(681) * lu(696) - lu(706) = lu(706) - lu(682) * lu(696) - lu(707) = lu(707) - lu(683) * lu(696) - lu(708) = lu(708) - lu(684) * lu(696) - lu(709) = lu(709) - lu(685) * lu(696) - lu(710) = lu(710) - lu(686) * lu(696) - lu(711) = lu(711) - lu(687) * lu(696) - lu(712) = lu(712) - lu(688) * lu(696) - lu(723) = lu(723) - lu(678) * lu(720) - lu(724) = lu(724) - lu(679) * lu(720) - lu(725) = lu(725) - lu(680) * lu(720) - lu(726) = lu(726) - lu(681) * lu(720) - lu(727) = lu(727) - lu(682) * lu(720) - lu(728) = lu(728) - lu(683) * lu(720) - lu(729) = lu(729) - lu(684) * lu(720) - lu(730) = lu(730) - lu(685) * lu(720) - lu(731) = lu(731) - lu(686) * lu(720) - lu(732) = lu(732) - lu(687) * lu(720) - lu(733) = lu(733) - lu(688) * lu(720) - lu(789) = lu(789) - lu(678) * lu(784) - lu(790) = lu(790) - lu(679) * lu(784) - lu(793) = lu(793) - lu(680) * lu(784) - lu(794) = lu(794) - lu(681) * lu(784) - lu(795) = lu(795) - lu(682) * lu(784) - lu(796) = lu(796) - lu(683) * lu(784) - lu(797) = lu(797) - lu(684) * lu(784) - lu(798) = lu(798) - lu(685) * lu(784) - lu(799) = lu(799) - lu(686) * lu(784) - lu(800) = lu(800) - lu(687) * lu(784) - lu(801) = lu(801) - lu(688) * lu(784) - lu(871) = lu(871) - lu(678) * lu(866) - lu(872) = lu(872) - lu(679) * lu(866) - lu(876) = lu(876) - lu(680) * lu(866) - lu(878) = lu(878) - lu(681) * lu(866) - lu(879) = lu(879) - lu(682) * lu(866) - lu(880) = lu(880) - lu(683) * lu(866) - lu(881) = lu(881) - lu(684) * lu(866) - lu(882) = lu(882) - lu(685) * lu(866) - lu(883) = lu(883) - lu(686) * lu(866) - lu(884) = lu(884) - lu(687) * lu(866) - lu(885) = lu(885) - lu(688) * lu(866) - lu(1009) = lu(1009) - lu(678) * lu(1004) - lu(1012) = lu(1012) - lu(679) * lu(1004) - lu(1018) = lu(1018) - lu(680) * lu(1004) - lu(1020) = lu(1020) - lu(681) * lu(1004) - lu(1022) = lu(1022) - lu(682) * lu(1004) - lu(1023) = lu(1023) - lu(683) * lu(1004) - lu(1024) = lu(1024) - lu(684) * lu(1004) - lu(1025) = lu(1025) - lu(685) * lu(1004) - lu(1026) = lu(1026) - lu(686) * lu(1004) - lu(1027) = lu(1027) - lu(687) * lu(1004) - lu(1028) = lu(1028) - lu(688) * lu(1004) - lu(1105) = lu(1105) - lu(678) * lu(1100) - lu(1108) = lu(1108) - lu(679) * lu(1100) - lu(1114) = lu(1114) - lu(680) * lu(1100) - lu(1116) = lu(1116) - lu(681) * lu(1100) - lu(1118) = lu(1118) - lu(682) * lu(1100) - lu(1119) = lu(1119) - lu(683) * lu(1100) - lu(1120) = lu(1120) - lu(684) * lu(1100) - lu(1121) = lu(1121) - lu(685) * lu(1100) - lu(1122) = lu(1122) - lu(686) * lu(1100) - lu(1123) = lu(1123) - lu(687) * lu(1100) - lu(1124) = lu(1124) - lu(688) * lu(1100) - lu(1240) = lu(1240) - lu(678) * lu(1235) - lu(1242) = lu(1242) - lu(679) * lu(1235) - lu(1248) = lu(1248) - lu(680) * lu(1235) - lu(1250) = lu(1250) - lu(681) * lu(1235) - lu(1252) = lu(1252) - lu(682) * lu(1235) - lu(1253) = lu(1253) - lu(683) * lu(1235) - lu(1254) = lu(1254) - lu(684) * lu(1235) - lu(1255) = lu(1255) - lu(685) * lu(1235) - lu(1256) = lu(1256) - lu(686) * lu(1235) - lu(1257) = lu(1257) - lu(687) * lu(1235) - lu(1258) = lu(1258) - lu(688) * lu(1235) - lu(1373) = lu(1373) - lu(678) * lu(1368) - lu(1377) = lu(1377) - lu(679) * lu(1368) - lu(1383) = lu(1383) - lu(680) * lu(1368) - lu(1385) = lu(1385) - lu(681) * lu(1368) - lu(1387) = lu(1387) - lu(682) * lu(1368) - lu(1388) = lu(1388) - lu(683) * lu(1368) - lu(1389) = lu(1389) - lu(684) * lu(1368) - lu(1390) = lu(1390) - lu(685) * lu(1368) - lu(1391) = lu(1391) - lu(686) * lu(1368) - lu(1392) = lu(1392) - lu(687) * lu(1368) - lu(1393) = lu(1393) - lu(688) * lu(1368) - lu(1418) = lu(1418) - lu(678) * lu(1413) - lu(1421) = lu(1421) - lu(679) * lu(1413) - lu(1427) = lu(1427) - lu(680) * lu(1413) - lu(1429) = lu(1429) - lu(681) * lu(1413) - lu(1431) = lu(1431) - lu(682) * lu(1413) - lu(1432) = lu(1432) - lu(683) * lu(1413) - lu(1433) = lu(1433) - lu(684) * lu(1413) - lu(1434) = lu(1434) - lu(685) * lu(1413) - lu(1435) = lu(1435) - lu(686) * lu(1413) - lu(1436) = lu(1436) - lu(687) * lu(1413) - lu(1437) = lu(1437) - lu(688) * lu(1413) - END SUBROUTINE lu_fac15 - - SUBROUTINE lu_fac16(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(697) = 1._r8 / lu(697) - lu(698) = lu(698) * lu(697) - lu(699) = lu(699) * lu(697) - lu(700) = lu(700) * lu(697) - lu(701) = lu(701) * lu(697) - lu(702) = lu(702) * lu(697) - lu(703) = lu(703) * lu(697) - lu(704) = lu(704) * lu(697) - lu(705) = lu(705) * lu(697) - lu(706) = lu(706) * lu(697) - lu(707) = lu(707) * lu(697) - lu(708) = lu(708) * lu(697) - lu(709) = lu(709) * lu(697) - lu(710) = lu(710) * lu(697) - lu(711) = lu(711) * lu(697) - lu(712) = lu(712) * lu(697) - lu(786) = lu(786) - lu(698) * lu(785) - lu(787) = lu(787) - lu(699) * lu(785) - lu(788) = lu(788) - lu(700) * lu(785) - lu(789) = lu(789) - lu(701) * lu(785) - lu(790) = lu(790) - lu(702) * lu(785) - lu(792) = lu(792) - lu(703) * lu(785) - lu(793) = lu(793) - lu(704) * lu(785) - lu(794) = lu(794) - lu(705) * lu(785) - lu(795) = lu(795) - lu(706) * lu(785) - lu(796) = lu(796) - lu(707) * lu(785) - lu(797) = lu(797) - lu(708) * lu(785) - lu(798) = lu(798) - lu(709) * lu(785) - lu(799) = lu(799) - lu(710) * lu(785) - lu(800) = lu(800) - lu(711) * lu(785) - lu(801) = lu(801) - lu(712) * lu(785) - lu(868) = lu(868) - lu(698) * lu(867) - lu(869) = lu(869) - lu(699) * lu(867) - lu(870) = lu(870) - lu(700) * lu(867) - lu(871) = lu(871) - lu(701) * lu(867) - lu(872) = lu(872) - lu(702) * lu(867) - lu(874) = lu(874) - lu(703) * lu(867) - lu(876) = lu(876) - lu(704) * lu(867) - lu(878) = lu(878) - lu(705) * lu(867) - lu(879) = lu(879) - lu(706) * lu(867) - lu(880) = lu(880) - lu(707) * lu(867) - lu(881) = lu(881) - lu(708) * lu(867) - lu(882) = lu(882) - lu(709) * lu(867) - lu(883) = lu(883) - lu(710) * lu(867) - lu(884) = lu(884) - lu(711) * lu(867) - lu(885) = lu(885) - lu(712) * lu(867) - lu(1006) = lu(1006) - lu(698) * lu(1005) - lu(1007) = lu(1007) - lu(699) * lu(1005) - lu(1008) = lu(1008) - lu(700) * lu(1005) - lu(1009) = lu(1009) - lu(701) * lu(1005) - lu(1012) = lu(1012) - lu(702) * lu(1005) - lu(1016) = lu(1016) - lu(703) * lu(1005) - lu(1018) = lu(1018) - lu(704) * lu(1005) - lu(1020) = lu(1020) - lu(705) * lu(1005) - lu(1022) = lu(1022) - lu(706) * lu(1005) - lu(1023) = lu(1023) - lu(707) * lu(1005) - lu(1024) = lu(1024) - lu(708) * lu(1005) - lu(1025) = lu(1025) - lu(709) * lu(1005) - lu(1026) = lu(1026) - lu(710) * lu(1005) - lu(1027) = lu(1027) - lu(711) * lu(1005) - lu(1028) = lu(1028) - lu(712) * lu(1005) - lu(1102) = lu(1102) - lu(698) * lu(1101) - lu(1103) = lu(1103) - lu(699) * lu(1101) - lu(1104) = lu(1104) - lu(700) * lu(1101) - lu(1105) = lu(1105) - lu(701) * lu(1101) - lu(1108) = lu(1108) - lu(702) * lu(1101) - lu(1112) = lu(1112) - lu(703) * lu(1101) - lu(1114) = lu(1114) - lu(704) * lu(1101) - lu(1116) = lu(1116) - lu(705) * lu(1101) - lu(1118) = lu(1118) - lu(706) * lu(1101) - lu(1119) = lu(1119) - lu(707) * lu(1101) - lu(1120) = lu(1120) - lu(708) * lu(1101) - lu(1121) = lu(1121) - lu(709) * lu(1101) - lu(1122) = lu(1122) - lu(710) * lu(1101) - lu(1123) = lu(1123) - lu(711) * lu(1101) - lu(1124) = lu(1124) - lu(712) * lu(1101) - lu(1237) = lu(1237) - lu(698) * lu(1236) - lu(1238) = lu(1238) - lu(699) * lu(1236) - lu(1239) = lu(1239) - lu(700) * lu(1236) - lu(1240) = lu(1240) - lu(701) * lu(1236) - lu(1242) = lu(1242) - lu(702) * lu(1236) - lu(1246) = lu(1246) - lu(703) * lu(1236) - lu(1248) = lu(1248) - lu(704) * lu(1236) - lu(1250) = lu(1250) - lu(705) * lu(1236) - lu(1252) = lu(1252) - lu(706) * lu(1236) - lu(1253) = lu(1253) - lu(707) * lu(1236) - lu(1254) = lu(1254) - lu(708) * lu(1236) - lu(1255) = lu(1255) - lu(709) * lu(1236) - lu(1256) = lu(1256) - lu(710) * lu(1236) - lu(1257) = lu(1257) - lu(711) * lu(1236) - lu(1258) = lu(1258) - lu(712) * lu(1236) - lu(1370) = lu(1370) - lu(698) * lu(1369) - lu(1371) = lu(1371) - lu(699) * lu(1369) - lu(1372) = lu(1372) - lu(700) * lu(1369) - lu(1373) = lu(1373) - lu(701) * lu(1369) - lu(1377) = lu(1377) - lu(702) * lu(1369) - lu(1381) = lu(1381) - lu(703) * lu(1369) - lu(1383) = lu(1383) - lu(704) * lu(1369) - lu(1385) = lu(1385) - lu(705) * lu(1369) - lu(1387) = lu(1387) - lu(706) * lu(1369) - lu(1388) = lu(1388) - lu(707) * lu(1369) - lu(1389) = lu(1389) - lu(708) * lu(1369) - lu(1390) = lu(1390) - lu(709) * lu(1369) - lu(1391) = lu(1391) - lu(710) * lu(1369) - lu(1392) = lu(1392) - lu(711) * lu(1369) - lu(1393) = lu(1393) - lu(712) * lu(1369) - lu(1415) = lu(1415) - lu(698) * lu(1414) - lu(1416) = lu(1416) - lu(699) * lu(1414) - lu(1417) = lu(1417) - lu(700) * lu(1414) - lu(1418) = lu(1418) - lu(701) * lu(1414) - lu(1421) = lu(1421) - lu(702) * lu(1414) - lu(1425) = lu(1425) - lu(703) * lu(1414) - lu(1427) = lu(1427) - lu(704) * lu(1414) - lu(1429) = lu(1429) - lu(705) * lu(1414) - lu(1431) = lu(1431) - lu(706) * lu(1414) - lu(1432) = lu(1432) - lu(707) * lu(1414) - lu(1433) = lu(1433) - lu(708) * lu(1414) - lu(1434) = lu(1434) - lu(709) * lu(1414) - lu(1435) = lu(1435) - lu(710) * lu(1414) - lu(1436) = lu(1436) - lu(711) * lu(1414) - lu(1437) = lu(1437) - lu(712) * lu(1414) - lu(721) = 1._r8 / lu(721) - lu(722) = lu(722) * lu(721) - lu(723) = lu(723) * lu(721) - lu(724) = lu(724) * lu(721) - lu(725) = lu(725) * lu(721) - lu(726) = lu(726) * lu(721) - lu(727) = lu(727) * lu(721) - lu(728) = lu(728) * lu(721) - lu(729) = lu(729) * lu(721) - lu(730) = lu(730) * lu(721) - lu(731) = lu(731) * lu(721) - lu(732) = lu(732) * lu(721) - lu(733) = lu(733) * lu(721) - lu(741) = - lu(722) * lu(739) - lu(742) = lu(742) - lu(723) * lu(739) - lu(743) = lu(743) - lu(724) * lu(739) - lu(746) = lu(746) - lu(725) * lu(739) - lu(747) = lu(747) - lu(726) * lu(739) - lu(748) = lu(748) - lu(727) * lu(739) - lu(749) = lu(749) - lu(728) * lu(739) - lu(750) = lu(750) - lu(729) * lu(739) - lu(751) = lu(751) - lu(730) * lu(739) - lu(752) = lu(752) - lu(731) * lu(739) - lu(753) = lu(753) - lu(732) * lu(739) - lu(754) = lu(754) - lu(733) * lu(739) - lu(788) = lu(788) - lu(722) * lu(786) - lu(789) = lu(789) - lu(723) * lu(786) - lu(790) = lu(790) - lu(724) * lu(786) - lu(793) = lu(793) - lu(725) * lu(786) - lu(794) = lu(794) - lu(726) * lu(786) - lu(795) = lu(795) - lu(727) * lu(786) - lu(796) = lu(796) - lu(728) * lu(786) - lu(797) = lu(797) - lu(729) * lu(786) - lu(798) = lu(798) - lu(730) * lu(786) - lu(799) = lu(799) - lu(731) * lu(786) - lu(800) = lu(800) - lu(732) * lu(786) - lu(801) = lu(801) - lu(733) * lu(786) - lu(870) = lu(870) - lu(722) * lu(868) - lu(871) = lu(871) - lu(723) * lu(868) - lu(872) = lu(872) - lu(724) * lu(868) - lu(876) = lu(876) - lu(725) * lu(868) - lu(878) = lu(878) - lu(726) * lu(868) - lu(879) = lu(879) - lu(727) * lu(868) - lu(880) = lu(880) - lu(728) * lu(868) - lu(881) = lu(881) - lu(729) * lu(868) - lu(882) = lu(882) - lu(730) * lu(868) - lu(883) = lu(883) - lu(731) * lu(868) - lu(884) = lu(884) - lu(732) * lu(868) - lu(885) = lu(885) - lu(733) * lu(868) - lu(1008) = lu(1008) - lu(722) * lu(1006) - lu(1009) = lu(1009) - lu(723) * lu(1006) - lu(1012) = lu(1012) - lu(724) * lu(1006) - lu(1018) = lu(1018) - lu(725) * lu(1006) - lu(1020) = lu(1020) - lu(726) * lu(1006) - lu(1022) = lu(1022) - lu(727) * lu(1006) - lu(1023) = lu(1023) - lu(728) * lu(1006) - lu(1024) = lu(1024) - lu(729) * lu(1006) - lu(1025) = lu(1025) - lu(730) * lu(1006) - lu(1026) = lu(1026) - lu(731) * lu(1006) - lu(1027) = lu(1027) - lu(732) * lu(1006) - lu(1028) = lu(1028) - lu(733) * lu(1006) - lu(1104) = lu(1104) - lu(722) * lu(1102) - lu(1105) = lu(1105) - lu(723) * lu(1102) - lu(1108) = lu(1108) - lu(724) * lu(1102) - lu(1114) = lu(1114) - lu(725) * lu(1102) - lu(1116) = lu(1116) - lu(726) * lu(1102) - lu(1118) = lu(1118) - lu(727) * lu(1102) - lu(1119) = lu(1119) - lu(728) * lu(1102) - lu(1120) = lu(1120) - lu(729) * lu(1102) - lu(1121) = lu(1121) - lu(730) * lu(1102) - lu(1122) = lu(1122) - lu(731) * lu(1102) - lu(1123) = lu(1123) - lu(732) * lu(1102) - lu(1124) = lu(1124) - lu(733) * lu(1102) - lu(1239) = lu(1239) - lu(722) * lu(1237) - lu(1240) = lu(1240) - lu(723) * lu(1237) - lu(1242) = lu(1242) - lu(724) * lu(1237) - lu(1248) = lu(1248) - lu(725) * lu(1237) - lu(1250) = lu(1250) - lu(726) * lu(1237) - lu(1252) = lu(1252) - lu(727) * lu(1237) - lu(1253) = lu(1253) - lu(728) * lu(1237) - lu(1254) = lu(1254) - lu(729) * lu(1237) - lu(1255) = lu(1255) - lu(730) * lu(1237) - lu(1256) = lu(1256) - lu(731) * lu(1237) - lu(1257) = lu(1257) - lu(732) * lu(1237) - lu(1258) = lu(1258) - lu(733) * lu(1237) - lu(1372) = lu(1372) - lu(722) * lu(1370) - lu(1373) = lu(1373) - lu(723) * lu(1370) - lu(1377) = lu(1377) - lu(724) * lu(1370) - lu(1383) = lu(1383) - lu(725) * lu(1370) - lu(1385) = lu(1385) - lu(726) * lu(1370) - lu(1387) = lu(1387) - lu(727) * lu(1370) - lu(1388) = lu(1388) - lu(728) * lu(1370) - lu(1389) = lu(1389) - lu(729) * lu(1370) - lu(1390) = lu(1390) - lu(730) * lu(1370) - lu(1391) = lu(1391) - lu(731) * lu(1370) - lu(1392) = lu(1392) - lu(732) * lu(1370) - lu(1393) = lu(1393) - lu(733) * lu(1370) - lu(1417) = lu(1417) - lu(722) * lu(1415) - lu(1418) = lu(1418) - lu(723) * lu(1415) - lu(1421) = lu(1421) - lu(724) * lu(1415) - lu(1427) = lu(1427) - lu(725) * lu(1415) - lu(1429) = lu(1429) - lu(726) * lu(1415) - lu(1431) = lu(1431) - lu(727) * lu(1415) - lu(1432) = lu(1432) - lu(728) * lu(1415) - lu(1433) = lu(1433) - lu(729) * lu(1415) - lu(1434) = lu(1434) - lu(730) * lu(1415) - lu(1435) = lu(1435) - lu(731) * lu(1415) - lu(1436) = lu(1436) - lu(732) * lu(1415) - lu(1437) = lu(1437) - lu(733) * lu(1415) - lu(740) = 1._r8 / lu(740) - lu(741) = lu(741) * lu(740) - lu(742) = lu(742) * lu(740) - lu(743) = lu(743) * lu(740) - lu(744) = lu(744) * lu(740) - lu(745) = lu(745) * lu(740) - lu(746) = lu(746) * lu(740) - lu(747) = lu(747) * lu(740) - lu(748) = lu(748) * lu(740) - lu(749) = lu(749) * lu(740) - lu(750) = lu(750) * lu(740) - lu(751) = lu(751) * lu(740) - lu(752) = lu(752) * lu(740) - lu(753) = lu(753) * lu(740) - lu(754) = lu(754) * lu(740) - lu(788) = lu(788) - lu(741) * lu(787) - lu(789) = lu(789) - lu(742) * lu(787) - lu(790) = lu(790) - lu(743) * lu(787) - lu(791) = - lu(744) * lu(787) - lu(792) = lu(792) - lu(745) * lu(787) - lu(793) = lu(793) - lu(746) * lu(787) - lu(794) = lu(794) - lu(747) * lu(787) - lu(795) = lu(795) - lu(748) * lu(787) - lu(796) = lu(796) - lu(749) * lu(787) - lu(797) = lu(797) - lu(750) * lu(787) - lu(798) = lu(798) - lu(751) * lu(787) - lu(799) = lu(799) - lu(752) * lu(787) - lu(800) = lu(800) - lu(753) * lu(787) - lu(801) = lu(801) - lu(754) * lu(787) - lu(870) = lu(870) - lu(741) * lu(869) - lu(871) = lu(871) - lu(742) * lu(869) - lu(872) = lu(872) - lu(743) * lu(869) - lu(873) = lu(873) - lu(744) * lu(869) - lu(874) = lu(874) - lu(745) * lu(869) - lu(876) = lu(876) - lu(746) * lu(869) - lu(878) = lu(878) - lu(747) * lu(869) - lu(879) = lu(879) - lu(748) * lu(869) - lu(880) = lu(880) - lu(749) * lu(869) - lu(881) = lu(881) - lu(750) * lu(869) - lu(882) = lu(882) - lu(751) * lu(869) - lu(883) = lu(883) - lu(752) * lu(869) - lu(884) = lu(884) - lu(753) * lu(869) - lu(885) = lu(885) - lu(754) * lu(869) - lu(1008) = lu(1008) - lu(741) * lu(1007) - lu(1009) = lu(1009) - lu(742) * lu(1007) - lu(1012) = lu(1012) - lu(743) * lu(1007) - lu(1013) = lu(1013) - lu(744) * lu(1007) - lu(1016) = lu(1016) - lu(745) * lu(1007) - lu(1018) = lu(1018) - lu(746) * lu(1007) - lu(1020) = lu(1020) - lu(747) * lu(1007) - lu(1022) = lu(1022) - lu(748) * lu(1007) - lu(1023) = lu(1023) - lu(749) * lu(1007) - lu(1024) = lu(1024) - lu(750) * lu(1007) - lu(1025) = lu(1025) - lu(751) * lu(1007) - lu(1026) = lu(1026) - lu(752) * lu(1007) - lu(1027) = lu(1027) - lu(753) * lu(1007) - lu(1028) = lu(1028) - lu(754) * lu(1007) - lu(1104) = lu(1104) - lu(741) * lu(1103) - lu(1105) = lu(1105) - lu(742) * lu(1103) - lu(1108) = lu(1108) - lu(743) * lu(1103) - lu(1109) = lu(1109) - lu(744) * lu(1103) - lu(1112) = lu(1112) - lu(745) * lu(1103) - lu(1114) = lu(1114) - lu(746) * lu(1103) - lu(1116) = lu(1116) - lu(747) * lu(1103) - lu(1118) = lu(1118) - lu(748) * lu(1103) - lu(1119) = lu(1119) - lu(749) * lu(1103) - lu(1120) = lu(1120) - lu(750) * lu(1103) - lu(1121) = lu(1121) - lu(751) * lu(1103) - lu(1122) = lu(1122) - lu(752) * lu(1103) - lu(1123) = lu(1123) - lu(753) * lu(1103) - lu(1124) = lu(1124) - lu(754) * lu(1103) - lu(1239) = lu(1239) - lu(741) * lu(1238) - lu(1240) = lu(1240) - lu(742) * lu(1238) - lu(1242) = lu(1242) - lu(743) * lu(1238) - lu(1243) = lu(1243) - lu(744) * lu(1238) - lu(1246) = lu(1246) - lu(745) * lu(1238) - lu(1248) = lu(1248) - lu(746) * lu(1238) - lu(1250) = lu(1250) - lu(747) * lu(1238) - lu(1252) = lu(1252) - lu(748) * lu(1238) - lu(1253) = lu(1253) - lu(749) * lu(1238) - lu(1254) = lu(1254) - lu(750) * lu(1238) - lu(1255) = lu(1255) - lu(751) * lu(1238) - lu(1256) = lu(1256) - lu(752) * lu(1238) - lu(1257) = lu(1257) - lu(753) * lu(1238) - lu(1258) = lu(1258) - lu(754) * lu(1238) - lu(1372) = lu(1372) - lu(741) * lu(1371) - lu(1373) = lu(1373) - lu(742) * lu(1371) - lu(1377) = lu(1377) - lu(743) * lu(1371) - lu(1378) = lu(1378) - lu(744) * lu(1371) - lu(1381) = lu(1381) - lu(745) * lu(1371) - lu(1383) = lu(1383) - lu(746) * lu(1371) - lu(1385) = lu(1385) - lu(747) * lu(1371) - lu(1387) = lu(1387) - lu(748) * lu(1371) - lu(1388) = lu(1388) - lu(749) * lu(1371) - lu(1389) = lu(1389) - lu(750) * lu(1371) - lu(1390) = lu(1390) - lu(751) * lu(1371) - lu(1391) = lu(1391) - lu(752) * lu(1371) - lu(1392) = lu(1392) - lu(753) * lu(1371) - lu(1393) = lu(1393) - lu(754) * lu(1371) - lu(1417) = lu(1417) - lu(741) * lu(1416) - lu(1418) = lu(1418) - lu(742) * lu(1416) - lu(1421) = lu(1421) - lu(743) * lu(1416) - lu(1422) = lu(1422) - lu(744) * lu(1416) - lu(1425) = lu(1425) - lu(745) * lu(1416) - lu(1427) = lu(1427) - lu(746) * lu(1416) - lu(1429) = lu(1429) - lu(747) * lu(1416) - lu(1431) = lu(1431) - lu(748) * lu(1416) - lu(1432) = lu(1432) - lu(749) * lu(1416) - lu(1433) = lu(1433) - lu(750) * lu(1416) - lu(1434) = lu(1434) - lu(751) * lu(1416) - lu(1435) = lu(1435) - lu(752) * lu(1416) - lu(1436) = lu(1436) - lu(753) * lu(1416) - lu(1437) = lu(1437) - lu(754) * lu(1416) - lu(760) = 1._r8 / lu(760) - lu(761) = lu(761) * lu(760) - lu(762) = lu(762) * lu(760) - lu(763) = lu(763) * lu(760) - lu(764) = lu(764) * lu(760) - lu(765) = lu(765) * lu(760) - lu(766) = lu(766) * lu(760) - lu(767) = lu(767) * lu(760) - lu(768) = lu(768) * lu(760) - lu(769) = lu(769) * lu(760) - lu(770) = lu(770) * lu(760) - lu(771) = lu(771) * lu(760) - lu(772) = lu(772) * lu(760) - lu(773) = lu(773) * lu(760) - lu(789) = lu(789) - lu(761) * lu(788) - lu(790) = lu(790) - lu(762) * lu(788) - lu(791) = lu(791) - lu(763) * lu(788) - lu(792) = lu(792) - lu(764) * lu(788) - lu(793) = lu(793) - lu(765) * lu(788) - lu(794) = lu(794) - lu(766) * lu(788) - lu(795) = lu(795) - lu(767) * lu(788) - lu(796) = lu(796) - lu(768) * lu(788) - lu(797) = lu(797) - lu(769) * lu(788) - lu(798) = lu(798) - lu(770) * lu(788) - lu(799) = lu(799) - lu(771) * lu(788) - lu(800) = lu(800) - lu(772) * lu(788) - lu(801) = lu(801) - lu(773) * lu(788) - lu(871) = lu(871) - lu(761) * lu(870) - lu(872) = lu(872) - lu(762) * lu(870) - lu(873) = lu(873) - lu(763) * lu(870) - lu(874) = lu(874) - lu(764) * lu(870) - lu(876) = lu(876) - lu(765) * lu(870) - lu(878) = lu(878) - lu(766) * lu(870) - lu(879) = lu(879) - lu(767) * lu(870) - lu(880) = lu(880) - lu(768) * lu(870) - lu(881) = lu(881) - lu(769) * lu(870) - lu(882) = lu(882) - lu(770) * lu(870) - lu(883) = lu(883) - lu(771) * lu(870) - lu(884) = lu(884) - lu(772) * lu(870) - lu(885) = lu(885) - lu(773) * lu(870) - lu(1009) = lu(1009) - lu(761) * lu(1008) - lu(1012) = lu(1012) - lu(762) * lu(1008) - lu(1013) = lu(1013) - lu(763) * lu(1008) - lu(1016) = lu(1016) - lu(764) * lu(1008) - lu(1018) = lu(1018) - lu(765) * lu(1008) - lu(1020) = lu(1020) - lu(766) * lu(1008) - lu(1022) = lu(1022) - lu(767) * lu(1008) - lu(1023) = lu(1023) - lu(768) * lu(1008) - lu(1024) = lu(1024) - lu(769) * lu(1008) - lu(1025) = lu(1025) - lu(770) * lu(1008) - lu(1026) = lu(1026) - lu(771) * lu(1008) - lu(1027) = lu(1027) - lu(772) * lu(1008) - lu(1028) = lu(1028) - lu(773) * lu(1008) - lu(1105) = lu(1105) - lu(761) * lu(1104) - lu(1108) = lu(1108) - lu(762) * lu(1104) - lu(1109) = lu(1109) - lu(763) * lu(1104) - lu(1112) = lu(1112) - lu(764) * lu(1104) - lu(1114) = lu(1114) - lu(765) * lu(1104) - lu(1116) = lu(1116) - lu(766) * lu(1104) - lu(1118) = lu(1118) - lu(767) * lu(1104) - lu(1119) = lu(1119) - lu(768) * lu(1104) - lu(1120) = lu(1120) - lu(769) * lu(1104) - lu(1121) = lu(1121) - lu(770) * lu(1104) - lu(1122) = lu(1122) - lu(771) * lu(1104) - lu(1123) = lu(1123) - lu(772) * lu(1104) - lu(1124) = lu(1124) - lu(773) * lu(1104) - lu(1240) = lu(1240) - lu(761) * lu(1239) - lu(1242) = lu(1242) - lu(762) * lu(1239) - lu(1243) = lu(1243) - lu(763) * lu(1239) - lu(1246) = lu(1246) - lu(764) * lu(1239) - lu(1248) = lu(1248) - lu(765) * lu(1239) - lu(1250) = lu(1250) - lu(766) * lu(1239) - lu(1252) = lu(1252) - lu(767) * lu(1239) - lu(1253) = lu(1253) - lu(768) * lu(1239) - lu(1254) = lu(1254) - lu(769) * lu(1239) - lu(1255) = lu(1255) - lu(770) * lu(1239) - lu(1256) = lu(1256) - lu(771) * lu(1239) - lu(1257) = lu(1257) - lu(772) * lu(1239) - lu(1258) = lu(1258) - lu(773) * lu(1239) - lu(1275) = lu(1275) - lu(761) * lu(1274) - lu(1279) = lu(1279) - lu(762) * lu(1274) - lu(1280) = lu(1280) - lu(763) * lu(1274) - lu(1283) = lu(1283) - lu(764) * lu(1274) - lu(1285) = lu(1285) - lu(765) * lu(1274) - lu(1287) = lu(1287) - lu(766) * lu(1274) - lu(1289) = lu(1289) - lu(767) * lu(1274) - lu(1290) = lu(1290) - lu(768) * lu(1274) - lu(1291) = lu(1291) - lu(769) * lu(1274) - lu(1292) = lu(1292) - lu(770) * lu(1274) - lu(1293) = lu(1293) - lu(771) * lu(1274) - lu(1294) = lu(1294) - lu(772) * lu(1274) - lu(1295) = lu(1295) - lu(773) * lu(1274) - lu(1373) = lu(1373) - lu(761) * lu(1372) - lu(1377) = lu(1377) - lu(762) * lu(1372) - lu(1378) = lu(1378) - lu(763) * lu(1372) - lu(1381) = lu(1381) - lu(764) * lu(1372) - lu(1383) = lu(1383) - lu(765) * lu(1372) - lu(1385) = lu(1385) - lu(766) * lu(1372) - lu(1387) = lu(1387) - lu(767) * lu(1372) - lu(1388) = lu(1388) - lu(768) * lu(1372) - lu(1389) = lu(1389) - lu(769) * lu(1372) - lu(1390) = lu(1390) - lu(770) * lu(1372) - lu(1391) = lu(1391) - lu(771) * lu(1372) - lu(1392) = lu(1392) - lu(772) * lu(1372) - lu(1393) = lu(1393) - lu(773) * lu(1372) - lu(1418) = lu(1418) - lu(761) * lu(1417) - lu(1421) = lu(1421) - lu(762) * lu(1417) - lu(1422) = lu(1422) - lu(763) * lu(1417) - lu(1425) = lu(1425) - lu(764) * lu(1417) - lu(1427) = lu(1427) - lu(765) * lu(1417) - lu(1429) = lu(1429) - lu(766) * lu(1417) - lu(1431) = lu(1431) - lu(767) * lu(1417) - lu(1432) = lu(1432) - lu(768) * lu(1417) - lu(1433) = lu(1433) - lu(769) * lu(1417) - lu(1434) = lu(1434) - lu(770) * lu(1417) - lu(1435) = lu(1435) - lu(771) * lu(1417) - lu(1436) = lu(1436) - lu(772) * lu(1417) - lu(1437) = lu(1437) - lu(773) * lu(1417) - END SUBROUTINE lu_fac16 - - SUBROUTINE lu_fac17(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(789) = 1._r8 / lu(789) - lu(790) = lu(790) * lu(789) - lu(791) = lu(791) * lu(789) - lu(792) = lu(792) * lu(789) - lu(793) = lu(793) * lu(789) - lu(794) = lu(794) * lu(789) - lu(795) = lu(795) * lu(789) - lu(796) = lu(796) * lu(789) - lu(797) = lu(797) * lu(789) - lu(798) = lu(798) * lu(789) - lu(799) = lu(799) * lu(789) - lu(800) = lu(800) * lu(789) - lu(801) = lu(801) * lu(789) - lu(872) = lu(872) - lu(790) * lu(871) - lu(873) = lu(873) - lu(791) * lu(871) - lu(874) = lu(874) - lu(792) * lu(871) - lu(876) = lu(876) - lu(793) * lu(871) - lu(878) = lu(878) - lu(794) * lu(871) - lu(879) = lu(879) - lu(795) * lu(871) - lu(880) = lu(880) - lu(796) * lu(871) - lu(881) = lu(881) - lu(797) * lu(871) - lu(882) = lu(882) - lu(798) * lu(871) - lu(883) = lu(883) - lu(799) * lu(871) - lu(884) = lu(884) - lu(800) * lu(871) - lu(885) = lu(885) - lu(801) * lu(871) - lu(1012) = lu(1012) - lu(790) * lu(1009) - lu(1013) = lu(1013) - lu(791) * lu(1009) - lu(1016) = lu(1016) - lu(792) * lu(1009) - lu(1018) = lu(1018) - lu(793) * lu(1009) - lu(1020) = lu(1020) - lu(794) * lu(1009) - lu(1022) = lu(1022) - lu(795) * lu(1009) - lu(1023) = lu(1023) - lu(796) * lu(1009) - lu(1024) = lu(1024) - lu(797) * lu(1009) - lu(1025) = lu(1025) - lu(798) * lu(1009) - lu(1026) = lu(1026) - lu(799) * lu(1009) - lu(1027) = lu(1027) - lu(800) * lu(1009) - lu(1028) = lu(1028) - lu(801) * lu(1009) - lu(1108) = lu(1108) - lu(790) * lu(1105) - lu(1109) = lu(1109) - lu(791) * lu(1105) - lu(1112) = lu(1112) - lu(792) * lu(1105) - lu(1114) = lu(1114) - lu(793) * lu(1105) - lu(1116) = lu(1116) - lu(794) * lu(1105) - lu(1118) = lu(1118) - lu(795) * lu(1105) - lu(1119) = lu(1119) - lu(796) * lu(1105) - lu(1120) = lu(1120) - lu(797) * lu(1105) - lu(1121) = lu(1121) - lu(798) * lu(1105) - lu(1122) = lu(1122) - lu(799) * lu(1105) - lu(1123) = lu(1123) - lu(800) * lu(1105) - lu(1124) = lu(1124) - lu(801) * lu(1105) - lu(1143) = lu(1143) - lu(790) * lu(1140) - lu(1144) = lu(1144) - lu(791) * lu(1140) - lu(1147) = lu(1147) - lu(792) * lu(1140) - lu(1149) = lu(1149) - lu(793) * lu(1140) - lu(1151) = lu(1151) - lu(794) * lu(1140) - lu(1153) = lu(1153) - lu(795) * lu(1140) - lu(1154) = lu(1154) - lu(796) * lu(1140) - lu(1155) = lu(1155) - lu(797) * lu(1140) - lu(1156) = lu(1156) - lu(798) * lu(1140) - lu(1157) = lu(1157) - lu(799) * lu(1140) - lu(1158) = lu(1158) - lu(800) * lu(1140) - lu(1159) = lu(1159) - lu(801) * lu(1140) - lu(1242) = lu(1242) - lu(790) * lu(1240) - lu(1243) = lu(1243) - lu(791) * lu(1240) - lu(1246) = lu(1246) - lu(792) * lu(1240) - lu(1248) = lu(1248) - lu(793) * lu(1240) - lu(1250) = lu(1250) - lu(794) * lu(1240) - lu(1252) = lu(1252) - lu(795) * lu(1240) - lu(1253) = lu(1253) - lu(796) * lu(1240) - lu(1254) = lu(1254) - lu(797) * lu(1240) - lu(1255) = lu(1255) - lu(798) * lu(1240) - lu(1256) = lu(1256) - lu(799) * lu(1240) - lu(1257) = lu(1257) - lu(800) * lu(1240) - lu(1258) = lu(1258) - lu(801) * lu(1240) - lu(1279) = lu(1279) - lu(790) * lu(1275) - lu(1280) = lu(1280) - lu(791) * lu(1275) - lu(1283) = lu(1283) - lu(792) * lu(1275) - lu(1285) = lu(1285) - lu(793) * lu(1275) - lu(1287) = lu(1287) - lu(794) * lu(1275) - lu(1289) = lu(1289) - lu(795) * lu(1275) - lu(1290) = lu(1290) - lu(796) * lu(1275) - lu(1291) = lu(1291) - lu(797) * lu(1275) - lu(1292) = lu(1292) - lu(798) * lu(1275) - lu(1293) = lu(1293) - lu(799) * lu(1275) - lu(1294) = lu(1294) - lu(800) * lu(1275) - lu(1295) = lu(1295) - lu(801) * lu(1275) - lu(1377) = lu(1377) - lu(790) * lu(1373) - lu(1378) = lu(1378) - lu(791) * lu(1373) - lu(1381) = lu(1381) - lu(792) * lu(1373) - lu(1383) = lu(1383) - lu(793) * lu(1373) - lu(1385) = lu(1385) - lu(794) * lu(1373) - lu(1387) = lu(1387) - lu(795) * lu(1373) - lu(1388) = lu(1388) - lu(796) * lu(1373) - lu(1389) = lu(1389) - lu(797) * lu(1373) - lu(1390) = lu(1390) - lu(798) * lu(1373) - lu(1391) = lu(1391) - lu(799) * lu(1373) - lu(1392) = lu(1392) - lu(800) * lu(1373) - lu(1393) = lu(1393) - lu(801) * lu(1373) - lu(1421) = lu(1421) - lu(790) * lu(1418) - lu(1422) = lu(1422) - lu(791) * lu(1418) - lu(1425) = lu(1425) - lu(792) * lu(1418) - lu(1427) = lu(1427) - lu(793) * lu(1418) - lu(1429) = lu(1429) - lu(794) * lu(1418) - lu(1431) = lu(1431) - lu(795) * lu(1418) - lu(1432) = lu(1432) - lu(796) * lu(1418) - lu(1433) = lu(1433) - lu(797) * lu(1418) - lu(1434) = lu(1434) - lu(798) * lu(1418) - lu(1435) = lu(1435) - lu(799) * lu(1418) - lu(1436) = lu(1436) - lu(800) * lu(1418) - lu(1437) = lu(1437) - lu(801) * lu(1418) - lu(805) = 1._r8 / lu(805) - lu(806) = lu(806) * lu(805) - lu(807) = lu(807) * lu(805) - lu(808) = lu(808) * lu(805) - lu(809) = lu(809) * lu(805) - lu(810) = lu(810) * lu(805) - lu(811) = lu(811) * lu(805) - lu(812) = lu(812) * lu(805) - lu(813) = lu(813) * lu(805) - lu(814) = lu(814) * lu(805) - lu(815) = lu(815) * lu(805) - lu(816) = lu(816) * lu(805) - lu(817) = lu(817) * lu(805) - lu(818) = lu(818) * lu(805) - lu(902) = - lu(806) * lu(901) - lu(903) = lu(903) - lu(807) * lu(901) - lu(904) = lu(904) - lu(808) * lu(901) - lu(906) = lu(906) - lu(809) * lu(901) - lu(907) = - lu(810) * lu(901) - lu(908) = lu(908) - lu(811) * lu(901) - lu(909) = - lu(812) * lu(901) - lu(910) = lu(910) - lu(813) * lu(901) - lu(911) = - lu(814) * lu(901) - lu(912) = lu(912) - lu(815) * lu(901) - lu(913) = lu(913) - lu(816) * lu(901) - lu(914) = lu(914) - lu(817) * lu(901) - lu(915) = lu(915) - lu(818) * lu(901) - lu(940) = lu(940) - lu(806) * lu(938) - lu(942) = lu(942) - lu(807) * lu(938) - lu(943) = lu(943) - lu(808) * lu(938) - lu(945) = lu(945) - lu(809) * lu(938) - lu(946) = lu(946) - lu(810) * lu(938) - lu(947) = lu(947) - lu(811) * lu(938) - lu(948) = lu(948) - lu(812) * lu(938) - lu(949) = lu(949) - lu(813) * lu(938) - lu(950) = lu(950) - lu(814) * lu(938) - lu(951) = lu(951) - lu(815) * lu(938) - lu(952) = lu(952) - lu(816) * lu(938) - lu(953) = lu(953) - lu(817) * lu(938) - lu(956) = lu(956) - lu(818) * lu(938) - lu(1011) = lu(1011) - lu(806) * lu(1010) - lu(1013) = lu(1013) - lu(807) * lu(1010) - lu(1014) = lu(1014) - lu(808) * lu(1010) - lu(1016) = lu(1016) - lu(809) * lu(1010) - lu(1017) = lu(1017) - lu(810) * lu(1010) - lu(1018) = lu(1018) - lu(811) * lu(1010) - lu(1019) = lu(1019) - lu(812) * lu(1010) - lu(1020) = lu(1020) - lu(813) * lu(1010) - lu(1021) = lu(1021) - lu(814) * lu(1010) - lu(1022) = lu(1022) - lu(815) * lu(1010) - lu(1023) = lu(1023) - lu(816) * lu(1010) - lu(1024) = lu(1024) - lu(817) * lu(1010) - lu(1027) = lu(1027) - lu(818) * lu(1010) - lu(1038) = lu(1038) - lu(806) * lu(1036) - lu(1040) = lu(1040) - lu(807) * lu(1036) - lu(1041) = lu(1041) - lu(808) * lu(1036) - lu(1043) = - lu(809) * lu(1036) - lu(1044) = lu(1044) - lu(810) * lu(1036) - lu(1045) = lu(1045) - lu(811) * lu(1036) - lu(1046) = lu(1046) - lu(812) * lu(1036) - lu(1047) = - lu(813) * lu(1036) - lu(1048) = lu(1048) - lu(814) * lu(1036) - lu(1049) = lu(1049) - lu(815) * lu(1036) - lu(1050) = lu(1050) - lu(816) * lu(1036) - lu(1051) = lu(1051) - lu(817) * lu(1036) - lu(1054) = lu(1054) - lu(818) * lu(1036) - lu(1187) = lu(1187) - lu(806) * lu(1185) - lu(1188) = lu(1188) - lu(807) * lu(1185) - lu(1189) = lu(1189) - lu(808) * lu(1185) - lu(1191) = - lu(809) * lu(1185) - lu(1192) = lu(1192) - lu(810) * lu(1185) - lu(1193) = lu(1193) - lu(811) * lu(1185) - lu(1194) = lu(1194) - lu(812) * lu(1185) - lu(1195) = - lu(813) * lu(1185) - lu(1196) = lu(1196) - lu(814) * lu(1185) - lu(1197) = lu(1197) - lu(815) * lu(1185) - lu(1198) = lu(1198) - lu(816) * lu(1185) - lu(1199) = lu(1199) - lu(817) * lu(1185) - lu(1202) = lu(1202) - lu(818) * lu(1185) - lu(1278) = lu(1278) - lu(806) * lu(1276) - lu(1280) = lu(1280) - lu(807) * lu(1276) - lu(1281) = lu(1281) - lu(808) * lu(1276) - lu(1283) = lu(1283) - lu(809) * lu(1276) - lu(1284) = lu(1284) - lu(810) * lu(1276) - lu(1285) = lu(1285) - lu(811) * lu(1276) - lu(1286) = lu(1286) - lu(812) * lu(1276) - lu(1287) = lu(1287) - lu(813) * lu(1276) - lu(1288) = lu(1288) - lu(814) * lu(1276) - lu(1289) = lu(1289) - lu(815) * lu(1276) - lu(1290) = lu(1290) - lu(816) * lu(1276) - lu(1291) = lu(1291) - lu(817) * lu(1276) - lu(1294) = lu(1294) - lu(818) * lu(1276) - lu(1376) = lu(1376) - lu(806) * lu(1374) - lu(1378) = lu(1378) - lu(807) * lu(1374) - lu(1379) = lu(1379) - lu(808) * lu(1374) - lu(1381) = lu(1381) - lu(809) * lu(1374) - lu(1382) = lu(1382) - lu(810) * lu(1374) - lu(1383) = lu(1383) - lu(811) * lu(1374) - lu(1384) = lu(1384) - lu(812) * lu(1374) - lu(1385) = lu(1385) - lu(813) * lu(1374) - lu(1386) = lu(1386) - lu(814) * lu(1374) - lu(1387) = lu(1387) - lu(815) * lu(1374) - lu(1388) = lu(1388) - lu(816) * lu(1374) - lu(1389) = lu(1389) - lu(817) * lu(1374) - lu(1392) = lu(1392) - lu(818) * lu(1374) - lu(1420) = - lu(806) * lu(1419) - lu(1422) = lu(1422) - lu(807) * lu(1419) - lu(1423) = lu(1423) - lu(808) * lu(1419) - lu(1425) = lu(1425) - lu(809) * lu(1419) - lu(1426) = - lu(810) * lu(1419) - lu(1427) = lu(1427) - lu(811) * lu(1419) - lu(1428) = - lu(812) * lu(1419) - lu(1429) = lu(1429) - lu(813) * lu(1419) - lu(1430) = - lu(814) * lu(1419) - lu(1431) = lu(1431) - lu(815) * lu(1419) - lu(1432) = lu(1432) - lu(816) * lu(1419) - lu(1433) = lu(1433) - lu(817) * lu(1419) - lu(1436) = lu(1436) - lu(818) * lu(1419) - lu(1468) = - lu(806) * lu(1466) - lu(1470) = - lu(807) * lu(1466) - lu(1471) = lu(1471) - lu(808) * lu(1466) - lu(1473) = - lu(809) * lu(1466) - lu(1474) = - lu(810) * lu(1466) - lu(1475) = lu(1475) - lu(811) * lu(1466) - lu(1476) = lu(1476) - lu(812) * lu(1466) - lu(1477) = lu(1477) - lu(813) * lu(1466) - lu(1478) = - lu(814) * lu(1466) - lu(1479) = - lu(815) * lu(1466) - lu(1480) = - lu(816) * lu(1466) - lu(1481) = lu(1481) - lu(817) * lu(1466) - lu(1484) = lu(1484) - lu(818) * lu(1466) - lu(824) = 1._r8 / lu(824) - lu(825) = lu(825) * lu(824) - lu(826) = lu(826) * lu(824) - lu(827) = lu(827) * lu(824) - lu(828) = lu(828) * lu(824) - lu(829) = lu(829) * lu(824) - lu(830) = lu(830) * lu(824) - lu(831) = lu(831) * lu(824) - lu(832) = lu(832) * lu(824) - lu(833) = lu(833) * lu(824) - lu(834) = lu(834) * lu(824) - lu(835) = lu(835) * lu(824) - lu(836) = lu(836) * lu(824) - lu(940) = lu(940) - lu(825) * lu(939) - lu(943) = lu(943) - lu(826) * lu(939) - lu(944) = lu(944) - lu(827) * lu(939) - lu(946) = lu(946) - lu(828) * lu(939) - lu(948) = lu(948) - lu(829) * lu(939) - lu(949) = lu(949) - lu(830) * lu(939) - lu(950) = lu(950) - lu(831) * lu(939) - lu(952) = lu(952) - lu(832) * lu(939) - lu(953) = lu(953) - lu(833) * lu(939) - lu(954) = lu(954) - lu(834) * lu(939) - lu(955) = lu(955) - lu(835) * lu(939) - lu(956) = lu(956) - lu(836) * lu(939) - lu(966) = lu(966) - lu(825) * lu(965) - lu(969) = lu(969) - lu(826) * lu(965) - lu(970) = lu(970) - lu(827) * lu(965) - lu(972) = - lu(828) * lu(965) - lu(974) = lu(974) - lu(829) * lu(965) - lu(975) = lu(975) - lu(830) * lu(965) - lu(976) = - lu(831) * lu(965) - lu(978) = - lu(832) * lu(965) - lu(979) = lu(979) - lu(833) * lu(965) - lu(980) = lu(980) - lu(834) * lu(965) - lu(981) = lu(981) - lu(835) * lu(965) - lu(982) = lu(982) - lu(836) * lu(965) - lu(1038) = lu(1038) - lu(825) * lu(1037) - lu(1041) = lu(1041) - lu(826) * lu(1037) - lu(1042) = - lu(827) * lu(1037) - lu(1044) = lu(1044) - lu(828) * lu(1037) - lu(1046) = lu(1046) - lu(829) * lu(1037) - lu(1047) = lu(1047) - lu(830) * lu(1037) - lu(1048) = lu(1048) - lu(831) * lu(1037) - lu(1050) = lu(1050) - lu(832) * lu(1037) - lu(1051) = lu(1051) - lu(833) * lu(1037) - lu(1052) = lu(1052) - lu(834) * lu(1037) - lu(1053) = lu(1053) - lu(835) * lu(1037) - lu(1054) = lu(1054) - lu(836) * lu(1037) - lu(1107) = lu(1107) - lu(825) * lu(1106) - lu(1110) = lu(1110) - lu(826) * lu(1106) - lu(1111) = lu(1111) - lu(827) * lu(1106) - lu(1113) = lu(1113) - lu(828) * lu(1106) - lu(1115) = lu(1115) - lu(829) * lu(1106) - lu(1116) = lu(1116) - lu(830) * lu(1106) - lu(1117) = lu(1117) - lu(831) * lu(1106) - lu(1119) = lu(1119) - lu(832) * lu(1106) - lu(1120) = lu(1120) - lu(833) * lu(1106) - lu(1121) = lu(1121) - lu(834) * lu(1106) - lu(1122) = lu(1122) - lu(835) * lu(1106) - lu(1123) = lu(1123) - lu(836) * lu(1106) - lu(1142) = lu(1142) - lu(825) * lu(1141) - lu(1145) = lu(1145) - lu(826) * lu(1141) - lu(1146) = lu(1146) - lu(827) * lu(1141) - lu(1148) = lu(1148) - lu(828) * lu(1141) - lu(1150) = lu(1150) - lu(829) * lu(1141) - lu(1151) = lu(1151) - lu(830) * lu(1141) - lu(1152) = - lu(831) * lu(1141) - lu(1154) = lu(1154) - lu(832) * lu(1141) - lu(1155) = lu(1155) - lu(833) * lu(1141) - lu(1156) = lu(1156) - lu(834) * lu(1141) - lu(1157) = lu(1157) - lu(835) * lu(1141) - lu(1158) = lu(1158) - lu(836) * lu(1141) - lu(1162) = - lu(825) * lu(1161) - lu(1165) = lu(1165) - lu(826) * lu(1161) - lu(1166) = lu(1166) - lu(827) * lu(1161) - lu(1168) = - lu(828) * lu(1161) - lu(1170) = lu(1170) - lu(829) * lu(1161) - lu(1171) = lu(1171) - lu(830) * lu(1161) - lu(1172) = - lu(831) * lu(1161) - lu(1174) = - lu(832) * lu(1161) - lu(1175) = lu(1175) - lu(833) * lu(1161) - lu(1176) = lu(1176) - lu(834) * lu(1161) - lu(1177) = lu(1177) - lu(835) * lu(1161) - lu(1178) = lu(1178) - lu(836) * lu(1161) - lu(1187) = lu(1187) - lu(825) * lu(1186) - lu(1189) = lu(1189) - lu(826) * lu(1186) - lu(1190) = - lu(827) * lu(1186) - lu(1192) = lu(1192) - lu(828) * lu(1186) - lu(1194) = lu(1194) - lu(829) * lu(1186) - lu(1195) = lu(1195) - lu(830) * lu(1186) - lu(1196) = lu(1196) - lu(831) * lu(1186) - lu(1198) = lu(1198) - lu(832) * lu(1186) - lu(1199) = lu(1199) - lu(833) * lu(1186) - lu(1200) = lu(1200) - lu(834) * lu(1186) - lu(1201) = lu(1201) - lu(835) * lu(1186) - lu(1202) = lu(1202) - lu(836) * lu(1186) - lu(1278) = lu(1278) - lu(825) * lu(1277) - lu(1281) = lu(1281) - lu(826) * lu(1277) - lu(1282) = lu(1282) - lu(827) * lu(1277) - lu(1284) = lu(1284) - lu(828) * lu(1277) - lu(1286) = lu(1286) - lu(829) * lu(1277) - lu(1287) = lu(1287) - lu(830) * lu(1277) - lu(1288) = lu(1288) - lu(831) * lu(1277) - lu(1290) = lu(1290) - lu(832) * lu(1277) - lu(1291) = lu(1291) - lu(833) * lu(1277) - lu(1292) = lu(1292) - lu(834) * lu(1277) - lu(1293) = lu(1293) - lu(835) * lu(1277) - lu(1294) = lu(1294) - lu(836) * lu(1277) - lu(1376) = lu(1376) - lu(825) * lu(1375) - lu(1379) = lu(1379) - lu(826) * lu(1375) - lu(1380) = lu(1380) - lu(827) * lu(1375) - lu(1382) = lu(1382) - lu(828) * lu(1375) - lu(1384) = lu(1384) - lu(829) * lu(1375) - lu(1385) = lu(1385) - lu(830) * lu(1375) - lu(1386) = lu(1386) - lu(831) * lu(1375) - lu(1388) = lu(1388) - lu(832) * lu(1375) - lu(1389) = lu(1389) - lu(833) * lu(1375) - lu(1390) = lu(1390) - lu(834) * lu(1375) - lu(1391) = lu(1391) - lu(835) * lu(1375) - lu(1392) = lu(1392) - lu(836) * lu(1375) - lu(1442) = - lu(825) * lu(1441) - lu(1445) = lu(1445) - lu(826) * lu(1441) - lu(1446) = lu(1446) - lu(827) * lu(1441) - lu(1448) = - lu(828) * lu(1441) - lu(1450) = lu(1450) - lu(829) * lu(1441) - lu(1451) = lu(1451) - lu(830) * lu(1441) - lu(1452) = - lu(831) * lu(1441) - lu(1454) = lu(1454) - lu(832) * lu(1441) - lu(1455) = lu(1455) - lu(833) * lu(1441) - lu(1456) = lu(1456) - lu(834) * lu(1441) - lu(1457) = lu(1457) - lu(835) * lu(1441) - lu(1458) = lu(1458) - lu(836) * lu(1441) - lu(1468) = lu(1468) - lu(825) * lu(1467) - lu(1471) = lu(1471) - lu(826) * lu(1467) - lu(1472) = lu(1472) - lu(827) * lu(1467) - lu(1474) = lu(1474) - lu(828) * lu(1467) - lu(1476) = lu(1476) - lu(829) * lu(1467) - lu(1477) = lu(1477) - lu(830) * lu(1467) - lu(1478) = lu(1478) - lu(831) * lu(1467) - lu(1480) = lu(1480) - lu(832) * lu(1467) - lu(1481) = lu(1481) - lu(833) * lu(1467) - lu(1482) = lu(1482) - lu(834) * lu(1467) - lu(1483) = lu(1483) - lu(835) * lu(1467) - lu(1484) = lu(1484) - lu(836) * lu(1467) - lu(1492) = lu(1492) - lu(825) * lu(1491) - lu(1495) = lu(1495) - lu(826) * lu(1491) - lu(1496) = lu(1496) - lu(827) * lu(1491) - lu(1498) = - lu(828) * lu(1491) - lu(1500) = lu(1500) - lu(829) * lu(1491) - lu(1501) = lu(1501) - lu(830) * lu(1491) - lu(1502) = - lu(831) * lu(1491) - lu(1504) = lu(1504) - lu(832) * lu(1491) - lu(1505) = lu(1505) - lu(833) * lu(1491) - lu(1506) = lu(1506) - lu(834) * lu(1491) - lu(1507) = lu(1507) - lu(835) * lu(1491) - lu(1508) = lu(1508) - lu(836) * lu(1491) - END SUBROUTINE lu_fac17 - - SUBROUTINE lu_fac18(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(839) = 1._r8 / lu(839) - lu(840) = lu(840) * lu(839) - lu(841) = lu(841) * lu(839) - lu(842) = lu(842) * lu(839) - lu(843) = lu(843) * lu(839) - lu(844) = lu(844) * lu(839) - lu(845) = lu(845) * lu(839) - lu(846) = lu(846) * lu(839) - lu(847) = lu(847) * lu(839) - lu(848) = lu(848) * lu(839) - lu(849) = lu(849) * lu(839) - lu(903) = lu(903) - lu(840) * lu(902) - lu(904) = lu(904) - lu(841) * lu(902) - lu(905) = lu(905) - lu(842) * lu(902) - lu(906) = lu(906) - lu(843) * lu(902) - lu(908) = lu(908) - lu(844) * lu(902) - lu(910) = lu(910) - lu(845) * lu(902) - lu(911) = lu(911) - lu(846) * lu(902) - lu(914) = lu(914) - lu(847) * lu(902) - lu(915) = lu(915) - lu(848) * lu(902) - lu(916) = lu(916) - lu(849) * lu(902) - lu(942) = lu(942) - lu(840) * lu(940) - lu(943) = lu(943) - lu(841) * lu(940) - lu(944) = lu(944) - lu(842) * lu(940) - lu(945) = lu(945) - lu(843) * lu(940) - lu(947) = lu(947) - lu(844) * lu(940) - lu(949) = lu(949) - lu(845) * lu(940) - lu(950) = lu(950) - lu(846) * lu(940) - lu(953) = lu(953) - lu(847) * lu(940) - lu(956) = lu(956) - lu(848) * lu(940) - lu(957) = lu(957) - lu(849) * lu(940) - lu(968) = lu(968) - lu(840) * lu(966) - lu(969) = lu(969) - lu(841) * lu(966) - lu(970) = lu(970) - lu(842) * lu(966) - lu(971) = lu(971) - lu(843) * lu(966) - lu(973) = lu(973) - lu(844) * lu(966) - lu(975) = lu(975) - lu(845) * lu(966) - lu(976) = lu(976) - lu(846) * lu(966) - lu(979) = lu(979) - lu(847) * lu(966) - lu(982) = lu(982) - lu(848) * lu(966) - lu(983) = lu(983) - lu(849) * lu(966) - lu(1013) = lu(1013) - lu(840) * lu(1011) - lu(1014) = lu(1014) - lu(841) * lu(1011) - lu(1015) = lu(1015) - lu(842) * lu(1011) - lu(1016) = lu(1016) - lu(843) * lu(1011) - lu(1018) = lu(1018) - lu(844) * lu(1011) - lu(1020) = lu(1020) - lu(845) * lu(1011) - lu(1021) = lu(1021) - lu(846) * lu(1011) - lu(1024) = lu(1024) - lu(847) * lu(1011) - lu(1027) = lu(1027) - lu(848) * lu(1011) - lu(1028) = lu(1028) - lu(849) * lu(1011) - lu(1040) = lu(1040) - lu(840) * lu(1038) - lu(1041) = lu(1041) - lu(841) * lu(1038) - lu(1042) = lu(1042) - lu(842) * lu(1038) - lu(1043) = lu(1043) - lu(843) * lu(1038) - lu(1045) = lu(1045) - lu(844) * lu(1038) - lu(1047) = lu(1047) - lu(845) * lu(1038) - lu(1048) = lu(1048) - lu(846) * lu(1038) - lu(1051) = lu(1051) - lu(847) * lu(1038) - lu(1054) = lu(1054) - lu(848) * lu(1038) - lu(1055) = lu(1055) - lu(849) * lu(1038) - lu(1109) = lu(1109) - lu(840) * lu(1107) - lu(1110) = lu(1110) - lu(841) * lu(1107) - lu(1111) = lu(1111) - lu(842) * lu(1107) - lu(1112) = lu(1112) - lu(843) * lu(1107) - lu(1114) = lu(1114) - lu(844) * lu(1107) - lu(1116) = lu(1116) - lu(845) * lu(1107) - lu(1117) = lu(1117) - lu(846) * lu(1107) - lu(1120) = lu(1120) - lu(847) * lu(1107) - lu(1123) = lu(1123) - lu(848) * lu(1107) - lu(1124) = lu(1124) - lu(849) * lu(1107) - lu(1144) = lu(1144) - lu(840) * lu(1142) - lu(1145) = lu(1145) - lu(841) * lu(1142) - lu(1146) = lu(1146) - lu(842) * lu(1142) - lu(1147) = lu(1147) - lu(843) * lu(1142) - lu(1149) = lu(1149) - lu(844) * lu(1142) - lu(1151) = lu(1151) - lu(845) * lu(1142) - lu(1152) = lu(1152) - lu(846) * lu(1142) - lu(1155) = lu(1155) - lu(847) * lu(1142) - lu(1158) = lu(1158) - lu(848) * lu(1142) - lu(1159) = lu(1159) - lu(849) * lu(1142) - lu(1164) = lu(1164) - lu(840) * lu(1162) - lu(1165) = lu(1165) - lu(841) * lu(1162) - lu(1166) = lu(1166) - lu(842) * lu(1162) - lu(1167) = lu(1167) - lu(843) * lu(1162) - lu(1169) = lu(1169) - lu(844) * lu(1162) - lu(1171) = lu(1171) - lu(845) * lu(1162) - lu(1172) = lu(1172) - lu(846) * lu(1162) - lu(1175) = lu(1175) - lu(847) * lu(1162) - lu(1178) = lu(1178) - lu(848) * lu(1162) - lu(1179) = - lu(849) * lu(1162) - lu(1188) = lu(1188) - lu(840) * lu(1187) - lu(1189) = lu(1189) - lu(841) * lu(1187) - lu(1190) = lu(1190) - lu(842) * lu(1187) - lu(1191) = lu(1191) - lu(843) * lu(1187) - lu(1193) = lu(1193) - lu(844) * lu(1187) - lu(1195) = lu(1195) - lu(845) * lu(1187) - lu(1196) = lu(1196) - lu(846) * lu(1187) - lu(1199) = lu(1199) - lu(847) * lu(1187) - lu(1202) = lu(1202) - lu(848) * lu(1187) - lu(1203) = - lu(849) * lu(1187) - lu(1243) = lu(1243) - lu(840) * lu(1241) - lu(1244) = lu(1244) - lu(841) * lu(1241) - lu(1245) = lu(1245) - lu(842) * lu(1241) - lu(1246) = lu(1246) - lu(843) * lu(1241) - lu(1248) = lu(1248) - lu(844) * lu(1241) - lu(1250) = lu(1250) - lu(845) * lu(1241) - lu(1251) = lu(1251) - lu(846) * lu(1241) - lu(1254) = lu(1254) - lu(847) * lu(1241) - lu(1257) = lu(1257) - lu(848) * lu(1241) - lu(1258) = lu(1258) - lu(849) * lu(1241) - lu(1280) = lu(1280) - lu(840) * lu(1278) - lu(1281) = lu(1281) - lu(841) * lu(1278) - lu(1282) = lu(1282) - lu(842) * lu(1278) - lu(1283) = lu(1283) - lu(843) * lu(1278) - lu(1285) = lu(1285) - lu(844) * lu(1278) - lu(1287) = lu(1287) - lu(845) * lu(1278) - lu(1288) = lu(1288) - lu(846) * lu(1278) - lu(1291) = lu(1291) - lu(847) * lu(1278) - lu(1294) = lu(1294) - lu(848) * lu(1278) - lu(1295) = lu(1295) - lu(849) * lu(1278) - lu(1378) = lu(1378) - lu(840) * lu(1376) - lu(1379) = lu(1379) - lu(841) * lu(1376) - lu(1380) = lu(1380) - lu(842) * lu(1376) - lu(1381) = lu(1381) - lu(843) * lu(1376) - lu(1383) = lu(1383) - lu(844) * lu(1376) - lu(1385) = lu(1385) - lu(845) * lu(1376) - lu(1386) = lu(1386) - lu(846) * lu(1376) - lu(1389) = lu(1389) - lu(847) * lu(1376) - lu(1392) = lu(1392) - lu(848) * lu(1376) - lu(1393) = lu(1393) - lu(849) * lu(1376) - lu(1422) = lu(1422) - lu(840) * lu(1420) - lu(1423) = lu(1423) - lu(841) * lu(1420) - lu(1424) = - lu(842) * lu(1420) - lu(1425) = lu(1425) - lu(843) * lu(1420) - lu(1427) = lu(1427) - lu(844) * lu(1420) - lu(1429) = lu(1429) - lu(845) * lu(1420) - lu(1430) = lu(1430) - lu(846) * lu(1420) - lu(1433) = lu(1433) - lu(847) * lu(1420) - lu(1436) = lu(1436) - lu(848) * lu(1420) - lu(1437) = lu(1437) - lu(849) * lu(1420) - lu(1444) = - lu(840) * lu(1442) - lu(1445) = lu(1445) - lu(841) * lu(1442) - lu(1446) = lu(1446) - lu(842) * lu(1442) - lu(1447) = - lu(843) * lu(1442) - lu(1449) = - lu(844) * lu(1442) - lu(1451) = lu(1451) - lu(845) * lu(1442) - lu(1452) = lu(1452) - lu(846) * lu(1442) - lu(1455) = lu(1455) - lu(847) * lu(1442) - lu(1458) = lu(1458) - lu(848) * lu(1442) - lu(1459) = - lu(849) * lu(1442) - lu(1470) = lu(1470) - lu(840) * lu(1468) - lu(1471) = lu(1471) - lu(841) * lu(1468) - lu(1472) = lu(1472) - lu(842) * lu(1468) - lu(1473) = lu(1473) - lu(843) * lu(1468) - lu(1475) = lu(1475) - lu(844) * lu(1468) - lu(1477) = lu(1477) - lu(845) * lu(1468) - lu(1478) = lu(1478) - lu(846) * lu(1468) - lu(1481) = lu(1481) - lu(847) * lu(1468) - lu(1484) = lu(1484) - lu(848) * lu(1468) - lu(1485) = - lu(849) * lu(1468) - lu(1494) = - lu(840) * lu(1492) - lu(1495) = lu(1495) - lu(841) * lu(1492) - lu(1496) = lu(1496) - lu(842) * lu(1492) - lu(1497) = - lu(843) * lu(1492) - lu(1499) = lu(1499) - lu(844) * lu(1492) - lu(1501) = lu(1501) - lu(845) * lu(1492) - lu(1502) = lu(1502) - lu(846) * lu(1492) - lu(1505) = lu(1505) - lu(847) * lu(1492) - lu(1508) = lu(1508) - lu(848) * lu(1492) - lu(1509) = lu(1509) - lu(849) * lu(1492) - lu(872) = 1._r8 / lu(872) - lu(873) = lu(873) * lu(872) - lu(874) = lu(874) * lu(872) - lu(875) = lu(875) * lu(872) - lu(876) = lu(876) * lu(872) - lu(877) = lu(877) * lu(872) - lu(878) = lu(878) * lu(872) - lu(879) = lu(879) * lu(872) - lu(880) = lu(880) * lu(872) - lu(881) = lu(881) * lu(872) - lu(882) = lu(882) * lu(872) - lu(883) = lu(883) * lu(872) - lu(884) = lu(884) * lu(872) - lu(885) = lu(885) * lu(872) - lu(942) = lu(942) - lu(873) * lu(941) - lu(945) = lu(945) - lu(874) * lu(941) - lu(946) = lu(946) - lu(875) * lu(941) - lu(947) = lu(947) - lu(876) * lu(941) - lu(948) = lu(948) - lu(877) * lu(941) - lu(949) = lu(949) - lu(878) * lu(941) - lu(951) = lu(951) - lu(879) * lu(941) - lu(952) = lu(952) - lu(880) * lu(941) - lu(953) = lu(953) - lu(881) * lu(941) - lu(954) = lu(954) - lu(882) * lu(941) - lu(955) = lu(955) - lu(883) * lu(941) - lu(956) = lu(956) - lu(884) * lu(941) - lu(957) = lu(957) - lu(885) * lu(941) - lu(968) = lu(968) - lu(873) * lu(967) - lu(971) = lu(971) - lu(874) * lu(967) - lu(972) = lu(972) - lu(875) * lu(967) - lu(973) = lu(973) - lu(876) * lu(967) - lu(974) = lu(974) - lu(877) * lu(967) - lu(975) = lu(975) - lu(878) * lu(967) - lu(977) = lu(977) - lu(879) * lu(967) - lu(978) = lu(978) - lu(880) * lu(967) - lu(979) = lu(979) - lu(881) * lu(967) - lu(980) = lu(980) - lu(882) * lu(967) - lu(981) = lu(981) - lu(883) * lu(967) - lu(982) = lu(982) - lu(884) * lu(967) - lu(983) = lu(983) - lu(885) * lu(967) - lu(1013) = lu(1013) - lu(873) * lu(1012) - lu(1016) = lu(1016) - lu(874) * lu(1012) - lu(1017) = lu(1017) - lu(875) * lu(1012) - lu(1018) = lu(1018) - lu(876) * lu(1012) - lu(1019) = lu(1019) - lu(877) * lu(1012) - lu(1020) = lu(1020) - lu(878) * lu(1012) - lu(1022) = lu(1022) - lu(879) * lu(1012) - lu(1023) = lu(1023) - lu(880) * lu(1012) - lu(1024) = lu(1024) - lu(881) * lu(1012) - lu(1025) = lu(1025) - lu(882) * lu(1012) - lu(1026) = lu(1026) - lu(883) * lu(1012) - lu(1027) = lu(1027) - lu(884) * lu(1012) - lu(1028) = lu(1028) - lu(885) * lu(1012) - lu(1040) = lu(1040) - lu(873) * lu(1039) - lu(1043) = lu(1043) - lu(874) * lu(1039) - lu(1044) = lu(1044) - lu(875) * lu(1039) - lu(1045) = lu(1045) - lu(876) * lu(1039) - lu(1046) = lu(1046) - lu(877) * lu(1039) - lu(1047) = lu(1047) - lu(878) * lu(1039) - lu(1049) = lu(1049) - lu(879) * lu(1039) - lu(1050) = lu(1050) - lu(880) * lu(1039) - lu(1051) = lu(1051) - lu(881) * lu(1039) - lu(1052) = lu(1052) - lu(882) * lu(1039) - lu(1053) = lu(1053) - lu(883) * lu(1039) - lu(1054) = lu(1054) - lu(884) * lu(1039) - lu(1055) = lu(1055) - lu(885) * lu(1039) - lu(1109) = lu(1109) - lu(873) * lu(1108) - lu(1112) = lu(1112) - lu(874) * lu(1108) - lu(1113) = lu(1113) - lu(875) * lu(1108) - lu(1114) = lu(1114) - lu(876) * lu(1108) - lu(1115) = lu(1115) - lu(877) * lu(1108) - lu(1116) = lu(1116) - lu(878) * lu(1108) - lu(1118) = lu(1118) - lu(879) * lu(1108) - lu(1119) = lu(1119) - lu(880) * lu(1108) - lu(1120) = lu(1120) - lu(881) * lu(1108) - lu(1121) = lu(1121) - lu(882) * lu(1108) - lu(1122) = lu(1122) - lu(883) * lu(1108) - lu(1123) = lu(1123) - lu(884) * lu(1108) - lu(1124) = lu(1124) - lu(885) * lu(1108) - lu(1144) = lu(1144) - lu(873) * lu(1143) - lu(1147) = lu(1147) - lu(874) * lu(1143) - lu(1148) = lu(1148) - lu(875) * lu(1143) - lu(1149) = lu(1149) - lu(876) * lu(1143) - lu(1150) = lu(1150) - lu(877) * lu(1143) - lu(1151) = lu(1151) - lu(878) * lu(1143) - lu(1153) = lu(1153) - lu(879) * lu(1143) - lu(1154) = lu(1154) - lu(880) * lu(1143) - lu(1155) = lu(1155) - lu(881) * lu(1143) - lu(1156) = lu(1156) - lu(882) * lu(1143) - lu(1157) = lu(1157) - lu(883) * lu(1143) - lu(1158) = lu(1158) - lu(884) * lu(1143) - lu(1159) = lu(1159) - lu(885) * lu(1143) - lu(1164) = lu(1164) - lu(873) * lu(1163) - lu(1167) = lu(1167) - lu(874) * lu(1163) - lu(1168) = lu(1168) - lu(875) * lu(1163) - lu(1169) = lu(1169) - lu(876) * lu(1163) - lu(1170) = lu(1170) - lu(877) * lu(1163) - lu(1171) = lu(1171) - lu(878) * lu(1163) - lu(1173) = - lu(879) * lu(1163) - lu(1174) = lu(1174) - lu(880) * lu(1163) - lu(1175) = lu(1175) - lu(881) * lu(1163) - lu(1176) = lu(1176) - lu(882) * lu(1163) - lu(1177) = lu(1177) - lu(883) * lu(1163) - lu(1178) = lu(1178) - lu(884) * lu(1163) - lu(1179) = lu(1179) - lu(885) * lu(1163) - lu(1243) = lu(1243) - lu(873) * lu(1242) - lu(1246) = lu(1246) - lu(874) * lu(1242) - lu(1247) = lu(1247) - lu(875) * lu(1242) - lu(1248) = lu(1248) - lu(876) * lu(1242) - lu(1249) = lu(1249) - lu(877) * lu(1242) - lu(1250) = lu(1250) - lu(878) * lu(1242) - lu(1252) = lu(1252) - lu(879) * lu(1242) - lu(1253) = lu(1253) - lu(880) * lu(1242) - lu(1254) = lu(1254) - lu(881) * lu(1242) - lu(1255) = lu(1255) - lu(882) * lu(1242) - lu(1256) = lu(1256) - lu(883) * lu(1242) - lu(1257) = lu(1257) - lu(884) * lu(1242) - lu(1258) = lu(1258) - lu(885) * lu(1242) - lu(1280) = lu(1280) - lu(873) * lu(1279) - lu(1283) = lu(1283) - lu(874) * lu(1279) - lu(1284) = lu(1284) - lu(875) * lu(1279) - lu(1285) = lu(1285) - lu(876) * lu(1279) - lu(1286) = lu(1286) - lu(877) * lu(1279) - lu(1287) = lu(1287) - lu(878) * lu(1279) - lu(1289) = lu(1289) - lu(879) * lu(1279) - lu(1290) = lu(1290) - lu(880) * lu(1279) - lu(1291) = lu(1291) - lu(881) * lu(1279) - lu(1292) = lu(1292) - lu(882) * lu(1279) - lu(1293) = lu(1293) - lu(883) * lu(1279) - lu(1294) = lu(1294) - lu(884) * lu(1279) - lu(1295) = lu(1295) - lu(885) * lu(1279) - lu(1378) = lu(1378) - lu(873) * lu(1377) - lu(1381) = lu(1381) - lu(874) * lu(1377) - lu(1382) = lu(1382) - lu(875) * lu(1377) - lu(1383) = lu(1383) - lu(876) * lu(1377) - lu(1384) = lu(1384) - lu(877) * lu(1377) - lu(1385) = lu(1385) - lu(878) * lu(1377) - lu(1387) = lu(1387) - lu(879) * lu(1377) - lu(1388) = lu(1388) - lu(880) * lu(1377) - lu(1389) = lu(1389) - lu(881) * lu(1377) - lu(1390) = lu(1390) - lu(882) * lu(1377) - lu(1391) = lu(1391) - lu(883) * lu(1377) - lu(1392) = lu(1392) - lu(884) * lu(1377) - lu(1393) = lu(1393) - lu(885) * lu(1377) - lu(1422) = lu(1422) - lu(873) * lu(1421) - lu(1425) = lu(1425) - lu(874) * lu(1421) - lu(1426) = lu(1426) - lu(875) * lu(1421) - lu(1427) = lu(1427) - lu(876) * lu(1421) - lu(1428) = lu(1428) - lu(877) * lu(1421) - lu(1429) = lu(1429) - lu(878) * lu(1421) - lu(1431) = lu(1431) - lu(879) * lu(1421) - lu(1432) = lu(1432) - lu(880) * lu(1421) - lu(1433) = lu(1433) - lu(881) * lu(1421) - lu(1434) = lu(1434) - lu(882) * lu(1421) - lu(1435) = lu(1435) - lu(883) * lu(1421) - lu(1436) = lu(1436) - lu(884) * lu(1421) - lu(1437) = lu(1437) - lu(885) * lu(1421) - lu(1444) = lu(1444) - lu(873) * lu(1443) - lu(1447) = lu(1447) - lu(874) * lu(1443) - lu(1448) = lu(1448) - lu(875) * lu(1443) - lu(1449) = lu(1449) - lu(876) * lu(1443) - lu(1450) = lu(1450) - lu(877) * lu(1443) - lu(1451) = lu(1451) - lu(878) * lu(1443) - lu(1453) = - lu(879) * lu(1443) - lu(1454) = lu(1454) - lu(880) * lu(1443) - lu(1455) = lu(1455) - lu(881) * lu(1443) - lu(1456) = lu(1456) - lu(882) * lu(1443) - lu(1457) = lu(1457) - lu(883) * lu(1443) - lu(1458) = lu(1458) - lu(884) * lu(1443) - lu(1459) = lu(1459) - lu(885) * lu(1443) - lu(1470) = lu(1470) - lu(873) * lu(1469) - lu(1473) = lu(1473) - lu(874) * lu(1469) - lu(1474) = lu(1474) - lu(875) * lu(1469) - lu(1475) = lu(1475) - lu(876) * lu(1469) - lu(1476) = lu(1476) - lu(877) * lu(1469) - lu(1477) = lu(1477) - lu(878) * lu(1469) - lu(1479) = lu(1479) - lu(879) * lu(1469) - lu(1480) = lu(1480) - lu(880) * lu(1469) - lu(1481) = lu(1481) - lu(881) * lu(1469) - lu(1482) = lu(1482) - lu(882) * lu(1469) - lu(1483) = lu(1483) - lu(883) * lu(1469) - lu(1484) = lu(1484) - lu(884) * lu(1469) - lu(1485) = lu(1485) - lu(885) * lu(1469) - lu(1494) = lu(1494) - lu(873) * lu(1493) - lu(1497) = lu(1497) - lu(874) * lu(1493) - lu(1498) = lu(1498) - lu(875) * lu(1493) - lu(1499) = lu(1499) - lu(876) * lu(1493) - lu(1500) = lu(1500) - lu(877) * lu(1493) - lu(1501) = lu(1501) - lu(878) * lu(1493) - lu(1503) = lu(1503) - lu(879) * lu(1493) - lu(1504) = lu(1504) - lu(880) * lu(1493) - lu(1505) = lu(1505) - lu(881) * lu(1493) - lu(1506) = lu(1506) - lu(882) * lu(1493) - lu(1507) = lu(1507) - lu(883) * lu(1493) - lu(1508) = lu(1508) - lu(884) * lu(1493) - lu(1509) = lu(1509) - lu(885) * lu(1493) - lu(903) = 1._r8 / lu(903) - lu(904) = lu(904) * lu(903) - lu(905) = lu(905) * lu(903) - lu(906) = lu(906) * lu(903) - lu(907) = lu(907) * lu(903) - lu(908) = lu(908) * lu(903) - lu(909) = lu(909) * lu(903) - lu(910) = lu(910) * lu(903) - lu(911) = lu(911) * lu(903) - lu(912) = lu(912) * lu(903) - lu(913) = lu(913) * lu(903) - lu(914) = lu(914) * lu(903) - lu(915) = lu(915) * lu(903) - lu(916) = lu(916) * lu(903) - lu(943) = lu(943) - lu(904) * lu(942) - lu(944) = lu(944) - lu(905) * lu(942) - lu(945) = lu(945) - lu(906) * lu(942) - lu(946) = lu(946) - lu(907) * lu(942) - lu(947) = lu(947) - lu(908) * lu(942) - lu(948) = lu(948) - lu(909) * lu(942) - lu(949) = lu(949) - lu(910) * lu(942) - lu(950) = lu(950) - lu(911) * lu(942) - lu(951) = lu(951) - lu(912) * lu(942) - lu(952) = lu(952) - lu(913) * lu(942) - lu(953) = lu(953) - lu(914) * lu(942) - lu(956) = lu(956) - lu(915) * lu(942) - lu(957) = lu(957) - lu(916) * lu(942) - lu(969) = lu(969) - lu(904) * lu(968) - lu(970) = lu(970) - lu(905) * lu(968) - lu(971) = lu(971) - lu(906) * lu(968) - lu(972) = lu(972) - lu(907) * lu(968) - lu(973) = lu(973) - lu(908) * lu(968) - lu(974) = lu(974) - lu(909) * lu(968) - lu(975) = lu(975) - lu(910) * lu(968) - lu(976) = lu(976) - lu(911) * lu(968) - lu(977) = lu(977) - lu(912) * lu(968) - lu(978) = lu(978) - lu(913) * lu(968) - lu(979) = lu(979) - lu(914) * lu(968) - lu(982) = lu(982) - lu(915) * lu(968) - lu(983) = lu(983) - lu(916) * lu(968) - lu(1014) = lu(1014) - lu(904) * lu(1013) - lu(1015) = lu(1015) - lu(905) * lu(1013) - lu(1016) = lu(1016) - lu(906) * lu(1013) - lu(1017) = lu(1017) - lu(907) * lu(1013) - lu(1018) = lu(1018) - lu(908) * lu(1013) - lu(1019) = lu(1019) - lu(909) * lu(1013) - lu(1020) = lu(1020) - lu(910) * lu(1013) - lu(1021) = lu(1021) - lu(911) * lu(1013) - lu(1022) = lu(1022) - lu(912) * lu(1013) - lu(1023) = lu(1023) - lu(913) * lu(1013) - lu(1024) = lu(1024) - lu(914) * lu(1013) - lu(1027) = lu(1027) - lu(915) * lu(1013) - lu(1028) = lu(1028) - lu(916) * lu(1013) - lu(1041) = lu(1041) - lu(904) * lu(1040) - lu(1042) = lu(1042) - lu(905) * lu(1040) - lu(1043) = lu(1043) - lu(906) * lu(1040) - lu(1044) = lu(1044) - lu(907) * lu(1040) - lu(1045) = lu(1045) - lu(908) * lu(1040) - lu(1046) = lu(1046) - lu(909) * lu(1040) - lu(1047) = lu(1047) - lu(910) * lu(1040) - lu(1048) = lu(1048) - lu(911) * lu(1040) - lu(1049) = lu(1049) - lu(912) * lu(1040) - lu(1050) = lu(1050) - lu(913) * lu(1040) - lu(1051) = lu(1051) - lu(914) * lu(1040) - lu(1054) = lu(1054) - lu(915) * lu(1040) - lu(1055) = lu(1055) - lu(916) * lu(1040) - lu(1110) = lu(1110) - lu(904) * lu(1109) - lu(1111) = lu(1111) - lu(905) * lu(1109) - lu(1112) = lu(1112) - lu(906) * lu(1109) - lu(1113) = lu(1113) - lu(907) * lu(1109) - lu(1114) = lu(1114) - lu(908) * lu(1109) - lu(1115) = lu(1115) - lu(909) * lu(1109) - lu(1116) = lu(1116) - lu(910) * lu(1109) - lu(1117) = lu(1117) - lu(911) * lu(1109) - lu(1118) = lu(1118) - lu(912) * lu(1109) - lu(1119) = lu(1119) - lu(913) * lu(1109) - lu(1120) = lu(1120) - lu(914) * lu(1109) - lu(1123) = lu(1123) - lu(915) * lu(1109) - lu(1124) = lu(1124) - lu(916) * lu(1109) - lu(1145) = lu(1145) - lu(904) * lu(1144) - lu(1146) = lu(1146) - lu(905) * lu(1144) - lu(1147) = lu(1147) - lu(906) * lu(1144) - lu(1148) = lu(1148) - lu(907) * lu(1144) - lu(1149) = lu(1149) - lu(908) * lu(1144) - lu(1150) = lu(1150) - lu(909) * lu(1144) - lu(1151) = lu(1151) - lu(910) * lu(1144) - lu(1152) = lu(1152) - lu(911) * lu(1144) - lu(1153) = lu(1153) - lu(912) * lu(1144) - lu(1154) = lu(1154) - lu(913) * lu(1144) - lu(1155) = lu(1155) - lu(914) * lu(1144) - lu(1158) = lu(1158) - lu(915) * lu(1144) - lu(1159) = lu(1159) - lu(916) * lu(1144) - lu(1165) = lu(1165) - lu(904) * lu(1164) - lu(1166) = lu(1166) - lu(905) * lu(1164) - lu(1167) = lu(1167) - lu(906) * lu(1164) - lu(1168) = lu(1168) - lu(907) * lu(1164) - lu(1169) = lu(1169) - lu(908) * lu(1164) - lu(1170) = lu(1170) - lu(909) * lu(1164) - lu(1171) = lu(1171) - lu(910) * lu(1164) - lu(1172) = lu(1172) - lu(911) * lu(1164) - lu(1173) = lu(1173) - lu(912) * lu(1164) - lu(1174) = lu(1174) - lu(913) * lu(1164) - lu(1175) = lu(1175) - lu(914) * lu(1164) - lu(1178) = lu(1178) - lu(915) * lu(1164) - lu(1179) = lu(1179) - lu(916) * lu(1164) - lu(1189) = lu(1189) - lu(904) * lu(1188) - lu(1190) = lu(1190) - lu(905) * lu(1188) - lu(1191) = lu(1191) - lu(906) * lu(1188) - lu(1192) = lu(1192) - lu(907) * lu(1188) - lu(1193) = lu(1193) - lu(908) * lu(1188) - lu(1194) = lu(1194) - lu(909) * lu(1188) - lu(1195) = lu(1195) - lu(910) * lu(1188) - lu(1196) = lu(1196) - lu(911) * lu(1188) - lu(1197) = lu(1197) - lu(912) * lu(1188) - lu(1198) = lu(1198) - lu(913) * lu(1188) - lu(1199) = lu(1199) - lu(914) * lu(1188) - lu(1202) = lu(1202) - lu(915) * lu(1188) - lu(1203) = lu(1203) - lu(916) * lu(1188) - lu(1244) = lu(1244) - lu(904) * lu(1243) - lu(1245) = lu(1245) - lu(905) * lu(1243) - lu(1246) = lu(1246) - lu(906) * lu(1243) - lu(1247) = lu(1247) - lu(907) * lu(1243) - lu(1248) = lu(1248) - lu(908) * lu(1243) - lu(1249) = lu(1249) - lu(909) * lu(1243) - lu(1250) = lu(1250) - lu(910) * lu(1243) - lu(1251) = lu(1251) - lu(911) * lu(1243) - lu(1252) = lu(1252) - lu(912) * lu(1243) - lu(1253) = lu(1253) - lu(913) * lu(1243) - lu(1254) = lu(1254) - lu(914) * lu(1243) - lu(1257) = lu(1257) - lu(915) * lu(1243) - lu(1258) = lu(1258) - lu(916) * lu(1243) - lu(1281) = lu(1281) - lu(904) * lu(1280) - lu(1282) = lu(1282) - lu(905) * lu(1280) - lu(1283) = lu(1283) - lu(906) * lu(1280) - lu(1284) = lu(1284) - lu(907) * lu(1280) - lu(1285) = lu(1285) - lu(908) * lu(1280) - lu(1286) = lu(1286) - lu(909) * lu(1280) - lu(1287) = lu(1287) - lu(910) * lu(1280) - lu(1288) = lu(1288) - lu(911) * lu(1280) - lu(1289) = lu(1289) - lu(912) * lu(1280) - lu(1290) = lu(1290) - lu(913) * lu(1280) - lu(1291) = lu(1291) - lu(914) * lu(1280) - lu(1294) = lu(1294) - lu(915) * lu(1280) - lu(1295) = lu(1295) - lu(916) * lu(1280) - lu(1379) = lu(1379) - lu(904) * lu(1378) - lu(1380) = lu(1380) - lu(905) * lu(1378) - lu(1381) = lu(1381) - lu(906) * lu(1378) - lu(1382) = lu(1382) - lu(907) * lu(1378) - lu(1383) = lu(1383) - lu(908) * lu(1378) - lu(1384) = lu(1384) - lu(909) * lu(1378) - lu(1385) = lu(1385) - lu(910) * lu(1378) - lu(1386) = lu(1386) - lu(911) * lu(1378) - lu(1387) = lu(1387) - lu(912) * lu(1378) - lu(1388) = lu(1388) - lu(913) * lu(1378) - lu(1389) = lu(1389) - lu(914) * lu(1378) - lu(1392) = lu(1392) - lu(915) * lu(1378) - lu(1393) = lu(1393) - lu(916) * lu(1378) - lu(1423) = lu(1423) - lu(904) * lu(1422) - lu(1424) = lu(1424) - lu(905) * lu(1422) - lu(1425) = lu(1425) - lu(906) * lu(1422) - lu(1426) = lu(1426) - lu(907) * lu(1422) - lu(1427) = lu(1427) - lu(908) * lu(1422) - lu(1428) = lu(1428) - lu(909) * lu(1422) - lu(1429) = lu(1429) - lu(910) * lu(1422) - lu(1430) = lu(1430) - lu(911) * lu(1422) - lu(1431) = lu(1431) - lu(912) * lu(1422) - lu(1432) = lu(1432) - lu(913) * lu(1422) - lu(1433) = lu(1433) - lu(914) * lu(1422) - lu(1436) = lu(1436) - lu(915) * lu(1422) - lu(1437) = lu(1437) - lu(916) * lu(1422) - lu(1445) = lu(1445) - lu(904) * lu(1444) - lu(1446) = lu(1446) - lu(905) * lu(1444) - lu(1447) = lu(1447) - lu(906) * lu(1444) - lu(1448) = lu(1448) - lu(907) * lu(1444) - lu(1449) = lu(1449) - lu(908) * lu(1444) - lu(1450) = lu(1450) - lu(909) * lu(1444) - lu(1451) = lu(1451) - lu(910) * lu(1444) - lu(1452) = lu(1452) - lu(911) * lu(1444) - lu(1453) = lu(1453) - lu(912) * lu(1444) - lu(1454) = lu(1454) - lu(913) * lu(1444) - lu(1455) = lu(1455) - lu(914) * lu(1444) - lu(1458) = lu(1458) - lu(915) * lu(1444) - lu(1459) = lu(1459) - lu(916) * lu(1444) - lu(1471) = lu(1471) - lu(904) * lu(1470) - lu(1472) = lu(1472) - lu(905) * lu(1470) - lu(1473) = lu(1473) - lu(906) * lu(1470) - lu(1474) = lu(1474) - lu(907) * lu(1470) - lu(1475) = lu(1475) - lu(908) * lu(1470) - lu(1476) = lu(1476) - lu(909) * lu(1470) - lu(1477) = lu(1477) - lu(910) * lu(1470) - lu(1478) = lu(1478) - lu(911) * lu(1470) - lu(1479) = lu(1479) - lu(912) * lu(1470) - lu(1480) = lu(1480) - lu(913) * lu(1470) - lu(1481) = lu(1481) - lu(914) * lu(1470) - lu(1484) = lu(1484) - lu(915) * lu(1470) - lu(1485) = lu(1485) - lu(916) * lu(1470) - lu(1495) = lu(1495) - lu(904) * lu(1494) - lu(1496) = lu(1496) - lu(905) * lu(1494) - lu(1497) = lu(1497) - lu(906) * lu(1494) - lu(1498) = lu(1498) - lu(907) * lu(1494) - lu(1499) = lu(1499) - lu(908) * lu(1494) - lu(1500) = lu(1500) - lu(909) * lu(1494) - lu(1501) = lu(1501) - lu(910) * lu(1494) - lu(1502) = lu(1502) - lu(911) * lu(1494) - lu(1503) = lu(1503) - lu(912) * lu(1494) - lu(1504) = lu(1504) - lu(913) * lu(1494) - lu(1505) = lu(1505) - lu(914) * lu(1494) - lu(1508) = lu(1508) - lu(915) * lu(1494) - lu(1509) = lu(1509) - lu(916) * lu(1494) - END SUBROUTINE lu_fac18 - - SUBROUTINE lu_fac19(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(943) = 1._r8 / lu(943) - lu(944) = lu(944) * lu(943) - lu(945) = lu(945) * lu(943) - lu(946) = lu(946) * lu(943) - lu(947) = lu(947) * lu(943) - lu(948) = lu(948) * lu(943) - lu(949) = lu(949) * lu(943) - lu(950) = lu(950) * lu(943) - lu(951) = lu(951) * lu(943) - lu(952) = lu(952) * lu(943) - lu(953) = lu(953) * lu(943) - lu(954) = lu(954) * lu(943) - lu(955) = lu(955) * lu(943) - lu(956) = lu(956) * lu(943) - lu(957) = lu(957) * lu(943) - lu(970) = lu(970) - lu(944) * lu(969) - lu(971) = lu(971) - lu(945) * lu(969) - lu(972) = lu(972) - lu(946) * lu(969) - lu(973) = lu(973) - lu(947) * lu(969) - lu(974) = lu(974) - lu(948) * lu(969) - lu(975) = lu(975) - lu(949) * lu(969) - lu(976) = lu(976) - lu(950) * lu(969) - lu(977) = lu(977) - lu(951) * lu(969) - lu(978) = lu(978) - lu(952) * lu(969) - lu(979) = lu(979) - lu(953) * lu(969) - lu(980) = lu(980) - lu(954) * lu(969) - lu(981) = lu(981) - lu(955) * lu(969) - lu(982) = lu(982) - lu(956) * lu(969) - lu(983) = lu(983) - lu(957) * lu(969) - lu(1015) = lu(1015) - lu(944) * lu(1014) - lu(1016) = lu(1016) - lu(945) * lu(1014) - lu(1017) = lu(1017) - lu(946) * lu(1014) - lu(1018) = lu(1018) - lu(947) * lu(1014) - lu(1019) = lu(1019) - lu(948) * lu(1014) - lu(1020) = lu(1020) - lu(949) * lu(1014) - lu(1021) = lu(1021) - lu(950) * lu(1014) - lu(1022) = lu(1022) - lu(951) * lu(1014) - lu(1023) = lu(1023) - lu(952) * lu(1014) - lu(1024) = lu(1024) - lu(953) * lu(1014) - lu(1025) = lu(1025) - lu(954) * lu(1014) - lu(1026) = lu(1026) - lu(955) * lu(1014) - lu(1027) = lu(1027) - lu(956) * lu(1014) - lu(1028) = lu(1028) - lu(957) * lu(1014) - lu(1042) = lu(1042) - lu(944) * lu(1041) - lu(1043) = lu(1043) - lu(945) * lu(1041) - lu(1044) = lu(1044) - lu(946) * lu(1041) - lu(1045) = lu(1045) - lu(947) * lu(1041) - lu(1046) = lu(1046) - lu(948) * lu(1041) - lu(1047) = lu(1047) - lu(949) * lu(1041) - lu(1048) = lu(1048) - lu(950) * lu(1041) - lu(1049) = lu(1049) - lu(951) * lu(1041) - lu(1050) = lu(1050) - lu(952) * lu(1041) - lu(1051) = lu(1051) - lu(953) * lu(1041) - lu(1052) = lu(1052) - lu(954) * lu(1041) - lu(1053) = lu(1053) - lu(955) * lu(1041) - lu(1054) = lu(1054) - lu(956) * lu(1041) - lu(1055) = lu(1055) - lu(957) * lu(1041) - lu(1111) = lu(1111) - lu(944) * lu(1110) - lu(1112) = lu(1112) - lu(945) * lu(1110) - lu(1113) = lu(1113) - lu(946) * lu(1110) - lu(1114) = lu(1114) - lu(947) * lu(1110) - lu(1115) = lu(1115) - lu(948) * lu(1110) - lu(1116) = lu(1116) - lu(949) * lu(1110) - lu(1117) = lu(1117) - lu(950) * lu(1110) - lu(1118) = lu(1118) - lu(951) * lu(1110) - lu(1119) = lu(1119) - lu(952) * lu(1110) - lu(1120) = lu(1120) - lu(953) * lu(1110) - lu(1121) = lu(1121) - lu(954) * lu(1110) - lu(1122) = lu(1122) - lu(955) * lu(1110) - lu(1123) = lu(1123) - lu(956) * lu(1110) - lu(1124) = lu(1124) - lu(957) * lu(1110) - lu(1146) = lu(1146) - lu(944) * lu(1145) - lu(1147) = lu(1147) - lu(945) * lu(1145) - lu(1148) = lu(1148) - lu(946) * lu(1145) - lu(1149) = lu(1149) - lu(947) * lu(1145) - lu(1150) = lu(1150) - lu(948) * lu(1145) - lu(1151) = lu(1151) - lu(949) * lu(1145) - lu(1152) = lu(1152) - lu(950) * lu(1145) - lu(1153) = lu(1153) - lu(951) * lu(1145) - lu(1154) = lu(1154) - lu(952) * lu(1145) - lu(1155) = lu(1155) - lu(953) * lu(1145) - lu(1156) = lu(1156) - lu(954) * lu(1145) - lu(1157) = lu(1157) - lu(955) * lu(1145) - lu(1158) = lu(1158) - lu(956) * lu(1145) - lu(1159) = lu(1159) - lu(957) * lu(1145) - lu(1166) = lu(1166) - lu(944) * lu(1165) - lu(1167) = lu(1167) - lu(945) * lu(1165) - lu(1168) = lu(1168) - lu(946) * lu(1165) - lu(1169) = lu(1169) - lu(947) * lu(1165) - lu(1170) = lu(1170) - lu(948) * lu(1165) - lu(1171) = lu(1171) - lu(949) * lu(1165) - lu(1172) = lu(1172) - lu(950) * lu(1165) - lu(1173) = lu(1173) - lu(951) * lu(1165) - lu(1174) = lu(1174) - lu(952) * lu(1165) - lu(1175) = lu(1175) - lu(953) * lu(1165) - lu(1176) = lu(1176) - lu(954) * lu(1165) - lu(1177) = lu(1177) - lu(955) * lu(1165) - lu(1178) = lu(1178) - lu(956) * lu(1165) - lu(1179) = lu(1179) - lu(957) * lu(1165) - lu(1190) = lu(1190) - lu(944) * lu(1189) - lu(1191) = lu(1191) - lu(945) * lu(1189) - lu(1192) = lu(1192) - lu(946) * lu(1189) - lu(1193) = lu(1193) - lu(947) * lu(1189) - lu(1194) = lu(1194) - lu(948) * lu(1189) - lu(1195) = lu(1195) - lu(949) * lu(1189) - lu(1196) = lu(1196) - lu(950) * lu(1189) - lu(1197) = lu(1197) - lu(951) * lu(1189) - lu(1198) = lu(1198) - lu(952) * lu(1189) - lu(1199) = lu(1199) - lu(953) * lu(1189) - lu(1200) = lu(1200) - lu(954) * lu(1189) - lu(1201) = lu(1201) - lu(955) * lu(1189) - lu(1202) = lu(1202) - lu(956) * lu(1189) - lu(1203) = lu(1203) - lu(957) * lu(1189) - lu(1245) = lu(1245) - lu(944) * lu(1244) - lu(1246) = lu(1246) - lu(945) * lu(1244) - lu(1247) = lu(1247) - lu(946) * lu(1244) - lu(1248) = lu(1248) - lu(947) * lu(1244) - lu(1249) = lu(1249) - lu(948) * lu(1244) - lu(1250) = lu(1250) - lu(949) * lu(1244) - lu(1251) = lu(1251) - lu(950) * lu(1244) - lu(1252) = lu(1252) - lu(951) * lu(1244) - lu(1253) = lu(1253) - lu(952) * lu(1244) - lu(1254) = lu(1254) - lu(953) * lu(1244) - lu(1255) = lu(1255) - lu(954) * lu(1244) - lu(1256) = lu(1256) - lu(955) * lu(1244) - lu(1257) = lu(1257) - lu(956) * lu(1244) - lu(1258) = lu(1258) - lu(957) * lu(1244) - lu(1282) = lu(1282) - lu(944) * lu(1281) - lu(1283) = lu(1283) - lu(945) * lu(1281) - lu(1284) = lu(1284) - lu(946) * lu(1281) - lu(1285) = lu(1285) - lu(947) * lu(1281) - lu(1286) = lu(1286) - lu(948) * lu(1281) - lu(1287) = lu(1287) - lu(949) * lu(1281) - lu(1288) = lu(1288) - lu(950) * lu(1281) - lu(1289) = lu(1289) - lu(951) * lu(1281) - lu(1290) = lu(1290) - lu(952) * lu(1281) - lu(1291) = lu(1291) - lu(953) * lu(1281) - lu(1292) = lu(1292) - lu(954) * lu(1281) - lu(1293) = lu(1293) - lu(955) * lu(1281) - lu(1294) = lu(1294) - lu(956) * lu(1281) - lu(1295) = lu(1295) - lu(957) * lu(1281) - lu(1380) = lu(1380) - lu(944) * lu(1379) - lu(1381) = lu(1381) - lu(945) * lu(1379) - lu(1382) = lu(1382) - lu(946) * lu(1379) - lu(1383) = lu(1383) - lu(947) * lu(1379) - lu(1384) = lu(1384) - lu(948) * lu(1379) - lu(1385) = lu(1385) - lu(949) * lu(1379) - lu(1386) = lu(1386) - lu(950) * lu(1379) - lu(1387) = lu(1387) - lu(951) * lu(1379) - lu(1388) = lu(1388) - lu(952) * lu(1379) - lu(1389) = lu(1389) - lu(953) * lu(1379) - lu(1390) = lu(1390) - lu(954) * lu(1379) - lu(1391) = lu(1391) - lu(955) * lu(1379) - lu(1392) = lu(1392) - lu(956) * lu(1379) - lu(1393) = lu(1393) - lu(957) * lu(1379) - lu(1424) = lu(1424) - lu(944) * lu(1423) - lu(1425) = lu(1425) - lu(945) * lu(1423) - lu(1426) = lu(1426) - lu(946) * lu(1423) - lu(1427) = lu(1427) - lu(947) * lu(1423) - lu(1428) = lu(1428) - lu(948) * lu(1423) - lu(1429) = lu(1429) - lu(949) * lu(1423) - lu(1430) = lu(1430) - lu(950) * lu(1423) - lu(1431) = lu(1431) - lu(951) * lu(1423) - lu(1432) = lu(1432) - lu(952) * lu(1423) - lu(1433) = lu(1433) - lu(953) * lu(1423) - lu(1434) = lu(1434) - lu(954) * lu(1423) - lu(1435) = lu(1435) - lu(955) * lu(1423) - lu(1436) = lu(1436) - lu(956) * lu(1423) - lu(1437) = lu(1437) - lu(957) * lu(1423) - lu(1446) = lu(1446) - lu(944) * lu(1445) - lu(1447) = lu(1447) - lu(945) * lu(1445) - lu(1448) = lu(1448) - lu(946) * lu(1445) - lu(1449) = lu(1449) - lu(947) * lu(1445) - lu(1450) = lu(1450) - lu(948) * lu(1445) - lu(1451) = lu(1451) - lu(949) * lu(1445) - lu(1452) = lu(1452) - lu(950) * lu(1445) - lu(1453) = lu(1453) - lu(951) * lu(1445) - lu(1454) = lu(1454) - lu(952) * lu(1445) - lu(1455) = lu(1455) - lu(953) * lu(1445) - lu(1456) = lu(1456) - lu(954) * lu(1445) - lu(1457) = lu(1457) - lu(955) * lu(1445) - lu(1458) = lu(1458) - lu(956) * lu(1445) - lu(1459) = lu(1459) - lu(957) * lu(1445) - lu(1472) = lu(1472) - lu(944) * lu(1471) - lu(1473) = lu(1473) - lu(945) * lu(1471) - lu(1474) = lu(1474) - lu(946) * lu(1471) - lu(1475) = lu(1475) - lu(947) * lu(1471) - lu(1476) = lu(1476) - lu(948) * lu(1471) - lu(1477) = lu(1477) - lu(949) * lu(1471) - lu(1478) = lu(1478) - lu(950) * lu(1471) - lu(1479) = lu(1479) - lu(951) * lu(1471) - lu(1480) = lu(1480) - lu(952) * lu(1471) - lu(1481) = lu(1481) - lu(953) * lu(1471) - lu(1482) = lu(1482) - lu(954) * lu(1471) - lu(1483) = lu(1483) - lu(955) * lu(1471) - lu(1484) = lu(1484) - lu(956) * lu(1471) - lu(1485) = lu(1485) - lu(957) * lu(1471) - lu(1496) = lu(1496) - lu(944) * lu(1495) - lu(1497) = lu(1497) - lu(945) * lu(1495) - lu(1498) = lu(1498) - lu(946) * lu(1495) - lu(1499) = lu(1499) - lu(947) * lu(1495) - lu(1500) = lu(1500) - lu(948) * lu(1495) - lu(1501) = lu(1501) - lu(949) * lu(1495) - lu(1502) = lu(1502) - lu(950) * lu(1495) - lu(1503) = lu(1503) - lu(951) * lu(1495) - lu(1504) = lu(1504) - lu(952) * lu(1495) - lu(1505) = lu(1505) - lu(953) * lu(1495) - lu(1506) = lu(1506) - lu(954) * lu(1495) - lu(1507) = lu(1507) - lu(955) * lu(1495) - lu(1508) = lu(1508) - lu(956) * lu(1495) - lu(1509) = lu(1509) - lu(957) * lu(1495) - lu(970) = 1._r8 / lu(970) - lu(971) = lu(971) * lu(970) - lu(972) = lu(972) * lu(970) - lu(973) = lu(973) * lu(970) - lu(974) = lu(974) * lu(970) - lu(975) = lu(975) * lu(970) - lu(976) = lu(976) * lu(970) - lu(977) = lu(977) * lu(970) - lu(978) = lu(978) * lu(970) - lu(979) = lu(979) * lu(970) - lu(980) = lu(980) * lu(970) - lu(981) = lu(981) * lu(970) - lu(982) = lu(982) * lu(970) - lu(983) = lu(983) * lu(970) - lu(1016) = lu(1016) - lu(971) * lu(1015) - lu(1017) = lu(1017) - lu(972) * lu(1015) - lu(1018) = lu(1018) - lu(973) * lu(1015) - lu(1019) = lu(1019) - lu(974) * lu(1015) - lu(1020) = lu(1020) - lu(975) * lu(1015) - lu(1021) = lu(1021) - lu(976) * lu(1015) - lu(1022) = lu(1022) - lu(977) * lu(1015) - lu(1023) = lu(1023) - lu(978) * lu(1015) - lu(1024) = lu(1024) - lu(979) * lu(1015) - lu(1025) = lu(1025) - lu(980) * lu(1015) - lu(1026) = lu(1026) - lu(981) * lu(1015) - lu(1027) = lu(1027) - lu(982) * lu(1015) - lu(1028) = lu(1028) - lu(983) * lu(1015) - lu(1043) = lu(1043) - lu(971) * lu(1042) - lu(1044) = lu(1044) - lu(972) * lu(1042) - lu(1045) = lu(1045) - lu(973) * lu(1042) - lu(1046) = lu(1046) - lu(974) * lu(1042) - lu(1047) = lu(1047) - lu(975) * lu(1042) - lu(1048) = lu(1048) - lu(976) * lu(1042) - lu(1049) = lu(1049) - lu(977) * lu(1042) - lu(1050) = lu(1050) - lu(978) * lu(1042) - lu(1051) = lu(1051) - lu(979) * lu(1042) - lu(1052) = lu(1052) - lu(980) * lu(1042) - lu(1053) = lu(1053) - lu(981) * lu(1042) - lu(1054) = lu(1054) - lu(982) * lu(1042) - lu(1055) = lu(1055) - lu(983) * lu(1042) - lu(1112) = lu(1112) - lu(971) * lu(1111) - lu(1113) = lu(1113) - lu(972) * lu(1111) - lu(1114) = lu(1114) - lu(973) * lu(1111) - lu(1115) = lu(1115) - lu(974) * lu(1111) - lu(1116) = lu(1116) - lu(975) * lu(1111) - lu(1117) = lu(1117) - lu(976) * lu(1111) - lu(1118) = lu(1118) - lu(977) * lu(1111) - lu(1119) = lu(1119) - lu(978) * lu(1111) - lu(1120) = lu(1120) - lu(979) * lu(1111) - lu(1121) = lu(1121) - lu(980) * lu(1111) - lu(1122) = lu(1122) - lu(981) * lu(1111) - lu(1123) = lu(1123) - lu(982) * lu(1111) - lu(1124) = lu(1124) - lu(983) * lu(1111) - lu(1147) = lu(1147) - lu(971) * lu(1146) - lu(1148) = lu(1148) - lu(972) * lu(1146) - lu(1149) = lu(1149) - lu(973) * lu(1146) - lu(1150) = lu(1150) - lu(974) * lu(1146) - lu(1151) = lu(1151) - lu(975) * lu(1146) - lu(1152) = lu(1152) - lu(976) * lu(1146) - lu(1153) = lu(1153) - lu(977) * lu(1146) - lu(1154) = lu(1154) - lu(978) * lu(1146) - lu(1155) = lu(1155) - lu(979) * lu(1146) - lu(1156) = lu(1156) - lu(980) * lu(1146) - lu(1157) = lu(1157) - lu(981) * lu(1146) - lu(1158) = lu(1158) - lu(982) * lu(1146) - lu(1159) = lu(1159) - lu(983) * lu(1146) - lu(1167) = lu(1167) - lu(971) * lu(1166) - lu(1168) = lu(1168) - lu(972) * lu(1166) - lu(1169) = lu(1169) - lu(973) * lu(1166) - lu(1170) = lu(1170) - lu(974) * lu(1166) - lu(1171) = lu(1171) - lu(975) * lu(1166) - lu(1172) = lu(1172) - lu(976) * lu(1166) - lu(1173) = lu(1173) - lu(977) * lu(1166) - lu(1174) = lu(1174) - lu(978) * lu(1166) - lu(1175) = lu(1175) - lu(979) * lu(1166) - lu(1176) = lu(1176) - lu(980) * lu(1166) - lu(1177) = lu(1177) - lu(981) * lu(1166) - lu(1178) = lu(1178) - lu(982) * lu(1166) - lu(1179) = lu(1179) - lu(983) * lu(1166) - lu(1191) = lu(1191) - lu(971) * lu(1190) - lu(1192) = lu(1192) - lu(972) * lu(1190) - lu(1193) = lu(1193) - lu(973) * lu(1190) - lu(1194) = lu(1194) - lu(974) * lu(1190) - lu(1195) = lu(1195) - lu(975) * lu(1190) - lu(1196) = lu(1196) - lu(976) * lu(1190) - lu(1197) = lu(1197) - lu(977) * lu(1190) - lu(1198) = lu(1198) - lu(978) * lu(1190) - lu(1199) = lu(1199) - lu(979) * lu(1190) - lu(1200) = lu(1200) - lu(980) * lu(1190) - lu(1201) = lu(1201) - lu(981) * lu(1190) - lu(1202) = lu(1202) - lu(982) * lu(1190) - lu(1203) = lu(1203) - lu(983) * lu(1190) - lu(1246) = lu(1246) - lu(971) * lu(1245) - lu(1247) = lu(1247) - lu(972) * lu(1245) - lu(1248) = lu(1248) - lu(973) * lu(1245) - lu(1249) = lu(1249) - lu(974) * lu(1245) - lu(1250) = lu(1250) - lu(975) * lu(1245) - lu(1251) = lu(1251) - lu(976) * lu(1245) - lu(1252) = lu(1252) - lu(977) * lu(1245) - lu(1253) = lu(1253) - lu(978) * lu(1245) - lu(1254) = lu(1254) - lu(979) * lu(1245) - lu(1255) = lu(1255) - lu(980) * lu(1245) - lu(1256) = lu(1256) - lu(981) * lu(1245) - lu(1257) = lu(1257) - lu(982) * lu(1245) - lu(1258) = lu(1258) - lu(983) * lu(1245) - lu(1283) = lu(1283) - lu(971) * lu(1282) - lu(1284) = lu(1284) - lu(972) * lu(1282) - lu(1285) = lu(1285) - lu(973) * lu(1282) - lu(1286) = lu(1286) - lu(974) * lu(1282) - lu(1287) = lu(1287) - lu(975) * lu(1282) - lu(1288) = lu(1288) - lu(976) * lu(1282) - lu(1289) = lu(1289) - lu(977) * lu(1282) - lu(1290) = lu(1290) - lu(978) * lu(1282) - lu(1291) = lu(1291) - lu(979) * lu(1282) - lu(1292) = lu(1292) - lu(980) * lu(1282) - lu(1293) = lu(1293) - lu(981) * lu(1282) - lu(1294) = lu(1294) - lu(982) * lu(1282) - lu(1295) = lu(1295) - lu(983) * lu(1282) - lu(1381) = lu(1381) - lu(971) * lu(1380) - lu(1382) = lu(1382) - lu(972) * lu(1380) - lu(1383) = lu(1383) - lu(973) * lu(1380) - lu(1384) = lu(1384) - lu(974) * lu(1380) - lu(1385) = lu(1385) - lu(975) * lu(1380) - lu(1386) = lu(1386) - lu(976) * lu(1380) - lu(1387) = lu(1387) - lu(977) * lu(1380) - lu(1388) = lu(1388) - lu(978) * lu(1380) - lu(1389) = lu(1389) - lu(979) * lu(1380) - lu(1390) = lu(1390) - lu(980) * lu(1380) - lu(1391) = lu(1391) - lu(981) * lu(1380) - lu(1392) = lu(1392) - lu(982) * lu(1380) - lu(1393) = lu(1393) - lu(983) * lu(1380) - lu(1425) = lu(1425) - lu(971) * lu(1424) - lu(1426) = lu(1426) - lu(972) * lu(1424) - lu(1427) = lu(1427) - lu(973) * lu(1424) - lu(1428) = lu(1428) - lu(974) * lu(1424) - lu(1429) = lu(1429) - lu(975) * lu(1424) - lu(1430) = lu(1430) - lu(976) * lu(1424) - lu(1431) = lu(1431) - lu(977) * lu(1424) - lu(1432) = lu(1432) - lu(978) * lu(1424) - lu(1433) = lu(1433) - lu(979) * lu(1424) - lu(1434) = lu(1434) - lu(980) * lu(1424) - lu(1435) = lu(1435) - lu(981) * lu(1424) - lu(1436) = lu(1436) - lu(982) * lu(1424) - lu(1437) = lu(1437) - lu(983) * lu(1424) - lu(1447) = lu(1447) - lu(971) * lu(1446) - lu(1448) = lu(1448) - lu(972) * lu(1446) - lu(1449) = lu(1449) - lu(973) * lu(1446) - lu(1450) = lu(1450) - lu(974) * lu(1446) - lu(1451) = lu(1451) - lu(975) * lu(1446) - lu(1452) = lu(1452) - lu(976) * lu(1446) - lu(1453) = lu(1453) - lu(977) * lu(1446) - lu(1454) = lu(1454) - lu(978) * lu(1446) - lu(1455) = lu(1455) - lu(979) * lu(1446) - lu(1456) = lu(1456) - lu(980) * lu(1446) - lu(1457) = lu(1457) - lu(981) * lu(1446) - lu(1458) = lu(1458) - lu(982) * lu(1446) - lu(1459) = lu(1459) - lu(983) * lu(1446) - lu(1473) = lu(1473) - lu(971) * lu(1472) - lu(1474) = lu(1474) - lu(972) * lu(1472) - lu(1475) = lu(1475) - lu(973) * lu(1472) - lu(1476) = lu(1476) - lu(974) * lu(1472) - lu(1477) = lu(1477) - lu(975) * lu(1472) - lu(1478) = lu(1478) - lu(976) * lu(1472) - lu(1479) = lu(1479) - lu(977) * lu(1472) - lu(1480) = lu(1480) - lu(978) * lu(1472) - lu(1481) = lu(1481) - lu(979) * lu(1472) - lu(1482) = lu(1482) - lu(980) * lu(1472) - lu(1483) = lu(1483) - lu(981) * lu(1472) - lu(1484) = lu(1484) - lu(982) * lu(1472) - lu(1485) = lu(1485) - lu(983) * lu(1472) - lu(1497) = lu(1497) - lu(971) * lu(1496) - lu(1498) = lu(1498) - lu(972) * lu(1496) - lu(1499) = lu(1499) - lu(973) * lu(1496) - lu(1500) = lu(1500) - lu(974) * lu(1496) - lu(1501) = lu(1501) - lu(975) * lu(1496) - lu(1502) = lu(1502) - lu(976) * lu(1496) - lu(1503) = lu(1503) - lu(977) * lu(1496) - lu(1504) = lu(1504) - lu(978) * lu(1496) - lu(1505) = lu(1505) - lu(979) * lu(1496) - lu(1506) = lu(1506) - lu(980) * lu(1496) - lu(1507) = lu(1507) - lu(981) * lu(1496) - lu(1508) = lu(1508) - lu(982) * lu(1496) - lu(1509) = lu(1509) - lu(983) * lu(1496) - lu(1016) = 1._r8 / lu(1016) - lu(1017) = lu(1017) * lu(1016) - lu(1018) = lu(1018) * lu(1016) - lu(1019) = lu(1019) * lu(1016) - lu(1020) = lu(1020) * lu(1016) - lu(1021) = lu(1021) * lu(1016) - lu(1022) = lu(1022) * lu(1016) - lu(1023) = lu(1023) * lu(1016) - lu(1024) = lu(1024) * lu(1016) - lu(1025) = lu(1025) * lu(1016) - lu(1026) = lu(1026) * lu(1016) - lu(1027) = lu(1027) * lu(1016) - lu(1028) = lu(1028) * lu(1016) - lu(1044) = lu(1044) - lu(1017) * lu(1043) - lu(1045) = lu(1045) - lu(1018) * lu(1043) - lu(1046) = lu(1046) - lu(1019) * lu(1043) - lu(1047) = lu(1047) - lu(1020) * lu(1043) - lu(1048) = lu(1048) - lu(1021) * lu(1043) - lu(1049) = lu(1049) - lu(1022) * lu(1043) - lu(1050) = lu(1050) - lu(1023) * lu(1043) - lu(1051) = lu(1051) - lu(1024) * lu(1043) - lu(1052) = lu(1052) - lu(1025) * lu(1043) - lu(1053) = lu(1053) - lu(1026) * lu(1043) - lu(1054) = lu(1054) - lu(1027) * lu(1043) - lu(1055) = lu(1055) - lu(1028) * lu(1043) - lu(1113) = lu(1113) - lu(1017) * lu(1112) - lu(1114) = lu(1114) - lu(1018) * lu(1112) - lu(1115) = lu(1115) - lu(1019) * lu(1112) - lu(1116) = lu(1116) - lu(1020) * lu(1112) - lu(1117) = lu(1117) - lu(1021) * lu(1112) - lu(1118) = lu(1118) - lu(1022) * lu(1112) - lu(1119) = lu(1119) - lu(1023) * lu(1112) - lu(1120) = lu(1120) - lu(1024) * lu(1112) - lu(1121) = lu(1121) - lu(1025) * lu(1112) - lu(1122) = lu(1122) - lu(1026) * lu(1112) - lu(1123) = lu(1123) - lu(1027) * lu(1112) - lu(1124) = lu(1124) - lu(1028) * lu(1112) - lu(1148) = lu(1148) - lu(1017) * lu(1147) - lu(1149) = lu(1149) - lu(1018) * lu(1147) - lu(1150) = lu(1150) - lu(1019) * lu(1147) - lu(1151) = lu(1151) - lu(1020) * lu(1147) - lu(1152) = lu(1152) - lu(1021) * lu(1147) - lu(1153) = lu(1153) - lu(1022) * lu(1147) - lu(1154) = lu(1154) - lu(1023) * lu(1147) - lu(1155) = lu(1155) - lu(1024) * lu(1147) - lu(1156) = lu(1156) - lu(1025) * lu(1147) - lu(1157) = lu(1157) - lu(1026) * lu(1147) - lu(1158) = lu(1158) - lu(1027) * lu(1147) - lu(1159) = lu(1159) - lu(1028) * lu(1147) - lu(1168) = lu(1168) - lu(1017) * lu(1167) - lu(1169) = lu(1169) - lu(1018) * lu(1167) - lu(1170) = lu(1170) - lu(1019) * lu(1167) - lu(1171) = lu(1171) - lu(1020) * lu(1167) - lu(1172) = lu(1172) - lu(1021) * lu(1167) - lu(1173) = lu(1173) - lu(1022) * lu(1167) - lu(1174) = lu(1174) - lu(1023) * lu(1167) - lu(1175) = lu(1175) - lu(1024) * lu(1167) - lu(1176) = lu(1176) - lu(1025) * lu(1167) - lu(1177) = lu(1177) - lu(1026) * lu(1167) - lu(1178) = lu(1178) - lu(1027) * lu(1167) - lu(1179) = lu(1179) - lu(1028) * lu(1167) - lu(1192) = lu(1192) - lu(1017) * lu(1191) - lu(1193) = lu(1193) - lu(1018) * lu(1191) - lu(1194) = lu(1194) - lu(1019) * lu(1191) - lu(1195) = lu(1195) - lu(1020) * lu(1191) - lu(1196) = lu(1196) - lu(1021) * lu(1191) - lu(1197) = lu(1197) - lu(1022) * lu(1191) - lu(1198) = lu(1198) - lu(1023) * lu(1191) - lu(1199) = lu(1199) - lu(1024) * lu(1191) - lu(1200) = lu(1200) - lu(1025) * lu(1191) - lu(1201) = lu(1201) - lu(1026) * lu(1191) - lu(1202) = lu(1202) - lu(1027) * lu(1191) - lu(1203) = lu(1203) - lu(1028) * lu(1191) - lu(1247) = lu(1247) - lu(1017) * lu(1246) - lu(1248) = lu(1248) - lu(1018) * lu(1246) - lu(1249) = lu(1249) - lu(1019) * lu(1246) - lu(1250) = lu(1250) - lu(1020) * lu(1246) - lu(1251) = lu(1251) - lu(1021) * lu(1246) - lu(1252) = lu(1252) - lu(1022) * lu(1246) - lu(1253) = lu(1253) - lu(1023) * lu(1246) - lu(1254) = lu(1254) - lu(1024) * lu(1246) - lu(1255) = lu(1255) - lu(1025) * lu(1246) - lu(1256) = lu(1256) - lu(1026) * lu(1246) - lu(1257) = lu(1257) - lu(1027) * lu(1246) - lu(1258) = lu(1258) - lu(1028) * lu(1246) - lu(1284) = lu(1284) - lu(1017) * lu(1283) - lu(1285) = lu(1285) - lu(1018) * lu(1283) - lu(1286) = lu(1286) - lu(1019) * lu(1283) - lu(1287) = lu(1287) - lu(1020) * lu(1283) - lu(1288) = lu(1288) - lu(1021) * lu(1283) - lu(1289) = lu(1289) - lu(1022) * lu(1283) - lu(1290) = lu(1290) - lu(1023) * lu(1283) - lu(1291) = lu(1291) - lu(1024) * lu(1283) - lu(1292) = lu(1292) - lu(1025) * lu(1283) - lu(1293) = lu(1293) - lu(1026) * lu(1283) - lu(1294) = lu(1294) - lu(1027) * lu(1283) - lu(1295) = lu(1295) - lu(1028) * lu(1283) - lu(1382) = lu(1382) - lu(1017) * lu(1381) - lu(1383) = lu(1383) - lu(1018) * lu(1381) - lu(1384) = lu(1384) - lu(1019) * lu(1381) - lu(1385) = lu(1385) - lu(1020) * lu(1381) - lu(1386) = lu(1386) - lu(1021) * lu(1381) - lu(1387) = lu(1387) - lu(1022) * lu(1381) - lu(1388) = lu(1388) - lu(1023) * lu(1381) - lu(1389) = lu(1389) - lu(1024) * lu(1381) - lu(1390) = lu(1390) - lu(1025) * lu(1381) - lu(1391) = lu(1391) - lu(1026) * lu(1381) - lu(1392) = lu(1392) - lu(1027) * lu(1381) - lu(1393) = lu(1393) - lu(1028) * lu(1381) - lu(1426) = lu(1426) - lu(1017) * lu(1425) - lu(1427) = lu(1427) - lu(1018) * lu(1425) - lu(1428) = lu(1428) - lu(1019) * lu(1425) - lu(1429) = lu(1429) - lu(1020) * lu(1425) - lu(1430) = lu(1430) - lu(1021) * lu(1425) - lu(1431) = lu(1431) - lu(1022) * lu(1425) - lu(1432) = lu(1432) - lu(1023) * lu(1425) - lu(1433) = lu(1433) - lu(1024) * lu(1425) - lu(1434) = lu(1434) - lu(1025) * lu(1425) - lu(1435) = lu(1435) - lu(1026) * lu(1425) - lu(1436) = lu(1436) - lu(1027) * lu(1425) - lu(1437) = lu(1437) - lu(1028) * lu(1425) - lu(1448) = lu(1448) - lu(1017) * lu(1447) - lu(1449) = lu(1449) - lu(1018) * lu(1447) - lu(1450) = lu(1450) - lu(1019) * lu(1447) - lu(1451) = lu(1451) - lu(1020) * lu(1447) - lu(1452) = lu(1452) - lu(1021) * lu(1447) - lu(1453) = lu(1453) - lu(1022) * lu(1447) - lu(1454) = lu(1454) - lu(1023) * lu(1447) - lu(1455) = lu(1455) - lu(1024) * lu(1447) - lu(1456) = lu(1456) - lu(1025) * lu(1447) - lu(1457) = lu(1457) - lu(1026) * lu(1447) - lu(1458) = lu(1458) - lu(1027) * lu(1447) - lu(1459) = lu(1459) - lu(1028) * lu(1447) - lu(1474) = lu(1474) - lu(1017) * lu(1473) - lu(1475) = lu(1475) - lu(1018) * lu(1473) - lu(1476) = lu(1476) - lu(1019) * lu(1473) - lu(1477) = lu(1477) - lu(1020) * lu(1473) - lu(1478) = lu(1478) - lu(1021) * lu(1473) - lu(1479) = lu(1479) - lu(1022) * lu(1473) - lu(1480) = lu(1480) - lu(1023) * lu(1473) - lu(1481) = lu(1481) - lu(1024) * lu(1473) - lu(1482) = lu(1482) - lu(1025) * lu(1473) - lu(1483) = lu(1483) - lu(1026) * lu(1473) - lu(1484) = lu(1484) - lu(1027) * lu(1473) - lu(1485) = lu(1485) - lu(1028) * lu(1473) - lu(1498) = lu(1498) - lu(1017) * lu(1497) - lu(1499) = lu(1499) - lu(1018) * lu(1497) - lu(1500) = lu(1500) - lu(1019) * lu(1497) - lu(1501) = lu(1501) - lu(1020) * lu(1497) - lu(1502) = lu(1502) - lu(1021) * lu(1497) - lu(1503) = lu(1503) - lu(1022) * lu(1497) - lu(1504) = lu(1504) - lu(1023) * lu(1497) - lu(1505) = lu(1505) - lu(1024) * lu(1497) - lu(1506) = lu(1506) - lu(1025) * lu(1497) - lu(1507) = lu(1507) - lu(1026) * lu(1497) - lu(1508) = lu(1508) - lu(1027) * lu(1497) - lu(1509) = lu(1509) - lu(1028) * lu(1497) - lu(1044) = 1._r8 / lu(1044) - lu(1045) = lu(1045) * lu(1044) - lu(1046) = lu(1046) * lu(1044) - lu(1047) = lu(1047) * lu(1044) - lu(1048) = lu(1048) * lu(1044) - lu(1049) = lu(1049) * lu(1044) - lu(1050) = lu(1050) * lu(1044) - lu(1051) = lu(1051) * lu(1044) - lu(1052) = lu(1052) * lu(1044) - lu(1053) = lu(1053) * lu(1044) - lu(1054) = lu(1054) * lu(1044) - lu(1055) = lu(1055) * lu(1044) - lu(1114) = lu(1114) - lu(1045) * lu(1113) - lu(1115) = lu(1115) - lu(1046) * lu(1113) - lu(1116) = lu(1116) - lu(1047) * lu(1113) - lu(1117) = lu(1117) - lu(1048) * lu(1113) - lu(1118) = lu(1118) - lu(1049) * lu(1113) - lu(1119) = lu(1119) - lu(1050) * lu(1113) - lu(1120) = lu(1120) - lu(1051) * lu(1113) - lu(1121) = lu(1121) - lu(1052) * lu(1113) - lu(1122) = lu(1122) - lu(1053) * lu(1113) - lu(1123) = lu(1123) - lu(1054) * lu(1113) - lu(1124) = lu(1124) - lu(1055) * lu(1113) - lu(1149) = lu(1149) - lu(1045) * lu(1148) - lu(1150) = lu(1150) - lu(1046) * lu(1148) - lu(1151) = lu(1151) - lu(1047) * lu(1148) - lu(1152) = lu(1152) - lu(1048) * lu(1148) - lu(1153) = lu(1153) - lu(1049) * lu(1148) - lu(1154) = lu(1154) - lu(1050) * lu(1148) - lu(1155) = lu(1155) - lu(1051) * lu(1148) - lu(1156) = lu(1156) - lu(1052) * lu(1148) - lu(1157) = lu(1157) - lu(1053) * lu(1148) - lu(1158) = lu(1158) - lu(1054) * lu(1148) - lu(1159) = lu(1159) - lu(1055) * lu(1148) - lu(1169) = lu(1169) - lu(1045) * lu(1168) - lu(1170) = lu(1170) - lu(1046) * lu(1168) - lu(1171) = lu(1171) - lu(1047) * lu(1168) - lu(1172) = lu(1172) - lu(1048) * lu(1168) - lu(1173) = lu(1173) - lu(1049) * lu(1168) - lu(1174) = lu(1174) - lu(1050) * lu(1168) - lu(1175) = lu(1175) - lu(1051) * lu(1168) - lu(1176) = lu(1176) - lu(1052) * lu(1168) - lu(1177) = lu(1177) - lu(1053) * lu(1168) - lu(1178) = lu(1178) - lu(1054) * lu(1168) - lu(1179) = lu(1179) - lu(1055) * lu(1168) - lu(1193) = lu(1193) - lu(1045) * lu(1192) - lu(1194) = lu(1194) - lu(1046) * lu(1192) - lu(1195) = lu(1195) - lu(1047) * lu(1192) - lu(1196) = lu(1196) - lu(1048) * lu(1192) - lu(1197) = lu(1197) - lu(1049) * lu(1192) - lu(1198) = lu(1198) - lu(1050) * lu(1192) - lu(1199) = lu(1199) - lu(1051) * lu(1192) - lu(1200) = lu(1200) - lu(1052) * lu(1192) - lu(1201) = lu(1201) - lu(1053) * lu(1192) - lu(1202) = lu(1202) - lu(1054) * lu(1192) - lu(1203) = lu(1203) - lu(1055) * lu(1192) - lu(1248) = lu(1248) - lu(1045) * lu(1247) - lu(1249) = lu(1249) - lu(1046) * lu(1247) - lu(1250) = lu(1250) - lu(1047) * lu(1247) - lu(1251) = lu(1251) - lu(1048) * lu(1247) - lu(1252) = lu(1252) - lu(1049) * lu(1247) - lu(1253) = lu(1253) - lu(1050) * lu(1247) - lu(1254) = lu(1254) - lu(1051) * lu(1247) - lu(1255) = lu(1255) - lu(1052) * lu(1247) - lu(1256) = lu(1256) - lu(1053) * lu(1247) - lu(1257) = lu(1257) - lu(1054) * lu(1247) - lu(1258) = lu(1258) - lu(1055) * lu(1247) - lu(1285) = lu(1285) - lu(1045) * lu(1284) - lu(1286) = lu(1286) - lu(1046) * lu(1284) - lu(1287) = lu(1287) - lu(1047) * lu(1284) - lu(1288) = lu(1288) - lu(1048) * lu(1284) - lu(1289) = lu(1289) - lu(1049) * lu(1284) - lu(1290) = lu(1290) - lu(1050) * lu(1284) - lu(1291) = lu(1291) - lu(1051) * lu(1284) - lu(1292) = lu(1292) - lu(1052) * lu(1284) - lu(1293) = lu(1293) - lu(1053) * lu(1284) - lu(1294) = lu(1294) - lu(1054) * lu(1284) - lu(1295) = lu(1295) - lu(1055) * lu(1284) - lu(1383) = lu(1383) - lu(1045) * lu(1382) - lu(1384) = lu(1384) - lu(1046) * lu(1382) - lu(1385) = lu(1385) - lu(1047) * lu(1382) - lu(1386) = lu(1386) - lu(1048) * lu(1382) - lu(1387) = lu(1387) - lu(1049) * lu(1382) - lu(1388) = lu(1388) - lu(1050) * lu(1382) - lu(1389) = lu(1389) - lu(1051) * lu(1382) - lu(1390) = lu(1390) - lu(1052) * lu(1382) - lu(1391) = lu(1391) - lu(1053) * lu(1382) - lu(1392) = lu(1392) - lu(1054) * lu(1382) - lu(1393) = lu(1393) - lu(1055) * lu(1382) - lu(1427) = lu(1427) - lu(1045) * lu(1426) - lu(1428) = lu(1428) - lu(1046) * lu(1426) - lu(1429) = lu(1429) - lu(1047) * lu(1426) - lu(1430) = lu(1430) - lu(1048) * lu(1426) - lu(1431) = lu(1431) - lu(1049) * lu(1426) - lu(1432) = lu(1432) - lu(1050) * lu(1426) - lu(1433) = lu(1433) - lu(1051) * lu(1426) - lu(1434) = lu(1434) - lu(1052) * lu(1426) - lu(1435) = lu(1435) - lu(1053) * lu(1426) - lu(1436) = lu(1436) - lu(1054) * lu(1426) - lu(1437) = lu(1437) - lu(1055) * lu(1426) - lu(1449) = lu(1449) - lu(1045) * lu(1448) - lu(1450) = lu(1450) - lu(1046) * lu(1448) - lu(1451) = lu(1451) - lu(1047) * lu(1448) - lu(1452) = lu(1452) - lu(1048) * lu(1448) - lu(1453) = lu(1453) - lu(1049) * lu(1448) - lu(1454) = lu(1454) - lu(1050) * lu(1448) - lu(1455) = lu(1455) - lu(1051) * lu(1448) - lu(1456) = lu(1456) - lu(1052) * lu(1448) - lu(1457) = lu(1457) - lu(1053) * lu(1448) - lu(1458) = lu(1458) - lu(1054) * lu(1448) - lu(1459) = lu(1459) - lu(1055) * lu(1448) - lu(1475) = lu(1475) - lu(1045) * lu(1474) - lu(1476) = lu(1476) - lu(1046) * lu(1474) - lu(1477) = lu(1477) - lu(1047) * lu(1474) - lu(1478) = lu(1478) - lu(1048) * lu(1474) - lu(1479) = lu(1479) - lu(1049) * lu(1474) - lu(1480) = lu(1480) - lu(1050) * lu(1474) - lu(1481) = lu(1481) - lu(1051) * lu(1474) - lu(1482) = lu(1482) - lu(1052) * lu(1474) - lu(1483) = lu(1483) - lu(1053) * lu(1474) - lu(1484) = lu(1484) - lu(1054) * lu(1474) - lu(1485) = lu(1485) - lu(1055) * lu(1474) - lu(1499) = lu(1499) - lu(1045) * lu(1498) - lu(1500) = lu(1500) - lu(1046) * lu(1498) - lu(1501) = lu(1501) - lu(1047) * lu(1498) - lu(1502) = lu(1502) - lu(1048) * lu(1498) - lu(1503) = lu(1503) - lu(1049) * lu(1498) - lu(1504) = lu(1504) - lu(1050) * lu(1498) - lu(1505) = lu(1505) - lu(1051) * lu(1498) - lu(1506) = lu(1506) - lu(1052) * lu(1498) - lu(1507) = lu(1507) - lu(1053) * lu(1498) - lu(1508) = lu(1508) - lu(1054) * lu(1498) - lu(1509) = lu(1509) - lu(1055) * lu(1498) - END SUBROUTINE lu_fac19 - - SUBROUTINE lu_fac20(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(1114) = 1._r8 / lu(1114) - lu(1115) = lu(1115) * lu(1114) - lu(1116) = lu(1116) * lu(1114) - lu(1117) = lu(1117) * lu(1114) - lu(1118) = lu(1118) * lu(1114) - lu(1119) = lu(1119) * lu(1114) - lu(1120) = lu(1120) * lu(1114) - lu(1121) = lu(1121) * lu(1114) - lu(1122) = lu(1122) * lu(1114) - lu(1123) = lu(1123) * lu(1114) - lu(1124) = lu(1124) * lu(1114) - lu(1150) = lu(1150) - lu(1115) * lu(1149) - lu(1151) = lu(1151) - lu(1116) * lu(1149) - lu(1152) = lu(1152) - lu(1117) * lu(1149) - lu(1153) = lu(1153) - lu(1118) * lu(1149) - lu(1154) = lu(1154) - lu(1119) * lu(1149) - lu(1155) = lu(1155) - lu(1120) * lu(1149) - lu(1156) = lu(1156) - lu(1121) * lu(1149) - lu(1157) = lu(1157) - lu(1122) * lu(1149) - lu(1158) = lu(1158) - lu(1123) * lu(1149) - lu(1159) = lu(1159) - lu(1124) * lu(1149) - lu(1170) = lu(1170) - lu(1115) * lu(1169) - lu(1171) = lu(1171) - lu(1116) * lu(1169) - lu(1172) = lu(1172) - lu(1117) * lu(1169) - lu(1173) = lu(1173) - lu(1118) * lu(1169) - lu(1174) = lu(1174) - lu(1119) * lu(1169) - lu(1175) = lu(1175) - lu(1120) * lu(1169) - lu(1176) = lu(1176) - lu(1121) * lu(1169) - lu(1177) = lu(1177) - lu(1122) * lu(1169) - lu(1178) = lu(1178) - lu(1123) * lu(1169) - lu(1179) = lu(1179) - lu(1124) * lu(1169) - lu(1194) = lu(1194) - lu(1115) * lu(1193) - lu(1195) = lu(1195) - lu(1116) * lu(1193) - lu(1196) = lu(1196) - lu(1117) * lu(1193) - lu(1197) = lu(1197) - lu(1118) * lu(1193) - lu(1198) = lu(1198) - lu(1119) * lu(1193) - lu(1199) = lu(1199) - lu(1120) * lu(1193) - lu(1200) = lu(1200) - lu(1121) * lu(1193) - lu(1201) = lu(1201) - lu(1122) * lu(1193) - lu(1202) = lu(1202) - lu(1123) * lu(1193) - lu(1203) = lu(1203) - lu(1124) * lu(1193) - lu(1249) = lu(1249) - lu(1115) * lu(1248) - lu(1250) = lu(1250) - lu(1116) * lu(1248) - lu(1251) = lu(1251) - lu(1117) * lu(1248) - lu(1252) = lu(1252) - lu(1118) * lu(1248) - lu(1253) = lu(1253) - lu(1119) * lu(1248) - lu(1254) = lu(1254) - lu(1120) * lu(1248) - lu(1255) = lu(1255) - lu(1121) * lu(1248) - lu(1256) = lu(1256) - lu(1122) * lu(1248) - lu(1257) = lu(1257) - lu(1123) * lu(1248) - lu(1258) = lu(1258) - lu(1124) * lu(1248) - lu(1286) = lu(1286) - lu(1115) * lu(1285) - lu(1287) = lu(1287) - lu(1116) * lu(1285) - lu(1288) = lu(1288) - lu(1117) * lu(1285) - lu(1289) = lu(1289) - lu(1118) * lu(1285) - lu(1290) = lu(1290) - lu(1119) * lu(1285) - lu(1291) = lu(1291) - lu(1120) * lu(1285) - lu(1292) = lu(1292) - lu(1121) * lu(1285) - lu(1293) = lu(1293) - lu(1122) * lu(1285) - lu(1294) = lu(1294) - lu(1123) * lu(1285) - lu(1295) = lu(1295) - lu(1124) * lu(1285) - lu(1384) = lu(1384) - lu(1115) * lu(1383) - lu(1385) = lu(1385) - lu(1116) * lu(1383) - lu(1386) = lu(1386) - lu(1117) * lu(1383) - lu(1387) = lu(1387) - lu(1118) * lu(1383) - lu(1388) = lu(1388) - lu(1119) * lu(1383) - lu(1389) = lu(1389) - lu(1120) * lu(1383) - lu(1390) = lu(1390) - lu(1121) * lu(1383) - lu(1391) = lu(1391) - lu(1122) * lu(1383) - lu(1392) = lu(1392) - lu(1123) * lu(1383) - lu(1393) = lu(1393) - lu(1124) * lu(1383) - lu(1428) = lu(1428) - lu(1115) * lu(1427) - lu(1429) = lu(1429) - lu(1116) * lu(1427) - lu(1430) = lu(1430) - lu(1117) * lu(1427) - lu(1431) = lu(1431) - lu(1118) * lu(1427) - lu(1432) = lu(1432) - lu(1119) * lu(1427) - lu(1433) = lu(1433) - lu(1120) * lu(1427) - lu(1434) = lu(1434) - lu(1121) * lu(1427) - lu(1435) = lu(1435) - lu(1122) * lu(1427) - lu(1436) = lu(1436) - lu(1123) * lu(1427) - lu(1437) = lu(1437) - lu(1124) * lu(1427) - lu(1450) = lu(1450) - lu(1115) * lu(1449) - lu(1451) = lu(1451) - lu(1116) * lu(1449) - lu(1452) = lu(1452) - lu(1117) * lu(1449) - lu(1453) = lu(1453) - lu(1118) * lu(1449) - lu(1454) = lu(1454) - lu(1119) * lu(1449) - lu(1455) = lu(1455) - lu(1120) * lu(1449) - lu(1456) = lu(1456) - lu(1121) * lu(1449) - lu(1457) = lu(1457) - lu(1122) * lu(1449) - lu(1458) = lu(1458) - lu(1123) * lu(1449) - lu(1459) = lu(1459) - lu(1124) * lu(1449) - lu(1476) = lu(1476) - lu(1115) * lu(1475) - lu(1477) = lu(1477) - lu(1116) * lu(1475) - lu(1478) = lu(1478) - lu(1117) * lu(1475) - lu(1479) = lu(1479) - lu(1118) * lu(1475) - lu(1480) = lu(1480) - lu(1119) * lu(1475) - lu(1481) = lu(1481) - lu(1120) * lu(1475) - lu(1482) = lu(1482) - lu(1121) * lu(1475) - lu(1483) = lu(1483) - lu(1122) * lu(1475) - lu(1484) = lu(1484) - lu(1123) * lu(1475) - lu(1485) = lu(1485) - lu(1124) * lu(1475) - lu(1500) = lu(1500) - lu(1115) * lu(1499) - lu(1501) = lu(1501) - lu(1116) * lu(1499) - lu(1502) = lu(1502) - lu(1117) * lu(1499) - lu(1503) = lu(1503) - lu(1118) * lu(1499) - lu(1504) = lu(1504) - lu(1119) * lu(1499) - lu(1505) = lu(1505) - lu(1120) * lu(1499) - lu(1506) = lu(1506) - lu(1121) * lu(1499) - lu(1507) = lu(1507) - lu(1122) * lu(1499) - lu(1508) = lu(1508) - lu(1123) * lu(1499) - lu(1509) = lu(1509) - lu(1124) * lu(1499) - lu(1150) = 1._r8 / lu(1150) - lu(1151) = lu(1151) * lu(1150) - lu(1152) = lu(1152) * lu(1150) - lu(1153) = lu(1153) * lu(1150) - lu(1154) = lu(1154) * lu(1150) - lu(1155) = lu(1155) * lu(1150) - lu(1156) = lu(1156) * lu(1150) - lu(1157) = lu(1157) * lu(1150) - lu(1158) = lu(1158) * lu(1150) - lu(1159) = lu(1159) * lu(1150) - lu(1171) = lu(1171) - lu(1151) * lu(1170) - lu(1172) = lu(1172) - lu(1152) * lu(1170) - lu(1173) = lu(1173) - lu(1153) * lu(1170) - lu(1174) = lu(1174) - lu(1154) * lu(1170) - lu(1175) = lu(1175) - lu(1155) * lu(1170) - lu(1176) = lu(1176) - lu(1156) * lu(1170) - lu(1177) = lu(1177) - lu(1157) * lu(1170) - lu(1178) = lu(1178) - lu(1158) * lu(1170) - lu(1179) = lu(1179) - lu(1159) * lu(1170) - lu(1195) = lu(1195) - lu(1151) * lu(1194) - lu(1196) = lu(1196) - lu(1152) * lu(1194) - lu(1197) = lu(1197) - lu(1153) * lu(1194) - lu(1198) = lu(1198) - lu(1154) * lu(1194) - lu(1199) = lu(1199) - lu(1155) * lu(1194) - lu(1200) = lu(1200) - lu(1156) * lu(1194) - lu(1201) = lu(1201) - lu(1157) * lu(1194) - lu(1202) = lu(1202) - lu(1158) * lu(1194) - lu(1203) = lu(1203) - lu(1159) * lu(1194) - lu(1250) = lu(1250) - lu(1151) * lu(1249) - lu(1251) = lu(1251) - lu(1152) * lu(1249) - lu(1252) = lu(1252) - lu(1153) * lu(1249) - lu(1253) = lu(1253) - lu(1154) * lu(1249) - lu(1254) = lu(1254) - lu(1155) * lu(1249) - lu(1255) = lu(1255) - lu(1156) * lu(1249) - lu(1256) = lu(1256) - lu(1157) * lu(1249) - lu(1257) = lu(1257) - lu(1158) * lu(1249) - lu(1258) = lu(1258) - lu(1159) * lu(1249) - lu(1287) = lu(1287) - lu(1151) * lu(1286) - lu(1288) = lu(1288) - lu(1152) * lu(1286) - lu(1289) = lu(1289) - lu(1153) * lu(1286) - lu(1290) = lu(1290) - lu(1154) * lu(1286) - lu(1291) = lu(1291) - lu(1155) * lu(1286) - lu(1292) = lu(1292) - lu(1156) * lu(1286) - lu(1293) = lu(1293) - lu(1157) * lu(1286) - lu(1294) = lu(1294) - lu(1158) * lu(1286) - lu(1295) = lu(1295) - lu(1159) * lu(1286) - lu(1385) = lu(1385) - lu(1151) * lu(1384) - lu(1386) = lu(1386) - lu(1152) * lu(1384) - lu(1387) = lu(1387) - lu(1153) * lu(1384) - lu(1388) = lu(1388) - lu(1154) * lu(1384) - lu(1389) = lu(1389) - lu(1155) * lu(1384) - lu(1390) = lu(1390) - lu(1156) * lu(1384) - lu(1391) = lu(1391) - lu(1157) * lu(1384) - lu(1392) = lu(1392) - lu(1158) * lu(1384) - lu(1393) = lu(1393) - lu(1159) * lu(1384) - lu(1429) = lu(1429) - lu(1151) * lu(1428) - lu(1430) = lu(1430) - lu(1152) * lu(1428) - lu(1431) = lu(1431) - lu(1153) * lu(1428) - lu(1432) = lu(1432) - lu(1154) * lu(1428) - lu(1433) = lu(1433) - lu(1155) * lu(1428) - lu(1434) = lu(1434) - lu(1156) * lu(1428) - lu(1435) = lu(1435) - lu(1157) * lu(1428) - lu(1436) = lu(1436) - lu(1158) * lu(1428) - lu(1437) = lu(1437) - lu(1159) * lu(1428) - lu(1451) = lu(1451) - lu(1151) * lu(1450) - lu(1452) = lu(1452) - lu(1152) * lu(1450) - lu(1453) = lu(1453) - lu(1153) * lu(1450) - lu(1454) = lu(1454) - lu(1154) * lu(1450) - lu(1455) = lu(1455) - lu(1155) * lu(1450) - lu(1456) = lu(1456) - lu(1156) * lu(1450) - lu(1457) = lu(1457) - lu(1157) * lu(1450) - lu(1458) = lu(1458) - lu(1158) * lu(1450) - lu(1459) = lu(1459) - lu(1159) * lu(1450) - lu(1477) = lu(1477) - lu(1151) * lu(1476) - lu(1478) = lu(1478) - lu(1152) * lu(1476) - lu(1479) = lu(1479) - lu(1153) * lu(1476) - lu(1480) = lu(1480) - lu(1154) * lu(1476) - lu(1481) = lu(1481) - lu(1155) * lu(1476) - lu(1482) = lu(1482) - lu(1156) * lu(1476) - lu(1483) = lu(1483) - lu(1157) * lu(1476) - lu(1484) = lu(1484) - lu(1158) * lu(1476) - lu(1485) = lu(1485) - lu(1159) * lu(1476) - lu(1501) = lu(1501) - lu(1151) * lu(1500) - lu(1502) = lu(1502) - lu(1152) * lu(1500) - lu(1503) = lu(1503) - lu(1153) * lu(1500) - lu(1504) = lu(1504) - lu(1154) * lu(1500) - lu(1505) = lu(1505) - lu(1155) * lu(1500) - lu(1506) = lu(1506) - lu(1156) * lu(1500) - lu(1507) = lu(1507) - lu(1157) * lu(1500) - lu(1508) = lu(1508) - lu(1158) * lu(1500) - lu(1509) = lu(1509) - lu(1159) * lu(1500) - lu(1171) = 1._r8 / lu(1171) - lu(1172) = lu(1172) * lu(1171) - lu(1173) = lu(1173) * lu(1171) - lu(1174) = lu(1174) * lu(1171) - lu(1175) = lu(1175) * lu(1171) - lu(1176) = lu(1176) * lu(1171) - lu(1177) = lu(1177) * lu(1171) - lu(1178) = lu(1178) * lu(1171) - lu(1179) = lu(1179) * lu(1171) - lu(1196) = lu(1196) - lu(1172) * lu(1195) - lu(1197) = lu(1197) - lu(1173) * lu(1195) - lu(1198) = lu(1198) - lu(1174) * lu(1195) - lu(1199) = lu(1199) - lu(1175) * lu(1195) - lu(1200) = lu(1200) - lu(1176) * lu(1195) - lu(1201) = lu(1201) - lu(1177) * lu(1195) - lu(1202) = lu(1202) - lu(1178) * lu(1195) - lu(1203) = lu(1203) - lu(1179) * lu(1195) - lu(1251) = lu(1251) - lu(1172) * lu(1250) - lu(1252) = lu(1252) - lu(1173) * lu(1250) - lu(1253) = lu(1253) - lu(1174) * lu(1250) - lu(1254) = lu(1254) - lu(1175) * lu(1250) - lu(1255) = lu(1255) - lu(1176) * lu(1250) - lu(1256) = lu(1256) - lu(1177) * lu(1250) - lu(1257) = lu(1257) - lu(1178) * lu(1250) - lu(1258) = lu(1258) - lu(1179) * lu(1250) - lu(1288) = lu(1288) - lu(1172) * lu(1287) - lu(1289) = lu(1289) - lu(1173) * lu(1287) - lu(1290) = lu(1290) - lu(1174) * lu(1287) - lu(1291) = lu(1291) - lu(1175) * lu(1287) - lu(1292) = lu(1292) - lu(1176) * lu(1287) - lu(1293) = lu(1293) - lu(1177) * lu(1287) - lu(1294) = lu(1294) - lu(1178) * lu(1287) - lu(1295) = lu(1295) - lu(1179) * lu(1287) - lu(1386) = lu(1386) - lu(1172) * lu(1385) - lu(1387) = lu(1387) - lu(1173) * lu(1385) - lu(1388) = lu(1388) - lu(1174) * lu(1385) - lu(1389) = lu(1389) - lu(1175) * lu(1385) - lu(1390) = lu(1390) - lu(1176) * lu(1385) - lu(1391) = lu(1391) - lu(1177) * lu(1385) - lu(1392) = lu(1392) - lu(1178) * lu(1385) - lu(1393) = lu(1393) - lu(1179) * lu(1385) - lu(1430) = lu(1430) - lu(1172) * lu(1429) - lu(1431) = lu(1431) - lu(1173) * lu(1429) - lu(1432) = lu(1432) - lu(1174) * lu(1429) - lu(1433) = lu(1433) - lu(1175) * lu(1429) - lu(1434) = lu(1434) - lu(1176) * lu(1429) - lu(1435) = lu(1435) - lu(1177) * lu(1429) - lu(1436) = lu(1436) - lu(1178) * lu(1429) - lu(1437) = lu(1437) - lu(1179) * lu(1429) - lu(1452) = lu(1452) - lu(1172) * lu(1451) - lu(1453) = lu(1453) - lu(1173) * lu(1451) - lu(1454) = lu(1454) - lu(1174) * lu(1451) - lu(1455) = lu(1455) - lu(1175) * lu(1451) - lu(1456) = lu(1456) - lu(1176) * lu(1451) - lu(1457) = lu(1457) - lu(1177) * lu(1451) - lu(1458) = lu(1458) - lu(1178) * lu(1451) - lu(1459) = lu(1459) - lu(1179) * lu(1451) - lu(1478) = lu(1478) - lu(1172) * lu(1477) - lu(1479) = lu(1479) - lu(1173) * lu(1477) - lu(1480) = lu(1480) - lu(1174) * lu(1477) - lu(1481) = lu(1481) - lu(1175) * lu(1477) - lu(1482) = lu(1482) - lu(1176) * lu(1477) - lu(1483) = lu(1483) - lu(1177) * lu(1477) - lu(1484) = lu(1484) - lu(1178) * lu(1477) - lu(1485) = lu(1485) - lu(1179) * lu(1477) - lu(1502) = lu(1502) - lu(1172) * lu(1501) - lu(1503) = lu(1503) - lu(1173) * lu(1501) - lu(1504) = lu(1504) - lu(1174) * lu(1501) - lu(1505) = lu(1505) - lu(1175) * lu(1501) - lu(1506) = lu(1506) - lu(1176) * lu(1501) - lu(1507) = lu(1507) - lu(1177) * lu(1501) - lu(1508) = lu(1508) - lu(1178) * lu(1501) - lu(1509) = lu(1509) - lu(1179) * lu(1501) - lu(1196) = 1._r8 / lu(1196) - lu(1197) = lu(1197) * lu(1196) - lu(1198) = lu(1198) * lu(1196) - lu(1199) = lu(1199) * lu(1196) - lu(1200) = lu(1200) * lu(1196) - lu(1201) = lu(1201) * lu(1196) - lu(1202) = lu(1202) * lu(1196) - lu(1203) = lu(1203) * lu(1196) - lu(1252) = lu(1252) - lu(1197) * lu(1251) - lu(1253) = lu(1253) - lu(1198) * lu(1251) - lu(1254) = lu(1254) - lu(1199) * lu(1251) - lu(1255) = lu(1255) - lu(1200) * lu(1251) - lu(1256) = lu(1256) - lu(1201) * lu(1251) - lu(1257) = lu(1257) - lu(1202) * lu(1251) - lu(1258) = lu(1258) - lu(1203) * lu(1251) - lu(1289) = lu(1289) - lu(1197) * lu(1288) - lu(1290) = lu(1290) - lu(1198) * lu(1288) - lu(1291) = lu(1291) - lu(1199) * lu(1288) - lu(1292) = lu(1292) - lu(1200) * lu(1288) - lu(1293) = lu(1293) - lu(1201) * lu(1288) - lu(1294) = lu(1294) - lu(1202) * lu(1288) - lu(1295) = lu(1295) - lu(1203) * lu(1288) - lu(1387) = lu(1387) - lu(1197) * lu(1386) - lu(1388) = lu(1388) - lu(1198) * lu(1386) - lu(1389) = lu(1389) - lu(1199) * lu(1386) - lu(1390) = lu(1390) - lu(1200) * lu(1386) - lu(1391) = lu(1391) - lu(1201) * lu(1386) - lu(1392) = lu(1392) - lu(1202) * lu(1386) - lu(1393) = lu(1393) - lu(1203) * lu(1386) - lu(1431) = lu(1431) - lu(1197) * lu(1430) - lu(1432) = lu(1432) - lu(1198) * lu(1430) - lu(1433) = lu(1433) - lu(1199) * lu(1430) - lu(1434) = lu(1434) - lu(1200) * lu(1430) - lu(1435) = lu(1435) - lu(1201) * lu(1430) - lu(1436) = lu(1436) - lu(1202) * lu(1430) - lu(1437) = lu(1437) - lu(1203) * lu(1430) - lu(1453) = lu(1453) - lu(1197) * lu(1452) - lu(1454) = lu(1454) - lu(1198) * lu(1452) - lu(1455) = lu(1455) - lu(1199) * lu(1452) - lu(1456) = lu(1456) - lu(1200) * lu(1452) - lu(1457) = lu(1457) - lu(1201) * lu(1452) - lu(1458) = lu(1458) - lu(1202) * lu(1452) - lu(1459) = lu(1459) - lu(1203) * lu(1452) - lu(1479) = lu(1479) - lu(1197) * lu(1478) - lu(1480) = lu(1480) - lu(1198) * lu(1478) - lu(1481) = lu(1481) - lu(1199) * lu(1478) - lu(1482) = lu(1482) - lu(1200) * lu(1478) - lu(1483) = lu(1483) - lu(1201) * lu(1478) - lu(1484) = lu(1484) - lu(1202) * lu(1478) - lu(1485) = lu(1485) - lu(1203) * lu(1478) - lu(1503) = lu(1503) - lu(1197) * lu(1502) - lu(1504) = lu(1504) - lu(1198) * lu(1502) - lu(1505) = lu(1505) - lu(1199) * lu(1502) - lu(1506) = lu(1506) - lu(1200) * lu(1502) - lu(1507) = lu(1507) - lu(1201) * lu(1502) - lu(1508) = lu(1508) - lu(1202) * lu(1502) - lu(1509) = lu(1509) - lu(1203) * lu(1502) - lu(1252) = 1._r8 / lu(1252) - lu(1253) = lu(1253) * lu(1252) - lu(1254) = lu(1254) * lu(1252) - lu(1255) = lu(1255) * lu(1252) - lu(1256) = lu(1256) * lu(1252) - lu(1257) = lu(1257) * lu(1252) - lu(1258) = lu(1258) * lu(1252) - lu(1290) = lu(1290) - lu(1253) * lu(1289) - lu(1291) = lu(1291) - lu(1254) * lu(1289) - lu(1292) = lu(1292) - lu(1255) * lu(1289) - lu(1293) = lu(1293) - lu(1256) * lu(1289) - lu(1294) = lu(1294) - lu(1257) * lu(1289) - lu(1295) = lu(1295) - lu(1258) * lu(1289) - lu(1388) = lu(1388) - lu(1253) * lu(1387) - lu(1389) = lu(1389) - lu(1254) * lu(1387) - lu(1390) = lu(1390) - lu(1255) * lu(1387) - lu(1391) = lu(1391) - lu(1256) * lu(1387) - lu(1392) = lu(1392) - lu(1257) * lu(1387) - lu(1393) = lu(1393) - lu(1258) * lu(1387) - lu(1432) = lu(1432) - lu(1253) * lu(1431) - lu(1433) = lu(1433) - lu(1254) * lu(1431) - lu(1434) = lu(1434) - lu(1255) * lu(1431) - lu(1435) = lu(1435) - lu(1256) * lu(1431) - lu(1436) = lu(1436) - lu(1257) * lu(1431) - lu(1437) = lu(1437) - lu(1258) * lu(1431) - lu(1454) = lu(1454) - lu(1253) * lu(1453) - lu(1455) = lu(1455) - lu(1254) * lu(1453) - lu(1456) = lu(1456) - lu(1255) * lu(1453) - lu(1457) = lu(1457) - lu(1256) * lu(1453) - lu(1458) = lu(1458) - lu(1257) * lu(1453) - lu(1459) = lu(1459) - lu(1258) * lu(1453) - lu(1480) = lu(1480) - lu(1253) * lu(1479) - lu(1481) = lu(1481) - lu(1254) * lu(1479) - lu(1482) = lu(1482) - lu(1255) * lu(1479) - lu(1483) = lu(1483) - lu(1256) * lu(1479) - lu(1484) = lu(1484) - lu(1257) * lu(1479) - lu(1485) = lu(1485) - lu(1258) * lu(1479) - lu(1504) = lu(1504) - lu(1253) * lu(1503) - lu(1505) = lu(1505) - lu(1254) * lu(1503) - lu(1506) = lu(1506) - lu(1255) * lu(1503) - lu(1507) = lu(1507) - lu(1256) * lu(1503) - lu(1508) = lu(1508) - lu(1257) * lu(1503) - lu(1509) = lu(1509) - lu(1258) * lu(1503) - lu(1290) = 1._r8 / lu(1290) - lu(1291) = lu(1291) * lu(1290) - lu(1292) = lu(1292) * lu(1290) - lu(1293) = lu(1293) * lu(1290) - lu(1294) = lu(1294) * lu(1290) - lu(1295) = lu(1295) * lu(1290) - lu(1389) = lu(1389) - lu(1291) * lu(1388) - lu(1390) = lu(1390) - lu(1292) * lu(1388) - lu(1391) = lu(1391) - lu(1293) * lu(1388) - lu(1392) = lu(1392) - lu(1294) * lu(1388) - lu(1393) = lu(1393) - lu(1295) * lu(1388) - lu(1433) = lu(1433) - lu(1291) * lu(1432) - lu(1434) = lu(1434) - lu(1292) * lu(1432) - lu(1435) = lu(1435) - lu(1293) * lu(1432) - lu(1436) = lu(1436) - lu(1294) * lu(1432) - lu(1437) = lu(1437) - lu(1295) * lu(1432) - lu(1455) = lu(1455) - lu(1291) * lu(1454) - lu(1456) = lu(1456) - lu(1292) * lu(1454) - lu(1457) = lu(1457) - lu(1293) * lu(1454) - lu(1458) = lu(1458) - lu(1294) * lu(1454) - lu(1459) = lu(1459) - lu(1295) * lu(1454) - lu(1481) = lu(1481) - lu(1291) * lu(1480) - lu(1482) = lu(1482) - lu(1292) * lu(1480) - lu(1483) = lu(1483) - lu(1293) * lu(1480) - lu(1484) = lu(1484) - lu(1294) * lu(1480) - lu(1485) = lu(1485) - lu(1295) * lu(1480) - lu(1505) = lu(1505) - lu(1291) * lu(1504) - lu(1506) = lu(1506) - lu(1292) * lu(1504) - lu(1507) = lu(1507) - lu(1293) * lu(1504) - lu(1508) = lu(1508) - lu(1294) * lu(1504) - lu(1509) = lu(1509) - lu(1295) * lu(1504) - END SUBROUTINE lu_fac20 - - SUBROUTINE lu_fac21(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - lu(1389) = 1._r8 / lu(1389) - lu(1390) = lu(1390) * lu(1389) - lu(1391) = lu(1391) * lu(1389) - lu(1392) = lu(1392) * lu(1389) - lu(1393) = lu(1393) * lu(1389) - lu(1434) = lu(1434) - lu(1390) * lu(1433) - lu(1435) = lu(1435) - lu(1391) * lu(1433) - lu(1436) = lu(1436) - lu(1392) * lu(1433) - lu(1437) = lu(1437) - lu(1393) * lu(1433) - lu(1456) = lu(1456) - lu(1390) * lu(1455) - lu(1457) = lu(1457) - lu(1391) * lu(1455) - lu(1458) = lu(1458) - lu(1392) * lu(1455) - lu(1459) = lu(1459) - lu(1393) * lu(1455) - lu(1482) = lu(1482) - lu(1390) * lu(1481) - lu(1483) = lu(1483) - lu(1391) * lu(1481) - lu(1484) = lu(1484) - lu(1392) * lu(1481) - lu(1485) = lu(1485) - lu(1393) * lu(1481) - lu(1506) = lu(1506) - lu(1390) * lu(1505) - lu(1507) = lu(1507) - lu(1391) * lu(1505) - lu(1508) = lu(1508) - lu(1392) * lu(1505) - lu(1509) = lu(1509) - lu(1393) * lu(1505) - lu(1434) = 1._r8 / lu(1434) - lu(1435) = lu(1435) * lu(1434) - lu(1436) = lu(1436) * lu(1434) - lu(1437) = lu(1437) * lu(1434) - lu(1457) = lu(1457) - lu(1435) * lu(1456) - lu(1458) = lu(1458) - lu(1436) * lu(1456) - lu(1459) = lu(1459) - lu(1437) * lu(1456) - lu(1483) = lu(1483) - lu(1435) * lu(1482) - lu(1484) = lu(1484) - lu(1436) * lu(1482) - lu(1485) = lu(1485) - lu(1437) * lu(1482) - lu(1507) = lu(1507) - lu(1435) * lu(1506) - lu(1508) = lu(1508) - lu(1436) * lu(1506) - lu(1509) = lu(1509) - lu(1437) * lu(1506) - lu(1457) = 1._r8 / lu(1457) - lu(1458) = lu(1458) * lu(1457) - lu(1459) = lu(1459) * lu(1457) - lu(1484) = lu(1484) - lu(1458) * lu(1483) - lu(1485) = lu(1485) - lu(1459) * lu(1483) - lu(1508) = lu(1508) - lu(1458) * lu(1507) - lu(1509) = lu(1509) - lu(1459) * lu(1507) - lu(1484) = 1._r8 / lu(1484) - lu(1485) = lu(1485) * lu(1484) - lu(1509) = lu(1509) - lu(1485) * lu(1508) - lu(1509) = 1._r8 / lu(1509) - END SUBROUTINE lu_fac21 - - SUBROUTINE lu_fac(lu) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(inout) :: lu(:) - call lu_fac01( lu ) - call lu_fac02( lu ) - call lu_fac03( lu ) - call lu_fac04( lu ) - call lu_fac05( lu ) - call lu_fac06( lu ) - call lu_fac07( lu ) - call lu_fac08( lu ) - call lu_fac09( lu ) - call lu_fac10( lu ) - call lu_fac11( lu ) - call lu_fac12( lu ) - call lu_fac13( lu ) - call lu_fac14( lu ) - call lu_fac15( lu ) - call lu_fac16( lu ) - call lu_fac17( lu ) - call lu_fac18( lu ) - call lu_fac19( lu ) - call lu_fac20( lu ) - call lu_fac21( lu ) - END SUBROUTINE lu_fac - END MODULE mo_lu_factor diff --git a/test/ncar_kernels/WACCM_lu_fac/src/shr_kind_mod.F90 b/test/ncar_kernels/WACCM_lu_fac/src/shr_kind_mod.F90 deleted file mode 100644 index e1e3f4c6ff..0000000000 --- a/test/ncar_kernels/WACCM_lu_fac/src/shr_kind_mod.F90 +++ /dev/null @@ -1,31 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : shr_kind_mod.F90 -! Generated at: 2015-07-15 10:35:30 -! KGEN version: 0.4.13 - - - - MODULE shr_kind_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - PUBLIC - INTEGER, parameter :: shr_kind_r8 = selected_real_kind(12) ! 8 byte real - ! 4 byte real - ! native real - ! 8 byte integer - ! 4 byte integer - ! native integer - ! short char - ! mid-sized char - ! long char - ! extra-long char - ! extra-extra-long char - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE shr_kind_mod diff --git a/test/ncar_kernels/WACCM_lu_slv/CESM_license.txt b/test/ncar_kernels/WACCM_lu_slv/CESM_license.txt deleted file mode 100644 index 957014187a..0000000000 --- a/test/ncar_kernels/WACCM_lu_slv/CESM_license.txt +++ /dev/null @@ -1,14 +0,0 @@ -CESM Kernel License - -The Community Earth System Model (CESM) was developed in cooperation with the National Science Foundation, the Department of Energy, the National Aeronautics and Space Administration, and the University Corporation for Atmospheric Research National Center for Atmospheric Research. - -THIS SOFTWARE IS PROVIDED BY UCAR AND ANY CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UCAR OR ANY CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -Except for the segregable components listed in the table below, CESM is public domain software. The following components are copyrighted and may only be used, modified, or redistributed under the terms indicated below. - -Code Institution Copyright Terms of Use/Disclaimer -POP University of Illinois/NCSA Copyright 2002-2009, University of Illinois/NCSA Open Source License University of Illinois/NCSA Open Source License (http://opensource.org/licenses/NCSA) -AER RRTMG Los Alamos National Laboratory Copyright 2013 Los Alamos National Security, LLC Los Alamos National Security, LLC (http://oceans11.lanl.gov/trac/CICE/wiki/CopyRight) -MCT LANL/U. Bristol/U. Edinburgh/U. Montana/U. Swansea) Copyright 2014, GNU Lesser General Public License GNU Lesser General Public License - -This is a copy of the text of the license file from https://github.com/NCAR/kernelOptimization/blob/master/all/CAM5_mg2_pgi/CESM_Kernel_License_091118.docx diff --git a/test/ncar_kernels/WACCM_lu_slv/data/lu_slv.10.0 b/test/ncar_kernels/WACCM_lu_slv/data/lu_slv.10.0 deleted file mode 100644 index 603471e1cf..0000000000 Binary files a/test/ncar_kernels/WACCM_lu_slv/data/lu_slv.10.0 and /dev/null differ diff --git a/test/ncar_kernels/WACCM_lu_slv/data/lu_slv.10.100 b/test/ncar_kernels/WACCM_lu_slv/data/lu_slv.10.100 deleted file mode 100644 index 6f00b5a1bf..0000000000 Binary files a/test/ncar_kernels/WACCM_lu_slv/data/lu_slv.10.100 and /dev/null differ diff --git a/test/ncar_kernels/WACCM_lu_slv/data/lu_slv.10.300 b/test/ncar_kernels/WACCM_lu_slv/data/lu_slv.10.300 deleted file mode 100644 index 954752af97..0000000000 Binary files a/test/ncar_kernels/WACCM_lu_slv/data/lu_slv.10.300 and /dev/null differ diff --git a/test/ncar_kernels/WACCM_lu_slv/data/lu_slv.5.0 b/test/ncar_kernels/WACCM_lu_slv/data/lu_slv.5.0 deleted file mode 100644 index 3912f8d356..0000000000 Binary files a/test/ncar_kernels/WACCM_lu_slv/data/lu_slv.5.0 and /dev/null differ diff --git a/test/ncar_kernels/WACCM_lu_slv/data/lu_slv.5.100 b/test/ncar_kernels/WACCM_lu_slv/data/lu_slv.5.100 deleted file mode 100644 index ea7f621210..0000000000 Binary files a/test/ncar_kernels/WACCM_lu_slv/data/lu_slv.5.100 and /dev/null differ diff --git a/test/ncar_kernels/WACCM_lu_slv/data/lu_slv.5.300 b/test/ncar_kernels/WACCM_lu_slv/data/lu_slv.5.300 deleted file mode 100644 index d43988b2c0..0000000000 Binary files a/test/ncar_kernels/WACCM_lu_slv/data/lu_slv.5.300 and /dev/null differ diff --git a/test/ncar_kernels/WACCM_lu_slv/inc/t1.mk b/test/ncar_kernels/WACCM_lu_slv/inc/t1.mk deleted file mode 100644 index 262bff9d73..0000000000 --- a/test/ncar_kernels/WACCM_lu_slv/inc/t1.mk +++ /dev/null @@ -1,63 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# Makefile for KGEN-generated kernel - -# PGI default flags -# -# FC_FLAGS := -fast -Mipa=fast,inline -# -# Intel default flags -# -# FC_FLAGS := -no-opt-dynamic-align -convert big_endian -assume byterecl -ftz -traceback -assume realloc_lhs -fp-model source -xHost -O2 - - -FC_FLAGS := $(OPT) - -ALL_OBJS := kernel_driver.o mo_imp_sol.o kgen_utils.o chem_mods.o mo_lu_solve.o mo_lu_solve_r4.o mo_lu_solve_vec.o mo_lu_solve_vecr4.o shr_kind_mod.o - -all: build run verify - -verify: - @(grep "verification.FAIL" $(TEST).rslt && echo "FAILED") || (grep "verification.PASS" $(TEST).rslt -q && echo PASSED) - -run: build - @mkdir rundir ; if [ ! -d data ] ; then ln -s $(SRC)/data data && echo "symlinked data directory: ln -s $(SRC)/data data"; fi; cd rundir; ../kernel.exe >> ../$(TEST).rslt 2>&1 || ( echo RUN FAILED: DID NOT EXIT 0) -# symlink data/ so it can be found in the directory made by lit - @echo ----------------------run-ouput-was---------- - @cat $(TEST).rslt - -build: ${ALL_OBJS} - ${FC} ${FC_FLAGS} -o kernel.exe $^ - -kernel_driver.o: $(SRC_DIR)/kernel_driver.f90 mo_imp_sol.o kgen_utils.o chem_mods.o mo_lu_solve.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_imp_sol.o: $(SRC_DIR)/mo_imp_sol.F90 kgen_utils.o mo_lu_solve.o mo_lu_solve_r4.o mo_lu_solve_vec.o mo_lu_solve_vecr4.o shr_kind_mod.o chem_mods.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -chem_mods.o: $(SRC_DIR)/chem_mods.F90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_lu_solve.o: $(SRC_DIR)/mo_lu_solve.F90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_lu_solve_r4.o: $(SRC_DIR)/mo_lu_solve_r4.F90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_lu_solve_vec.o: $(SRC_DIR)/mo_lu_solve_vec.F90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -mo_lu_solve_vecr4.o: $(SRC_DIR)/mo_lu_solve_vecr4.F90 kgen_utils.o shr_kind_mod.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -shr_kind_mod.o: $(SRC_DIR)/shr_kind_mod.F90 kgen_utils.o - ${FC} ${FC_FLAGS} -c -o $@ $< - -kgen_utils.o: $(SRC_DIR)/kgen_utils.f90 - ${FC} ${FC_FLAGS} -c -o $@ $< - -clean: - rm -f kernel.exe *.mod *.o *.optrpt *.oo *.rslt diff --git a/test/ncar_kernels/WACCM_lu_slv/lit/runmake b/test/ncar_kernels/WACCM_lu_slv/lit/runmake deleted file mode 100644 index 822fd9d9a2..0000000000 --- a/test/ncar_kernels/WACCM_lu_slv/lit/runmake +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/bash -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -test_name=${TEST_SRC##*/} # Strip path. -test_name=${test_name%.*} # Strip extension. - -temp_dir="$test_name" -rm -rf $temp_dir - -MAKE_FILE=$MAKE_FILE_DIR/makefile - -mkdir $temp_dir -if [[ ! $KEEP_FILES ]]; then - # If keep files is not specified, remove these files at the end. - trap "rm -rf $(pwd)/$temp_dir" EXIT -fi -cd $temp_dir -export PATH=$PATH:$(pwd) - -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 -make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 -# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/ncar_kernels/WACCM_lu_slv/lit/t1.sh b/test/ncar_kernels/WACCM_lu_slv/lit/t1.sh deleted file mode 100644 index 33c953a156..0000000000 --- a/test/ncar_kernels/WACCM_lu_slv/lit/t1.sh +++ /dev/null @@ -1,9 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception - -# Shared lit script for each tests. Run bash commands that run tests with make. - -# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t -# RUN: cat %t | FileCheck %S/runmake diff --git a/test/ncar_kernels/WACCM_lu_slv/makefile b/test/ncar_kernels/WACCM_lu_slv/makefile deleted file mode 100644 index 566cb22d08..0000000000 --- a/test/ncar_kernels/WACCM_lu_slv/makefile +++ /dev/null @@ -1,32 +0,0 @@ -# -# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. -# See https://llvm.org/LICENSE.txt for license information. -# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -# -# makefile for NCAR Kernel tests. - - -#TEST_DIR=./src -SRC=$(HOMEQA) -INCLUDES = $(HOMEQA)/inc -SRC_DIR=$(SRC)/src -FC=flang -OBJX=o -EXTRA_CFLAGS= -EXTRA_FFLAGS= -LD=$(FC) -RUN= -OPT= -ENDIAN= -FFLAGS=$(OPT) -LDFLAGS=$(EXTRA_LDFLAGS) -LIBS=$(EXTRA_LIBS) -KIEE= -CFLAGS=$(OPT) $(EXTRA_CFLAGS) -EXE=out - - -RM=rm -f - -TEST = t1 -include $(INCLUDES)/$(TEST).mk diff --git a/test/ncar_kernels/WACCM_lu_slv/src/chem_mods.F90 b/test/ncar_kernels/WACCM_lu_slv/src/chem_mods.F90 deleted file mode 100644 index 582d04c35d..0000000000 --- a/test/ncar_kernels/WACCM_lu_slv/src/chem_mods.F90 +++ /dev/null @@ -1,39 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : chem_mods.F90 -! Generated at: 2015-07-14 19:56:41 -! KGEN version: 0.4.13 - - - - MODULE chem_mods - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !-------------------------------------------------------------- - ! ... Basic chemistry parameters and arrays - !-------------------------------------------------------------- - IMPLICIT NONE - INTEGER, parameter :: nzcnt = 1509 - INTEGER, parameter :: clscnt4 = 135 ! number of photolysis reactions - ! number of total reactions - ! number of gas phase reactions - ! number of absorbing column densities - ! number of "gas phase" species - ! number of "fixed" species - ! number of relationship species - ! number of group members - ! number of non-zero matrix entries - ! number of species with external forcing - ! number of species in explicit class - ! number of species in hov class - ! number of species in ebi class - ! number of species in implicit class - ! number of species in rodas class - ! index of total atm density in invariant array - ! index of water vapor density - ! loop length for implicit chemistry - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE chem_mods diff --git a/test/ncar_kernels/WACCM_lu_slv/src/kernel_driver.f90 b/test/ncar_kernels/WACCM_lu_slv/src/kernel_driver.f90 deleted file mode 100644 index 82c877efa6..0000000000 --- a/test/ncar_kernels/WACCM_lu_slv/src/kernel_driver.f90 +++ /dev/null @@ -1,76 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : kernel_driver.f90 -! Generated at: 2015-07-14 19:56:41 -! KGEN version: 0.4.13 - - -PROGRAM kernel_driver - USE mo_imp_sol, ONLY : imp_sol - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - - IMPLICIT NONE - - INTEGER :: kgen_mpi_rank - CHARACTER(LEN=16) ::kgen_mpi_rank_conv - INTEGER, DIMENSION(3), PARAMETER :: kgen_mpi_rank_at = (/ 0, 100, 300 /) - INTEGER :: kgen_ierr, kgen_unit - INTEGER :: kgen_repeat_counter - INTEGER :: kgen_counter - CHARACTER(LEN=16) :: kgen_counter_conv - INTEGER, DIMENSION(2), PARAMETER :: kgen_counter_at = (/ 10, 5 /) - CHARACTER(LEN=1024) :: kgen_filepath - - DO kgen_repeat_counter = 0, 5 - kgen_counter = kgen_counter_at(mod(kgen_repeat_counter, 2)+1) - WRITE( kgen_counter_conv, * ) kgen_counter - kgen_mpi_rank = kgen_mpi_rank_at(mod(kgen_repeat_counter, 3)+1) - WRITE( kgen_mpi_rank_conv, * ) kgen_mpi_rank - kgen_filepath = "../data/lu_slv." // trim(adjustl(kgen_counter_conv)) // "." // trim(adjustl(kgen_mpi_rank_conv)) - kgen_unit = kgen_get_newunit() - OPEN (UNIT=kgen_unit, FILE=kgen_filepath, STATUS="OLD", ACCESS="STREAM", FORM="UNFORMATTED", ACTION="READ", IOSTAT=kgen_ierr, CONVERT="BIG_ENDIAN") - WRITE (*,*) - IF ( kgen_ierr /= 0 ) THEN - CALL kgen_error_stop( "FILE OPEN ERROR: " // trim(adjustl(kgen_filepath)) ) - END IF - WRITE (*,*) - WRITE (*,*) "** Verification against '" // trim(adjustl(kgen_filepath)) // "' **" - - - ! driver variables - ! Not kernel driver input - - call imp_sol(kgen_unit) - - CLOSE (UNIT=kgen_unit) - END DO - CONTAINS - - ! write subroutines - ! No subroutines - FUNCTION kgen_get_newunit() RESULT(new_unit) - INTEGER, PARAMETER :: UNIT_MIN=100, UNIT_MAX=1000000 - LOGICAL :: is_opened - INTEGER :: nunit, new_unit, counter - - new_unit = -1 - DO counter=UNIT_MIN, UNIT_MAX - inquire(UNIT=counter, OPENED=is_opened) - IF (.NOT. is_opened) THEN - new_unit = counter - EXIT - END IF - END DO - END FUNCTION - - SUBROUTINE kgen_error_stop( msg ) - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: msg - - WRITE (*,*) msg - STOP 1 - END SUBROUTINE - - - END PROGRAM kernel_driver diff --git a/test/ncar_kernels/WACCM_lu_slv/src/kgen_utils.f90 b/test/ncar_kernels/WACCM_lu_slv/src/kgen_utils.f90 deleted file mode 100644 index cfa8d114e0..0000000000 --- a/test/ncar_kernels/WACCM_lu_slv/src/kgen_utils.f90 +++ /dev/null @@ -1,61 +0,0 @@ -module kgen_utils_mod - -INTEGER, PARAMETER :: kgen_dp = selected_real_kind(15, 307) - -type check_t - logical :: Passed - integer :: numFatal - integer :: numTotal - integer :: numIdentical - integer :: numWarning - integer :: VerboseLevel - real(kind=kgen_dp) :: tolerance - real(kind=kgen_dp) :: minvalue -end type check_t - -public kgen_dp, check_t, kgen_init_check, kgen_print_check - -contains - -subroutine kgen_init_check(check, tolerance, minvalue) - type(check_t), intent(inout) :: check - real(kind=kgen_dp), intent(in), optional :: tolerance - real(kind=kgen_dp), intent(in), optional :: minvalue - - check%Passed = .TRUE. - check%numFatal = 0 - check%numWarning = 0 - check%numTotal = 0 - check%numIdentical = 0 - check%VerboseLevel = 1 - if(present(tolerance)) then - check%tolerance = tolerance - else - check%tolerance = 1.0D-15 - endif - if(present(minvalue)) then - check%minvalue = minvalue - else - check%minvalue = 1.0D-15 - endif -end subroutine kgen_init_check - -subroutine kgen_print_check(kname, check) - character(len=*) :: kname - type(check_t), intent(in) :: check - - write (*,*) - write (*,*) TRIM(kname),' KGENPrtCheck: Tolerance for normalized RMS: ',check%tolerance - write (*,*) TRIM(kname),' KGENPrtCheck: Number of variables checked: ',check%numTotal - write (*,*) TRIM(kname),' KGENPrtCheck: Number of Identical results: ',check%numIdentical - write (*,*) TRIM(kname),' KGENPrtCheck: Number of warnings detected: ',check%numWarning - write (*,*) TRIM(kname),' KGENPrtCheck: Number of fatal errors detected: ', check%numFatal - - if (check%numFatal> 0) then - write(*,*) TRIM(kname),' KGENPrtCheck: verification FAILED' - else - write(*,*) TRIM(kname),' KGENPrtCheck: verification PASSED' - endif -end subroutine kgen_print_check - -end module diff --git a/test/ncar_kernels/WACCM_lu_slv/src/mo_imp_sol.F90 b/test/ncar_kernels/WACCM_lu_slv/src/mo_imp_sol.F90 deleted file mode 100644 index bee54316a8..0000000000 --- a/test/ncar_kernels/WACCM_lu_slv/src/mo_imp_sol.F90 +++ /dev/null @@ -1,227 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_imp_sol.F90 -! Generated at: 2015-07-14 19:56:41 -! KGEN version: 0.4.13 - - - - MODULE mo_imp_sol - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - USE shr_kind_mod, ONLY: r8 => shr_kind_r8, r4 => shr_kind_r4 - IMPLICIT NONE - PRIVATE - PUBLIC imp_sol - !----------------------------------------------------------------------- - ! Newton-Raphson iteration limits - !----------------------------------------------------------------------- - ! for xnox ozone chemistry diagnostics - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - - - SUBROUTINE imp_sol(kgen_unit) - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !----------------------------------------------------------------------- - ! ... imp_sol advances the volumetric mixing ratio - ! forward one time step via the fully implicit euler scheme. - ! this source is meant for small l1 cache machines such as - ! the intel pentium and itanium cpus - !----------------------------------------------------------------------- - USE chem_mods, ONLY: nzcnt - USE chem_mods, only : clscnt4 - USE mo_lu_solve, ONLY: lu_slv - USE mo_lu_solve_r4, ONLY: lu_slv_r4 - USE mo_lu_solve_vec, ONLY: lu_slv_vec - USE mo_lu_solve_vecr4, ONLY: lu_slv_vecr4 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... dummy args - !----------------------------------------------------------------------- - integer, intent(in) :: kgen_unit - INTEGER*8 :: kgen_intvar, start_clock, stop_clock, rate_clock,maxiter=1000 - integer*4, parameter :: veclen=8 - - TYPE(check_t):: check_status - REAL(KIND=kgen_dp) :: tolerance - ! columns in chunck - ! chunk id - ! time step (s) - ! rxt rates (1/cm^3/s) - ! external in-situ forcing (1/cm^3/s) - ! washout rates (1/s) - ! species mixing ratios (vmr) - ! chemistry troposphere boundary (index) - !----------------------------------------------------------------------- - ! ... local variables - !----------------------------------------------------------------------- - REAL(KIND=r8) :: sys_jac(max(1,nzcnt)) - REAL(KIND=r4) :: sys_jac_r4(max(1,nzcnt)) - REAL(KIND=r8) :: sys_jac_vec(veclen,max(1,nzcnt)) - REAL(KIND=r4) :: sys_jac_vecr4(veclen,max(1,nzcnt)) - - REAL(KIND=r8), dimension(max(1,clscnt4)) :: forcing - REAL(KIND=r4), dimension(max(1,clscnt4)) :: forcing_r4 - REAL(KIND=r8), dimension(veclen,max(1,clscnt4)) :: forcing_vec - REAL(KIND=r4), dimension(veclen,max(1,clscnt4)) :: forcing_vecr4 - -!dir$ attributes align : 64 :: forcing_vec - REAL(KIND=r8) :: ref_forcing(max(1,clscnt4)) - integer :: i - !----------------------------------------------------------------------- - ! ... class independent forcing - !----------------------------------------------------------------------- - tolerance = 1.E-14 - CALL kgen_init_check(check_status, tolerance) - READ(UNIT=kgen_unit) sys_jac - READ(UNIT=kgen_unit) forcing - - READ(UNIT=kgen_unit) ref_forcing - - - ! call to kernel - call lu_slv( sys_jac, forcing ) - - ! kernel verification for output variables - CALL kgen_verify_real_r8_dim1( "forcing", check_status, forcing, ref_forcing) - CALL kgen_print_check("lu_slv", check_status) - - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,maxiter - CALL lu_slv(sys_jac, forcing) - END DO - CALL system_clock(stop_clock, rate_clock) - - WRITE(*,*) - PRINT *, "Elapsed time [R8](sec): ", (stop_clock - start_clock)/REAL(rate_clock) - PRINT *, "veclen: 1 Time per lu_slv call [R8](usec): ", (stop_clock - start_clock)*1e6/REAL(rate_clock*maxiter) - - forcing_r4 = forcing - sys_jac_r4 = sys_jac - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,maxiter - CALL lu_slv_r4(sys_jac_r4, forcing_r4) - END DO - CALL system_clock(stop_clock, rate_clock) - - WRITE(*,*) - PRINT *, "Elapsed time [R4] (sec): ", (stop_clock - start_clock)/REAL(rate_clock) - PRINT *, "veclen: 1 Time per lu_slv call [R4] (usec): ", (stop_clock - start_clock)*1e6/REAL(rate_clock*maxiter) - - do i=1,veclen - sys_jac_vec(i,:) = sys_jac(:) - sys_jac_vecr4(i,:) = sys_jac(:) - forcing_vec(i,:) = forcing(:) - forcing_vecr4(i,:) = forcing(:) - enddo - - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,maxiter - CALL lu_slv_vec(veclen,max(1,clscnt4),max(1,nzcnt),sys_jac_vec, forcing_vec) - END DO - CALL system_clock(stop_clock, rate_clock) - - PRINT *, 'veclen: ',veclen,' Time per lu_slv call [R8](usec): ', (stop_clock - start_clock)*1e6/REAL(rate_clock*maxiter) - PRINT *, 'veclen: ',veclen,' Time per lu_slv per system [R8](usec): ', (stop_clock - start_clock)*1e6/REAL(veclen*rate_clock*maxiter) - - CALL system_clock(start_clock, rate_clock) - DO kgen_intvar=1,maxiter - CALL lu_slv_vecr4(veclen,max(1,clscnt4),max(1,nzcnt),sys_jac_vecr4, forcing_vecr4) - END DO - CALL system_clock(stop_clock, rate_clock) - - PRINT *, 'veclen: ',veclen,' Time per lu_slv call [R4](usec): ', (stop_clock - start_clock)*1e6/REAL(rate_clock*maxiter) - PRINT *, 'veclen: ',veclen,' Time per lu_slv per system [R4](usec): ', (stop_clock - start_clock)*1e6/REAL(veclen*rate_clock*maxiter) - ! - ! - CONTAINS - - ! write subroutines - SUBROUTINE kgen_read_real_r8_dim1(var, kgen_unit, printvar) - INTEGER, INTENT(IN) :: kgen_unit - CHARACTER(*), INTENT(IN), OPTIONAL :: printvar - real(KIND=r8), INTENT(OUT), ALLOCATABLE, DIMENSION(:) :: var - LOGICAL :: is_true - INTEGER :: idx1 - INTEGER, DIMENSION(2,1) :: kgen_bound - - READ(UNIT = kgen_unit) is_true - - IF ( is_true ) THEN - READ(UNIT = kgen_unit) kgen_bound(1, 1) - READ(UNIT = kgen_unit) kgen_bound(2, 1) - ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1)) - READ(UNIT = kgen_unit) var - IF ( PRESENT(printvar) ) THEN - PRINT *, "** " // printvar // " **", var - END IF - END IF - END SUBROUTINE kgen_read_real_r8_dim1 - - - ! verify subroutines - SUBROUTINE kgen_verify_real_r8_dim1( varname, check_status, var, ref_var) - character(*), intent(in) :: varname - type(check_t), intent(inout) :: check_status - real(KIND=r8), intent(in), DIMENSION(:) :: var, ref_var - real(KIND=r8) :: nrmsdiff, rmsdiff - real(KIND=r8), allocatable, DIMENSION(:) :: temp, temp2 - integer :: n - check_status%numTotal = check_status%numTotal + 1 - IF ( ALL( var == ref_var ) ) THEN - - check_status%numIdentical = check_status%numIdentical + 1 - if(check_status%verboseLevel > 1) then - WRITE(*,*) - WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." - !WRITE(*,*) "KERNEL: ", var - !WRITE(*,*) "REF. : ", ref_var - IF ( ALL( var == 0 ) ) THEN - if(check_status%verboseLevel > 2) then - WRITE(*,*) "All values are zero." - end if - END IF - end if - ELSE - allocate(temp(SIZE(var,dim=1))) - allocate(temp2(SIZE(var,dim=1))) - - n = count(var/=ref_var) - where(abs(ref_var) > check_status%minvalue) - temp = ((var-ref_var)/ref_var)**2 - temp2 = (var-ref_var)**2 - elsewhere - temp = (var-ref_var)**2 - temp2 = temp - endwhere - nrmsdiff = sqrt(sum(temp)/real(n)) - rmsdiff = sqrt(sum(temp2)/real(n)) - - if(check_status%verboseLevel > 0) then - WRITE(*,*) - WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." - WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." - if(check_status%verboseLevel > 1) then - WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) - WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) - endif - WRITE(*,*) "RMS of difference is ",rmsdiff - WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff - end if - - if (nrmsdiff > check_status%tolerance) then - check_status%numFatal = check_status%numFatal+1 - else - check_status%numWarning = check_status%numWarning+1 - endif - - deallocate(temp,temp2) - END IF - END SUBROUTINE kgen_verify_real_r8_dim1 - - END SUBROUTINE imp_sol - END MODULE mo_imp_sol diff --git a/test/ncar_kernels/WACCM_lu_slv/src/mo_lu_solve.F90 b/test/ncar_kernels/WACCM_lu_slv/src/mo_lu_solve.F90 deleted file mode 100644 index f6f128f3ba..0000000000 --- a/test/ncar_kernels/WACCM_lu_slv/src/mo_lu_solve.F90 +++ /dev/null @@ -1,1677 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_lu_solve.F90 -! Generated at: 2015-07-14 19:56:41 -! KGEN version: 0.4.13 - - - - MODULE mo_lu_solve - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - PRIVATE - PUBLIC lu_slv - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - - SUBROUTINE lu_slv01(lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(in) :: lu(:) - REAL(KIND=r8), intent(inout) :: b(:) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - b(125) = b(125) - lu(18) * b(17) - b(131) = b(131) - lu(19) * b(17) - b(124) = b(124) - lu(21) * b(18) - b(126) = b(126) - lu(22) * b(18) - b(79) = b(79) - lu(24) * b(19) - b(131) = b(131) - lu(25) * b(19) - b(41) = b(41) - lu(27) * b(20) - b(131) = b(131) - lu(28) * b(20) - b(96) = b(96) - lu(30) * b(21) - b(131) = b(131) - lu(31) * b(21) - b(134) = b(134) - lu(32) * b(21) - b(23) = b(23) - lu(34) * b(22) - b(65) = b(65) - lu(35) * b(22) - b(125) = b(125) - lu(36) * b(22) - b(131) = b(131) - lu(37) * b(22) - b(31) = b(31) - lu(39) * b(23) - b(131) = b(131) - lu(40) * b(23) - b(56) = b(56) - lu(42) * b(24) - b(131) = b(131) - lu(43) * b(24) - b(88) = b(88) - lu(45) * b(25) - b(122) = b(122) - lu(46) * b(25) - b(36) = b(36) - lu(48) * b(26) - b(134) = b(134) - lu(49) * b(26) - b(120) = b(120) - lu(51) * b(27) - b(120) = b(120) - lu(54) * b(28) - b(126) = b(126) - lu(56) * b(29) - b(122) = b(122) - lu(58) * b(30) - b(125) = b(125) - lu(59) * b(30) - b(131) = b(131) - lu(60) * b(30) - b(66) = b(66) - lu(62) * b(31) - b(125) = b(125) - lu(63) * b(31) - b(130) = b(130) - lu(64) * b(31) - b(88) = b(88) - lu(66) * b(32) - b(122) = b(122) - lu(67) * b(32) - b(126) = b(126) - lu(68) * b(32) - b(118) = b(118) - lu(70) * b(33) - b(126) = b(126) - lu(71) * b(33) - b(88) = b(88) - lu(73) * b(34) - b(127) = b(127) - lu(74) * b(34) - b(104) = b(104) - lu(76) * b(35) - b(125) = b(125) - lu(77) * b(35) - b(131) = b(131) - lu(78) * b(35) - b(99) = b(99) - lu(81) * b(36) - b(121) = b(121) - lu(82) * b(36) - b(134) = b(134) - lu(83) * b(36) - b(91) = b(91) - lu(85) * b(37) - b(117) = b(117) - lu(86) * b(37) - b(126) = b(126) - lu(87) * b(37) - b(131) = b(131) - lu(88) * b(37) - b(134) = b(134) - lu(89) * b(37) - b(64) = b(64) - lu(91) * b(38) - b(81) = b(81) - lu(92) * b(38) - b(103) = b(103) - lu(93) * b(38) - b(125) = b(125) - lu(94) * b(38) - b(131) = b(131) - lu(95) * b(38) - b(99) = b(99) - lu(97) * b(39) - b(125) = b(125) - lu(98) * b(39) - b(131) = b(131) - lu(99) * b(39) - b(132) = b(132) - lu(100) * b(39) - b(133) = b(133) - lu(101) * b(39) - b(121) = b(121) - lu(103) * b(40) - b(129) = b(129) - lu(104) * b(40) - b(130) = b(130) - lu(105) * b(40) - b(132) = b(132) - lu(106) * b(40) - b(133) = b(133) - lu(107) * b(40) - b(80) = b(80) - lu(109) * b(41) - b(104) = b(104) - lu(110) * b(41) - b(125) = b(125) - lu(111) * b(41) - b(129) = b(129) - lu(112) * b(41) - b(130) = b(130) - lu(113) * b(41) - b(135) = b(135) - lu(114) * b(41) - b(77) = b(77) - lu(116) * b(42) - b(104) = b(104) - lu(117) * b(42) - b(115) = b(115) - lu(118) * b(42) - b(131) = b(131) - lu(119) * b(42) - b(112) = b(112) - lu(121) * b(43) - b(114) = b(114) - lu(122) * b(43) - b(125) = b(125) - lu(123) * b(43) - b(131) = b(131) - lu(124) * b(43) - b(91) = b(91) - lu(126) * b(44) - b(104) = b(104) - lu(127) * b(44) - b(125) = b(125) - lu(128) * b(44) - b(131) = b(131) - lu(129) * b(44) - b(110) = b(110) - lu(131) * b(45) - b(131) = b(131) - lu(132) * b(45) - b(134) = b(134) - lu(133) * b(45) - b(99) = b(99) - lu(135) * b(46) - b(116) = b(116) - lu(136) * b(46) - b(121) = b(121) - lu(137) * b(46) - b(124) = b(124) - lu(138) * b(46) - b(110) = b(110) - lu(140) * b(47) - b(131) = b(131) - lu(141) * b(47) - b(82) = b(82) - lu(143) * b(48) - b(99) = b(99) - lu(144) * b(48) - b(103) = b(103) - lu(145) * b(48) - b(116) = b(116) - lu(146) * b(48) - b(121) = b(121) - lu(147) * b(48) - b(127) = b(127) - lu(148) * b(48) - b(131) = b(131) - lu(149) * b(48) - b(109) = b(109) - lu(151) * b(49) - b(130) = b(130) - lu(152) * b(49) - b(131) = b(131) - lu(153) * b(49) - b(119) = b(119) - lu(155) * b(50) - b(127) = b(127) - lu(156) * b(50) - b(131) = b(131) - lu(157) * b(50) - b(134) = b(134) - lu(158) * b(50) - b(135) = b(135) - lu(159) * b(50) - b(65) = b(65) - lu(161) * b(51) - b(66) = b(66) - lu(162) * b(51) - b(81) = b(81) - lu(163) * b(51) - b(109) = b(109) - lu(164) * b(51) - b(131) = b(131) - lu(165) * b(51) - b(80) = b(80) - lu(167) * b(52) - b(96) = b(96) - lu(168) * b(52) - b(125) = b(125) - lu(169) * b(52) - b(131) = b(131) - lu(170) * b(52) - b(134) = b(134) - lu(171) * b(52) - b(106) = b(106) - lu(173) * b(53) - b(115) = b(115) - lu(174) * b(53) - b(131) = b(131) - lu(175) * b(53) - b(134) = b(134) - lu(176) * b(53) - b(135) = b(135) - lu(177) * b(53) - b(64) = b(64) - lu(179) * b(54) - b(125) = b(125) - lu(180) * b(54) - b(129) = b(129) - lu(181) * b(54) - b(130) = b(130) - lu(182) * b(54) - b(135) = b(135) - lu(183) * b(54) - b(77) = b(77) - lu(185) * b(55) - b(91) = b(91) - lu(186) * b(55) - b(115) = b(115) - lu(187) * b(55) - b(131) = b(131) - lu(188) * b(55) - b(95) = b(95) - lu(190) * b(56) - b(120) = b(120) - lu(191) * b(56) - b(125) = b(125) - lu(192) * b(56) - b(135) = b(135) - lu(193) * b(56) - b(115) = b(115) - lu(195) * b(57) - b(119) = b(119) - lu(196) * b(57) - b(130) = b(130) - lu(197) * b(57) - b(131) = b(131) - lu(198) * b(57) - b(132) = b(132) - lu(199) * b(57) - b(135) = b(135) - lu(200) * b(57) - b(72) = b(72) - lu(202) * b(58) - b(85) = b(85) - lu(203) * b(58) - b(86) = b(86) - lu(204) * b(58) - b(92) = b(92) - lu(205) * b(58) - b(120) = b(120) - lu(206) * b(58) - b(121) = b(121) - lu(207) * b(58) - b(80) = b(80) - lu(209) * b(59) - b(98) = b(98) - lu(210) * b(59) - b(107) = b(107) - lu(211) * b(59) - b(113) = b(113) - lu(212) * b(59) - b(125) = b(125) - lu(213) * b(59) - b(131) = b(131) - lu(214) * b(59) - b(120) = b(120) - lu(216) * b(60) - b(125) = b(125) - lu(217) * b(60) - b(130) = b(130) - lu(218) * b(60) - b(131) = b(131) - lu(219) * b(60) - b(132) = b(132) - lu(220) * b(60) - b(134) = b(134) - lu(221) * b(60) - b(92) = b(92) - lu(223) * b(61) - b(120) = b(120) - lu(224) * b(61) - b(122) = b(122) - lu(225) * b(61) - b(129) = b(129) - lu(226) * b(61) - b(115) = b(115) - lu(228) * b(62) - b(119) = b(119) - lu(229) * b(62) - b(131) = b(131) - lu(230) * b(62) - b(134) = b(134) - lu(231) * b(62) - b(135) = b(135) - lu(232) * b(62) - b(64) = b(64) - lu(234) * b(63) - b(83) = b(83) - lu(235) * b(63) - b(103) = b(103) - lu(236) * b(63) - b(123) = b(123) - lu(237) * b(63) - b(125) = b(125) - lu(238) * b(63) - b(131) = b(131) - lu(239) * b(63) - b(135) = b(135) - lu(240) * b(63) - b(125) = b(125) - lu(242) * b(64) - b(131) = b(131) - lu(243) * b(64) - b(134) = b(134) - lu(244) * b(64) - b(66) = b(66) - lu(247) * b(65) - b(81) = b(81) - lu(248) * b(65) - b(109) = b(109) - lu(249) * b(65) - b(125) = b(125) - lu(250) * b(65) - b(129) = b(129) - lu(251) * b(65) - b(130) = b(130) - lu(252) * b(65) - b(131) = b(131) - lu(253) * b(65) - b(81) = b(81) - lu(255) * b(66) - b(103) = b(103) - lu(256) * b(66) - b(109) = b(109) - lu(257) * b(66) - b(115) = b(115) - lu(258) * b(66) - b(125) = b(125) - lu(259) * b(66) - b(89) = b(89) - lu(261) * b(67) - b(104) = b(104) - lu(262) * b(67) - b(105) = b(105) - lu(263) * b(67) - b(125) = b(125) - lu(264) * b(67) - b(131) = b(131) - lu(265) * b(67) - b(134) = b(134) - lu(266) * b(67) - b(135) = b(135) - lu(267) * b(67) - b(125) = b(125) - lu(269) * b(68) - b(131) = b(131) - lu(270) * b(68) - b(135) = b(135) - lu(271) * b(68) - b(107) = b(107) - lu(273) * b(69) - b(110) = b(110) - lu(274) * b(69) - b(111) = b(111) - lu(275) * b(69) - b(113) = b(113) - lu(276) * b(69) - b(125) = b(125) - lu(277) * b(69) - b(131) = b(131) - lu(278) * b(69) - b(135) = b(135) - lu(279) * b(69) - END SUBROUTINE lu_slv01 - - SUBROUTINE lu_slv02(lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(in) :: lu(:) - REAL(KIND=r8), intent(inout) :: b(:) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - b(84) = b(84) - lu(281) * b(70) - b(118) = b(118) - lu(282) * b(70) - b(121) = b(121) - lu(283) * b(70) - b(128) = b(128) - lu(284) * b(70) - b(130) = b(130) - lu(285) * b(70) - b(132) = b(132) - lu(286) * b(70) - b(133) = b(133) - lu(287) * b(70) - b(105) = b(105) - lu(289) * b(71) - b(114) = b(114) - lu(290) * b(71) - b(125) = b(125) - lu(291) * b(71) - b(130) = b(130) - lu(292) * b(71) - b(131) = b(131) - lu(293) * b(71) - b(132) = b(132) - lu(294) * b(71) - b(135) = b(135) - lu(295) * b(71) - b(85) = b(85) - lu(297) * b(72) - b(86) = b(86) - lu(298) * b(72) - b(92) = b(92) - lu(299) * b(72) - b(103) = b(103) - lu(300) * b(72) - b(120) = b(120) - lu(301) * b(72) - b(121) = b(121) - lu(302) * b(72) - b(98) = b(98) - lu(304) * b(73) - b(107) = b(107) - lu(305) * b(73) - b(113) = b(113) - lu(306) * b(73) - b(123) = b(123) - lu(307) * b(73) - b(125) = b(125) - lu(308) * b(73) - b(130) = b(130) - lu(309) * b(73) - b(131) = b(131) - lu(310) * b(73) - b(132) = b(132) - lu(311) * b(73) - b(117) = b(117) - lu(313) * b(74) - b(121) = b(121) - lu(314) * b(74) - b(125) = b(125) - lu(315) * b(74) - b(126) = b(126) - lu(316) * b(74) - b(131) = b(131) - lu(317) * b(74) - b(134) = b(134) - lu(318) * b(74) - b(119) = b(119) - lu(320) * b(75) - b(131) = b(131) - lu(321) * b(75) - b(134) = b(134) - lu(322) * b(75) - b(77) = b(77) - lu(325) * b(76) - b(79) = b(79) - lu(326) * b(76) - b(80) = b(80) - lu(327) * b(76) - b(91) = b(91) - lu(328) * b(76) - b(104) = b(104) - lu(329) * b(76) - b(115) = b(115) - lu(330) * b(76) - b(125) = b(125) - lu(331) * b(76) - b(131) = b(131) - lu(332) * b(76) - b(135) = b(135) - lu(333) * b(76) - b(104) = b(104) - lu(336) * b(77) - b(115) = b(115) - lu(337) * b(77) - b(125) = b(125) - lu(338) * b(77) - b(129) = b(129) - lu(339) * b(77) - b(130) = b(130) - lu(340) * b(77) - b(131) = b(131) - lu(341) * b(77) - b(85) = b(85) - lu(345) * b(78) - b(86) = b(86) - lu(346) * b(78) - b(87) = b(87) - lu(347) * b(78) - b(92) = b(92) - lu(348) * b(78) - b(103) = b(103) - lu(349) * b(78) - b(120) = b(120) - lu(350) * b(78) - b(121) = b(121) - lu(351) * b(78) - b(122) = b(122) - lu(352) * b(78) - b(129) = b(129) - lu(353) * b(78) - b(80) = b(80) - lu(359) * b(79) - b(91) = b(91) - lu(360) * b(79) - b(104) = b(104) - lu(361) * b(79) - b(109) = b(109) - lu(362) * b(79) - b(115) = b(115) - lu(363) * b(79) - b(125) = b(125) - lu(364) * b(79) - b(129) = b(129) - lu(365) * b(79) - b(130) = b(130) - lu(366) * b(79) - b(131) = b(131) - lu(367) * b(79) - b(135) = b(135) - lu(368) * b(79) - b(106) = b(106) - lu(370) * b(80) - b(115) = b(115) - lu(371) * b(80) - b(119) = b(119) - lu(372) * b(80) - b(131) = b(131) - lu(373) * b(80) - b(134) = b(134) - lu(374) * b(80) - b(103) = b(103) - lu(376) * b(81) - b(125) = b(125) - lu(377) * b(81) - b(131) = b(131) - lu(378) * b(81) - b(116) = b(116) - lu(380) * b(82) - b(120) = b(120) - lu(381) * b(82) - b(121) = b(121) - lu(382) * b(82) - b(123) = b(123) - lu(383) * b(82) - b(127) = b(127) - lu(384) * b(82) - b(131) = b(131) - lu(385) * b(82) - b(95) = b(95) - lu(389) * b(83) - b(120) = b(120) - lu(390) * b(83) - b(125) = b(125) - lu(391) * b(83) - b(129) = b(129) - lu(392) * b(83) - b(130) = b(130) - lu(393) * b(83) - b(131) = b(131) - lu(394) * b(83) - b(135) = b(135) - lu(395) * b(83) - b(117) = b(117) - lu(398) * b(84) - b(118) = b(118) - lu(399) * b(84) - b(121) = b(121) - lu(400) * b(84) - b(126) = b(126) - lu(401) * b(84) - b(128) = b(128) - lu(402) * b(84) - b(131) = b(131) - lu(403) * b(84) - b(134) = b(134) - lu(404) * b(84) - b(86) = b(86) - lu(406) * b(85) - b(87) = b(87) - lu(407) * b(85) - b(92) = b(92) - lu(408) * b(85) - b(120) = b(120) - lu(409) * b(85) - b(121) = b(121) - lu(410) * b(85) - b(122) = b(122) - lu(411) * b(85) - b(129) = b(129) - lu(412) * b(85) - b(87) = b(87) - lu(415) * b(86) - b(92) = b(92) - lu(416) * b(86) - b(120) = b(120) - lu(417) * b(86) - b(121) = b(121) - lu(418) * b(86) - b(122) = b(122) - lu(419) * b(86) - b(129) = b(129) - lu(420) * b(86) - b(92) = b(92) - lu(426) * b(87) - b(103) = b(103) - lu(427) * b(87) - b(120) = b(120) - lu(428) * b(87) - b(121) = b(121) - lu(429) * b(87) - b(122) = b(122) - lu(430) * b(87) - b(129) = b(129) - lu(431) * b(87) - b(108) = b(108) - lu(434) * b(88) - b(119) = b(119) - lu(435) * b(88) - b(127) = b(127) - lu(436) * b(88) - b(131) = b(131) - lu(437) * b(88) - b(132) = b(132) - lu(438) * b(88) - b(133) = b(133) - lu(439) * b(88) - b(134) = b(134) - lu(440) * b(88) - b(104) = b(104) - lu(443) * b(89) - b(105) = b(105) - lu(444) * b(89) - b(120) = b(120) - lu(445) * b(89) - b(125) = b(125) - lu(446) * b(89) - b(129) = b(129) - lu(447) * b(89) - b(130) = b(130) - lu(448) * b(89) - b(131) = b(131) - lu(449) * b(89) - b(134) = b(134) - lu(450) * b(89) - b(135) = b(135) - lu(451) * b(89) - b(118) = b(118) - lu(453) * b(90) - b(121) = b(121) - lu(454) * b(90) - b(122) = b(122) - lu(455) * b(90) - b(127) = b(127) - lu(456) * b(90) - b(131) = b(131) - lu(457) * b(90) - b(134) = b(134) - lu(458) * b(90) - b(104) = b(104) - lu(463) * b(91) - b(119) = b(119) - lu(464) * b(91) - b(120) = b(120) - lu(465) * b(91) - b(125) = b(125) - lu(466) * b(91) - b(129) = b(129) - lu(467) * b(91) - b(130) = b(130) - lu(468) * b(91) - b(131) = b(131) - lu(469) * b(91) - b(135) = b(135) - lu(470) * b(91) - b(103) = b(103) - lu(477) * b(92) - b(120) = b(120) - lu(478) * b(92) - b(121) = b(121) - lu(479) * b(92) - b(122) = b(122) - lu(480) * b(92) - b(127) = b(127) - lu(481) * b(92) - b(129) = b(129) - lu(482) * b(92) - b(130) = b(130) - lu(483) * b(92) - b(131) = b(131) - lu(484) * b(92) - b(117) = b(117) - lu(487) * b(93) - b(121) = b(121) - lu(488) * b(93) - b(124) = b(124) - lu(489) * b(93) - b(126) = b(126) - lu(490) * b(93) - b(131) = b(131) - lu(491) * b(93) - b(134) = b(134) - lu(492) * b(93) - b(101) = b(101) - lu(495) * b(94) - b(102) = b(102) - lu(496) * b(94) - b(103) = b(103) - lu(497) * b(94) - b(107) = b(107) - lu(498) * b(94) - b(111) = b(111) - lu(499) * b(94) - b(113) = b(113) - lu(500) * b(94) - b(114) = b(114) - lu(501) * b(94) - b(119) = b(119) - lu(502) * b(94) - b(123) = b(123) - lu(503) * b(94) - b(125) = b(125) - lu(504) * b(94) - b(131) = b(131) - lu(505) * b(94) - b(132) = b(132) - lu(506) * b(94) - b(134) = b(134) - lu(507) * b(94) - b(135) = b(135) - lu(508) * b(94) - b(103) = b(103) - lu(511) * b(95) - b(125) = b(125) - lu(512) * b(95) - b(131) = b(131) - lu(513) * b(95) - b(135) = b(135) - lu(514) * b(95) - b(104) = b(104) - lu(518) * b(96) - b(106) = b(106) - lu(519) * b(96) - b(115) = b(115) - lu(520) * b(96) - b(119) = b(119) - lu(521) * b(96) - b(120) = b(120) - lu(522) * b(96) - b(125) = b(125) - lu(523) * b(96) - b(129) = b(129) - lu(524) * b(96) - b(130) = b(130) - lu(525) * b(96) - b(131) = b(131) - lu(526) * b(96) - b(134) = b(134) - lu(527) * b(96) - b(135) = b(135) - lu(528) * b(96) - b(103) = b(103) - lu(531) * b(97) - b(110) = b(110) - lu(532) * b(97) - b(125) = b(125) - lu(533) * b(97) - b(130) = b(130) - lu(534) * b(97) - b(131) = b(131) - lu(535) * b(97) - b(132) = b(132) - lu(536) * b(97) - b(135) = b(135) - lu(537) * b(97) - b(106) = b(106) - lu(541) * b(98) - b(107) = b(107) - lu(542) * b(98) - b(113) = b(113) - lu(543) * b(98) - b(115) = b(115) - lu(544) * b(98) - b(119) = b(119) - lu(545) * b(98) - b(125) = b(125) - lu(546) * b(98) - b(129) = b(129) - lu(547) * b(98) - b(130) = b(130) - lu(548) * b(98) - b(131) = b(131) - lu(549) * b(98) - b(134) = b(134) - lu(550) * b(98) - END SUBROUTINE lu_slv02 - - SUBROUTINE lu_slv03(lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(in) :: lu(:) - REAL(KIND=r8), intent(inout) :: b(:) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - b(116) = b(116) - lu(553) * b(99) - b(121) = b(121) - lu(554) * b(99) - b(125) = b(125) - lu(555) * b(99) - b(131) = b(131) - lu(556) * b(99) - b(134) = b(134) - lu(557) * b(99) - b(117) = b(117) - lu(561) * b(100) - b(121) = b(121) - lu(562) * b(100) - b(124) = b(124) - lu(563) * b(100) - b(126) = b(126) - lu(564) * b(100) - b(130) = b(130) - lu(565) * b(100) - b(131) = b(131) - lu(566) * b(100) - b(132) = b(132) - lu(567) * b(100) - b(133) = b(133) - lu(568) * b(100) - b(134) = b(134) - lu(569) * b(100) - b(103) = b(103) - lu(573) * b(101) - b(107) = b(107) - lu(574) * b(101) - b(110) = b(110) - lu(575) * b(101) - b(113) = b(113) - lu(576) * b(101) - b(125) = b(125) - lu(577) * b(101) - b(129) = b(129) - lu(578) * b(101) - b(130) = b(130) - lu(579) * b(101) - b(131) = b(131) - lu(580) * b(101) - b(132) = b(132) - lu(581) * b(101) - b(134) = b(134) - lu(582) * b(101) - b(135) = b(135) - lu(583) * b(101) - b(103) = b(103) - lu(588) * b(102) - b(104) = b(104) - lu(589) * b(102) - b(105) = b(105) - lu(590) * b(102) - b(109) = b(109) - lu(591) * b(102) - b(119) = b(119) - lu(592) * b(102) - b(120) = b(120) - lu(593) * b(102) - b(123) = b(123) - lu(594) * b(102) - b(125) = b(125) - lu(595) * b(102) - b(129) = b(129) - lu(596) * b(102) - b(130) = b(130) - lu(597) * b(102) - b(131) = b(131) - lu(598) * b(102) - b(132) = b(132) - lu(599) * b(102) - b(134) = b(134) - lu(600) * b(102) - b(135) = b(135) - lu(601) * b(102) - b(125) = b(125) - lu(603) * b(103) - b(127) = b(127) - lu(604) * b(103) - b(131) = b(131) - lu(605) * b(103) - b(115) = b(115) - lu(608) * b(104) - b(119) = b(119) - lu(609) * b(104) - b(125) = b(125) - lu(610) * b(104) - b(127) = b(127) - lu(611) * b(104) - b(131) = b(131) - lu(612) * b(104) - b(132) = b(132) - lu(613) * b(104) - b(133) = b(133) - lu(614) * b(104) - b(134) = b(134) - lu(615) * b(104) - b(109) = b(109) - lu(617) * b(105) - b(115) = b(115) - lu(618) * b(105) - b(125) = b(125) - lu(619) * b(105) - b(131) = b(131) - lu(620) * b(105) - b(135) = b(135) - lu(621) * b(105) - b(109) = b(109) - lu(626) * b(106) - b(115) = b(115) - lu(627) * b(106) - b(119) = b(119) - lu(628) * b(106) - b(120) = b(120) - lu(629) * b(106) - b(125) = b(125) - lu(630) * b(106) - b(129) = b(129) - lu(631) * b(106) - b(130) = b(130) - lu(632) * b(106) - b(131) = b(131) - lu(633) * b(106) - b(134) = b(134) - lu(634) * b(106) - b(135) = b(135) - lu(635) * b(106) - b(109) = b(109) - lu(638) * b(107) - b(112) = b(112) - lu(639) * b(107) - b(114) = b(114) - lu(640) * b(107) - b(115) = b(115) - lu(641) * b(107) - b(123) = b(123) - lu(642) * b(107) - b(125) = b(125) - lu(643) * b(107) - b(127) = b(127) - lu(644) * b(107) - b(131) = b(131) - lu(645) * b(107) - b(134) = b(134) - lu(646) * b(107) - b(135) = b(135) - lu(647) * b(107) - b(117) = b(117) - lu(651) * b(108) - b(119) = b(119) - lu(652) * b(108) - b(121) = b(121) - lu(653) * b(108) - b(122) = b(122) - lu(654) * b(108) - b(126) = b(126) - lu(655) * b(108) - b(127) = b(127) - lu(656) * b(108) - b(131) = b(131) - lu(657) * b(108) - b(132) = b(132) - lu(658) * b(108) - b(133) = b(133) - lu(659) * b(108) - b(134) = b(134) - lu(660) * b(108) - b(115) = b(115) - lu(663) * b(109) - b(125) = b(125) - lu(664) * b(109) - b(127) = b(127) - lu(665) * b(109) - b(131) = b(131) - lu(666) * b(109) - b(132) = b(132) - lu(667) * b(109) - b(133) = b(133) - lu(668) * b(109) - b(134) = b(134) - lu(669) * b(109) - b(115) = b(115) - lu(678) * b(110) - b(119) = b(119) - lu(679) * b(110) - b(125) = b(125) - lu(680) * b(110) - b(127) = b(127) - lu(681) * b(110) - b(129) = b(129) - lu(682) * b(110) - b(130) = b(130) - lu(683) * b(110) - b(131) = b(131) - lu(684) * b(110) - b(132) = b(132) - lu(685) * b(110) - b(133) = b(133) - lu(686) * b(110) - b(134) = b(134) - lu(687) * b(110) - b(135) = b(135) - lu(688) * b(110) - b(112) = b(112) - lu(698) * b(111) - b(113) = b(113) - lu(699) * b(111) - b(114) = b(114) - lu(700) * b(111) - b(115) = b(115) - lu(701) * b(111) - b(119) = b(119) - lu(702) * b(111) - b(123) = b(123) - lu(703) * b(111) - b(125) = b(125) - lu(704) * b(111) - b(127) = b(127) - lu(705) * b(111) - b(129) = b(129) - lu(706) * b(111) - b(130) = b(130) - lu(707) * b(111) - b(131) = b(131) - lu(708) * b(111) - b(132) = b(132) - lu(709) * b(111) - b(133) = b(133) - lu(710) * b(111) - b(134) = b(134) - lu(711) * b(111) - b(135) = b(135) - lu(712) * b(111) - b(114) = b(114) - lu(722) * b(112) - b(115) = b(115) - lu(723) * b(112) - b(119) = b(119) - lu(724) * b(112) - b(125) = b(125) - lu(725) * b(112) - b(127) = b(127) - lu(726) * b(112) - b(129) = b(129) - lu(727) * b(112) - b(130) = b(130) - lu(728) * b(112) - b(131) = b(131) - lu(729) * b(112) - b(132) = b(132) - lu(730) * b(112) - b(133) = b(133) - lu(731) * b(112) - b(134) = b(134) - lu(732) * b(112) - b(135) = b(135) - lu(733) * b(112) - b(114) = b(114) - lu(741) * b(113) - b(115) = b(115) - lu(742) * b(113) - b(119) = b(119) - lu(743) * b(113) - b(120) = b(120) - lu(744) * b(113) - b(123) = b(123) - lu(745) * b(113) - b(125) = b(125) - lu(746) * b(113) - b(127) = b(127) - lu(747) * b(113) - b(129) = b(129) - lu(748) * b(113) - b(130) = b(130) - lu(749) * b(113) - b(131) = b(131) - lu(750) * b(113) - b(132) = b(132) - lu(751) * b(113) - b(133) = b(133) - lu(752) * b(113) - b(134) = b(134) - lu(753) * b(113) - b(135) = b(135) - lu(754) * b(113) - b(115) = b(115) - lu(761) * b(114) - b(119) = b(119) - lu(762) * b(114) - b(120) = b(120) - lu(763) * b(114) - b(123) = b(123) - lu(764) * b(114) - b(125) = b(125) - lu(765) * b(114) - b(127) = b(127) - lu(766) * b(114) - b(129) = b(129) - lu(767) * b(114) - b(130) = b(130) - lu(768) * b(114) - b(131) = b(131) - lu(769) * b(114) - b(132) = b(132) - lu(770) * b(114) - b(133) = b(133) - lu(771) * b(114) - b(134) = b(134) - lu(772) * b(114) - b(135) = b(135) - lu(773) * b(114) - b(119) = b(119) - lu(790) * b(115) - b(120) = b(120) - lu(791) * b(115) - b(123) = b(123) - lu(792) * b(115) - b(125) = b(125) - lu(793) * b(115) - b(127) = b(127) - lu(794) * b(115) - b(129) = b(129) - lu(795) * b(115) - b(130) = b(130) - lu(796) * b(115) - b(131) = b(131) - lu(797) * b(115) - b(132) = b(132) - lu(798) * b(115) - b(133) = b(133) - lu(799) * b(115) - b(134) = b(134) - lu(800) * b(115) - b(135) = b(135) - lu(801) * b(115) - b(118) = b(118) - lu(806) * b(116) - b(120) = b(120) - lu(807) * b(116) - b(121) = b(121) - lu(808) * b(116) - b(123) = b(123) - lu(809) * b(116) - b(124) = b(124) - lu(810) * b(116) - b(125) = b(125) - lu(811) * b(116) - b(126) = b(126) - lu(812) * b(116) - b(127) = b(127) - lu(813) * b(116) - b(128) = b(128) - lu(814) * b(116) - b(129) = b(129) - lu(815) * b(116) - b(130) = b(130) - lu(816) * b(116) - b(131) = b(131) - lu(817) * b(116) - b(134) = b(134) - lu(818) * b(116) - b(118) = b(118) - lu(825) * b(117) - b(121) = b(121) - lu(826) * b(117) - b(122) = b(122) - lu(827) * b(117) - b(124) = b(124) - lu(828) * b(117) - b(126) = b(126) - lu(829) * b(117) - b(127) = b(127) - lu(830) * b(117) - b(128) = b(128) - lu(831) * b(117) - b(130) = b(130) - lu(832) * b(117) - b(131) = b(131) - lu(833) * b(117) - b(132) = b(132) - lu(834) * b(117) - b(133) = b(133) - lu(835) * b(117) - b(134) = b(134) - lu(836) * b(117) - b(120) = b(120) - lu(840) * b(118) - b(121) = b(121) - lu(841) * b(118) - b(122) = b(122) - lu(842) * b(118) - b(123) = b(123) - lu(843) * b(118) - b(125) = b(125) - lu(844) * b(118) - b(127) = b(127) - lu(845) * b(118) - b(128) = b(128) - lu(846) * b(118) - b(131) = b(131) - lu(847) * b(118) - b(134) = b(134) - lu(848) * b(118) - b(135) = b(135) - lu(849) * b(118) - END SUBROUTINE lu_slv03 - - SUBROUTINE lu_slv04(lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(in) :: lu(:) - REAL(KIND=r8), intent(inout) :: b(:) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - b(120) = b(120) - lu(873) * b(119) - b(123) = b(123) - lu(874) * b(119) - b(124) = b(124) - lu(875) * b(119) - b(125) = b(125) - lu(876) * b(119) - b(126) = b(126) - lu(877) * b(119) - b(127) = b(127) - lu(878) * b(119) - b(129) = b(129) - lu(879) * b(119) - b(130) = b(130) - lu(880) * b(119) - b(131) = b(131) - lu(881) * b(119) - b(132) = b(132) - lu(882) * b(119) - b(133) = b(133) - lu(883) * b(119) - b(134) = b(134) - lu(884) * b(119) - b(135) = b(135) - lu(885) * b(119) - b(121) = b(121) - lu(904) * b(120) - b(122) = b(122) - lu(905) * b(120) - b(123) = b(123) - lu(906) * b(120) - b(124) = b(124) - lu(907) * b(120) - b(125) = b(125) - lu(908) * b(120) - b(126) = b(126) - lu(909) * b(120) - b(127) = b(127) - lu(910) * b(120) - b(128) = b(128) - lu(911) * b(120) - b(129) = b(129) - lu(912) * b(120) - b(130) = b(130) - lu(913) * b(120) - b(131) = b(131) - lu(914) * b(120) - b(134) = b(134) - lu(915) * b(120) - b(135) = b(135) - lu(916) * b(120) - b(122) = b(122) - lu(944) * b(121) - b(123) = b(123) - lu(945) * b(121) - b(124) = b(124) - lu(946) * b(121) - b(125) = b(125) - lu(947) * b(121) - b(126) = b(126) - lu(948) * b(121) - b(127) = b(127) - lu(949) * b(121) - b(128) = b(128) - lu(950) * b(121) - b(129) = b(129) - lu(951) * b(121) - b(130) = b(130) - lu(952) * b(121) - b(131) = b(131) - lu(953) * b(121) - b(132) = b(132) - lu(954) * b(121) - b(133) = b(133) - lu(955) * b(121) - b(134) = b(134) - lu(956) * b(121) - b(135) = b(135) - lu(957) * b(121) - b(123) = b(123) - lu(971) * b(122) - b(124) = b(124) - lu(972) * b(122) - b(125) = b(125) - lu(973) * b(122) - b(126) = b(126) - lu(974) * b(122) - b(127) = b(127) - lu(975) * b(122) - b(128) = b(128) - lu(976) * b(122) - b(129) = b(129) - lu(977) * b(122) - b(130) = b(130) - lu(978) * b(122) - b(131) = b(131) - lu(979) * b(122) - b(132) = b(132) - lu(980) * b(122) - b(133) = b(133) - lu(981) * b(122) - b(134) = b(134) - lu(982) * b(122) - b(135) = b(135) - lu(983) * b(122) - b(124) = b(124) - lu(1017) * b(123) - b(125) = b(125) - lu(1018) * b(123) - b(126) = b(126) - lu(1019) * b(123) - b(127) = b(127) - lu(1020) * b(123) - b(128) = b(128) - lu(1021) * b(123) - b(129) = b(129) - lu(1022) * b(123) - b(130) = b(130) - lu(1023) * b(123) - b(131) = b(131) - lu(1024) * b(123) - b(132) = b(132) - lu(1025) * b(123) - b(133) = b(133) - lu(1026) * b(123) - b(134) = b(134) - lu(1027) * b(123) - b(135) = b(135) - lu(1028) * b(123) - b(125) = b(125) - lu(1045) * b(124) - b(126) = b(126) - lu(1046) * b(124) - b(127) = b(127) - lu(1047) * b(124) - b(128) = b(128) - lu(1048) * b(124) - b(129) = b(129) - lu(1049) * b(124) - b(130) = b(130) - lu(1050) * b(124) - b(131) = b(131) - lu(1051) * b(124) - b(132) = b(132) - lu(1052) * b(124) - b(133) = b(133) - lu(1053) * b(124) - b(134) = b(134) - lu(1054) * b(124) - b(135) = b(135) - lu(1055) * b(124) - b(126) = b(126) - lu(1115) * b(125) - b(127) = b(127) - lu(1116) * b(125) - b(128) = b(128) - lu(1117) * b(125) - b(129) = b(129) - lu(1118) * b(125) - b(130) = b(130) - lu(1119) * b(125) - b(131) = b(131) - lu(1120) * b(125) - b(132) = b(132) - lu(1121) * b(125) - b(133) = b(133) - lu(1122) * b(125) - b(134) = b(134) - lu(1123) * b(125) - b(135) = b(135) - lu(1124) * b(125) - b(127) = b(127) - lu(1151) * b(126) - b(128) = b(128) - lu(1152) * b(126) - b(129) = b(129) - lu(1153) * b(126) - b(130) = b(130) - lu(1154) * b(126) - b(131) = b(131) - lu(1155) * b(126) - b(132) = b(132) - lu(1156) * b(126) - b(133) = b(133) - lu(1157) * b(126) - b(134) = b(134) - lu(1158) * b(126) - b(135) = b(135) - lu(1159) * b(126) - b(128) = b(128) - lu(1172) * b(127) - b(129) = b(129) - lu(1173) * b(127) - b(130) = b(130) - lu(1174) * b(127) - b(131) = b(131) - lu(1175) * b(127) - b(132) = b(132) - lu(1176) * b(127) - b(133) = b(133) - lu(1177) * b(127) - b(134) = b(134) - lu(1178) * b(127) - b(135) = b(135) - lu(1179) * b(127) - b(129) = b(129) - lu(1197) * b(128) - b(130) = b(130) - lu(1198) * b(128) - b(131) = b(131) - lu(1199) * b(128) - b(132) = b(132) - lu(1200) * b(128) - b(133) = b(133) - lu(1201) * b(128) - b(134) = b(134) - lu(1202) * b(128) - b(135) = b(135) - lu(1203) * b(128) - b(130) = b(130) - lu(1253) * b(129) - b(131) = b(131) - lu(1254) * b(129) - b(132) = b(132) - lu(1255) * b(129) - b(133) = b(133) - lu(1256) * b(129) - b(134) = b(134) - lu(1257) * b(129) - b(135) = b(135) - lu(1258) * b(129) - b(131) = b(131) - lu(1291) * b(130) - b(132) = b(132) - lu(1292) * b(130) - b(133) = b(133) - lu(1293) * b(130) - b(134) = b(134) - lu(1294) * b(130) - b(135) = b(135) - lu(1295) * b(130) - b(132) = b(132) - lu(1390) * b(131) - b(133) = b(133) - lu(1391) * b(131) - b(134) = b(134) - lu(1392) * b(131) - b(135) = b(135) - lu(1393) * b(131) - b(133) = b(133) - lu(1435) * b(132) - b(134) = b(134) - lu(1436) * b(132) - b(135) = b(135) - lu(1437) * b(132) - b(134) = b(134) - lu(1458) * b(133) - b(135) = b(135) - lu(1459) * b(133) - b(135) = b(135) - lu(1485) * b(134) - END SUBROUTINE lu_slv04 - - SUBROUTINE lu_slv05(lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(in) :: lu(:) - REAL(KIND=r8), intent(inout) :: b(:) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... Solve U * x = y - !----------------------------------------------------------------------- - b(135) = b(135) * lu(1509) - b(134) = b(134) - lu(1508) * b(135) - b(133) = b(133) - lu(1507) * b(135) - b(132) = b(132) - lu(1506) * b(135) - b(131) = b(131) - lu(1505) * b(135) - b(130) = b(130) - lu(1504) * b(135) - b(129) = b(129) - lu(1503) * b(135) - b(128) = b(128) - lu(1502) * b(135) - b(127) = b(127) - lu(1501) * b(135) - b(126) = b(126) - lu(1500) * b(135) - b(125) = b(125) - lu(1499) * b(135) - b(124) = b(124) - lu(1498) * b(135) - b(123) = b(123) - lu(1497) * b(135) - b(122) = b(122) - lu(1496) * b(135) - b(121) = b(121) - lu(1495) * b(135) - b(120) = b(120) - lu(1494) * b(135) - b(119) = b(119) - lu(1493) * b(135) - b(118) = b(118) - lu(1492) * b(135) - b(117) = b(117) - lu(1491) * b(135) - b(108) = b(108) - lu(1490) * b(135) - b(103) = b(103) - lu(1489) * b(135) - b(90) = b(90) - lu(1488) * b(135) - b(64) = b(64) - lu(1487) * b(135) - b(54) = b(54) - lu(1486) * b(135) - b(134) = b(134) * lu(1484) - b(133) = b(133) - lu(1483) * b(134) - b(132) = b(132) - lu(1482) * b(134) - b(131) = b(131) - lu(1481) * b(134) - b(130) = b(130) - lu(1480) * b(134) - b(129) = b(129) - lu(1479) * b(134) - b(128) = b(128) - lu(1478) * b(134) - b(127) = b(127) - lu(1477) * b(134) - b(126) = b(126) - lu(1476) * b(134) - b(125) = b(125) - lu(1475) * b(134) - b(124) = b(124) - lu(1474) * b(134) - b(123) = b(123) - lu(1473) * b(134) - b(122) = b(122) - lu(1472) * b(134) - b(121) = b(121) - lu(1471) * b(134) - b(120) = b(120) - lu(1470) * b(134) - b(119) = b(119) - lu(1469) * b(134) - b(118) = b(118) - lu(1468) * b(134) - b(117) = b(117) - lu(1467) * b(134) - b(116) = b(116) - lu(1466) * b(134) - b(108) = b(108) - lu(1465) * b(134) - b(99) = b(99) - lu(1464) * b(134) - b(88) = b(88) - lu(1463) * b(134) - b(36) = b(36) - lu(1462) * b(134) - b(34) = b(34) - lu(1461) * b(134) - b(26) = b(26) - lu(1460) * b(134) - b(133) = b(133) * lu(1457) - b(132) = b(132) - lu(1456) * b(133) - b(131) = b(131) - lu(1455) * b(133) - b(130) = b(130) - lu(1454) * b(133) - b(129) = b(129) - lu(1453) * b(133) - b(128) = b(128) - lu(1452) * b(133) - b(127) = b(127) - lu(1451) * b(133) - b(126) = b(126) - lu(1450) * b(133) - b(125) = b(125) - lu(1449) * b(133) - b(124) = b(124) - lu(1448) * b(133) - b(123) = b(123) - lu(1447) * b(133) - b(122) = b(122) - lu(1446) * b(133) - b(121) = b(121) - lu(1445) * b(133) - b(120) = b(120) - lu(1444) * b(133) - b(119) = b(119) - lu(1443) * b(133) - b(118) = b(118) - lu(1442) * b(133) - b(117) = b(117) - lu(1441) * b(133) - b(108) = b(108) - lu(1440) * b(133) - b(88) = b(88) - lu(1439) * b(133) - b(34) = b(34) - lu(1438) * b(133) - b(132) = b(132) * lu(1434) - b(131) = b(131) - lu(1433) * b(132) - b(130) = b(130) - lu(1432) * b(132) - b(129) = b(129) - lu(1431) * b(132) - b(128) = b(128) - lu(1430) * b(132) - b(127) = b(127) - lu(1429) * b(132) - b(126) = b(126) - lu(1428) * b(132) - b(125) = b(125) - lu(1427) * b(132) - b(124) = b(124) - lu(1426) * b(132) - b(123) = b(123) - lu(1425) * b(132) - b(122) = b(122) - lu(1424) * b(132) - b(121) = b(121) - lu(1423) * b(132) - b(120) = b(120) - lu(1422) * b(132) - b(119) = b(119) - lu(1421) * b(132) - b(118) = b(118) - lu(1420) * b(132) - b(116) = b(116) - lu(1419) * b(132) - b(115) = b(115) - lu(1418) * b(132) - b(114) = b(114) - lu(1417) * b(132) - b(113) = b(113) - lu(1416) * b(132) - b(112) = b(112) - lu(1415) * b(132) - b(111) = b(111) - lu(1414) * b(132) - b(110) = b(110) - lu(1413) * b(132) - b(109) = b(109) - lu(1412) * b(132) - b(107) = b(107) - lu(1411) * b(132) - b(106) = b(106) - lu(1410) * b(132) - b(105) = b(105) - lu(1409) * b(132) - b(104) = b(104) - lu(1408) * b(132) - b(103) = b(103) - lu(1407) * b(132) - b(102) = b(102) - lu(1406) * b(132) - b(101) = b(101) - lu(1405) * b(132) - b(99) = b(99) - lu(1404) * b(132) - b(98) = b(98) - lu(1403) * b(132) - b(97) = b(97) - lu(1402) * b(132) - b(95) = b(95) - lu(1401) * b(132) - b(94) = b(94) - lu(1400) * b(132) - b(81) = b(81) - lu(1399) * b(132) - b(73) = b(73) - lu(1398) * b(132) - b(49) = b(49) - lu(1397) * b(132) - b(47) = b(47) - lu(1396) * b(132) - b(40) = b(40) - lu(1395) * b(132) - b(39) = b(39) - lu(1394) * b(132) - b(131) = b(131) * lu(1389) - b(130) = b(130) - lu(1388) * b(131) - b(129) = b(129) - lu(1387) * b(131) - b(128) = b(128) - lu(1386) * b(131) - b(127) = b(127) - lu(1385) * b(131) - b(126) = b(126) - lu(1384) * b(131) - b(125) = b(125) - lu(1383) * b(131) - b(124) = b(124) - lu(1382) * b(131) - b(123) = b(123) - lu(1381) * b(131) - b(122) = b(122) - lu(1380) * b(131) - b(121) = b(121) - lu(1379) * b(131) - b(120) = b(120) - lu(1378) * b(131) - b(119) = b(119) - lu(1377) * b(131) - b(118) = b(118) - lu(1376) * b(131) - b(117) = b(117) - lu(1375) * b(131) - b(116) = b(116) - lu(1374) * b(131) - b(115) = b(115) - lu(1373) * b(131) - b(114) = b(114) - lu(1372) * b(131) - b(113) = b(113) - lu(1371) * b(131) - b(112) = b(112) - lu(1370) * b(131) - b(111) = b(111) - lu(1369) * b(131) - b(110) = b(110) - lu(1368) * b(131) - b(109) = b(109) - lu(1367) * b(131) - b(108) = b(108) - lu(1366) * b(131) - b(107) = b(107) - lu(1365) * b(131) - b(106) = b(106) - lu(1364) * b(131) - b(105) = b(105) - lu(1363) * b(131) - b(104) = b(104) - lu(1362) * b(131) - b(103) = b(103) - lu(1361) * b(131) - b(102) = b(102) - lu(1360) * b(131) - b(101) = b(101) - lu(1359) * b(131) - b(100) = b(100) - lu(1358) * b(131) - b(99) = b(99) - lu(1357) * b(131) - b(98) = b(98) - lu(1356) * b(131) - b(97) = b(97) - lu(1355) * b(131) - b(96) = b(96) - lu(1354) * b(131) - b(95) = b(95) - lu(1353) * b(131) - b(94) = b(94) - lu(1352) * b(131) - b(93) = b(93) - lu(1351) * b(131) - b(92) = b(92) - lu(1350) * b(131) - b(91) = b(91) - lu(1349) * b(131) - b(90) = b(90) - lu(1348) * b(131) - b(89) = b(89) - lu(1347) * b(131) - b(88) = b(88) - lu(1346) * b(131) - b(83) = b(83) - lu(1345) * b(131) - b(82) = b(82) - lu(1344) * b(131) - b(81) = b(81) - lu(1343) * b(131) - b(80) = b(80) - lu(1342) * b(131) - b(79) = b(79) - lu(1341) * b(131) - b(77) = b(77) - lu(1340) * b(131) - b(76) = b(76) - lu(1339) * b(131) - b(75) = b(75) - lu(1338) * b(131) - b(74) = b(74) - lu(1337) * b(131) - b(73) = b(73) - lu(1336) * b(131) - b(71) = b(71) - lu(1335) * b(131) - b(69) = b(69) - lu(1334) * b(131) - b(68) = b(68) - lu(1333) * b(131) - b(67) = b(67) - lu(1332) * b(131) - b(66) = b(66) - lu(1331) * b(131) - b(65) = b(65) - lu(1330) * b(131) - b(64) = b(64) - lu(1329) * b(131) - b(63) = b(63) - lu(1328) * b(131) - b(62) = b(62) - lu(1327) * b(131) - b(60) = b(60) - lu(1326) * b(131) - b(59) = b(59) - lu(1325) * b(131) - b(57) = b(57) - lu(1324) * b(131) - b(55) = b(55) - lu(1323) * b(131) - b(53) = b(53) - lu(1322) * b(131) - b(52) = b(52) - lu(1321) * b(131) - b(51) = b(51) - lu(1320) * b(131) - b(50) = b(50) - lu(1319) * b(131) - b(49) = b(49) - lu(1318) * b(131) - b(48) = b(48) - lu(1317) * b(131) - b(47) = b(47) - lu(1316) * b(131) - b(45) = b(45) - lu(1315) * b(131) - b(44) = b(44) - lu(1314) * b(131) - b(43) = b(43) - lu(1313) * b(131) - b(42) = b(42) - lu(1312) * b(131) - b(41) = b(41) - lu(1311) * b(131) - b(39) = b(39) - lu(1310) * b(131) - b(38) = b(38) - lu(1309) * b(131) - b(37) = b(37) - lu(1308) * b(131) - b(36) = b(36) - lu(1307) * b(131) - b(35) = b(35) - lu(1306) * b(131) - b(32) = b(32) - lu(1305) * b(131) - b(31) = b(31) - lu(1304) * b(131) - b(30) = b(30) - lu(1303) * b(131) - b(25) = b(25) - lu(1302) * b(131) - b(23) = b(23) - lu(1301) * b(131) - b(22) = b(22) - lu(1300) * b(131) - b(21) = b(21) - lu(1299) * b(131) - b(20) = b(20) - lu(1298) * b(131) - b(19) = b(19) - lu(1297) * b(131) - b(17) = b(17) - lu(1296) * b(131) - END SUBROUTINE lu_slv05 - - SUBROUTINE lu_slv06(lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(in) :: lu(:) - REAL(KIND=r8), intent(inout) :: b(:) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - b(130) = b(130) * lu(1290) - b(129) = b(129) - lu(1289) * b(130) - b(128) = b(128) - lu(1288) * b(130) - b(127) = b(127) - lu(1287) * b(130) - b(126) = b(126) - lu(1286) * b(130) - b(125) = b(125) - lu(1285) * b(130) - b(124) = b(124) - lu(1284) * b(130) - b(123) = b(123) - lu(1283) * b(130) - b(122) = b(122) - lu(1282) * b(130) - b(121) = b(121) - lu(1281) * b(130) - b(120) = b(120) - lu(1280) * b(130) - b(119) = b(119) - lu(1279) * b(130) - b(118) = b(118) - lu(1278) * b(130) - b(117) = b(117) - lu(1277) * b(130) - b(116) = b(116) - lu(1276) * b(130) - b(115) = b(115) - lu(1275) * b(130) - b(114) = b(114) - lu(1274) * b(130) - b(109) = b(109) - lu(1273) * b(130) - b(105) = b(105) - lu(1272) * b(130) - b(103) = b(103) - lu(1271) * b(130) - b(100) = b(100) - lu(1270) * b(130) - b(99) = b(99) - lu(1269) * b(130) - b(92) = b(92) - lu(1268) * b(130) - b(84) = b(84) - lu(1267) * b(130) - b(81) = b(81) - lu(1266) * b(130) - b(71) = b(71) - lu(1265) * b(130) - b(70) = b(70) - lu(1264) * b(130) - b(66) = b(66) - lu(1263) * b(130) - b(60) = b(60) - lu(1262) * b(130) - b(57) = b(57) - lu(1261) * b(130) - b(40) = b(40) - lu(1260) * b(130) - b(31) = b(31) - lu(1259) * b(130) - b(129) = b(129) * lu(1252) - b(128) = b(128) - lu(1251) * b(129) - b(127) = b(127) - lu(1250) * b(129) - b(126) = b(126) - lu(1249) * b(129) - b(125) = b(125) - lu(1248) * b(129) - b(124) = b(124) - lu(1247) * b(129) - b(123) = b(123) - lu(1246) * b(129) - b(122) = b(122) - lu(1245) * b(129) - b(121) = b(121) - lu(1244) * b(129) - b(120) = b(120) - lu(1243) * b(129) - b(119) = b(119) - lu(1242) * b(129) - b(118) = b(118) - lu(1241) * b(129) - b(115) = b(115) - lu(1240) * b(129) - b(114) = b(114) - lu(1239) * b(129) - b(113) = b(113) - lu(1238) * b(129) - b(112) = b(112) - lu(1237) * b(129) - b(111) = b(111) - lu(1236) * b(129) - b(110) = b(110) - lu(1235) * b(129) - b(109) = b(109) - lu(1234) * b(129) - b(107) = b(107) - lu(1233) * b(129) - b(106) = b(106) - lu(1232) * b(129) - b(105) = b(105) - lu(1231) * b(129) - b(104) = b(104) - lu(1230) * b(129) - b(103) = b(103) - lu(1229) * b(129) - b(101) = b(101) - lu(1228) * b(129) - b(98) = b(98) - lu(1227) * b(129) - b(97) = b(97) - lu(1226) * b(129) - b(96) = b(96) - lu(1225) * b(129) - b(95) = b(95) - lu(1224) * b(129) - b(92) = b(92) - lu(1223) * b(129) - b(91) = b(91) - lu(1222) * b(129) - b(89) = b(89) - lu(1221) * b(129) - b(87) = b(87) - lu(1220) * b(129) - b(86) = b(86) - lu(1219) * b(129) - b(85) = b(85) - lu(1218) * b(129) - b(83) = b(83) - lu(1217) * b(129) - b(81) = b(81) - lu(1216) * b(129) - b(80) = b(80) - lu(1215) * b(129) - b(79) = b(79) - lu(1214) * b(129) - b(77) = b(77) - lu(1213) * b(129) - b(66) = b(66) - lu(1212) * b(129) - b(65) = b(65) - lu(1211) * b(129) - b(64) = b(64) - lu(1210) * b(129) - b(56) = b(56) - lu(1209) * b(129) - b(55) = b(55) - lu(1208) * b(129) - b(54) = b(54) - lu(1207) * b(129) - b(49) = b(49) - lu(1206) * b(129) - b(47) = b(47) - lu(1205) * b(129) - b(41) = b(41) - lu(1204) * b(129) - b(128) = b(128) * lu(1196) - b(127) = b(127) - lu(1195) * b(128) - b(126) = b(126) - lu(1194) * b(128) - b(125) = b(125) - lu(1193) * b(128) - b(124) = b(124) - lu(1192) * b(128) - b(123) = b(123) - lu(1191) * b(128) - b(122) = b(122) - lu(1190) * b(128) - b(121) = b(121) - lu(1189) * b(128) - b(120) = b(120) - lu(1188) * b(128) - b(118) = b(118) - lu(1187) * b(128) - b(117) = b(117) - lu(1186) * b(128) - b(116) = b(116) - lu(1185) * b(128) - b(99) = b(99) - lu(1184) * b(128) - b(84) = b(84) - lu(1183) * b(128) - b(70) = b(70) - lu(1182) * b(128) - b(46) = b(46) - lu(1181) * b(128) - b(33) = b(33) - lu(1180) * b(128) - b(127) = b(127) * lu(1171) - b(126) = b(126) - lu(1170) * b(127) - b(125) = b(125) - lu(1169) * b(127) - b(124) = b(124) - lu(1168) * b(127) - b(123) = b(123) - lu(1167) * b(127) - b(122) = b(122) - lu(1166) * b(127) - b(121) = b(121) - lu(1165) * b(127) - b(120) = b(120) - lu(1164) * b(127) - b(119) = b(119) - lu(1163) * b(127) - b(118) = b(118) - lu(1162) * b(127) - b(117) = b(117) - lu(1161) * b(127) - b(108) = b(108) - lu(1160) * b(127) - b(126) = b(126) * lu(1150) - b(125) = b(125) - lu(1149) * b(126) - b(124) = b(124) - lu(1148) * b(126) - b(123) = b(123) - lu(1147) * b(126) - b(122) = b(122) - lu(1146) * b(126) - b(121) = b(121) - lu(1145) * b(126) - b(120) = b(120) - lu(1144) * b(126) - b(119) = b(119) - lu(1143) * b(126) - b(118) = b(118) - lu(1142) * b(126) - b(117) = b(117) - lu(1141) * b(126) - b(115) = b(115) - lu(1140) * b(126) - b(108) = b(108) - lu(1139) * b(126) - b(104) = b(104) - lu(1138) * b(126) - b(103) = b(103) - lu(1137) * b(126) - b(100) = b(100) - lu(1136) * b(126) - b(95) = b(95) - lu(1135) * b(126) - b(93) = b(93) - lu(1134) * b(126) - b(91) = b(91) - lu(1133) * b(126) - b(83) = b(83) - lu(1132) * b(126) - b(81) = b(81) - lu(1131) * b(126) - b(74) = b(74) - lu(1130) * b(126) - b(64) = b(64) - lu(1129) * b(126) - b(63) = b(63) - lu(1128) * b(126) - b(38) = b(38) - lu(1127) * b(126) - b(37) = b(37) - lu(1126) * b(126) - b(29) = b(29) - lu(1125) * b(126) - b(125) = b(125) * lu(1114) - b(124) = b(124) - lu(1113) * b(125) - b(123) = b(123) - lu(1112) * b(125) - b(122) = b(122) - lu(1111) * b(125) - b(121) = b(121) - lu(1110) * b(125) - b(120) = b(120) - lu(1109) * b(125) - b(119) = b(119) - lu(1108) * b(125) - b(118) = b(118) - lu(1107) * b(125) - b(117) = b(117) - lu(1106) * b(125) - b(115) = b(115) - lu(1105) * b(125) - b(114) = b(114) - lu(1104) * b(125) - b(113) = b(113) - lu(1103) * b(125) - b(112) = b(112) - lu(1102) * b(125) - b(111) = b(111) - lu(1101) * b(125) - b(110) = b(110) - lu(1100) * b(125) - b(109) = b(109) - lu(1099) * b(125) - b(108) = b(108) - lu(1098) * b(125) - b(107) = b(107) - lu(1097) * b(125) - b(106) = b(106) - lu(1096) * b(125) - b(105) = b(105) - lu(1095) * b(125) - b(104) = b(104) - lu(1094) * b(125) - b(103) = b(103) - lu(1093) * b(125) - b(101) = b(101) - lu(1092) * b(125) - b(98) = b(98) - lu(1091) * b(125) - b(97) = b(97) - lu(1090) * b(125) - b(96) = b(96) - lu(1089) * b(125) - b(95) = b(95) - lu(1088) * b(125) - b(93) = b(93) - lu(1087) * b(125) - b(91) = b(91) - lu(1086) * b(125) - b(90) = b(90) - lu(1085) * b(125) - b(89) = b(89) - lu(1084) * b(125) - b(84) = b(84) - lu(1083) * b(125) - b(83) = b(83) - lu(1082) * b(125) - b(81) = b(81) - lu(1081) * b(125) - b(80) = b(80) - lu(1080) * b(125) - b(79) = b(79) - lu(1079) * b(125) - b(77) = b(77) - lu(1078) * b(125) - b(76) = b(76) - lu(1077) * b(125) - b(75) = b(75) - lu(1076) * b(125) - b(74) = b(74) - lu(1075) * b(125) - b(69) = b(69) - lu(1074) * b(125) - b(67) = b(67) - lu(1073) * b(125) - b(66) = b(66) - lu(1072) * b(125) - b(65) = b(65) - lu(1071) * b(125) - b(64) = b(64) - lu(1070) * b(125) - b(62) = b(62) - lu(1069) * b(125) - b(60) = b(60) - lu(1068) * b(125) - b(59) = b(59) - lu(1067) * b(125) - b(56) = b(56) - lu(1066) * b(125) - b(54) = b(54) - lu(1065) * b(125) - b(53) = b(53) - lu(1064) * b(125) - b(52) = b(52) - lu(1063) * b(125) - b(51) = b(51) - lu(1062) * b(125) - b(50) = b(50) - lu(1061) * b(125) - b(45) = b(45) - lu(1060) * b(125) - b(44) = b(44) - lu(1059) * b(125) - b(43) = b(43) - lu(1058) * b(125) - b(42) = b(42) - lu(1057) * b(125) - b(24) = b(24) - lu(1056) * b(125) - b(124) = b(124) * lu(1044) - b(123) = b(123) - lu(1043) * b(124) - b(122) = b(122) - lu(1042) * b(124) - b(121) = b(121) - lu(1041) * b(124) - b(120) = b(120) - lu(1040) * b(124) - b(119) = b(119) - lu(1039) * b(124) - b(118) = b(118) - lu(1038) * b(124) - b(117) = b(117) - lu(1037) * b(124) - b(116) = b(116) - lu(1036) * b(124) - b(100) = b(100) - lu(1035) * b(124) - b(99) = b(99) - lu(1034) * b(124) - b(93) = b(93) - lu(1033) * b(124) - b(46) = b(46) - lu(1032) * b(124) - b(33) = b(33) - lu(1031) * b(124) - b(29) = b(29) - lu(1030) * b(124) - b(18) = b(18) - lu(1029) * b(124) - END SUBROUTINE lu_slv06 - - SUBROUTINE lu_slv07(lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(in) :: lu(:) - REAL(KIND=r8), intent(inout) :: b(:) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - b(123) = b(123) * lu(1016) - b(122) = b(122) - lu(1015) * b(123) - b(121) = b(121) - lu(1014) * b(123) - b(120) = b(120) - lu(1013) * b(123) - b(119) = b(119) - lu(1012) * b(123) - b(118) = b(118) - lu(1011) * b(123) - b(116) = b(116) - lu(1010) * b(123) - b(115) = b(115) - lu(1009) * b(123) - b(114) = b(114) - lu(1008) * b(123) - b(113) = b(113) - lu(1007) * b(123) - b(112) = b(112) - lu(1006) * b(123) - b(111) = b(111) - lu(1005) * b(123) - b(110) = b(110) - lu(1004) * b(123) - b(109) = b(109) - lu(1003) * b(123) - b(107) = b(107) - lu(1002) * b(123) - b(106) = b(106) - lu(1001) * b(123) - b(105) = b(105) - lu(1000) * b(123) - b(104) = b(104) - lu(999) * b(123) - b(103) = b(103) - lu(998) * b(123) - b(102) = b(102) - lu(997) * b(123) - b(101) = b(101) - lu(996) * b(123) - b(99) = b(99) - lu(995) * b(123) - b(98) = b(98) - lu(994) * b(123) - b(95) = b(95) - lu(993) * b(123) - b(94) = b(94) - lu(992) * b(123) - b(83) = b(83) - lu(991) * b(123) - b(82) = b(82) - lu(990) * b(123) - b(75) = b(75) - lu(989) * b(123) - b(73) = b(73) - lu(988) * b(123) - b(64) = b(64) - lu(987) * b(123) - b(63) = b(63) - lu(986) * b(123) - b(28) = b(28) - lu(985) * b(123) - b(27) = b(27) - lu(984) * b(123) - b(122) = b(122) * lu(970) - b(121) = b(121) - lu(969) * b(122) - b(120) = b(120) - lu(968) * b(122) - b(119) = b(119) - lu(967) * b(122) - b(118) = b(118) - lu(966) * b(122) - b(117) = b(117) - lu(965) * b(122) - b(108) = b(108) - lu(964) * b(122) - b(90) = b(90) - lu(963) * b(122) - b(88) = b(88) - lu(962) * b(122) - b(32) = b(32) - lu(961) * b(122) - b(30) = b(30) - lu(960) * b(122) - b(28) = b(28) - lu(959) * b(122) - b(25) = b(25) - lu(958) * b(122) - b(121) = b(121) * lu(943) - b(120) = b(120) - lu(942) * b(121) - b(119) = b(119) - lu(941) * b(121) - b(118) = b(118) - lu(940) * b(121) - b(117) = b(117) - lu(939) * b(121) - b(116) = b(116) - lu(938) * b(121) - b(108) = b(108) - lu(937) * b(121) - b(103) = b(103) - lu(936) * b(121) - b(100) = b(100) - lu(935) * b(121) - b(99) = b(99) - lu(934) * b(121) - b(93) = b(93) - lu(933) * b(121) - b(92) = b(92) - lu(932) * b(121) - b(90) = b(90) - lu(931) * b(121) - b(87) = b(87) - lu(930) * b(121) - b(86) = b(86) - lu(929) * b(121) - b(85) = b(85) - lu(928) * b(121) - b(84) = b(84) - lu(927) * b(121) - b(82) = b(82) - lu(926) * b(121) - b(78) = b(78) - lu(925) * b(121) - b(74) = b(74) - lu(924) * b(121) - b(72) = b(72) - lu(923) * b(121) - b(70) = b(70) - lu(922) * b(121) - b(61) = b(61) - lu(921) * b(121) - b(58) = b(58) - lu(920) * b(121) - b(48) = b(48) - lu(919) * b(121) - b(28) = b(28) - lu(918) * b(121) - b(27) = b(27) - lu(917) * b(121) - b(120) = b(120) * lu(903) - b(118) = b(118) - lu(902) * b(120) - b(116) = b(116) - lu(901) * b(120) - b(103) = b(103) - lu(900) * b(120) - b(99) = b(99) - lu(899) * b(120) - b(95) = b(95) - lu(898) * b(120) - b(92) = b(92) - lu(897) * b(120) - b(87) = b(87) - lu(896) * b(120) - b(86) = b(86) - lu(895) * b(120) - b(85) = b(85) - lu(894) * b(120) - b(82) = b(82) - lu(893) * b(120) - b(78) = b(78) - lu(892) * b(120) - b(72) = b(72) - lu(891) * b(120) - b(61) = b(61) - lu(890) * b(120) - b(58) = b(58) - lu(889) * b(120) - b(56) = b(56) - lu(888) * b(120) - b(28) = b(28) - lu(887) * b(120) - b(27) = b(27) - lu(886) * b(120) - b(119) = b(119) * lu(872) - b(115) = b(115) - lu(871) * b(119) - b(114) = b(114) - lu(870) * b(119) - b(113) = b(113) - lu(869) * b(119) - b(112) = b(112) - lu(868) * b(119) - b(111) = b(111) - lu(867) * b(119) - b(110) = b(110) - lu(866) * b(119) - b(109) = b(109) - lu(865) * b(119) - b(107) = b(107) - lu(864) * b(119) - b(106) = b(106) - lu(863) * b(119) - b(105) = b(105) - lu(862) * b(119) - b(104) = b(104) - lu(861) * b(119) - b(103) = b(103) - lu(860) * b(119) - b(96) = b(96) - lu(859) * b(119) - b(95) = b(95) - lu(858) * b(119) - b(91) = b(91) - lu(857) * b(119) - b(81) = b(81) - lu(856) * b(119) - b(80) = b(80) - lu(855) * b(119) - b(75) = b(75) - lu(854) * b(119) - b(68) = b(68) - lu(853) * b(119) - b(50) = b(50) - lu(852) * b(119) - b(47) = b(47) - lu(851) * b(119) - b(35) = b(35) - lu(850) * b(119) - b(118) = b(118) * lu(839) - b(103) = b(103) - lu(838) * b(118) - b(90) = b(90) - lu(837) * b(118) - b(117) = b(117) * lu(824) - b(100) = b(100) - lu(823) * b(117) - b(93) = b(93) - lu(822) * b(117) - b(84) = b(84) - lu(821) * b(117) - b(33) = b(33) - lu(820) * b(117) - b(29) = b(29) - lu(819) * b(117) - b(116) = b(116) * lu(805) - b(99) = b(99) - lu(804) * b(116) - b(82) = b(82) - lu(803) * b(116) - b(46) = b(46) - lu(802) * b(116) - b(115) = b(115) * lu(789) - b(114) = b(114) - lu(788) * b(115) - b(113) = b(113) - lu(787) * b(115) - b(112) = b(112) - lu(786) * b(115) - b(111) = b(111) - lu(785) * b(115) - b(110) = b(110) - lu(784) * b(115) - b(109) = b(109) - lu(783) * b(115) - b(107) = b(107) - lu(782) * b(115) - b(105) = b(105) - lu(781) * b(115) - b(103) = b(103) - lu(780) * b(115) - b(95) = b(95) - lu(779) * b(115) - b(81) = b(81) - lu(778) * b(115) - b(75) = b(75) - lu(777) * b(115) - b(62) = b(62) - lu(776) * b(115) - b(57) = b(57) - lu(775) * b(115) - b(47) = b(47) - lu(774) * b(115) - b(114) = b(114) * lu(760) - b(109) = b(109) - lu(759) * b(114) - b(105) = b(105) - lu(758) * b(114) - b(75) = b(75) - lu(757) * b(114) - b(71) = b(71) - lu(756) * b(114) - b(62) = b(62) - lu(755) * b(114) - b(113) = b(113) * lu(740) - b(112) = b(112) - lu(739) * b(113) - b(109) = b(109) - lu(738) * b(113) - b(105) = b(105) - lu(737) * b(113) - b(104) = b(104) - lu(736) * b(113) - b(103) = b(103) - lu(735) * b(113) - b(102) = b(102) - lu(734) * b(113) - b(112) = b(112) * lu(721) - b(110) = b(110) - lu(720) * b(112) - b(109) = b(109) - lu(719) * b(112) - b(105) = b(105) - lu(718) * b(112) - b(103) = b(103) - lu(717) * b(112) - b(97) = b(97) - lu(716) * b(112) - b(95) = b(95) - lu(715) * b(112) - b(68) = b(68) - lu(714) * b(112) - b(43) = b(43) - lu(713) * b(112) - b(111) = b(111) * lu(697) - b(110) = b(110) - lu(696) * b(111) - b(109) = b(109) - lu(695) * b(111) - b(107) = b(107) - lu(694) * b(111) - b(103) = b(103) - lu(693) * b(111) - b(97) = b(97) - lu(692) * b(111) - b(69) = b(69) - lu(691) * b(111) - b(68) = b(68) - lu(690) * b(111) - b(47) = b(47) - lu(689) * b(111) - b(110) = b(110) * lu(677) - b(109) = b(109) - lu(676) * b(110) - b(105) = b(105) - lu(675) * b(110) - b(103) = b(103) - lu(674) * b(110) - b(95) = b(95) - lu(673) * b(110) - b(81) = b(81) - lu(672) * b(110) - b(68) = b(68) - lu(671) * b(110) - b(45) = b(45) - lu(670) * b(110) - b(109) = b(109) * lu(662) - b(103) = b(103) - lu(661) * b(109) - b(108) = b(108) * lu(650) - b(88) = b(88) - lu(649) * b(108) - b(34) = b(34) - lu(648) * b(108) - b(107) = b(107) * lu(637) - b(103) = b(103) - lu(636) * b(107) - b(106) = b(106) * lu(625) - b(105) = b(105) - lu(624) * b(106) - b(68) = b(68) - lu(623) * b(106) - b(53) = b(53) - lu(622) * b(106) - b(105) = b(105) * lu(616) - b(104) = b(104) * lu(607) - b(103) = b(103) - lu(606) * b(104) - b(103) = b(103) * lu(602) - b(102) = b(102) * lu(587) - b(89) = b(89) - lu(586) * b(102) - b(75) = b(75) - lu(585) * b(102) - b(49) = b(49) - lu(584) * b(102) - END SUBROUTINE lu_slv07 - - SUBROUTINE lu_slv08(lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(in) :: lu(:) - REAL(KIND=r8), intent(inout) :: b(:) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - b(101) = b(101) * lu(572) - b(97) = b(97) - lu(571) * b(101) - b(45) = b(45) - lu(570) * b(101) - b(100) = b(100) * lu(560) - b(93) = b(93) - lu(559) * b(100) - b(29) = b(29) - lu(558) * b(100) - b(99) = b(99) * lu(552) - b(36) = b(36) - lu(551) * b(99) - b(98) = b(98) * lu(540) - b(80) = b(80) - lu(539) * b(98) - b(59) = b(59) - lu(538) * b(98) - b(97) = b(97) * lu(530) - b(47) = b(47) - lu(529) * b(97) - b(96) = b(96) * lu(517) - b(80) = b(80) - lu(516) * b(96) - b(52) = b(52) - lu(515) * b(96) - b(95) = b(95) * lu(510) - b(81) = b(81) - lu(509) * b(95) - b(94) = b(94) * lu(494) - b(75) = b(75) - lu(493) * b(94) - b(93) = b(93) * lu(486) - b(29) = b(29) - lu(485) * b(93) - b(92) = b(92) * lu(476) - b(87) = b(87) - lu(475) * b(92) - b(86) = b(86) - lu(474) * b(92) - b(85) = b(85) - lu(473) * b(92) - b(72) = b(72) - lu(472) * b(92) - b(58) = b(58) - lu(471) * b(92) - b(91) = b(91) * lu(462) - b(68) = b(68) - lu(461) * b(91) - b(44) = b(44) - lu(460) * b(91) - b(35) = b(35) - lu(459) * b(91) - b(90) = b(90) * lu(452) - b(89) = b(89) * lu(442) - b(67) = b(67) - lu(441) * b(89) - b(88) = b(88) * lu(433) - b(34) = b(34) - lu(432) * b(88) - b(87) = b(87) * lu(425) - b(86) = b(86) - lu(424) * b(87) - b(85) = b(85) - lu(423) * b(87) - b(78) = b(78) - lu(422) * b(87) - b(61) = b(61) - lu(421) * b(87) - b(86) = b(86) * lu(414) - b(61) = b(61) - lu(413) * b(86) - b(85) = b(85) * lu(405) - b(84) = b(84) * lu(397) - b(33) = b(33) - lu(396) * b(84) - b(83) = b(83) * lu(388) - b(56) = b(56) - lu(387) * b(83) - b(24) = b(24) - lu(386) * b(83) - b(82) = b(82) * lu(379) - b(81) = b(81) * lu(375) - b(80) = b(80) * lu(369) - b(79) = b(79) * lu(358) - b(77) = b(77) - lu(357) * b(79) - b(76) = b(76) - lu(356) * b(79) - b(55) = b(55) - lu(355) * b(79) - b(49) = b(49) - lu(354) * b(79) - b(78) = b(78) * lu(344) - b(72) = b(72) - lu(343) * b(78) - b(61) = b(61) - lu(342) * b(78) - b(77) = b(77) * lu(335) - b(42) = b(42) - lu(334) * b(77) - b(76) = b(76) * lu(324) - b(55) = b(55) - lu(323) * b(76) - b(75) = b(75) * lu(319) - b(74) = b(74) * lu(312) - b(73) = b(73) * lu(303) - b(72) = b(72) * lu(296) - b(71) = b(71) * lu(288) - b(70) = b(70) * lu(280) - b(69) = b(69) * lu(272) - b(68) = b(68) * lu(268) - b(67) = b(67) * lu(260) - b(66) = b(66) * lu(254) - b(65) = b(65) * lu(246) - b(51) = b(51) - lu(245) * b(65) - b(64) = b(64) * lu(241) - b(63) = b(63) * lu(233) - b(62) = b(62) * lu(227) - b(61) = b(61) * lu(222) - b(60) = b(60) * lu(215) - b(59) = b(59) * lu(208) - b(58) = b(58) * lu(201) - b(57) = b(57) * lu(194) - b(56) = b(56) * lu(189) - b(55) = b(55) * lu(184) - b(54) = b(54) * lu(178) - b(53) = b(53) * lu(172) - b(52) = b(52) * lu(166) - b(51) = b(51) * lu(160) - b(50) = b(50) * lu(154) - b(49) = b(49) * lu(150) - b(48) = b(48) * lu(142) - b(47) = b(47) * lu(139) - b(46) = b(46) * lu(134) - b(45) = b(45) * lu(130) - b(44) = b(44) * lu(125) - b(43) = b(43) * lu(120) - b(42) = b(42) * lu(115) - b(41) = b(41) * lu(108) - b(40) = b(40) * lu(102) - b(39) = b(39) * lu(96) - b(38) = b(38) * lu(90) - b(37) = b(37) * lu(84) - b(36) = b(36) * lu(80) - b(26) = b(26) - lu(79) * b(36) - b(35) = b(35) * lu(75) - b(34) = b(34) * lu(72) - b(33) = b(33) * lu(69) - b(32) = b(32) * lu(65) - b(31) = b(31) * lu(61) - b(30) = b(30) * lu(57) - b(29) = b(29) * lu(55) - b(28) = b(28) * lu(53) - b(27) = b(27) - lu(52) * b(28) - b(27) = b(27) * lu(50) - b(26) = b(26) * lu(47) - b(25) = b(25) * lu(44) - b(24) = b(24) * lu(41) - b(23) = b(23) * lu(38) - b(22) = b(22) * lu(33) - b(21) = b(21) * lu(29) - b(20) = b(20) * lu(26) - b(19) = b(19) * lu(23) - b(18) = b(18) * lu(20) - b(17) = b(17) * lu(17) - b(16) = b(16) * lu(16) - b(15) = b(15) * lu(15) - b(14) = b(14) * lu(14) - b(13) = b(13) * lu(13) - b(12) = b(12) * lu(12) - b(11) = b(11) * lu(11) - b(10) = b(10) * lu(10) - b(9) = b(9) * lu(9) - b(8) = b(8) * lu(8) - b(7) = b(7) * lu(7) - b(6) = b(6) * lu(6) - b(5) = b(5) * lu(5) - b(4) = b(4) * lu(4) - b(3) = b(3) * lu(3) - b(2) = b(2) * lu(2) - b(1) = b(1) * lu(1) - END SUBROUTINE lu_slv08 - - SUBROUTINE lu_slv(lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r8), intent(in) :: lu(:) - REAL(KIND=r8), intent(inout) :: b(:) - call lu_slv01( lu, b ) - call lu_slv02( lu, b ) - call lu_slv03( lu, b ) - call lu_slv04( lu, b ) - call lu_slv05( lu, b ) - call lu_slv06( lu, b ) - call lu_slv07( lu, b ) - call lu_slv08( lu, b ) - END SUBROUTINE lu_slv - END MODULE mo_lu_solve diff --git a/test/ncar_kernels/WACCM_lu_slv/src/mo_lu_solve_r4.F90 b/test/ncar_kernels/WACCM_lu_slv/src/mo_lu_solve_r4.F90 deleted file mode 100644 index 70dac84215..0000000000 --- a/test/ncar_kernels/WACCM_lu_slv/src/mo_lu_solve_r4.F90 +++ /dev/null @@ -1,1677 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_lu_solve.F90 -! Generated at: 2015-07-14 19:56:41 -! KGEN version: 0.4.13 - - - - MODULE mo_lu_solve_r4 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - PRIVATE - PUBLIC lu_slv_r4 - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - - SUBROUTINE lu_slv01(lu, b) - USE shr_kind_mod, ONLY: r4 => shr_kind_r4 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r4), intent(in) :: lu(:) - REAL(KIND=r4), intent(inout) :: b(:) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - b(125) = b(125) - lu(18) * b(17) - b(131) = b(131) - lu(19) * b(17) - b(124) = b(124) - lu(21) * b(18) - b(126) = b(126) - lu(22) * b(18) - b(79) = b(79) - lu(24) * b(19) - b(131) = b(131) - lu(25) * b(19) - b(41) = b(41) - lu(27) * b(20) - b(131) = b(131) - lu(28) * b(20) - b(96) = b(96) - lu(30) * b(21) - b(131) = b(131) - lu(31) * b(21) - b(134) = b(134) - lu(32) * b(21) - b(23) = b(23) - lu(34) * b(22) - b(65) = b(65) - lu(35) * b(22) - b(125) = b(125) - lu(36) * b(22) - b(131) = b(131) - lu(37) * b(22) - b(31) = b(31) - lu(39) * b(23) - b(131) = b(131) - lu(40) * b(23) - b(56) = b(56) - lu(42) * b(24) - b(131) = b(131) - lu(43) * b(24) - b(88) = b(88) - lu(45) * b(25) - b(122) = b(122) - lu(46) * b(25) - b(36) = b(36) - lu(48) * b(26) - b(134) = b(134) - lu(49) * b(26) - b(120) = b(120) - lu(51) * b(27) - b(120) = b(120) - lu(54) * b(28) - b(126) = b(126) - lu(56) * b(29) - b(122) = b(122) - lu(58) * b(30) - b(125) = b(125) - lu(59) * b(30) - b(131) = b(131) - lu(60) * b(30) - b(66) = b(66) - lu(62) * b(31) - b(125) = b(125) - lu(63) * b(31) - b(130) = b(130) - lu(64) * b(31) - b(88) = b(88) - lu(66) * b(32) - b(122) = b(122) - lu(67) * b(32) - b(126) = b(126) - lu(68) * b(32) - b(118) = b(118) - lu(70) * b(33) - b(126) = b(126) - lu(71) * b(33) - b(88) = b(88) - lu(73) * b(34) - b(127) = b(127) - lu(74) * b(34) - b(104) = b(104) - lu(76) * b(35) - b(125) = b(125) - lu(77) * b(35) - b(131) = b(131) - lu(78) * b(35) - b(99) = b(99) - lu(81) * b(36) - b(121) = b(121) - lu(82) * b(36) - b(134) = b(134) - lu(83) * b(36) - b(91) = b(91) - lu(85) * b(37) - b(117) = b(117) - lu(86) * b(37) - b(126) = b(126) - lu(87) * b(37) - b(131) = b(131) - lu(88) * b(37) - b(134) = b(134) - lu(89) * b(37) - b(64) = b(64) - lu(91) * b(38) - b(81) = b(81) - lu(92) * b(38) - b(103) = b(103) - lu(93) * b(38) - b(125) = b(125) - lu(94) * b(38) - b(131) = b(131) - lu(95) * b(38) - b(99) = b(99) - lu(97) * b(39) - b(125) = b(125) - lu(98) * b(39) - b(131) = b(131) - lu(99) * b(39) - b(132) = b(132) - lu(100) * b(39) - b(133) = b(133) - lu(101) * b(39) - b(121) = b(121) - lu(103) * b(40) - b(129) = b(129) - lu(104) * b(40) - b(130) = b(130) - lu(105) * b(40) - b(132) = b(132) - lu(106) * b(40) - b(133) = b(133) - lu(107) * b(40) - b(80) = b(80) - lu(109) * b(41) - b(104) = b(104) - lu(110) * b(41) - b(125) = b(125) - lu(111) * b(41) - b(129) = b(129) - lu(112) * b(41) - b(130) = b(130) - lu(113) * b(41) - b(135) = b(135) - lu(114) * b(41) - b(77) = b(77) - lu(116) * b(42) - b(104) = b(104) - lu(117) * b(42) - b(115) = b(115) - lu(118) * b(42) - b(131) = b(131) - lu(119) * b(42) - b(112) = b(112) - lu(121) * b(43) - b(114) = b(114) - lu(122) * b(43) - b(125) = b(125) - lu(123) * b(43) - b(131) = b(131) - lu(124) * b(43) - b(91) = b(91) - lu(126) * b(44) - b(104) = b(104) - lu(127) * b(44) - b(125) = b(125) - lu(128) * b(44) - b(131) = b(131) - lu(129) * b(44) - b(110) = b(110) - lu(131) * b(45) - b(131) = b(131) - lu(132) * b(45) - b(134) = b(134) - lu(133) * b(45) - b(99) = b(99) - lu(135) * b(46) - b(116) = b(116) - lu(136) * b(46) - b(121) = b(121) - lu(137) * b(46) - b(124) = b(124) - lu(138) * b(46) - b(110) = b(110) - lu(140) * b(47) - b(131) = b(131) - lu(141) * b(47) - b(82) = b(82) - lu(143) * b(48) - b(99) = b(99) - lu(144) * b(48) - b(103) = b(103) - lu(145) * b(48) - b(116) = b(116) - lu(146) * b(48) - b(121) = b(121) - lu(147) * b(48) - b(127) = b(127) - lu(148) * b(48) - b(131) = b(131) - lu(149) * b(48) - b(109) = b(109) - lu(151) * b(49) - b(130) = b(130) - lu(152) * b(49) - b(131) = b(131) - lu(153) * b(49) - b(119) = b(119) - lu(155) * b(50) - b(127) = b(127) - lu(156) * b(50) - b(131) = b(131) - lu(157) * b(50) - b(134) = b(134) - lu(158) * b(50) - b(135) = b(135) - lu(159) * b(50) - b(65) = b(65) - lu(161) * b(51) - b(66) = b(66) - lu(162) * b(51) - b(81) = b(81) - lu(163) * b(51) - b(109) = b(109) - lu(164) * b(51) - b(131) = b(131) - lu(165) * b(51) - b(80) = b(80) - lu(167) * b(52) - b(96) = b(96) - lu(168) * b(52) - b(125) = b(125) - lu(169) * b(52) - b(131) = b(131) - lu(170) * b(52) - b(134) = b(134) - lu(171) * b(52) - b(106) = b(106) - lu(173) * b(53) - b(115) = b(115) - lu(174) * b(53) - b(131) = b(131) - lu(175) * b(53) - b(134) = b(134) - lu(176) * b(53) - b(135) = b(135) - lu(177) * b(53) - b(64) = b(64) - lu(179) * b(54) - b(125) = b(125) - lu(180) * b(54) - b(129) = b(129) - lu(181) * b(54) - b(130) = b(130) - lu(182) * b(54) - b(135) = b(135) - lu(183) * b(54) - b(77) = b(77) - lu(185) * b(55) - b(91) = b(91) - lu(186) * b(55) - b(115) = b(115) - lu(187) * b(55) - b(131) = b(131) - lu(188) * b(55) - b(95) = b(95) - lu(190) * b(56) - b(120) = b(120) - lu(191) * b(56) - b(125) = b(125) - lu(192) * b(56) - b(135) = b(135) - lu(193) * b(56) - b(115) = b(115) - lu(195) * b(57) - b(119) = b(119) - lu(196) * b(57) - b(130) = b(130) - lu(197) * b(57) - b(131) = b(131) - lu(198) * b(57) - b(132) = b(132) - lu(199) * b(57) - b(135) = b(135) - lu(200) * b(57) - b(72) = b(72) - lu(202) * b(58) - b(85) = b(85) - lu(203) * b(58) - b(86) = b(86) - lu(204) * b(58) - b(92) = b(92) - lu(205) * b(58) - b(120) = b(120) - lu(206) * b(58) - b(121) = b(121) - lu(207) * b(58) - b(80) = b(80) - lu(209) * b(59) - b(98) = b(98) - lu(210) * b(59) - b(107) = b(107) - lu(211) * b(59) - b(113) = b(113) - lu(212) * b(59) - b(125) = b(125) - lu(213) * b(59) - b(131) = b(131) - lu(214) * b(59) - b(120) = b(120) - lu(216) * b(60) - b(125) = b(125) - lu(217) * b(60) - b(130) = b(130) - lu(218) * b(60) - b(131) = b(131) - lu(219) * b(60) - b(132) = b(132) - lu(220) * b(60) - b(134) = b(134) - lu(221) * b(60) - b(92) = b(92) - lu(223) * b(61) - b(120) = b(120) - lu(224) * b(61) - b(122) = b(122) - lu(225) * b(61) - b(129) = b(129) - lu(226) * b(61) - b(115) = b(115) - lu(228) * b(62) - b(119) = b(119) - lu(229) * b(62) - b(131) = b(131) - lu(230) * b(62) - b(134) = b(134) - lu(231) * b(62) - b(135) = b(135) - lu(232) * b(62) - b(64) = b(64) - lu(234) * b(63) - b(83) = b(83) - lu(235) * b(63) - b(103) = b(103) - lu(236) * b(63) - b(123) = b(123) - lu(237) * b(63) - b(125) = b(125) - lu(238) * b(63) - b(131) = b(131) - lu(239) * b(63) - b(135) = b(135) - lu(240) * b(63) - b(125) = b(125) - lu(242) * b(64) - b(131) = b(131) - lu(243) * b(64) - b(134) = b(134) - lu(244) * b(64) - b(66) = b(66) - lu(247) * b(65) - b(81) = b(81) - lu(248) * b(65) - b(109) = b(109) - lu(249) * b(65) - b(125) = b(125) - lu(250) * b(65) - b(129) = b(129) - lu(251) * b(65) - b(130) = b(130) - lu(252) * b(65) - b(131) = b(131) - lu(253) * b(65) - b(81) = b(81) - lu(255) * b(66) - b(103) = b(103) - lu(256) * b(66) - b(109) = b(109) - lu(257) * b(66) - b(115) = b(115) - lu(258) * b(66) - b(125) = b(125) - lu(259) * b(66) - b(89) = b(89) - lu(261) * b(67) - b(104) = b(104) - lu(262) * b(67) - b(105) = b(105) - lu(263) * b(67) - b(125) = b(125) - lu(264) * b(67) - b(131) = b(131) - lu(265) * b(67) - b(134) = b(134) - lu(266) * b(67) - b(135) = b(135) - lu(267) * b(67) - b(125) = b(125) - lu(269) * b(68) - b(131) = b(131) - lu(270) * b(68) - b(135) = b(135) - lu(271) * b(68) - b(107) = b(107) - lu(273) * b(69) - b(110) = b(110) - lu(274) * b(69) - b(111) = b(111) - lu(275) * b(69) - b(113) = b(113) - lu(276) * b(69) - b(125) = b(125) - lu(277) * b(69) - b(131) = b(131) - lu(278) * b(69) - b(135) = b(135) - lu(279) * b(69) - END SUBROUTINE lu_slv01 - - SUBROUTINE lu_slv02(lu, b) - USE shr_kind_mod, ONLY: r4 => shr_kind_r4 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r4), intent(in) :: lu(:) - REAL(KIND=r4), intent(inout) :: b(:) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - b(84) = b(84) - lu(281) * b(70) - b(118) = b(118) - lu(282) * b(70) - b(121) = b(121) - lu(283) * b(70) - b(128) = b(128) - lu(284) * b(70) - b(130) = b(130) - lu(285) * b(70) - b(132) = b(132) - lu(286) * b(70) - b(133) = b(133) - lu(287) * b(70) - b(105) = b(105) - lu(289) * b(71) - b(114) = b(114) - lu(290) * b(71) - b(125) = b(125) - lu(291) * b(71) - b(130) = b(130) - lu(292) * b(71) - b(131) = b(131) - lu(293) * b(71) - b(132) = b(132) - lu(294) * b(71) - b(135) = b(135) - lu(295) * b(71) - b(85) = b(85) - lu(297) * b(72) - b(86) = b(86) - lu(298) * b(72) - b(92) = b(92) - lu(299) * b(72) - b(103) = b(103) - lu(300) * b(72) - b(120) = b(120) - lu(301) * b(72) - b(121) = b(121) - lu(302) * b(72) - b(98) = b(98) - lu(304) * b(73) - b(107) = b(107) - lu(305) * b(73) - b(113) = b(113) - lu(306) * b(73) - b(123) = b(123) - lu(307) * b(73) - b(125) = b(125) - lu(308) * b(73) - b(130) = b(130) - lu(309) * b(73) - b(131) = b(131) - lu(310) * b(73) - b(132) = b(132) - lu(311) * b(73) - b(117) = b(117) - lu(313) * b(74) - b(121) = b(121) - lu(314) * b(74) - b(125) = b(125) - lu(315) * b(74) - b(126) = b(126) - lu(316) * b(74) - b(131) = b(131) - lu(317) * b(74) - b(134) = b(134) - lu(318) * b(74) - b(119) = b(119) - lu(320) * b(75) - b(131) = b(131) - lu(321) * b(75) - b(134) = b(134) - lu(322) * b(75) - b(77) = b(77) - lu(325) * b(76) - b(79) = b(79) - lu(326) * b(76) - b(80) = b(80) - lu(327) * b(76) - b(91) = b(91) - lu(328) * b(76) - b(104) = b(104) - lu(329) * b(76) - b(115) = b(115) - lu(330) * b(76) - b(125) = b(125) - lu(331) * b(76) - b(131) = b(131) - lu(332) * b(76) - b(135) = b(135) - lu(333) * b(76) - b(104) = b(104) - lu(336) * b(77) - b(115) = b(115) - lu(337) * b(77) - b(125) = b(125) - lu(338) * b(77) - b(129) = b(129) - lu(339) * b(77) - b(130) = b(130) - lu(340) * b(77) - b(131) = b(131) - lu(341) * b(77) - b(85) = b(85) - lu(345) * b(78) - b(86) = b(86) - lu(346) * b(78) - b(87) = b(87) - lu(347) * b(78) - b(92) = b(92) - lu(348) * b(78) - b(103) = b(103) - lu(349) * b(78) - b(120) = b(120) - lu(350) * b(78) - b(121) = b(121) - lu(351) * b(78) - b(122) = b(122) - lu(352) * b(78) - b(129) = b(129) - lu(353) * b(78) - b(80) = b(80) - lu(359) * b(79) - b(91) = b(91) - lu(360) * b(79) - b(104) = b(104) - lu(361) * b(79) - b(109) = b(109) - lu(362) * b(79) - b(115) = b(115) - lu(363) * b(79) - b(125) = b(125) - lu(364) * b(79) - b(129) = b(129) - lu(365) * b(79) - b(130) = b(130) - lu(366) * b(79) - b(131) = b(131) - lu(367) * b(79) - b(135) = b(135) - lu(368) * b(79) - b(106) = b(106) - lu(370) * b(80) - b(115) = b(115) - lu(371) * b(80) - b(119) = b(119) - lu(372) * b(80) - b(131) = b(131) - lu(373) * b(80) - b(134) = b(134) - lu(374) * b(80) - b(103) = b(103) - lu(376) * b(81) - b(125) = b(125) - lu(377) * b(81) - b(131) = b(131) - lu(378) * b(81) - b(116) = b(116) - lu(380) * b(82) - b(120) = b(120) - lu(381) * b(82) - b(121) = b(121) - lu(382) * b(82) - b(123) = b(123) - lu(383) * b(82) - b(127) = b(127) - lu(384) * b(82) - b(131) = b(131) - lu(385) * b(82) - b(95) = b(95) - lu(389) * b(83) - b(120) = b(120) - lu(390) * b(83) - b(125) = b(125) - lu(391) * b(83) - b(129) = b(129) - lu(392) * b(83) - b(130) = b(130) - lu(393) * b(83) - b(131) = b(131) - lu(394) * b(83) - b(135) = b(135) - lu(395) * b(83) - b(117) = b(117) - lu(398) * b(84) - b(118) = b(118) - lu(399) * b(84) - b(121) = b(121) - lu(400) * b(84) - b(126) = b(126) - lu(401) * b(84) - b(128) = b(128) - lu(402) * b(84) - b(131) = b(131) - lu(403) * b(84) - b(134) = b(134) - lu(404) * b(84) - b(86) = b(86) - lu(406) * b(85) - b(87) = b(87) - lu(407) * b(85) - b(92) = b(92) - lu(408) * b(85) - b(120) = b(120) - lu(409) * b(85) - b(121) = b(121) - lu(410) * b(85) - b(122) = b(122) - lu(411) * b(85) - b(129) = b(129) - lu(412) * b(85) - b(87) = b(87) - lu(415) * b(86) - b(92) = b(92) - lu(416) * b(86) - b(120) = b(120) - lu(417) * b(86) - b(121) = b(121) - lu(418) * b(86) - b(122) = b(122) - lu(419) * b(86) - b(129) = b(129) - lu(420) * b(86) - b(92) = b(92) - lu(426) * b(87) - b(103) = b(103) - lu(427) * b(87) - b(120) = b(120) - lu(428) * b(87) - b(121) = b(121) - lu(429) * b(87) - b(122) = b(122) - lu(430) * b(87) - b(129) = b(129) - lu(431) * b(87) - b(108) = b(108) - lu(434) * b(88) - b(119) = b(119) - lu(435) * b(88) - b(127) = b(127) - lu(436) * b(88) - b(131) = b(131) - lu(437) * b(88) - b(132) = b(132) - lu(438) * b(88) - b(133) = b(133) - lu(439) * b(88) - b(134) = b(134) - lu(440) * b(88) - b(104) = b(104) - lu(443) * b(89) - b(105) = b(105) - lu(444) * b(89) - b(120) = b(120) - lu(445) * b(89) - b(125) = b(125) - lu(446) * b(89) - b(129) = b(129) - lu(447) * b(89) - b(130) = b(130) - lu(448) * b(89) - b(131) = b(131) - lu(449) * b(89) - b(134) = b(134) - lu(450) * b(89) - b(135) = b(135) - lu(451) * b(89) - b(118) = b(118) - lu(453) * b(90) - b(121) = b(121) - lu(454) * b(90) - b(122) = b(122) - lu(455) * b(90) - b(127) = b(127) - lu(456) * b(90) - b(131) = b(131) - lu(457) * b(90) - b(134) = b(134) - lu(458) * b(90) - b(104) = b(104) - lu(463) * b(91) - b(119) = b(119) - lu(464) * b(91) - b(120) = b(120) - lu(465) * b(91) - b(125) = b(125) - lu(466) * b(91) - b(129) = b(129) - lu(467) * b(91) - b(130) = b(130) - lu(468) * b(91) - b(131) = b(131) - lu(469) * b(91) - b(135) = b(135) - lu(470) * b(91) - b(103) = b(103) - lu(477) * b(92) - b(120) = b(120) - lu(478) * b(92) - b(121) = b(121) - lu(479) * b(92) - b(122) = b(122) - lu(480) * b(92) - b(127) = b(127) - lu(481) * b(92) - b(129) = b(129) - lu(482) * b(92) - b(130) = b(130) - lu(483) * b(92) - b(131) = b(131) - lu(484) * b(92) - b(117) = b(117) - lu(487) * b(93) - b(121) = b(121) - lu(488) * b(93) - b(124) = b(124) - lu(489) * b(93) - b(126) = b(126) - lu(490) * b(93) - b(131) = b(131) - lu(491) * b(93) - b(134) = b(134) - lu(492) * b(93) - b(101) = b(101) - lu(495) * b(94) - b(102) = b(102) - lu(496) * b(94) - b(103) = b(103) - lu(497) * b(94) - b(107) = b(107) - lu(498) * b(94) - b(111) = b(111) - lu(499) * b(94) - b(113) = b(113) - lu(500) * b(94) - b(114) = b(114) - lu(501) * b(94) - b(119) = b(119) - lu(502) * b(94) - b(123) = b(123) - lu(503) * b(94) - b(125) = b(125) - lu(504) * b(94) - b(131) = b(131) - lu(505) * b(94) - b(132) = b(132) - lu(506) * b(94) - b(134) = b(134) - lu(507) * b(94) - b(135) = b(135) - lu(508) * b(94) - b(103) = b(103) - lu(511) * b(95) - b(125) = b(125) - lu(512) * b(95) - b(131) = b(131) - lu(513) * b(95) - b(135) = b(135) - lu(514) * b(95) - b(104) = b(104) - lu(518) * b(96) - b(106) = b(106) - lu(519) * b(96) - b(115) = b(115) - lu(520) * b(96) - b(119) = b(119) - lu(521) * b(96) - b(120) = b(120) - lu(522) * b(96) - b(125) = b(125) - lu(523) * b(96) - b(129) = b(129) - lu(524) * b(96) - b(130) = b(130) - lu(525) * b(96) - b(131) = b(131) - lu(526) * b(96) - b(134) = b(134) - lu(527) * b(96) - b(135) = b(135) - lu(528) * b(96) - b(103) = b(103) - lu(531) * b(97) - b(110) = b(110) - lu(532) * b(97) - b(125) = b(125) - lu(533) * b(97) - b(130) = b(130) - lu(534) * b(97) - b(131) = b(131) - lu(535) * b(97) - b(132) = b(132) - lu(536) * b(97) - b(135) = b(135) - lu(537) * b(97) - b(106) = b(106) - lu(541) * b(98) - b(107) = b(107) - lu(542) * b(98) - b(113) = b(113) - lu(543) * b(98) - b(115) = b(115) - lu(544) * b(98) - b(119) = b(119) - lu(545) * b(98) - b(125) = b(125) - lu(546) * b(98) - b(129) = b(129) - lu(547) * b(98) - b(130) = b(130) - lu(548) * b(98) - b(131) = b(131) - lu(549) * b(98) - b(134) = b(134) - lu(550) * b(98) - END SUBROUTINE lu_slv02 - - SUBROUTINE lu_slv03(lu, b) - USE shr_kind_mod, ONLY: r4 => shr_kind_r4 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r4), intent(in) :: lu(:) - REAL(KIND=r4), intent(inout) :: b(:) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - b(116) = b(116) - lu(553) * b(99) - b(121) = b(121) - lu(554) * b(99) - b(125) = b(125) - lu(555) * b(99) - b(131) = b(131) - lu(556) * b(99) - b(134) = b(134) - lu(557) * b(99) - b(117) = b(117) - lu(561) * b(100) - b(121) = b(121) - lu(562) * b(100) - b(124) = b(124) - lu(563) * b(100) - b(126) = b(126) - lu(564) * b(100) - b(130) = b(130) - lu(565) * b(100) - b(131) = b(131) - lu(566) * b(100) - b(132) = b(132) - lu(567) * b(100) - b(133) = b(133) - lu(568) * b(100) - b(134) = b(134) - lu(569) * b(100) - b(103) = b(103) - lu(573) * b(101) - b(107) = b(107) - lu(574) * b(101) - b(110) = b(110) - lu(575) * b(101) - b(113) = b(113) - lu(576) * b(101) - b(125) = b(125) - lu(577) * b(101) - b(129) = b(129) - lu(578) * b(101) - b(130) = b(130) - lu(579) * b(101) - b(131) = b(131) - lu(580) * b(101) - b(132) = b(132) - lu(581) * b(101) - b(134) = b(134) - lu(582) * b(101) - b(135) = b(135) - lu(583) * b(101) - b(103) = b(103) - lu(588) * b(102) - b(104) = b(104) - lu(589) * b(102) - b(105) = b(105) - lu(590) * b(102) - b(109) = b(109) - lu(591) * b(102) - b(119) = b(119) - lu(592) * b(102) - b(120) = b(120) - lu(593) * b(102) - b(123) = b(123) - lu(594) * b(102) - b(125) = b(125) - lu(595) * b(102) - b(129) = b(129) - lu(596) * b(102) - b(130) = b(130) - lu(597) * b(102) - b(131) = b(131) - lu(598) * b(102) - b(132) = b(132) - lu(599) * b(102) - b(134) = b(134) - lu(600) * b(102) - b(135) = b(135) - lu(601) * b(102) - b(125) = b(125) - lu(603) * b(103) - b(127) = b(127) - lu(604) * b(103) - b(131) = b(131) - lu(605) * b(103) - b(115) = b(115) - lu(608) * b(104) - b(119) = b(119) - lu(609) * b(104) - b(125) = b(125) - lu(610) * b(104) - b(127) = b(127) - lu(611) * b(104) - b(131) = b(131) - lu(612) * b(104) - b(132) = b(132) - lu(613) * b(104) - b(133) = b(133) - lu(614) * b(104) - b(134) = b(134) - lu(615) * b(104) - b(109) = b(109) - lu(617) * b(105) - b(115) = b(115) - lu(618) * b(105) - b(125) = b(125) - lu(619) * b(105) - b(131) = b(131) - lu(620) * b(105) - b(135) = b(135) - lu(621) * b(105) - b(109) = b(109) - lu(626) * b(106) - b(115) = b(115) - lu(627) * b(106) - b(119) = b(119) - lu(628) * b(106) - b(120) = b(120) - lu(629) * b(106) - b(125) = b(125) - lu(630) * b(106) - b(129) = b(129) - lu(631) * b(106) - b(130) = b(130) - lu(632) * b(106) - b(131) = b(131) - lu(633) * b(106) - b(134) = b(134) - lu(634) * b(106) - b(135) = b(135) - lu(635) * b(106) - b(109) = b(109) - lu(638) * b(107) - b(112) = b(112) - lu(639) * b(107) - b(114) = b(114) - lu(640) * b(107) - b(115) = b(115) - lu(641) * b(107) - b(123) = b(123) - lu(642) * b(107) - b(125) = b(125) - lu(643) * b(107) - b(127) = b(127) - lu(644) * b(107) - b(131) = b(131) - lu(645) * b(107) - b(134) = b(134) - lu(646) * b(107) - b(135) = b(135) - lu(647) * b(107) - b(117) = b(117) - lu(651) * b(108) - b(119) = b(119) - lu(652) * b(108) - b(121) = b(121) - lu(653) * b(108) - b(122) = b(122) - lu(654) * b(108) - b(126) = b(126) - lu(655) * b(108) - b(127) = b(127) - lu(656) * b(108) - b(131) = b(131) - lu(657) * b(108) - b(132) = b(132) - lu(658) * b(108) - b(133) = b(133) - lu(659) * b(108) - b(134) = b(134) - lu(660) * b(108) - b(115) = b(115) - lu(663) * b(109) - b(125) = b(125) - lu(664) * b(109) - b(127) = b(127) - lu(665) * b(109) - b(131) = b(131) - lu(666) * b(109) - b(132) = b(132) - lu(667) * b(109) - b(133) = b(133) - lu(668) * b(109) - b(134) = b(134) - lu(669) * b(109) - b(115) = b(115) - lu(678) * b(110) - b(119) = b(119) - lu(679) * b(110) - b(125) = b(125) - lu(680) * b(110) - b(127) = b(127) - lu(681) * b(110) - b(129) = b(129) - lu(682) * b(110) - b(130) = b(130) - lu(683) * b(110) - b(131) = b(131) - lu(684) * b(110) - b(132) = b(132) - lu(685) * b(110) - b(133) = b(133) - lu(686) * b(110) - b(134) = b(134) - lu(687) * b(110) - b(135) = b(135) - lu(688) * b(110) - b(112) = b(112) - lu(698) * b(111) - b(113) = b(113) - lu(699) * b(111) - b(114) = b(114) - lu(700) * b(111) - b(115) = b(115) - lu(701) * b(111) - b(119) = b(119) - lu(702) * b(111) - b(123) = b(123) - lu(703) * b(111) - b(125) = b(125) - lu(704) * b(111) - b(127) = b(127) - lu(705) * b(111) - b(129) = b(129) - lu(706) * b(111) - b(130) = b(130) - lu(707) * b(111) - b(131) = b(131) - lu(708) * b(111) - b(132) = b(132) - lu(709) * b(111) - b(133) = b(133) - lu(710) * b(111) - b(134) = b(134) - lu(711) * b(111) - b(135) = b(135) - lu(712) * b(111) - b(114) = b(114) - lu(722) * b(112) - b(115) = b(115) - lu(723) * b(112) - b(119) = b(119) - lu(724) * b(112) - b(125) = b(125) - lu(725) * b(112) - b(127) = b(127) - lu(726) * b(112) - b(129) = b(129) - lu(727) * b(112) - b(130) = b(130) - lu(728) * b(112) - b(131) = b(131) - lu(729) * b(112) - b(132) = b(132) - lu(730) * b(112) - b(133) = b(133) - lu(731) * b(112) - b(134) = b(134) - lu(732) * b(112) - b(135) = b(135) - lu(733) * b(112) - b(114) = b(114) - lu(741) * b(113) - b(115) = b(115) - lu(742) * b(113) - b(119) = b(119) - lu(743) * b(113) - b(120) = b(120) - lu(744) * b(113) - b(123) = b(123) - lu(745) * b(113) - b(125) = b(125) - lu(746) * b(113) - b(127) = b(127) - lu(747) * b(113) - b(129) = b(129) - lu(748) * b(113) - b(130) = b(130) - lu(749) * b(113) - b(131) = b(131) - lu(750) * b(113) - b(132) = b(132) - lu(751) * b(113) - b(133) = b(133) - lu(752) * b(113) - b(134) = b(134) - lu(753) * b(113) - b(135) = b(135) - lu(754) * b(113) - b(115) = b(115) - lu(761) * b(114) - b(119) = b(119) - lu(762) * b(114) - b(120) = b(120) - lu(763) * b(114) - b(123) = b(123) - lu(764) * b(114) - b(125) = b(125) - lu(765) * b(114) - b(127) = b(127) - lu(766) * b(114) - b(129) = b(129) - lu(767) * b(114) - b(130) = b(130) - lu(768) * b(114) - b(131) = b(131) - lu(769) * b(114) - b(132) = b(132) - lu(770) * b(114) - b(133) = b(133) - lu(771) * b(114) - b(134) = b(134) - lu(772) * b(114) - b(135) = b(135) - lu(773) * b(114) - b(119) = b(119) - lu(790) * b(115) - b(120) = b(120) - lu(791) * b(115) - b(123) = b(123) - lu(792) * b(115) - b(125) = b(125) - lu(793) * b(115) - b(127) = b(127) - lu(794) * b(115) - b(129) = b(129) - lu(795) * b(115) - b(130) = b(130) - lu(796) * b(115) - b(131) = b(131) - lu(797) * b(115) - b(132) = b(132) - lu(798) * b(115) - b(133) = b(133) - lu(799) * b(115) - b(134) = b(134) - lu(800) * b(115) - b(135) = b(135) - lu(801) * b(115) - b(118) = b(118) - lu(806) * b(116) - b(120) = b(120) - lu(807) * b(116) - b(121) = b(121) - lu(808) * b(116) - b(123) = b(123) - lu(809) * b(116) - b(124) = b(124) - lu(810) * b(116) - b(125) = b(125) - lu(811) * b(116) - b(126) = b(126) - lu(812) * b(116) - b(127) = b(127) - lu(813) * b(116) - b(128) = b(128) - lu(814) * b(116) - b(129) = b(129) - lu(815) * b(116) - b(130) = b(130) - lu(816) * b(116) - b(131) = b(131) - lu(817) * b(116) - b(134) = b(134) - lu(818) * b(116) - b(118) = b(118) - lu(825) * b(117) - b(121) = b(121) - lu(826) * b(117) - b(122) = b(122) - lu(827) * b(117) - b(124) = b(124) - lu(828) * b(117) - b(126) = b(126) - lu(829) * b(117) - b(127) = b(127) - lu(830) * b(117) - b(128) = b(128) - lu(831) * b(117) - b(130) = b(130) - lu(832) * b(117) - b(131) = b(131) - lu(833) * b(117) - b(132) = b(132) - lu(834) * b(117) - b(133) = b(133) - lu(835) * b(117) - b(134) = b(134) - lu(836) * b(117) - b(120) = b(120) - lu(840) * b(118) - b(121) = b(121) - lu(841) * b(118) - b(122) = b(122) - lu(842) * b(118) - b(123) = b(123) - lu(843) * b(118) - b(125) = b(125) - lu(844) * b(118) - b(127) = b(127) - lu(845) * b(118) - b(128) = b(128) - lu(846) * b(118) - b(131) = b(131) - lu(847) * b(118) - b(134) = b(134) - lu(848) * b(118) - b(135) = b(135) - lu(849) * b(118) - END SUBROUTINE lu_slv03 - - SUBROUTINE lu_slv04(lu, b) - USE shr_kind_mod, ONLY: r4 => shr_kind_r4 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r4), intent(in) :: lu(:) - REAL(KIND=r4), intent(inout) :: b(:) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - b(120) = b(120) - lu(873) * b(119) - b(123) = b(123) - lu(874) * b(119) - b(124) = b(124) - lu(875) * b(119) - b(125) = b(125) - lu(876) * b(119) - b(126) = b(126) - lu(877) * b(119) - b(127) = b(127) - lu(878) * b(119) - b(129) = b(129) - lu(879) * b(119) - b(130) = b(130) - lu(880) * b(119) - b(131) = b(131) - lu(881) * b(119) - b(132) = b(132) - lu(882) * b(119) - b(133) = b(133) - lu(883) * b(119) - b(134) = b(134) - lu(884) * b(119) - b(135) = b(135) - lu(885) * b(119) - b(121) = b(121) - lu(904) * b(120) - b(122) = b(122) - lu(905) * b(120) - b(123) = b(123) - lu(906) * b(120) - b(124) = b(124) - lu(907) * b(120) - b(125) = b(125) - lu(908) * b(120) - b(126) = b(126) - lu(909) * b(120) - b(127) = b(127) - lu(910) * b(120) - b(128) = b(128) - lu(911) * b(120) - b(129) = b(129) - lu(912) * b(120) - b(130) = b(130) - lu(913) * b(120) - b(131) = b(131) - lu(914) * b(120) - b(134) = b(134) - lu(915) * b(120) - b(135) = b(135) - lu(916) * b(120) - b(122) = b(122) - lu(944) * b(121) - b(123) = b(123) - lu(945) * b(121) - b(124) = b(124) - lu(946) * b(121) - b(125) = b(125) - lu(947) * b(121) - b(126) = b(126) - lu(948) * b(121) - b(127) = b(127) - lu(949) * b(121) - b(128) = b(128) - lu(950) * b(121) - b(129) = b(129) - lu(951) * b(121) - b(130) = b(130) - lu(952) * b(121) - b(131) = b(131) - lu(953) * b(121) - b(132) = b(132) - lu(954) * b(121) - b(133) = b(133) - lu(955) * b(121) - b(134) = b(134) - lu(956) * b(121) - b(135) = b(135) - lu(957) * b(121) - b(123) = b(123) - lu(971) * b(122) - b(124) = b(124) - lu(972) * b(122) - b(125) = b(125) - lu(973) * b(122) - b(126) = b(126) - lu(974) * b(122) - b(127) = b(127) - lu(975) * b(122) - b(128) = b(128) - lu(976) * b(122) - b(129) = b(129) - lu(977) * b(122) - b(130) = b(130) - lu(978) * b(122) - b(131) = b(131) - lu(979) * b(122) - b(132) = b(132) - lu(980) * b(122) - b(133) = b(133) - lu(981) * b(122) - b(134) = b(134) - lu(982) * b(122) - b(135) = b(135) - lu(983) * b(122) - b(124) = b(124) - lu(1017) * b(123) - b(125) = b(125) - lu(1018) * b(123) - b(126) = b(126) - lu(1019) * b(123) - b(127) = b(127) - lu(1020) * b(123) - b(128) = b(128) - lu(1021) * b(123) - b(129) = b(129) - lu(1022) * b(123) - b(130) = b(130) - lu(1023) * b(123) - b(131) = b(131) - lu(1024) * b(123) - b(132) = b(132) - lu(1025) * b(123) - b(133) = b(133) - lu(1026) * b(123) - b(134) = b(134) - lu(1027) * b(123) - b(135) = b(135) - lu(1028) * b(123) - b(125) = b(125) - lu(1045) * b(124) - b(126) = b(126) - lu(1046) * b(124) - b(127) = b(127) - lu(1047) * b(124) - b(128) = b(128) - lu(1048) * b(124) - b(129) = b(129) - lu(1049) * b(124) - b(130) = b(130) - lu(1050) * b(124) - b(131) = b(131) - lu(1051) * b(124) - b(132) = b(132) - lu(1052) * b(124) - b(133) = b(133) - lu(1053) * b(124) - b(134) = b(134) - lu(1054) * b(124) - b(135) = b(135) - lu(1055) * b(124) - b(126) = b(126) - lu(1115) * b(125) - b(127) = b(127) - lu(1116) * b(125) - b(128) = b(128) - lu(1117) * b(125) - b(129) = b(129) - lu(1118) * b(125) - b(130) = b(130) - lu(1119) * b(125) - b(131) = b(131) - lu(1120) * b(125) - b(132) = b(132) - lu(1121) * b(125) - b(133) = b(133) - lu(1122) * b(125) - b(134) = b(134) - lu(1123) * b(125) - b(135) = b(135) - lu(1124) * b(125) - b(127) = b(127) - lu(1151) * b(126) - b(128) = b(128) - lu(1152) * b(126) - b(129) = b(129) - lu(1153) * b(126) - b(130) = b(130) - lu(1154) * b(126) - b(131) = b(131) - lu(1155) * b(126) - b(132) = b(132) - lu(1156) * b(126) - b(133) = b(133) - lu(1157) * b(126) - b(134) = b(134) - lu(1158) * b(126) - b(135) = b(135) - lu(1159) * b(126) - b(128) = b(128) - lu(1172) * b(127) - b(129) = b(129) - lu(1173) * b(127) - b(130) = b(130) - lu(1174) * b(127) - b(131) = b(131) - lu(1175) * b(127) - b(132) = b(132) - lu(1176) * b(127) - b(133) = b(133) - lu(1177) * b(127) - b(134) = b(134) - lu(1178) * b(127) - b(135) = b(135) - lu(1179) * b(127) - b(129) = b(129) - lu(1197) * b(128) - b(130) = b(130) - lu(1198) * b(128) - b(131) = b(131) - lu(1199) * b(128) - b(132) = b(132) - lu(1200) * b(128) - b(133) = b(133) - lu(1201) * b(128) - b(134) = b(134) - lu(1202) * b(128) - b(135) = b(135) - lu(1203) * b(128) - b(130) = b(130) - lu(1253) * b(129) - b(131) = b(131) - lu(1254) * b(129) - b(132) = b(132) - lu(1255) * b(129) - b(133) = b(133) - lu(1256) * b(129) - b(134) = b(134) - lu(1257) * b(129) - b(135) = b(135) - lu(1258) * b(129) - b(131) = b(131) - lu(1291) * b(130) - b(132) = b(132) - lu(1292) * b(130) - b(133) = b(133) - lu(1293) * b(130) - b(134) = b(134) - lu(1294) * b(130) - b(135) = b(135) - lu(1295) * b(130) - b(132) = b(132) - lu(1390) * b(131) - b(133) = b(133) - lu(1391) * b(131) - b(134) = b(134) - lu(1392) * b(131) - b(135) = b(135) - lu(1393) * b(131) - b(133) = b(133) - lu(1435) * b(132) - b(134) = b(134) - lu(1436) * b(132) - b(135) = b(135) - lu(1437) * b(132) - b(134) = b(134) - lu(1458) * b(133) - b(135) = b(135) - lu(1459) * b(133) - b(135) = b(135) - lu(1485) * b(134) - END SUBROUTINE lu_slv04 - - SUBROUTINE lu_slv05(lu, b) - USE shr_kind_mod, ONLY: r4 => shr_kind_r4 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r4), intent(in) :: lu(:) - REAL(KIND=r4), intent(inout) :: b(:) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... Solve U * x = y - !----------------------------------------------------------------------- - b(135) = b(135) * lu(1509) - b(134) = b(134) - lu(1508) * b(135) - b(133) = b(133) - lu(1507) * b(135) - b(132) = b(132) - lu(1506) * b(135) - b(131) = b(131) - lu(1505) * b(135) - b(130) = b(130) - lu(1504) * b(135) - b(129) = b(129) - lu(1503) * b(135) - b(128) = b(128) - lu(1502) * b(135) - b(127) = b(127) - lu(1501) * b(135) - b(126) = b(126) - lu(1500) * b(135) - b(125) = b(125) - lu(1499) * b(135) - b(124) = b(124) - lu(1498) * b(135) - b(123) = b(123) - lu(1497) * b(135) - b(122) = b(122) - lu(1496) * b(135) - b(121) = b(121) - lu(1495) * b(135) - b(120) = b(120) - lu(1494) * b(135) - b(119) = b(119) - lu(1493) * b(135) - b(118) = b(118) - lu(1492) * b(135) - b(117) = b(117) - lu(1491) * b(135) - b(108) = b(108) - lu(1490) * b(135) - b(103) = b(103) - lu(1489) * b(135) - b(90) = b(90) - lu(1488) * b(135) - b(64) = b(64) - lu(1487) * b(135) - b(54) = b(54) - lu(1486) * b(135) - b(134) = b(134) * lu(1484) - b(133) = b(133) - lu(1483) * b(134) - b(132) = b(132) - lu(1482) * b(134) - b(131) = b(131) - lu(1481) * b(134) - b(130) = b(130) - lu(1480) * b(134) - b(129) = b(129) - lu(1479) * b(134) - b(128) = b(128) - lu(1478) * b(134) - b(127) = b(127) - lu(1477) * b(134) - b(126) = b(126) - lu(1476) * b(134) - b(125) = b(125) - lu(1475) * b(134) - b(124) = b(124) - lu(1474) * b(134) - b(123) = b(123) - lu(1473) * b(134) - b(122) = b(122) - lu(1472) * b(134) - b(121) = b(121) - lu(1471) * b(134) - b(120) = b(120) - lu(1470) * b(134) - b(119) = b(119) - lu(1469) * b(134) - b(118) = b(118) - lu(1468) * b(134) - b(117) = b(117) - lu(1467) * b(134) - b(116) = b(116) - lu(1466) * b(134) - b(108) = b(108) - lu(1465) * b(134) - b(99) = b(99) - lu(1464) * b(134) - b(88) = b(88) - lu(1463) * b(134) - b(36) = b(36) - lu(1462) * b(134) - b(34) = b(34) - lu(1461) * b(134) - b(26) = b(26) - lu(1460) * b(134) - b(133) = b(133) * lu(1457) - b(132) = b(132) - lu(1456) * b(133) - b(131) = b(131) - lu(1455) * b(133) - b(130) = b(130) - lu(1454) * b(133) - b(129) = b(129) - lu(1453) * b(133) - b(128) = b(128) - lu(1452) * b(133) - b(127) = b(127) - lu(1451) * b(133) - b(126) = b(126) - lu(1450) * b(133) - b(125) = b(125) - lu(1449) * b(133) - b(124) = b(124) - lu(1448) * b(133) - b(123) = b(123) - lu(1447) * b(133) - b(122) = b(122) - lu(1446) * b(133) - b(121) = b(121) - lu(1445) * b(133) - b(120) = b(120) - lu(1444) * b(133) - b(119) = b(119) - lu(1443) * b(133) - b(118) = b(118) - lu(1442) * b(133) - b(117) = b(117) - lu(1441) * b(133) - b(108) = b(108) - lu(1440) * b(133) - b(88) = b(88) - lu(1439) * b(133) - b(34) = b(34) - lu(1438) * b(133) - b(132) = b(132) * lu(1434) - b(131) = b(131) - lu(1433) * b(132) - b(130) = b(130) - lu(1432) * b(132) - b(129) = b(129) - lu(1431) * b(132) - b(128) = b(128) - lu(1430) * b(132) - b(127) = b(127) - lu(1429) * b(132) - b(126) = b(126) - lu(1428) * b(132) - b(125) = b(125) - lu(1427) * b(132) - b(124) = b(124) - lu(1426) * b(132) - b(123) = b(123) - lu(1425) * b(132) - b(122) = b(122) - lu(1424) * b(132) - b(121) = b(121) - lu(1423) * b(132) - b(120) = b(120) - lu(1422) * b(132) - b(119) = b(119) - lu(1421) * b(132) - b(118) = b(118) - lu(1420) * b(132) - b(116) = b(116) - lu(1419) * b(132) - b(115) = b(115) - lu(1418) * b(132) - b(114) = b(114) - lu(1417) * b(132) - b(113) = b(113) - lu(1416) * b(132) - b(112) = b(112) - lu(1415) * b(132) - b(111) = b(111) - lu(1414) * b(132) - b(110) = b(110) - lu(1413) * b(132) - b(109) = b(109) - lu(1412) * b(132) - b(107) = b(107) - lu(1411) * b(132) - b(106) = b(106) - lu(1410) * b(132) - b(105) = b(105) - lu(1409) * b(132) - b(104) = b(104) - lu(1408) * b(132) - b(103) = b(103) - lu(1407) * b(132) - b(102) = b(102) - lu(1406) * b(132) - b(101) = b(101) - lu(1405) * b(132) - b(99) = b(99) - lu(1404) * b(132) - b(98) = b(98) - lu(1403) * b(132) - b(97) = b(97) - lu(1402) * b(132) - b(95) = b(95) - lu(1401) * b(132) - b(94) = b(94) - lu(1400) * b(132) - b(81) = b(81) - lu(1399) * b(132) - b(73) = b(73) - lu(1398) * b(132) - b(49) = b(49) - lu(1397) * b(132) - b(47) = b(47) - lu(1396) * b(132) - b(40) = b(40) - lu(1395) * b(132) - b(39) = b(39) - lu(1394) * b(132) - b(131) = b(131) * lu(1389) - b(130) = b(130) - lu(1388) * b(131) - b(129) = b(129) - lu(1387) * b(131) - b(128) = b(128) - lu(1386) * b(131) - b(127) = b(127) - lu(1385) * b(131) - b(126) = b(126) - lu(1384) * b(131) - b(125) = b(125) - lu(1383) * b(131) - b(124) = b(124) - lu(1382) * b(131) - b(123) = b(123) - lu(1381) * b(131) - b(122) = b(122) - lu(1380) * b(131) - b(121) = b(121) - lu(1379) * b(131) - b(120) = b(120) - lu(1378) * b(131) - b(119) = b(119) - lu(1377) * b(131) - b(118) = b(118) - lu(1376) * b(131) - b(117) = b(117) - lu(1375) * b(131) - b(116) = b(116) - lu(1374) * b(131) - b(115) = b(115) - lu(1373) * b(131) - b(114) = b(114) - lu(1372) * b(131) - b(113) = b(113) - lu(1371) * b(131) - b(112) = b(112) - lu(1370) * b(131) - b(111) = b(111) - lu(1369) * b(131) - b(110) = b(110) - lu(1368) * b(131) - b(109) = b(109) - lu(1367) * b(131) - b(108) = b(108) - lu(1366) * b(131) - b(107) = b(107) - lu(1365) * b(131) - b(106) = b(106) - lu(1364) * b(131) - b(105) = b(105) - lu(1363) * b(131) - b(104) = b(104) - lu(1362) * b(131) - b(103) = b(103) - lu(1361) * b(131) - b(102) = b(102) - lu(1360) * b(131) - b(101) = b(101) - lu(1359) * b(131) - b(100) = b(100) - lu(1358) * b(131) - b(99) = b(99) - lu(1357) * b(131) - b(98) = b(98) - lu(1356) * b(131) - b(97) = b(97) - lu(1355) * b(131) - b(96) = b(96) - lu(1354) * b(131) - b(95) = b(95) - lu(1353) * b(131) - b(94) = b(94) - lu(1352) * b(131) - b(93) = b(93) - lu(1351) * b(131) - b(92) = b(92) - lu(1350) * b(131) - b(91) = b(91) - lu(1349) * b(131) - b(90) = b(90) - lu(1348) * b(131) - b(89) = b(89) - lu(1347) * b(131) - b(88) = b(88) - lu(1346) * b(131) - b(83) = b(83) - lu(1345) * b(131) - b(82) = b(82) - lu(1344) * b(131) - b(81) = b(81) - lu(1343) * b(131) - b(80) = b(80) - lu(1342) * b(131) - b(79) = b(79) - lu(1341) * b(131) - b(77) = b(77) - lu(1340) * b(131) - b(76) = b(76) - lu(1339) * b(131) - b(75) = b(75) - lu(1338) * b(131) - b(74) = b(74) - lu(1337) * b(131) - b(73) = b(73) - lu(1336) * b(131) - b(71) = b(71) - lu(1335) * b(131) - b(69) = b(69) - lu(1334) * b(131) - b(68) = b(68) - lu(1333) * b(131) - b(67) = b(67) - lu(1332) * b(131) - b(66) = b(66) - lu(1331) * b(131) - b(65) = b(65) - lu(1330) * b(131) - b(64) = b(64) - lu(1329) * b(131) - b(63) = b(63) - lu(1328) * b(131) - b(62) = b(62) - lu(1327) * b(131) - b(60) = b(60) - lu(1326) * b(131) - b(59) = b(59) - lu(1325) * b(131) - b(57) = b(57) - lu(1324) * b(131) - b(55) = b(55) - lu(1323) * b(131) - b(53) = b(53) - lu(1322) * b(131) - b(52) = b(52) - lu(1321) * b(131) - b(51) = b(51) - lu(1320) * b(131) - b(50) = b(50) - lu(1319) * b(131) - b(49) = b(49) - lu(1318) * b(131) - b(48) = b(48) - lu(1317) * b(131) - b(47) = b(47) - lu(1316) * b(131) - b(45) = b(45) - lu(1315) * b(131) - b(44) = b(44) - lu(1314) * b(131) - b(43) = b(43) - lu(1313) * b(131) - b(42) = b(42) - lu(1312) * b(131) - b(41) = b(41) - lu(1311) * b(131) - b(39) = b(39) - lu(1310) * b(131) - b(38) = b(38) - lu(1309) * b(131) - b(37) = b(37) - lu(1308) * b(131) - b(36) = b(36) - lu(1307) * b(131) - b(35) = b(35) - lu(1306) * b(131) - b(32) = b(32) - lu(1305) * b(131) - b(31) = b(31) - lu(1304) * b(131) - b(30) = b(30) - lu(1303) * b(131) - b(25) = b(25) - lu(1302) * b(131) - b(23) = b(23) - lu(1301) * b(131) - b(22) = b(22) - lu(1300) * b(131) - b(21) = b(21) - lu(1299) * b(131) - b(20) = b(20) - lu(1298) * b(131) - b(19) = b(19) - lu(1297) * b(131) - b(17) = b(17) - lu(1296) * b(131) - END SUBROUTINE lu_slv05 - - SUBROUTINE lu_slv06(lu, b) - USE shr_kind_mod, ONLY: r4 => shr_kind_r4 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r4), intent(in) :: lu(:) - REAL(KIND=r4), intent(inout) :: b(:) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - b(130) = b(130) * lu(1290) - b(129) = b(129) - lu(1289) * b(130) - b(128) = b(128) - lu(1288) * b(130) - b(127) = b(127) - lu(1287) * b(130) - b(126) = b(126) - lu(1286) * b(130) - b(125) = b(125) - lu(1285) * b(130) - b(124) = b(124) - lu(1284) * b(130) - b(123) = b(123) - lu(1283) * b(130) - b(122) = b(122) - lu(1282) * b(130) - b(121) = b(121) - lu(1281) * b(130) - b(120) = b(120) - lu(1280) * b(130) - b(119) = b(119) - lu(1279) * b(130) - b(118) = b(118) - lu(1278) * b(130) - b(117) = b(117) - lu(1277) * b(130) - b(116) = b(116) - lu(1276) * b(130) - b(115) = b(115) - lu(1275) * b(130) - b(114) = b(114) - lu(1274) * b(130) - b(109) = b(109) - lu(1273) * b(130) - b(105) = b(105) - lu(1272) * b(130) - b(103) = b(103) - lu(1271) * b(130) - b(100) = b(100) - lu(1270) * b(130) - b(99) = b(99) - lu(1269) * b(130) - b(92) = b(92) - lu(1268) * b(130) - b(84) = b(84) - lu(1267) * b(130) - b(81) = b(81) - lu(1266) * b(130) - b(71) = b(71) - lu(1265) * b(130) - b(70) = b(70) - lu(1264) * b(130) - b(66) = b(66) - lu(1263) * b(130) - b(60) = b(60) - lu(1262) * b(130) - b(57) = b(57) - lu(1261) * b(130) - b(40) = b(40) - lu(1260) * b(130) - b(31) = b(31) - lu(1259) * b(130) - b(129) = b(129) * lu(1252) - b(128) = b(128) - lu(1251) * b(129) - b(127) = b(127) - lu(1250) * b(129) - b(126) = b(126) - lu(1249) * b(129) - b(125) = b(125) - lu(1248) * b(129) - b(124) = b(124) - lu(1247) * b(129) - b(123) = b(123) - lu(1246) * b(129) - b(122) = b(122) - lu(1245) * b(129) - b(121) = b(121) - lu(1244) * b(129) - b(120) = b(120) - lu(1243) * b(129) - b(119) = b(119) - lu(1242) * b(129) - b(118) = b(118) - lu(1241) * b(129) - b(115) = b(115) - lu(1240) * b(129) - b(114) = b(114) - lu(1239) * b(129) - b(113) = b(113) - lu(1238) * b(129) - b(112) = b(112) - lu(1237) * b(129) - b(111) = b(111) - lu(1236) * b(129) - b(110) = b(110) - lu(1235) * b(129) - b(109) = b(109) - lu(1234) * b(129) - b(107) = b(107) - lu(1233) * b(129) - b(106) = b(106) - lu(1232) * b(129) - b(105) = b(105) - lu(1231) * b(129) - b(104) = b(104) - lu(1230) * b(129) - b(103) = b(103) - lu(1229) * b(129) - b(101) = b(101) - lu(1228) * b(129) - b(98) = b(98) - lu(1227) * b(129) - b(97) = b(97) - lu(1226) * b(129) - b(96) = b(96) - lu(1225) * b(129) - b(95) = b(95) - lu(1224) * b(129) - b(92) = b(92) - lu(1223) * b(129) - b(91) = b(91) - lu(1222) * b(129) - b(89) = b(89) - lu(1221) * b(129) - b(87) = b(87) - lu(1220) * b(129) - b(86) = b(86) - lu(1219) * b(129) - b(85) = b(85) - lu(1218) * b(129) - b(83) = b(83) - lu(1217) * b(129) - b(81) = b(81) - lu(1216) * b(129) - b(80) = b(80) - lu(1215) * b(129) - b(79) = b(79) - lu(1214) * b(129) - b(77) = b(77) - lu(1213) * b(129) - b(66) = b(66) - lu(1212) * b(129) - b(65) = b(65) - lu(1211) * b(129) - b(64) = b(64) - lu(1210) * b(129) - b(56) = b(56) - lu(1209) * b(129) - b(55) = b(55) - lu(1208) * b(129) - b(54) = b(54) - lu(1207) * b(129) - b(49) = b(49) - lu(1206) * b(129) - b(47) = b(47) - lu(1205) * b(129) - b(41) = b(41) - lu(1204) * b(129) - b(128) = b(128) * lu(1196) - b(127) = b(127) - lu(1195) * b(128) - b(126) = b(126) - lu(1194) * b(128) - b(125) = b(125) - lu(1193) * b(128) - b(124) = b(124) - lu(1192) * b(128) - b(123) = b(123) - lu(1191) * b(128) - b(122) = b(122) - lu(1190) * b(128) - b(121) = b(121) - lu(1189) * b(128) - b(120) = b(120) - lu(1188) * b(128) - b(118) = b(118) - lu(1187) * b(128) - b(117) = b(117) - lu(1186) * b(128) - b(116) = b(116) - lu(1185) * b(128) - b(99) = b(99) - lu(1184) * b(128) - b(84) = b(84) - lu(1183) * b(128) - b(70) = b(70) - lu(1182) * b(128) - b(46) = b(46) - lu(1181) * b(128) - b(33) = b(33) - lu(1180) * b(128) - b(127) = b(127) * lu(1171) - b(126) = b(126) - lu(1170) * b(127) - b(125) = b(125) - lu(1169) * b(127) - b(124) = b(124) - lu(1168) * b(127) - b(123) = b(123) - lu(1167) * b(127) - b(122) = b(122) - lu(1166) * b(127) - b(121) = b(121) - lu(1165) * b(127) - b(120) = b(120) - lu(1164) * b(127) - b(119) = b(119) - lu(1163) * b(127) - b(118) = b(118) - lu(1162) * b(127) - b(117) = b(117) - lu(1161) * b(127) - b(108) = b(108) - lu(1160) * b(127) - b(126) = b(126) * lu(1150) - b(125) = b(125) - lu(1149) * b(126) - b(124) = b(124) - lu(1148) * b(126) - b(123) = b(123) - lu(1147) * b(126) - b(122) = b(122) - lu(1146) * b(126) - b(121) = b(121) - lu(1145) * b(126) - b(120) = b(120) - lu(1144) * b(126) - b(119) = b(119) - lu(1143) * b(126) - b(118) = b(118) - lu(1142) * b(126) - b(117) = b(117) - lu(1141) * b(126) - b(115) = b(115) - lu(1140) * b(126) - b(108) = b(108) - lu(1139) * b(126) - b(104) = b(104) - lu(1138) * b(126) - b(103) = b(103) - lu(1137) * b(126) - b(100) = b(100) - lu(1136) * b(126) - b(95) = b(95) - lu(1135) * b(126) - b(93) = b(93) - lu(1134) * b(126) - b(91) = b(91) - lu(1133) * b(126) - b(83) = b(83) - lu(1132) * b(126) - b(81) = b(81) - lu(1131) * b(126) - b(74) = b(74) - lu(1130) * b(126) - b(64) = b(64) - lu(1129) * b(126) - b(63) = b(63) - lu(1128) * b(126) - b(38) = b(38) - lu(1127) * b(126) - b(37) = b(37) - lu(1126) * b(126) - b(29) = b(29) - lu(1125) * b(126) - b(125) = b(125) * lu(1114) - b(124) = b(124) - lu(1113) * b(125) - b(123) = b(123) - lu(1112) * b(125) - b(122) = b(122) - lu(1111) * b(125) - b(121) = b(121) - lu(1110) * b(125) - b(120) = b(120) - lu(1109) * b(125) - b(119) = b(119) - lu(1108) * b(125) - b(118) = b(118) - lu(1107) * b(125) - b(117) = b(117) - lu(1106) * b(125) - b(115) = b(115) - lu(1105) * b(125) - b(114) = b(114) - lu(1104) * b(125) - b(113) = b(113) - lu(1103) * b(125) - b(112) = b(112) - lu(1102) * b(125) - b(111) = b(111) - lu(1101) * b(125) - b(110) = b(110) - lu(1100) * b(125) - b(109) = b(109) - lu(1099) * b(125) - b(108) = b(108) - lu(1098) * b(125) - b(107) = b(107) - lu(1097) * b(125) - b(106) = b(106) - lu(1096) * b(125) - b(105) = b(105) - lu(1095) * b(125) - b(104) = b(104) - lu(1094) * b(125) - b(103) = b(103) - lu(1093) * b(125) - b(101) = b(101) - lu(1092) * b(125) - b(98) = b(98) - lu(1091) * b(125) - b(97) = b(97) - lu(1090) * b(125) - b(96) = b(96) - lu(1089) * b(125) - b(95) = b(95) - lu(1088) * b(125) - b(93) = b(93) - lu(1087) * b(125) - b(91) = b(91) - lu(1086) * b(125) - b(90) = b(90) - lu(1085) * b(125) - b(89) = b(89) - lu(1084) * b(125) - b(84) = b(84) - lu(1083) * b(125) - b(83) = b(83) - lu(1082) * b(125) - b(81) = b(81) - lu(1081) * b(125) - b(80) = b(80) - lu(1080) * b(125) - b(79) = b(79) - lu(1079) * b(125) - b(77) = b(77) - lu(1078) * b(125) - b(76) = b(76) - lu(1077) * b(125) - b(75) = b(75) - lu(1076) * b(125) - b(74) = b(74) - lu(1075) * b(125) - b(69) = b(69) - lu(1074) * b(125) - b(67) = b(67) - lu(1073) * b(125) - b(66) = b(66) - lu(1072) * b(125) - b(65) = b(65) - lu(1071) * b(125) - b(64) = b(64) - lu(1070) * b(125) - b(62) = b(62) - lu(1069) * b(125) - b(60) = b(60) - lu(1068) * b(125) - b(59) = b(59) - lu(1067) * b(125) - b(56) = b(56) - lu(1066) * b(125) - b(54) = b(54) - lu(1065) * b(125) - b(53) = b(53) - lu(1064) * b(125) - b(52) = b(52) - lu(1063) * b(125) - b(51) = b(51) - lu(1062) * b(125) - b(50) = b(50) - lu(1061) * b(125) - b(45) = b(45) - lu(1060) * b(125) - b(44) = b(44) - lu(1059) * b(125) - b(43) = b(43) - lu(1058) * b(125) - b(42) = b(42) - lu(1057) * b(125) - b(24) = b(24) - lu(1056) * b(125) - b(124) = b(124) * lu(1044) - b(123) = b(123) - lu(1043) * b(124) - b(122) = b(122) - lu(1042) * b(124) - b(121) = b(121) - lu(1041) * b(124) - b(120) = b(120) - lu(1040) * b(124) - b(119) = b(119) - lu(1039) * b(124) - b(118) = b(118) - lu(1038) * b(124) - b(117) = b(117) - lu(1037) * b(124) - b(116) = b(116) - lu(1036) * b(124) - b(100) = b(100) - lu(1035) * b(124) - b(99) = b(99) - lu(1034) * b(124) - b(93) = b(93) - lu(1033) * b(124) - b(46) = b(46) - lu(1032) * b(124) - b(33) = b(33) - lu(1031) * b(124) - b(29) = b(29) - lu(1030) * b(124) - b(18) = b(18) - lu(1029) * b(124) - END SUBROUTINE lu_slv06 - - SUBROUTINE lu_slv07(lu, b) - USE shr_kind_mod, ONLY: r4 => shr_kind_r4 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r4), intent(in) :: lu(:) - REAL(KIND=r4), intent(inout) :: b(:) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - b(123) = b(123) * lu(1016) - b(122) = b(122) - lu(1015) * b(123) - b(121) = b(121) - lu(1014) * b(123) - b(120) = b(120) - lu(1013) * b(123) - b(119) = b(119) - lu(1012) * b(123) - b(118) = b(118) - lu(1011) * b(123) - b(116) = b(116) - lu(1010) * b(123) - b(115) = b(115) - lu(1009) * b(123) - b(114) = b(114) - lu(1008) * b(123) - b(113) = b(113) - lu(1007) * b(123) - b(112) = b(112) - lu(1006) * b(123) - b(111) = b(111) - lu(1005) * b(123) - b(110) = b(110) - lu(1004) * b(123) - b(109) = b(109) - lu(1003) * b(123) - b(107) = b(107) - lu(1002) * b(123) - b(106) = b(106) - lu(1001) * b(123) - b(105) = b(105) - lu(1000) * b(123) - b(104) = b(104) - lu(999) * b(123) - b(103) = b(103) - lu(998) * b(123) - b(102) = b(102) - lu(997) * b(123) - b(101) = b(101) - lu(996) * b(123) - b(99) = b(99) - lu(995) * b(123) - b(98) = b(98) - lu(994) * b(123) - b(95) = b(95) - lu(993) * b(123) - b(94) = b(94) - lu(992) * b(123) - b(83) = b(83) - lu(991) * b(123) - b(82) = b(82) - lu(990) * b(123) - b(75) = b(75) - lu(989) * b(123) - b(73) = b(73) - lu(988) * b(123) - b(64) = b(64) - lu(987) * b(123) - b(63) = b(63) - lu(986) * b(123) - b(28) = b(28) - lu(985) * b(123) - b(27) = b(27) - lu(984) * b(123) - b(122) = b(122) * lu(970) - b(121) = b(121) - lu(969) * b(122) - b(120) = b(120) - lu(968) * b(122) - b(119) = b(119) - lu(967) * b(122) - b(118) = b(118) - lu(966) * b(122) - b(117) = b(117) - lu(965) * b(122) - b(108) = b(108) - lu(964) * b(122) - b(90) = b(90) - lu(963) * b(122) - b(88) = b(88) - lu(962) * b(122) - b(32) = b(32) - lu(961) * b(122) - b(30) = b(30) - lu(960) * b(122) - b(28) = b(28) - lu(959) * b(122) - b(25) = b(25) - lu(958) * b(122) - b(121) = b(121) * lu(943) - b(120) = b(120) - lu(942) * b(121) - b(119) = b(119) - lu(941) * b(121) - b(118) = b(118) - lu(940) * b(121) - b(117) = b(117) - lu(939) * b(121) - b(116) = b(116) - lu(938) * b(121) - b(108) = b(108) - lu(937) * b(121) - b(103) = b(103) - lu(936) * b(121) - b(100) = b(100) - lu(935) * b(121) - b(99) = b(99) - lu(934) * b(121) - b(93) = b(93) - lu(933) * b(121) - b(92) = b(92) - lu(932) * b(121) - b(90) = b(90) - lu(931) * b(121) - b(87) = b(87) - lu(930) * b(121) - b(86) = b(86) - lu(929) * b(121) - b(85) = b(85) - lu(928) * b(121) - b(84) = b(84) - lu(927) * b(121) - b(82) = b(82) - lu(926) * b(121) - b(78) = b(78) - lu(925) * b(121) - b(74) = b(74) - lu(924) * b(121) - b(72) = b(72) - lu(923) * b(121) - b(70) = b(70) - lu(922) * b(121) - b(61) = b(61) - lu(921) * b(121) - b(58) = b(58) - lu(920) * b(121) - b(48) = b(48) - lu(919) * b(121) - b(28) = b(28) - lu(918) * b(121) - b(27) = b(27) - lu(917) * b(121) - b(120) = b(120) * lu(903) - b(118) = b(118) - lu(902) * b(120) - b(116) = b(116) - lu(901) * b(120) - b(103) = b(103) - lu(900) * b(120) - b(99) = b(99) - lu(899) * b(120) - b(95) = b(95) - lu(898) * b(120) - b(92) = b(92) - lu(897) * b(120) - b(87) = b(87) - lu(896) * b(120) - b(86) = b(86) - lu(895) * b(120) - b(85) = b(85) - lu(894) * b(120) - b(82) = b(82) - lu(893) * b(120) - b(78) = b(78) - lu(892) * b(120) - b(72) = b(72) - lu(891) * b(120) - b(61) = b(61) - lu(890) * b(120) - b(58) = b(58) - lu(889) * b(120) - b(56) = b(56) - lu(888) * b(120) - b(28) = b(28) - lu(887) * b(120) - b(27) = b(27) - lu(886) * b(120) - b(119) = b(119) * lu(872) - b(115) = b(115) - lu(871) * b(119) - b(114) = b(114) - lu(870) * b(119) - b(113) = b(113) - lu(869) * b(119) - b(112) = b(112) - lu(868) * b(119) - b(111) = b(111) - lu(867) * b(119) - b(110) = b(110) - lu(866) * b(119) - b(109) = b(109) - lu(865) * b(119) - b(107) = b(107) - lu(864) * b(119) - b(106) = b(106) - lu(863) * b(119) - b(105) = b(105) - lu(862) * b(119) - b(104) = b(104) - lu(861) * b(119) - b(103) = b(103) - lu(860) * b(119) - b(96) = b(96) - lu(859) * b(119) - b(95) = b(95) - lu(858) * b(119) - b(91) = b(91) - lu(857) * b(119) - b(81) = b(81) - lu(856) * b(119) - b(80) = b(80) - lu(855) * b(119) - b(75) = b(75) - lu(854) * b(119) - b(68) = b(68) - lu(853) * b(119) - b(50) = b(50) - lu(852) * b(119) - b(47) = b(47) - lu(851) * b(119) - b(35) = b(35) - lu(850) * b(119) - b(118) = b(118) * lu(839) - b(103) = b(103) - lu(838) * b(118) - b(90) = b(90) - lu(837) * b(118) - b(117) = b(117) * lu(824) - b(100) = b(100) - lu(823) * b(117) - b(93) = b(93) - lu(822) * b(117) - b(84) = b(84) - lu(821) * b(117) - b(33) = b(33) - lu(820) * b(117) - b(29) = b(29) - lu(819) * b(117) - b(116) = b(116) * lu(805) - b(99) = b(99) - lu(804) * b(116) - b(82) = b(82) - lu(803) * b(116) - b(46) = b(46) - lu(802) * b(116) - b(115) = b(115) * lu(789) - b(114) = b(114) - lu(788) * b(115) - b(113) = b(113) - lu(787) * b(115) - b(112) = b(112) - lu(786) * b(115) - b(111) = b(111) - lu(785) * b(115) - b(110) = b(110) - lu(784) * b(115) - b(109) = b(109) - lu(783) * b(115) - b(107) = b(107) - lu(782) * b(115) - b(105) = b(105) - lu(781) * b(115) - b(103) = b(103) - lu(780) * b(115) - b(95) = b(95) - lu(779) * b(115) - b(81) = b(81) - lu(778) * b(115) - b(75) = b(75) - lu(777) * b(115) - b(62) = b(62) - lu(776) * b(115) - b(57) = b(57) - lu(775) * b(115) - b(47) = b(47) - lu(774) * b(115) - b(114) = b(114) * lu(760) - b(109) = b(109) - lu(759) * b(114) - b(105) = b(105) - lu(758) * b(114) - b(75) = b(75) - lu(757) * b(114) - b(71) = b(71) - lu(756) * b(114) - b(62) = b(62) - lu(755) * b(114) - b(113) = b(113) * lu(740) - b(112) = b(112) - lu(739) * b(113) - b(109) = b(109) - lu(738) * b(113) - b(105) = b(105) - lu(737) * b(113) - b(104) = b(104) - lu(736) * b(113) - b(103) = b(103) - lu(735) * b(113) - b(102) = b(102) - lu(734) * b(113) - b(112) = b(112) * lu(721) - b(110) = b(110) - lu(720) * b(112) - b(109) = b(109) - lu(719) * b(112) - b(105) = b(105) - lu(718) * b(112) - b(103) = b(103) - lu(717) * b(112) - b(97) = b(97) - lu(716) * b(112) - b(95) = b(95) - lu(715) * b(112) - b(68) = b(68) - lu(714) * b(112) - b(43) = b(43) - lu(713) * b(112) - b(111) = b(111) * lu(697) - b(110) = b(110) - lu(696) * b(111) - b(109) = b(109) - lu(695) * b(111) - b(107) = b(107) - lu(694) * b(111) - b(103) = b(103) - lu(693) * b(111) - b(97) = b(97) - lu(692) * b(111) - b(69) = b(69) - lu(691) * b(111) - b(68) = b(68) - lu(690) * b(111) - b(47) = b(47) - lu(689) * b(111) - b(110) = b(110) * lu(677) - b(109) = b(109) - lu(676) * b(110) - b(105) = b(105) - lu(675) * b(110) - b(103) = b(103) - lu(674) * b(110) - b(95) = b(95) - lu(673) * b(110) - b(81) = b(81) - lu(672) * b(110) - b(68) = b(68) - lu(671) * b(110) - b(45) = b(45) - lu(670) * b(110) - b(109) = b(109) * lu(662) - b(103) = b(103) - lu(661) * b(109) - b(108) = b(108) * lu(650) - b(88) = b(88) - lu(649) * b(108) - b(34) = b(34) - lu(648) * b(108) - b(107) = b(107) * lu(637) - b(103) = b(103) - lu(636) * b(107) - b(106) = b(106) * lu(625) - b(105) = b(105) - lu(624) * b(106) - b(68) = b(68) - lu(623) * b(106) - b(53) = b(53) - lu(622) * b(106) - b(105) = b(105) * lu(616) - b(104) = b(104) * lu(607) - b(103) = b(103) - lu(606) * b(104) - b(103) = b(103) * lu(602) - b(102) = b(102) * lu(587) - b(89) = b(89) - lu(586) * b(102) - b(75) = b(75) - lu(585) * b(102) - b(49) = b(49) - lu(584) * b(102) - END SUBROUTINE lu_slv07 - - SUBROUTINE lu_slv08(lu, b) - USE shr_kind_mod, ONLY: r4 => shr_kind_r4 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r4), intent(in) :: lu(:) - REAL(KIND=r4), intent(inout) :: b(:) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - b(101) = b(101) * lu(572) - b(97) = b(97) - lu(571) * b(101) - b(45) = b(45) - lu(570) * b(101) - b(100) = b(100) * lu(560) - b(93) = b(93) - lu(559) * b(100) - b(29) = b(29) - lu(558) * b(100) - b(99) = b(99) * lu(552) - b(36) = b(36) - lu(551) * b(99) - b(98) = b(98) * lu(540) - b(80) = b(80) - lu(539) * b(98) - b(59) = b(59) - lu(538) * b(98) - b(97) = b(97) * lu(530) - b(47) = b(47) - lu(529) * b(97) - b(96) = b(96) * lu(517) - b(80) = b(80) - lu(516) * b(96) - b(52) = b(52) - lu(515) * b(96) - b(95) = b(95) * lu(510) - b(81) = b(81) - lu(509) * b(95) - b(94) = b(94) * lu(494) - b(75) = b(75) - lu(493) * b(94) - b(93) = b(93) * lu(486) - b(29) = b(29) - lu(485) * b(93) - b(92) = b(92) * lu(476) - b(87) = b(87) - lu(475) * b(92) - b(86) = b(86) - lu(474) * b(92) - b(85) = b(85) - lu(473) * b(92) - b(72) = b(72) - lu(472) * b(92) - b(58) = b(58) - lu(471) * b(92) - b(91) = b(91) * lu(462) - b(68) = b(68) - lu(461) * b(91) - b(44) = b(44) - lu(460) * b(91) - b(35) = b(35) - lu(459) * b(91) - b(90) = b(90) * lu(452) - b(89) = b(89) * lu(442) - b(67) = b(67) - lu(441) * b(89) - b(88) = b(88) * lu(433) - b(34) = b(34) - lu(432) * b(88) - b(87) = b(87) * lu(425) - b(86) = b(86) - lu(424) * b(87) - b(85) = b(85) - lu(423) * b(87) - b(78) = b(78) - lu(422) * b(87) - b(61) = b(61) - lu(421) * b(87) - b(86) = b(86) * lu(414) - b(61) = b(61) - lu(413) * b(86) - b(85) = b(85) * lu(405) - b(84) = b(84) * lu(397) - b(33) = b(33) - lu(396) * b(84) - b(83) = b(83) * lu(388) - b(56) = b(56) - lu(387) * b(83) - b(24) = b(24) - lu(386) * b(83) - b(82) = b(82) * lu(379) - b(81) = b(81) * lu(375) - b(80) = b(80) * lu(369) - b(79) = b(79) * lu(358) - b(77) = b(77) - lu(357) * b(79) - b(76) = b(76) - lu(356) * b(79) - b(55) = b(55) - lu(355) * b(79) - b(49) = b(49) - lu(354) * b(79) - b(78) = b(78) * lu(344) - b(72) = b(72) - lu(343) * b(78) - b(61) = b(61) - lu(342) * b(78) - b(77) = b(77) * lu(335) - b(42) = b(42) - lu(334) * b(77) - b(76) = b(76) * lu(324) - b(55) = b(55) - lu(323) * b(76) - b(75) = b(75) * lu(319) - b(74) = b(74) * lu(312) - b(73) = b(73) * lu(303) - b(72) = b(72) * lu(296) - b(71) = b(71) * lu(288) - b(70) = b(70) * lu(280) - b(69) = b(69) * lu(272) - b(68) = b(68) * lu(268) - b(67) = b(67) * lu(260) - b(66) = b(66) * lu(254) - b(65) = b(65) * lu(246) - b(51) = b(51) - lu(245) * b(65) - b(64) = b(64) * lu(241) - b(63) = b(63) * lu(233) - b(62) = b(62) * lu(227) - b(61) = b(61) * lu(222) - b(60) = b(60) * lu(215) - b(59) = b(59) * lu(208) - b(58) = b(58) * lu(201) - b(57) = b(57) * lu(194) - b(56) = b(56) * lu(189) - b(55) = b(55) * lu(184) - b(54) = b(54) * lu(178) - b(53) = b(53) * lu(172) - b(52) = b(52) * lu(166) - b(51) = b(51) * lu(160) - b(50) = b(50) * lu(154) - b(49) = b(49) * lu(150) - b(48) = b(48) * lu(142) - b(47) = b(47) * lu(139) - b(46) = b(46) * lu(134) - b(45) = b(45) * lu(130) - b(44) = b(44) * lu(125) - b(43) = b(43) * lu(120) - b(42) = b(42) * lu(115) - b(41) = b(41) * lu(108) - b(40) = b(40) * lu(102) - b(39) = b(39) * lu(96) - b(38) = b(38) * lu(90) - b(37) = b(37) * lu(84) - b(36) = b(36) * lu(80) - b(26) = b(26) - lu(79) * b(36) - b(35) = b(35) * lu(75) - b(34) = b(34) * lu(72) - b(33) = b(33) * lu(69) - b(32) = b(32) * lu(65) - b(31) = b(31) * lu(61) - b(30) = b(30) * lu(57) - b(29) = b(29) * lu(55) - b(28) = b(28) * lu(53) - b(27) = b(27) - lu(52) * b(28) - b(27) = b(27) * lu(50) - b(26) = b(26) * lu(47) - b(25) = b(25) * lu(44) - b(24) = b(24) * lu(41) - b(23) = b(23) * lu(38) - b(22) = b(22) * lu(33) - b(21) = b(21) * lu(29) - b(20) = b(20) * lu(26) - b(19) = b(19) * lu(23) - b(18) = b(18) * lu(20) - b(17) = b(17) * lu(17) - b(16) = b(16) * lu(16) - b(15) = b(15) * lu(15) - b(14) = b(14) * lu(14) - b(13) = b(13) * lu(13) - b(12) = b(12) * lu(12) - b(11) = b(11) * lu(11) - b(10) = b(10) * lu(10) - b(9) = b(9) * lu(9) - b(8) = b(8) * lu(8) - b(7) = b(7) * lu(7) - b(6) = b(6) * lu(6) - b(5) = b(5) * lu(5) - b(4) = b(4) * lu(4) - b(3) = b(3) * lu(3) - b(2) = b(2) * lu(2) - b(1) = b(1) * lu(1) - END SUBROUTINE lu_slv08 - - SUBROUTINE lu_slv_r4(lu, b) - USE shr_kind_mod, ONLY: r4 => shr_kind_r4 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - REAL(KIND=r4), intent(in) :: lu(:) - REAL(KIND=r4), intent(inout) :: b(:) - call lu_slv01( lu, b ) - call lu_slv02( lu, b ) - call lu_slv03( lu, b ) - call lu_slv04( lu, b ) - call lu_slv05( lu, b ) - call lu_slv06( lu, b ) - call lu_slv07( lu, b ) - call lu_slv08( lu, b ) - END SUBROUTINE lu_slv_r4 - END MODULE mo_lu_solve_r4 diff --git a/test/ncar_kernels/WACCM_lu_slv/src/mo_lu_solve_vec.F90 b/test/ncar_kernels/WACCM_lu_slv/src/mo_lu_solve_vec.F90 deleted file mode 100644 index 86a1a64a1b..0000000000 --- a/test/ncar_kernels/WACCM_lu_slv/src/mo_lu_solve_vec.F90 +++ /dev/null @@ -1,1783 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_lu_solve.F90 -! Generated at: 2015-07-14 19:56:41 -! KGEN version: 0.4.13 - -#define FASTER 1 -#undef DOINLINE - - - MODULE mo_lu_solve_vec - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - PRIVATE - PUBLIC lu_slv_vec - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - -#ifdef DOINLINE -!DIR$ ATTRIBUTES FORCEINLINE :: lu_slv01_vec -#else -!DIR$ ATTRIBUTES NOINLINE :: lu_slv01_vec -#endif - SUBROUTINE lu_slv01_vec(ncol,nb,nz,lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - integer :: ncol - integer :: nz, nb - REAL(KIND=r8), intent(in) :: lu(ncol,nz) - REAL(KIND=r8), intent(inout) :: b(ncol,nb) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - integer :: i - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- -!DIR$ ASSUME_ALIGNED lu:64 -!DIR$ ASSUME_ALIGNED b:64 -#ifdef FASTER - b(:,125) = b(:,125) - lu(:,18) * b(:,17) - b(:,131) = b(:,131) - lu(:,19) * b(:,17) -!DIR$ NOFUSION - b(:,124) = b(:,124) - lu(:,21) * b(:,18) - b(:,126) = b(:,126) - lu(:,22) * b(:,18) -!DIR$ NOFUSION - do i=1,ncol -#else - b(:,125) = b(:,125) - lu(:,18) * b(:,17) - b(:,131) = b(:,131) - lu(:,19) * b(:,17) - do i=1,ncol - b(i,124) = b(i,124) - lu(i,21) * b(i,18) - b(i,126) = b(i,126) - lu(i,22) * b(i,18) -#endif - b(i,79) = b(i,79) - lu(i,24) * b(i,19) - b(i,131) = b(i,131) - lu(i,25) * b(i,19) - b(i,41) = b(i,41) - lu(i,27) * b(i,20) - b(i,131) = b(i,131) - lu(i,28) * b(i,20) - b(i,96) = b(i,96) - lu(i,30) * b(i,21) - b(i,131) = b(i,131) - lu(i,31) * b(i,21) - b(i,134) = b(i,134) - lu(i,32) * b(i,21) - b(i,23) = b(i,23) - lu(i,34) * b(i,22) - b(i,65) = b(i,65) - lu(i,35) * b(i,22) - b(i,125) = b(i,125) - lu(i,36) * b(i,22) - b(i,131) = b(i,131) - lu(i,37) * b(i,22) - b(i,31) = b(i,31) - lu(i,39) * b(i,23) - b(i,131) = b(i,131) - lu(i,40) * b(i,23) - b(i,56) = b(i,56) - lu(i,42) * b(i,24) - b(i,131) = b(i,131) - lu(i,43) * b(i,24) - b(i,88) = b(i,88) - lu(i,45) * b(i,25) - b(i,122) = b(i,122) - lu(i,46) * b(i,25) - b(i,36) = b(i,36) - lu(i,48) * b(i,26) - b(i,134) = b(i,134) - lu(i,49) * b(i,26) - b(i,120) = b(i,120) - lu(i,51) * b(i,27) - b(i,120) = b(i,120) - lu(i,54) * b(i,28) - b(i,126) = b(i,126) - lu(i,56) * b(i,29) - b(i,122) = b(i,122) - lu(i,58) * b(i,30) - b(i,125) = b(i,125) - lu(i,59) * b(i,30) - b(i,131) = b(i,131) - lu(i,60) * b(i,30) - b(i,66) = b(i,66) - lu(i,62) * b(i,31) - b(i,125) = b(i,125) - lu(i,63) * b(i,31) - b(i,130) = b(i,130) - lu(i,64) * b(i,31) - b(i,88) = b(i,88) - lu(i,66) * b(i,32) - b(i,122) = b(i,122) - lu(i,67) * b(i,32) - b(i,126) = b(i,126) - lu(i,68) * b(i,32) - b(i,118) = b(i,118) - lu(i,70) * b(i,33) - b(i,126) = b(i,126) - lu(i,71) * b(i,33) - b(i,88) = b(i,88) - lu(i,73) * b(i,34) - b(i,127) = b(i,127) - lu(i,74) * b(i,34) - b(i,104) = b(i,104) - lu(i,76) * b(i,35) - b(i,125) = b(i,125) - lu(i,77) * b(i,35) - b(i,131) = b(i,131) - lu(i,78) * b(i,35) - b(i,99) = b(i,99) - lu(i,81) * b(i,36) - b(i,121) = b(i,121) - lu(i,82) * b(i,36) - b(i,134) = b(i,134) - lu(i,83) * b(i,36) - b(i,91) = b(i,91) - lu(i,85) * b(i,37) - b(i,117) = b(i,117) - lu(i,86) * b(i,37) - b(i,126) = b(i,126) - lu(i,87) * b(i,37) - b(i,131) = b(i,131) - lu(i,88) * b(i,37) - b(i,134) = b(i,134) - lu(i,89) * b(i,37) - b(i,64) = b(i,64) - lu(i,91) * b(i,38) - b(i,81) = b(i,81) - lu(i,92) * b(i,38) - b(i,103) = b(i,103) - lu(i,93) * b(i,38) - b(i,125) = b(i,125) - lu(i,94) * b(i,38) - b(i,131) = b(i,131) - lu(i,95) * b(i,38) - b(i,99) = b(i,99) - lu(i,97) * b(i,39) - b(i,125) = b(i,125) - lu(i,98) * b(i,39) - b(i,131) = b(i,131) - lu(i,99) * b(i,39) - b(i,132) = b(i,132) - lu(i,100) * b(i,39) - b(i,133) = b(i,133) - lu(i,101) * b(i,39) - b(i,121) = b(i,121) - lu(i,103) * b(i,40) - b(i,129) = b(i,129) - lu(i,104) * b(i,40) - b(i,130) = b(i,130) - lu(i,105) * b(i,40) - b(i,132) = b(i,132) - lu(i,106) * b(i,40) - b(i,133) = b(i,133) - lu(i,107) * b(i,40) - b(i,80) = b(i,80) - lu(i,109) * b(i,41) - b(i,104) = b(i,104) - lu(i,110) * b(i,41) - b(i,125) = b(i,125) - lu(i,111) * b(i,41) - b(i,129) = b(i,129) - lu(i,112) * b(i,41) - b(i,130) = b(i,130) - lu(i,113) * b(i,41) - b(i,135) = b(i,135) - lu(i,114) * b(i,41) - b(i,77) = b(i,77) - lu(i,116) * b(i,42) - b(i,104) = b(i,104) - lu(i,117) * b(i,42) - b(i,115) = b(i,115) - lu(i,118) * b(i,42) - b(i,131) = b(i,131) - lu(i,119) * b(i,42) - b(i,112) = b(i,112) - lu(i,121) * b(i,43) - b(i,114) = b(i,114) - lu(i,122) * b(i,43) - b(i,125) = b(i,125) - lu(i,123) * b(i,43) - b(i,131) = b(i,131) - lu(i,124) * b(i,43) - b(i,91) = b(i,91) - lu(i,126) * b(i,44) - b(i,104) = b(i,104) - lu(i,127) * b(i,44) - b(i,125) = b(i,125) - lu(i,128) * b(i,44) - b(i,131) = b(i,131) - lu(i,129) * b(i,44) - b(i,110) = b(i,110) - lu(i,131) * b(i,45) - b(i,131) = b(i,131) - lu(i,132) * b(i,45) - b(i,134) = b(i,134) - lu(i,133) * b(i,45) - b(i,99) = b(i,99) - lu(i,135) * b(i,46) - b(i,116) = b(i,116) - lu(i,136) * b(i,46) - b(i,121) = b(i,121) - lu(i,137) * b(i,46) - b(i,124) = b(i,124) - lu(i,138) * b(i,46) - b(i,110) = b(i,110) - lu(i,140) * b(i,47) - b(i,131) = b(i,131) - lu(i,141) * b(i,47) - b(i,82) = b(i,82) - lu(i,143) * b(i,48) - b(i,99) = b(i,99) - lu(i,144) * b(i,48) - b(i,103) = b(i,103) - lu(i,145) * b(i,48) - b(i,116) = b(i,116) - lu(i,146) * b(i,48) - b(i,121) = b(i,121) - lu(i,147) * b(i,48) - b(i,127) = b(i,127) - lu(i,148) * b(i,48) - b(i,131) = b(i,131) - lu(i,149) * b(i,48) - b(i,109) = b(i,109) - lu(i,151) * b(i,49) - b(i,130) = b(i,130) - lu(i,152) * b(i,49) - b(i,131) = b(i,131) - lu(i,153) * b(i,49) - b(i,119) = b(i,119) - lu(i,155) * b(i,50) - b(i,127) = b(i,127) - lu(i,156) * b(i,50) - b(i,131) = b(i,131) - lu(i,157) * b(i,50) - b(i,134) = b(i,134) - lu(i,158) * b(i,50) - b(i,135) = b(i,135) - lu(i,159) * b(i,50) - b(i,65) = b(i,65) - lu(i,161) * b(i,51) - b(i,66) = b(i,66) - lu(i,162) * b(i,51) - b(i,81) = b(i,81) - lu(i,163) * b(i,51) - b(i,109) = b(i,109) - lu(i,164) * b(i,51) - b(i,131) = b(i,131) - lu(i,165) * b(i,51) - b(i,80) = b(i,80) - lu(i,167) * b(i,52) - b(i,96) = b(i,96) - lu(i,168) * b(i,52) - b(i,125) = b(i,125) - lu(i,169) * b(i,52) - b(i,131) = b(i,131) - lu(i,170) * b(i,52) - b(i,134) = b(i,134) - lu(i,171) * b(i,52) - b(i,106) = b(i,106) - lu(i,173) * b(i,53) - b(i,115) = b(i,115) - lu(i,174) * b(i,53) - b(i,131) = b(i,131) - lu(i,175) * b(i,53) - b(i,134) = b(i,134) - lu(i,176) * b(i,53) - b(i,135) = b(i,135) - lu(i,177) * b(i,53) - b(i,64) = b(i,64) - lu(i,179) * b(i,54) - b(i,125) = b(i,125) - lu(i,180) * b(i,54) - b(i,129) = b(i,129) - lu(i,181) * b(i,54) - b(i,130) = b(i,130) - lu(i,182) * b(i,54) - b(i,135) = b(i,135) - lu(i,183) * b(i,54) - b(i,77) = b(i,77) - lu(i,185) * b(i,55) - b(i,91) = b(i,91) - lu(i,186) * b(i,55) - b(i,115) = b(i,115) - lu(i,187) * b(i,55) - b(i,131) = b(i,131) - lu(i,188) * b(i,55) - b(i,95) = b(i,95) - lu(i,190) * b(i,56) - b(i,120) = b(i,120) - lu(i,191) * b(i,56) - b(i,125) = b(i,125) - lu(i,192) * b(i,56) - b(i,135) = b(i,135) - lu(i,193) * b(i,56) - b(i,115) = b(i,115) - lu(i,195) * b(i,57) - b(i,119) = b(i,119) - lu(i,196) * b(i,57) - b(i,130) = b(i,130) - lu(i,197) * b(i,57) - b(i,131) = b(i,131) - lu(i,198) * b(i,57) - b(i,132) = b(i,132) - lu(i,199) * b(i,57) - b(i,135) = b(i,135) - lu(i,200) * b(i,57) - b(i,72) = b(i,72) - lu(i,202) * b(i,58) - b(i,85) = b(i,85) - lu(i,203) * b(i,58) - b(i,86) = b(i,86) - lu(i,204) * b(i,58) - b(i,92) = b(i,92) - lu(i,205) * b(i,58) - b(i,120) = b(i,120) - lu(i,206) * b(i,58) - b(i,121) = b(i,121) - lu(i,207) * b(i,58) - b(i,80) = b(i,80) - lu(i,209) * b(i,59) - b(i,98) = b(i,98) - lu(i,210) * b(i,59) - b(i,107) = b(i,107) - lu(i,211) * b(i,59) - b(i,113) = b(i,113) - lu(i,212) * b(i,59) - b(i,125) = b(i,125) - lu(i,213) * b(i,59) - b(i,131) = b(i,131) - lu(i,214) * b(i,59) - b(i,120) = b(i,120) - lu(i,216) * b(i,60) - b(i,125) = b(i,125) - lu(i,217) * b(i,60) - b(i,130) = b(i,130) - lu(i,218) * b(i,60) - b(i,131) = b(i,131) - lu(i,219) * b(i,60) - b(i,132) = b(i,132) - lu(i,220) * b(i,60) - b(i,134) = b(i,134) - lu(i,221) * b(i,60) - b(i,92) = b(i,92) - lu(i,223) * b(i,61) - b(i,120) = b(i,120) - lu(i,224) * b(i,61) - b(i,122) = b(i,122) - lu(i,225) * b(i,61) - b(i,129) = b(i,129) - lu(i,226) * b(i,61) - b(i,115) = b(i,115) - lu(i,228) * b(i,62) - b(i,119) = b(i,119) - lu(i,229) * b(i,62) - b(i,131) = b(i,131) - lu(i,230) * b(i,62) - b(i,134) = b(i,134) - lu(i,231) * b(i,62) - b(i,135) = b(i,135) - lu(i,232) * b(i,62) - b(i,64) = b(i,64) - lu(i,234) * b(i,63) - b(i,83) = b(i,83) - lu(i,235) * b(i,63) - b(i,103) = b(i,103) - lu(i,236) * b(i,63) - b(i,123) = b(i,123) - lu(i,237) * b(i,63) - b(i,125) = b(i,125) - lu(i,238) * b(i,63) - b(i,131) = b(i,131) - lu(i,239) * b(i,63) - b(i,135) = b(i,135) - lu(i,240) * b(i,63) - b(i,125) = b(i,125) - lu(i,242) * b(i,64) - b(i,131) = b(i,131) - lu(i,243) * b(i,64) - b(i,134) = b(i,134) - lu(i,244) * b(i,64) - b(i,66) = b(i,66) - lu(i,247) * b(i,65) - b(i,81) = b(i,81) - lu(i,248) * b(i,65) - b(i,109) = b(i,109) - lu(i,249) * b(i,65) - b(i,125) = b(i,125) - lu(i,250) * b(i,65) - b(i,129) = b(i,129) - lu(i,251) * b(i,65) - b(i,130) = b(i,130) - lu(i,252) * b(i,65) - b(i,131) = b(i,131) - lu(i,253) * b(i,65) - b(i,81) = b(i,81) - lu(i,255) * b(i,66) - b(i,103) = b(i,103) - lu(i,256) * b(i,66) - b(i,109) = b(i,109) - lu(i,257) * b(i,66) - b(i,115) = b(i,115) - lu(i,258) * b(i,66) - b(i,125) = b(i,125) - lu(i,259) * b(i,66) - b(i,89) = b(i,89) - lu(i,261) * b(i,67) - b(i,104) = b(i,104) - lu(i,262) * b(i,67) - b(i,105) = b(i,105) - lu(i,263) * b(i,67) - b(i,125) = b(i,125) - lu(i,264) * b(i,67) - b(i,131) = b(i,131) - lu(i,265) * b(i,67) - b(i,134) = b(i,134) - lu(i,266) * b(i,67) - b(i,135) = b(i,135) - lu(i,267) * b(i,67) - b(i,125) = b(i,125) - lu(i,269) * b(i,68) - b(i,131) = b(i,131) - lu(i,270) * b(i,68) - b(i,135) = b(i,135) - lu(i,271) * b(i,68) - b(i,107) = b(i,107) - lu(i,273) * b(i,69) - b(i,110) = b(i,110) - lu(i,274) * b(i,69) - b(i,111) = b(i,111) - lu(i,275) * b(i,69) - b(i,113) = b(i,113) - lu(i,276) * b(i,69) - b(i,125) = b(i,125) - lu(i,277) * b(i,69) - b(i,131) = b(i,131) - lu(i,278) * b(i,69) - b(i,135) = b(i,135) - lu(i,279) * b(i,69) - enddo - END SUBROUTINE lu_slv01_vec - -#ifdef DOINLINE -!DIR$ ATTRIBUTES FORCEINLINE :: lu_slv02_vec -#else -!DIR$ ATTRIBUTES NOINLINE :: lu_slv02_vec -#endif - SUBROUTINE lu_slv02_vec(ncol,nb,nz,lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - integer :: ncol,nb,nz - REAL(KIND=r8), intent(in) :: lu(ncol,nz) - REAL(KIND=r8), intent(inout) :: b(ncol,nb) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - integer :: i - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- -!DIR$ ASSUME_ALIGNED lu:64 -!DIR$ ASSUME_ALIGNED b:64 - do i=1,ncol - b(i,84) = b(i,84) - lu(i,281) * b(i,70) - b(i,118) = b(i,118) - lu(i,282) * b(i,70) - b(i,121) = b(i,121) - lu(i,283) * b(i,70) - b(i,128) = b(i,128) - lu(i,284) * b(i,70) - b(i,130) = b(i,130) - lu(i,285) * b(i,70) - b(i,132) = b(i,132) - lu(i,286) * b(i,70) - b(i,133) = b(i,133) - lu(i,287) * b(i,70) - enddo - - do i=1,ncol - b(i,105) = b(i,105) - lu(i,289) * b(i,71) - b(i,114) = b(i,114) - lu(i,290) * b(i,71) - b(i,125) = b(i,125) - lu(i,291) * b(i,71) - b(i,130) = b(i,130) - lu(i,292) * b(i,71) - b(i,131) = b(i,131) - lu(i,293) * b(i,71) - b(i,132) = b(i,132) - lu(i,294) * b(i,71) - b(i,135) = b(i,135) - lu(i,295) * b(i,71) - b(i,85) = b(i,85) - lu(i,297) * b(i,72) - b(i,86) = b(i,86) - lu(i,298) * b(i,72) - b(i,92) = b(i,92) - lu(i,299) * b(i,72) - b(i,103) = b(i,103) - lu(i,300) * b(i,72) - b(i,120) = b(i,120) - lu(i,301) * b(i,72) - b(i,121) = b(i,121) - lu(i,302) * b(i,72) - b(i,98) = b(i,98) - lu(i,304) * b(i,73) - b(i,107) = b(i,107) - lu(i,305) * b(i,73) - b(i,113) = b(i,113) - lu(i,306) * b(i,73) - b(i,123) = b(i,123) - lu(i,307) * b(i,73) - b(i,125) = b(i,125) - lu(i,308) * b(i,73) - b(i,130) = b(i,130) - lu(i,309) * b(i,73) - b(i,131) = b(i,131) - lu(i,310) * b(i,73) - b(i,132) = b(i,132) - lu(i,311) * b(i,73) - b(i,117) = b(i,117) - lu(i,313) * b(i,74) - b(i,121) = b(i,121) - lu(i,314) * b(i,74) - b(i,125) = b(i,125) - lu(i,315) * b(i,74) - b(i,126) = b(i,126) - lu(i,316) * b(i,74) - b(i,131) = b(i,131) - lu(i,317) * b(i,74) - b(i,134) = b(i,134) - lu(i,318) * b(i,74) - b(i,119) = b(i,119) - lu(i,320) * b(i,75) - b(i,131) = b(i,131) - lu(i,321) * b(i,75) - b(i,134) = b(i,134) - lu(i,322) * b(i,75) - b(i,77) = b(i,77) - lu(i,325) * b(i,76) - b(i,79) = b(i,79) - lu(i,326) * b(i,76) - b(i,80) = b(i,80) - lu(i,327) * b(i,76) - b(i,91) = b(i,91) - lu(i,328) * b(i,76) - b(i,104) = b(i,104) - lu(i,329) * b(i,76) - b(i,115) = b(i,115) - lu(i,330) * b(i,76) - b(i,125) = b(i,125) - lu(i,331) * b(i,76) - b(i,131) = b(i,131) - lu(i,332) * b(i,76) - b(i,135) = b(i,135) - lu(i,333) * b(i,76) - b(i,104) = b(i,104) - lu(i,336) * b(i,77) - b(i,115) = b(i,115) - lu(i,337) * b(i,77) - b(i,125) = b(i,125) - lu(i,338) * b(i,77) - b(i,129) = b(i,129) - lu(i,339) * b(i,77) - b(i,130) = b(i,130) - lu(i,340) * b(i,77) - b(i,131) = b(i,131) - lu(i,341) * b(i,77) - b(i,85) = b(i,85) - lu(i,345) * b(i,78) - b(i,86) = b(i,86) - lu(i,346) * b(i,78) - b(i,87) = b(i,87) - lu(i,347) * b(i,78) - b(i,92) = b(i,92) - lu(i,348) * b(i,78) - b(i,103) = b(i,103) - lu(i,349) * b(i,78) - b(i,120) = b(i,120) - lu(i,350) * b(i,78) - b(i,121) = b(i,121) - lu(i,351) * b(i,78) - b(i,122) = b(i,122) - lu(i,352) * b(i,78) - b(i,129) = b(i,129) - lu(i,353) * b(i,78) - b(i,80) = b(i,80) - lu(i,359) * b(i,79) - b(i,91) = b(i,91) - lu(i,360) * b(i,79) - b(i,104) = b(i,104) - lu(i,361) * b(i,79) - b(i,109) = b(i,109) - lu(i,362) * b(i,79) - b(i,115) = b(i,115) - lu(i,363) * b(i,79) - b(i,125) = b(i,125) - lu(i,364) * b(i,79) - b(i,129) = b(i,129) - lu(i,365) * b(i,79) - b(i,130) = b(i,130) - lu(i,366) * b(i,79) - b(i,131) = b(i,131) - lu(i,367) * b(i,79) - b(i,135) = b(i,135) - lu(i,368) * b(i,79) - b(i,106) = b(i,106) - lu(i,370) * b(i,80) - b(i,115) = b(i,115) - lu(i,371) * b(i,80) - b(i,119) = b(i,119) - lu(i,372) * b(i,80) - b(i,131) = b(i,131) - lu(i,373) * b(i,80) - b(i,134) = b(i,134) - lu(i,374) * b(i,80) - b(i,103) = b(i,103) - lu(i,376) * b(i,81) - b(i,125) = b(i,125) - lu(i,377) * b(i,81) - b(i,131) = b(i,131) - lu(i,378) * b(i,81) - b(i,116) = b(i,116) - lu(i,380) * b(i,82) - b(i,120) = b(i,120) - lu(i,381) * b(i,82) - b(i,121) = b(i,121) - lu(i,382) * b(i,82) - b(i,123) = b(i,123) - lu(i,383) * b(i,82) - b(i,127) = b(i,127) - lu(i,384) * b(i,82) - b(i,131) = b(i,131) - lu(i,385) * b(i,82) - b(i,95) = b(i,95) - lu(i,389) * b(i,83) - b(i,120) = b(i,120) - lu(i,390) * b(i,83) - b(i,125) = b(i,125) - lu(i,391) * b(i,83) - b(i,129) = b(i,129) - lu(i,392) * b(i,83) - b(i,130) = b(i,130) - lu(i,393) * b(i,83) - b(i,131) = b(i,131) - lu(i,394) * b(i,83) - b(i,135) = b(i,135) - lu(i,395) * b(i,83) - b(i,117) = b(i,117) - lu(i,398) * b(i,84) - b(i,118) = b(i,118) - lu(i,399) * b(i,84) - b(i,121) = b(i,121) - lu(i,400) * b(i,84) - b(i,126) = b(i,126) - lu(i,401) * b(i,84) - b(i,128) = b(i,128) - lu(i,402) * b(i,84) - b(i,131) = b(i,131) - lu(i,403) * b(i,84) - b(i,134) = b(i,134) - lu(i,404) * b(i,84) - b(i,86) = b(i,86) - lu(i,406) * b(i,85) - b(i,87) = b(i,87) - lu(i,407) * b(i,85) - b(i,92) = b(i,92) - lu(i,408) * b(i,85) - b(i,120) = b(i,120) - lu(i,409) * b(i,85) - b(i,121) = b(i,121) - lu(i,410) * b(i,85) - b(i,122) = b(i,122) - lu(i,411) * b(i,85) - b(i,129) = b(i,129) - lu(i,412) * b(i,85) - b(i,87) = b(i,87) - lu(i,415) * b(i,86) - b(i,92) = b(i,92) - lu(i,416) * b(i,86) - b(i,120) = b(i,120) - lu(i,417) * b(i,86) - b(i,121) = b(i,121) - lu(i,418) * b(i,86) - b(i,122) = b(i,122) - lu(i,419) * b(i,86) - b(i,129) = b(i,129) - lu(i,420) * b(i,86) - b(i,92) = b(i,92) - lu(i,426) * b(i,87) - b(i,103) = b(i,103) - lu(i,427) * b(i,87) - b(i,120) = b(i,120) - lu(i,428) * b(i,87) - b(i,121) = b(i,121) - lu(i,429) * b(i,87) - b(i,122) = b(i,122) - lu(i,430) * b(i,87) - b(i,129) = b(i,129) - lu(i,431) * b(i,87) - b(i,108) = b(i,108) - lu(i,434) * b(i,88) - b(i,119) = b(i,119) - lu(i,435) * b(i,88) - b(i,127) = b(i,127) - lu(i,436) * b(i,88) - b(i,131) = b(i,131) - lu(i,437) * b(i,88) - b(i,132) = b(i,132) - lu(i,438) * b(i,88) - b(i,133) = b(i,133) - lu(i,439) * b(i,88) - b(i,134) = b(i,134) - lu(i,440) * b(i,88) - b(i,104) = b(i,104) - lu(i,443) * b(i,89) - b(i,105) = b(i,105) - lu(i,444) * b(i,89) - b(i,120) = b(i,120) - lu(i,445) * b(i,89) - b(i,125) = b(i,125) - lu(i,446) * b(i,89) - b(i,129) = b(i,129) - lu(i,447) * b(i,89) - b(i,130) = b(i,130) - lu(i,448) * b(i,89) - b(i,131) = b(i,131) - lu(i,449) * b(i,89) - b(i,134) = b(i,134) - lu(i,450) * b(i,89) - b(i,135) = b(i,135) - lu(i,451) * b(i,89) - b(i,118) = b(i,118) - lu(i,453) * b(i,90) - b(i,121) = b(i,121) - lu(i,454) * b(i,90) - b(i,122) = b(i,122) - lu(i,455) * b(i,90) - b(i,127) = b(i,127) - lu(i,456) * b(i,90) - b(i,131) = b(i,131) - lu(i,457) * b(i,90) - b(i,134) = b(i,134) - lu(i,458) * b(i,90) - b(i,104) = b(i,104) - lu(i,463) * b(i,91) - b(i,119) = b(i,119) - lu(i,464) * b(i,91) - b(i,120) = b(i,120) - lu(i,465) * b(i,91) - b(i,125) = b(i,125) - lu(i,466) * b(i,91) - b(i,129) = b(i,129) - lu(i,467) * b(i,91) - b(i,130) = b(i,130) - lu(i,468) * b(i,91) - b(i,131) = b(i,131) - lu(i,469) * b(i,91) - b(i,135) = b(i,135) - lu(i,470) * b(i,91) - b(i,103) = b(i,103) - lu(i,477) * b(i,92) - b(i,120) = b(i,120) - lu(i,478) * b(i,92) - b(i,121) = b(i,121) - lu(i,479) * b(i,92) - b(i,122) = b(i,122) - lu(i,480) * b(i,92) - b(i,127) = b(i,127) - lu(i,481) * b(i,92) - b(i,129) = b(i,129) - lu(i,482) * b(i,92) - b(i,130) = b(i,130) - lu(i,483) * b(i,92) - b(i,131) = b(i,131) - lu(i,484) * b(i,92) - b(i,117) = b(i,117) - lu(i,487) * b(i,93) - b(i,121) = b(i,121) - lu(i,488) * b(i,93) - b(i,124) = b(i,124) - lu(i,489) * b(i,93) - b(i,126) = b(i,126) - lu(i,490) * b(i,93) - b(i,131) = b(i,131) - lu(i,491) * b(i,93) - b(i,134) = b(i,134) - lu(i,492) * b(i,93) - b(i,101) = b(i,101) - lu(i,495) * b(i,94) - b(i,102) = b(i,102) - lu(i,496) * b(i,94) - b(i,103) = b(i,103) - lu(i,497) * b(i,94) - b(i,107) = b(i,107) - lu(i,498) * b(i,94) - b(i,111) = b(i,111) - lu(i,499) * b(i,94) - b(i,113) = b(i,113) - lu(i,500) * b(i,94) - b(i,114) = b(i,114) - lu(i,501) * b(i,94) - b(i,119) = b(i,119) - lu(i,502) * b(i,94) - b(i,123) = b(i,123) - lu(i,503) * b(i,94) - b(i,125) = b(i,125) - lu(i,504) * b(i,94) - b(i,131) = b(i,131) - lu(i,505) * b(i,94) - b(i,132) = b(i,132) - lu(i,506) * b(i,94) - b(i,134) = b(i,134) - lu(i,507) * b(i,94) - b(i,135) = b(i,135) - lu(i,508) * b(i,94) - b(i,103) = b(i,103) - lu(i,511) * b(i,95) - b(i,125) = b(i,125) - lu(i,512) * b(i,95) - b(i,131) = b(i,131) - lu(i,513) * b(i,95) - b(i,135) = b(i,135) - lu(i,514) * b(i,95) - b(i,104) = b(i,104) - lu(i,518) * b(i,96) - b(i,106) = b(i,106) - lu(i,519) * b(i,96) - b(i,115) = b(i,115) - lu(i,520) * b(i,96) - b(i,119) = b(i,119) - lu(i,521) * b(i,96) - b(i,120) = b(i,120) - lu(i,522) * b(i,96) - b(i,125) = b(i,125) - lu(i,523) * b(i,96) - b(i,129) = b(i,129) - lu(i,524) * b(i,96) - b(i,130) = b(i,130) - lu(i,525) * b(i,96) - b(i,131) = b(i,131) - lu(i,526) * b(i,96) - b(i,134) = b(i,134) - lu(i,527) * b(i,96) - b(i,135) = b(i,135) - lu(i,528) * b(i,96) - b(i,103) = b(i,103) - lu(i,531) * b(i,97) - b(i,110) = b(i,110) - lu(i,532) * b(i,97) - b(i,125) = b(i,125) - lu(i,533) * b(i,97) - b(i,130) = b(i,130) - lu(i,534) * b(i,97) - b(i,131) = b(i,131) - lu(i,535) * b(i,97) - b(i,132) = b(i,132) - lu(i,536) * b(i,97) - b(i,135) = b(i,135) - lu(i,537) * b(i,97) - b(i,106) = b(i,106) - lu(i,541) * b(i,98) - b(i,107) = b(i,107) - lu(i,542) * b(i,98) - b(i,113) = b(i,113) - lu(i,543) * b(i,98) - b(i,115) = b(i,115) - lu(i,544) * b(i,98) - b(i,119) = b(i,119) - lu(i,545) * b(i,98) - b(i,125) = b(i,125) - lu(i,546) * b(i,98) - b(i,129) = b(i,129) - lu(i,547) * b(i,98) - b(i,130) = b(i,130) - lu(i,548) * b(i,98) - b(i,131) = b(i,131) - lu(i,549) * b(i,98) - b(i,134) = b(i,134) - lu(i,550) * b(i,98) - enddo - END SUBROUTINE lu_slv02_vec - -#ifdef DOINLINE -!DIR$ ATTRIBUTES FORCEINLINE :: lu_slv03_vec -#else -!DIR$ ATTRIBUTES NOINLINE :: lu_slv03_vec -#endif - SUBROUTINE lu_slv03_vec(ncol,nb,nz,lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - integer*4 :: ncol,nb,nz - REAL(KIND=r8), intent(in) :: lu(ncol,nz) - REAL(KIND=r8), intent(inout) :: b(ncol,nb) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - integer :: i - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- -!DIR$ ASSUME_ALIGNED lu:64 -!DIR$ ASSUME_ALIGNED b:64 - do i=1,ncol - b(i,116) = b(i,116) - lu(i,553) * b(i,99) - b(i,121) = b(i,121) - lu(i,554) * b(i,99) - b(i,125) = b(i,125) - lu(i,555) * b(i,99) - b(i,131) = b(i,131) - lu(i,556) * b(i,99) - b(i,134) = b(i,134) - lu(i,557) * b(i,99) - b(i,117) = b(i,117) - lu(i,561) * b(i,100) - b(i,121) = b(i,121) - lu(i,562) * b(i,100) - b(i,124) = b(i,124) - lu(i,563) * b(i,100) - b(i,126) = b(i,126) - lu(i,564) * b(i,100) - b(i,130) = b(i,130) - lu(i,565) * b(i,100) - b(i,131) = b(i,131) - lu(i,566) * b(i,100) - b(i,132) = b(i,132) - lu(i,567) * b(i,100) - b(i,133) = b(i,133) - lu(i,568) * b(i,100) - b(i,134) = b(i,134) - lu(i,569) * b(i,100) - b(i,103) = b(i,103) - lu(i,573) * b(i,101) - b(i,107) = b(i,107) - lu(i,574) * b(i,101) - b(i,110) = b(i,110) - lu(i,575) * b(i,101) - b(i,113) = b(i,113) - lu(i,576) * b(i,101) - b(i,125) = b(i,125) - lu(i,577) * b(i,101) - b(i,129) = b(i,129) - lu(i,578) * b(i,101) - b(i,130) = b(i,130) - lu(i,579) * b(i,101) - b(i,131) = b(i,131) - lu(i,580) * b(i,101) - b(i,132) = b(i,132) - lu(i,581) * b(i,101) - b(i,134) = b(i,134) - lu(i,582) * b(i,101) - b(i,135) = b(i,135) - lu(i,583) * b(i,101) - b(i,103) = b(i,103) - lu(i,588) * b(i,102) - b(i,104) = b(i,104) - lu(i,589) * b(i,102) - b(i,105) = b(i,105) - lu(i,590) * b(i,102) - b(i,109) = b(i,109) - lu(i,591) * b(i,102) - b(i,119) = b(i,119) - lu(i,592) * b(i,102) - b(i,120) = b(i,120) - lu(i,593) * b(i,102) - b(i,123) = b(i,123) - lu(i,594) * b(i,102) - b(i,125) = b(i,125) - lu(i,595) * b(i,102) - b(i,129) = b(i,129) - lu(i,596) * b(i,102) - b(i,130) = b(i,130) - lu(i,597) * b(i,102) - b(i,131) = b(i,131) - lu(i,598) * b(i,102) - b(i,132) = b(i,132) - lu(i,599) * b(i,102) - b(i,134) = b(i,134) - lu(i,600) * b(i,102) - b(i,135) = b(i,135) - lu(i,601) * b(i,102) - b(i,125) = b(i,125) - lu(i,603) * b(i,103) - b(i,127) = b(i,127) - lu(i,604) * b(i,103) - b(i,131) = b(i,131) - lu(i,605) * b(i,103) - b(i,115) = b(i,115) - lu(i,608) * b(i,104) - b(i,119) = b(i,119) - lu(i,609) * b(i,104) - b(i,125) = b(i,125) - lu(i,610) * b(i,104) - b(i,127) = b(i,127) - lu(i,611) * b(i,104) - b(i,131) = b(i,131) - lu(i,612) * b(i,104) - b(i,132) = b(i,132) - lu(i,613) * b(i,104) - b(i,133) = b(i,133) - lu(i,614) * b(i,104) - b(i,134) = b(i,134) - lu(i,615) * b(i,104) - b(i,109) = b(i,109) - lu(i,617) * b(i,105) - b(i,115) = b(i,115) - lu(i,618) * b(i,105) - b(i,125) = b(i,125) - lu(i,619) * b(i,105) - b(i,131) = b(i,131) - lu(i,620) * b(i,105) - b(i,135) = b(i,135) - lu(i,621) * b(i,105) - b(i,109) = b(i,109) - lu(i,626) * b(i,106) - b(i,115) = b(i,115) - lu(i,627) * b(i,106) - b(i,119) = b(i,119) - lu(i,628) * b(i,106) - b(i,120) = b(i,120) - lu(i,629) * b(i,106) - b(i,125) = b(i,125) - lu(i,630) * b(i,106) - b(i,129) = b(i,129) - lu(i,631) * b(i,106) - b(i,130) = b(i,130) - lu(i,632) * b(i,106) - b(i,131) = b(i,131) - lu(i,633) * b(i,106) - b(i,134) = b(i,134) - lu(i,634) * b(i,106) - b(i,135) = b(i,135) - lu(i,635) * b(i,106) - b(i,109) = b(i,109) - lu(i,638) * b(i,107) - b(i,112) = b(i,112) - lu(i,639) * b(i,107) - b(i,114) = b(i,114) - lu(i,640) * b(i,107) - b(i,115) = b(i,115) - lu(i,641) * b(i,107) - b(i,123) = b(i,123) - lu(i,642) * b(i,107) - b(i,125) = b(i,125) - lu(i,643) * b(i,107) - b(i,127) = b(i,127) - lu(i,644) * b(i,107) - b(i,131) = b(i,131) - lu(i,645) * b(i,107) - b(i,134) = b(i,134) - lu(i,646) * b(i,107) - b(i,135) = b(i,135) - lu(i,647) * b(i,107) - b(i,117) = b(i,117) - lu(i,651) * b(i,108) - b(i,119) = b(i,119) - lu(i,652) * b(i,108) - b(i,121) = b(i,121) - lu(i,653) * b(i,108) - b(i,122) = b(i,122) - lu(i,654) * b(i,108) - b(i,126) = b(i,126) - lu(i,655) * b(i,108) - b(i,127) = b(i,127) - lu(i,656) * b(i,108) - b(i,131) = b(i,131) - lu(i,657) * b(i,108) - b(i,132) = b(i,132) - lu(i,658) * b(i,108) - b(i,133) = b(i,133) - lu(i,659) * b(i,108) - b(i,134) = b(i,134) - lu(i,660) * b(i,108) - b(i,115) = b(i,115) - lu(i,663) * b(i,109) - b(i,125) = b(i,125) - lu(i,664) * b(i,109) - b(i,127) = b(i,127) - lu(i,665) * b(i,109) - b(i,131) = b(i,131) - lu(i,666) * b(i,109) - b(i,132) = b(i,132) - lu(i,667) * b(i,109) - b(i,133) = b(i,133) - lu(i,668) * b(i,109) - b(i,134) = b(i,134) - lu(i,669) * b(i,109) - b(i,115) = b(i,115) - lu(i,678) * b(i,110) - b(i,119) = b(i,119) - lu(i,679) * b(i,110) - b(i,125) = b(i,125) - lu(i,680) * b(i,110) - b(i,127) = b(i,127) - lu(i,681) * b(i,110) - b(i,129) = b(i,129) - lu(i,682) * b(i,110) - b(i,130) = b(i,130) - lu(i,683) * b(i,110) - b(i,131) = b(i,131) - lu(i,684) * b(i,110) - b(i,132) = b(i,132) - lu(i,685) * b(i,110) - b(i,133) = b(i,133) - lu(i,686) * b(i,110) - b(i,134) = b(i,134) - lu(i,687) * b(i,110) - b(i,135) = b(i,135) - lu(i,688) * b(i,110) - b(i,112) = b(i,112) - lu(i,698) * b(i,111) - b(i,113) = b(i,113) - lu(i,699) * b(i,111) - b(i,114) = b(i,114) - lu(i,700) * b(i,111) - b(i,115) = b(i,115) - lu(i,701) * b(i,111) - b(i,119) = b(i,119) - lu(i,702) * b(i,111) - b(i,123) = b(i,123) - lu(i,703) * b(i,111) - b(i,125) = b(i,125) - lu(i,704) * b(i,111) - b(i,127) = b(i,127) - lu(i,705) * b(i,111) - b(i,129) = b(i,129) - lu(i,706) * b(i,111) - b(i,130) = b(i,130) - lu(i,707) * b(i,111) - b(i,131) = b(i,131) - lu(i,708) * b(i,111) - b(i,132) = b(i,132) - lu(i,709) * b(i,111) - b(i,133) = b(i,133) - lu(i,710) * b(i,111) - b(i,134) = b(i,134) - lu(i,711) * b(i,111) - b(i,135) = b(i,135) - lu(i,712) * b(i,111) - b(i,114) = b(i,114) - lu(i,722) * b(i,112) - b(i,115) = b(i,115) - lu(i,723) * b(i,112) - b(i,119) = b(i,119) - lu(i,724) * b(i,112) - b(i,125) = b(i,125) - lu(i,725) * b(i,112) - b(i,127) = b(i,127) - lu(i,726) * b(i,112) - b(i,129) = b(i,129) - lu(i,727) * b(i,112) - b(i,130) = b(i,130) - lu(i,728) * b(i,112) - b(i,131) = b(i,131) - lu(i,729) * b(i,112) - b(i,132) = b(i,132) - lu(i,730) * b(i,112) - b(i,133) = b(i,133) - lu(i,731) * b(i,112) - b(i,134) = b(i,134) - lu(i,732) * b(i,112) - b(i,135) = b(i,135) - lu(i,733) * b(i,112) - b(i,114) = b(i,114) - lu(i,741) * b(i,113) - b(i,115) = b(i,115) - lu(i,742) * b(i,113) - b(i,119) = b(i,119) - lu(i,743) * b(i,113) - b(i,120) = b(i,120) - lu(i,744) * b(i,113) - b(i,123) = b(i,123) - lu(i,745) * b(i,113) - b(i,125) = b(i,125) - lu(i,746) * b(i,113) - b(i,127) = b(i,127) - lu(i,747) * b(i,113) - b(i,129) = b(i,129) - lu(i,748) * b(i,113) - b(i,130) = b(i,130) - lu(i,749) * b(i,113) - b(i,131) = b(i,131) - lu(i,750) * b(i,113) - b(i,132) = b(i,132) - lu(i,751) * b(i,113) - b(i,133) = b(i,133) - lu(i,752) * b(i,113) - b(i,134) = b(i,134) - lu(i,753) * b(i,113) - b(i,135) = b(i,135) - lu(i,754) * b(i,113) - b(i,115) = b(i,115) - lu(i,761) * b(i,114) - b(i,119) = b(i,119) - lu(i,762) * b(i,114) - b(i,120) = b(i,120) - lu(i,763) * b(i,114) - b(i,123) = b(i,123) - lu(i,764) * b(i,114) - b(i,125) = b(i,125) - lu(i,765) * b(i,114) - b(i,127) = b(i,127) - lu(i,766) * b(i,114) - b(i,129) = b(i,129) - lu(i,767) * b(i,114) - b(i,130) = b(i,130) - lu(i,768) * b(i,114) - b(i,131) = b(i,131) - lu(i,769) * b(i,114) - b(i,132) = b(i,132) - lu(i,770) * b(i,114) - b(i,133) = b(i,133) - lu(i,771) * b(i,114) - b(i,134) = b(i,134) - lu(i,772) * b(i,114) - b(i,135) = b(i,135) - lu(i,773) * b(i,114) - b(i,119) = b(i,119) - lu(i,790) * b(i,115) - b(i,120) = b(i,120) - lu(i,791) * b(i,115) - b(i,123) = b(i,123) - lu(i,792) * b(i,115) - b(i,125) = b(i,125) - lu(i,793) * b(i,115) - b(i,127) = b(i,127) - lu(i,794) * b(i,115) - b(i,129) = b(i,129) - lu(i,795) * b(i,115) - b(i,130) = b(i,130) - lu(i,796) * b(i,115) - b(i,131) = b(i,131) - lu(i,797) * b(i,115) - b(i,132) = b(i,132) - lu(i,798) * b(i,115) - b(i,133) = b(i,133) - lu(i,799) * b(i,115) - b(i,134) = b(i,134) - lu(i,800) * b(i,115) - b(i,135) = b(i,135) - lu(i,801) * b(i,115) - b(i,118) = b(i,118) - lu(i,806) * b(i,116) - b(i,120) = b(i,120) - lu(i,807) * b(i,116) - b(i,121) = b(i,121) - lu(i,808) * b(i,116) - b(i,123) = b(i,123) - lu(i,809) * b(i,116) - b(i,124) = b(i,124) - lu(i,810) * b(i,116) - b(i,125) = b(i,125) - lu(i,811) * b(i,116) - b(i,126) = b(i,126) - lu(i,812) * b(i,116) - b(i,127) = b(i,127) - lu(i,813) * b(i,116) - b(i,128) = b(i,128) - lu(i,814) * b(i,116) - b(i,129) = b(i,129) - lu(i,815) * b(i,116) - b(i,130) = b(i,130) - lu(i,816) * b(i,116) - b(i,131) = b(i,131) - lu(i,817) * b(i,116) - b(i,134) = b(i,134) - lu(i,818) * b(i,116) - b(i,118) = b(i,118) - lu(i,825) * b(i,117) - b(i,121) = b(i,121) - lu(i,826) * b(i,117) - b(i,122) = b(i,122) - lu(i,827) * b(i,117) - b(i,124) = b(i,124) - lu(i,828) * b(i,117) - b(i,126) = b(i,126) - lu(i,829) * b(i,117) - b(i,127) = b(i,127) - lu(i,830) * b(i,117) - b(i,128) = b(i,128) - lu(i,831) * b(i,117) - b(i,130) = b(i,130) - lu(i,832) * b(i,117) - b(i,131) = b(i,131) - lu(i,833) * b(i,117) - b(i,132) = b(i,132) - lu(i,834) * b(i,117) - b(i,133) = b(i,133) - lu(i,835) * b(i,117) - b(i,134) = b(i,134) - lu(i,836) * b(i,117) - b(i,120) = b(i,120) - lu(i,840) * b(i,118) - b(i,121) = b(i,121) - lu(i,841) * b(i,118) - b(i,122) = b(i,122) - lu(i,842) * b(i,118) - b(i,123) = b(i,123) - lu(i,843) * b(i,118) - b(i,125) = b(i,125) - lu(i,844) * b(i,118) - b(i,127) = b(i,127) - lu(i,845) * b(i,118) - b(i,128) = b(i,128) - lu(i,846) * b(i,118) - b(i,131) = b(i,131) - lu(i,847) * b(i,118) - b(i,134) = b(i,134) - lu(i,848) * b(i,118) - b(i,135) = b(i,135) - lu(i,849) * b(i,118) - enddo - END SUBROUTINE lu_slv03_vec - -#ifdef DOINLINE -!DIR$ ATTRIBUTES FORCEINLINE :: lu_slv04_vec -#else -!DIR$ ATTRIBUTES NOINLINE :: lu_slv04_vec -#endif - SUBROUTINE lu_slv04_vec(ncol,nb,nz,lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - integer :: ncol,nb,nz - REAL(KIND=r8), intent(in) :: lu(ncol,nz) - REAL(KIND=r8), intent(inout) :: b(ncol,nb) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - integer :: i - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- -!DIR$ ASSUME_ALIGNED lu:64 -!DIR$ ASSUME_ALIGNED b:64 - do i=1,ncol - b(i,120) = b(i,120) - lu(i,873) * b(i,119) - b(i,123) = b(i,123) - lu(i,874) * b(i,119) - b(i,124) = b(i,124) - lu(i,875) * b(i,119) - b(i,125) = b(i,125) - lu(i,876) * b(i,119) - b(i,126) = b(i,126) - lu(i,877) * b(i,119) - b(i,127) = b(i,127) - lu(i,878) * b(i,119) - b(i,129) = b(i,129) - lu(i,879) * b(i,119) - b(i,130) = b(i,130) - lu(i,880) * b(i,119) - b(i,131) = b(i,131) - lu(i,881) * b(i,119) - b(i,132) = b(i,132) - lu(i,882) * b(i,119) - b(i,133) = b(i,133) - lu(i,883) * b(i,119) - b(i,134) = b(i,134) - lu(i,884) * b(i,119) - b(i,135) = b(i,135) - lu(i,885) * b(i,119) - b(i,121) = b(i,121) - lu(i,904) * b(i,120) - b(i,122) = b(i,122) - lu(i,905) * b(i,120) - b(i,123) = b(i,123) - lu(i,906) * b(i,120) - b(i,124) = b(i,124) - lu(i,907) * b(i,120) - b(i,125) = b(i,125) - lu(i,908) * b(i,120) - b(i,126) = b(i,126) - lu(i,909) * b(i,120) - b(i,127) = b(i,127) - lu(i,910) * b(i,120) - b(i,128) = b(i,128) - lu(i,911) * b(i,120) - b(i,129) = b(i,129) - lu(i,912) * b(i,120) - b(i,130) = b(i,130) - lu(i,913) * b(i,120) - b(i,131) = b(i,131) - lu(i,914) * b(i,120) - b(i,134) = b(i,134) - lu(i,915) * b(i,120) - b(i,135) = b(i,135) - lu(i,916) * b(i,120) - b(i,122) = b(i,122) - lu(i,944) * b(i,121) - b(i,123) = b(i,123) - lu(i,945) * b(i,121) - b(i,124) = b(i,124) - lu(i,946) * b(i,121) - b(i,125) = b(i,125) - lu(i,947) * b(i,121) - b(i,126) = b(i,126) - lu(i,948) * b(i,121) - b(i,127) = b(i,127) - lu(i,949) * b(i,121) - b(i,128) = b(i,128) - lu(i,950) * b(i,121) - b(i,129) = b(i,129) - lu(i,951) * b(i,121) - b(i,130) = b(i,130) - lu(i,952) * b(i,121) - b(i,131) = b(i,131) - lu(i,953) * b(i,121) - b(i,132) = b(i,132) - lu(i,954) * b(i,121) - b(i,133) = b(i,133) - lu(i,955) * b(i,121) - b(i,134) = b(i,134) - lu(i,956) * b(i,121) - b(i,135) = b(i,135) - lu(i,957) * b(i,121) - b(i,123) = b(i,123) - lu(i,971) * b(i,122) - b(i,124) = b(i,124) - lu(i,972) * b(i,122) - b(i,125) = b(i,125) - lu(i,973) * b(i,122) - b(i,126) = b(i,126) - lu(i,974) * b(i,122) - b(i,127) = b(i,127) - lu(i,975) * b(i,122) - b(i,128) = b(i,128) - lu(i,976) * b(i,122) - b(i,129) = b(i,129) - lu(i,977) * b(i,122) - b(i,130) = b(i,130) - lu(i,978) * b(i,122) - b(i,131) = b(i,131) - lu(i,979) * b(i,122) - b(i,132) = b(i,132) - lu(i,980) * b(i,122) - b(i,133) = b(i,133) - lu(i,981) * b(i,122) - b(i,134) = b(i,134) - lu(i,982) * b(i,122) - b(i,135) = b(i,135) - lu(i,983) * b(i,122) - b(i,124) = b(i,124) - lu(i,1017) * b(i,123) - b(i,125) = b(i,125) - lu(i,1018) * b(i,123) - b(i,126) = b(i,126) - lu(i,1019) * b(i,123) - b(i,127) = b(i,127) - lu(i,1020) * b(i,123) - b(i,128) = b(i,128) - lu(i,1021) * b(i,123) - b(i,129) = b(i,129) - lu(i,1022) * b(i,123) - b(i,130) = b(i,130) - lu(i,1023) * b(i,123) - b(i,131) = b(i,131) - lu(i,1024) * b(i,123) - b(i,132) = b(i,132) - lu(i,1025) * b(i,123) - b(i,133) = b(i,133) - lu(i,1026) * b(i,123) - b(i,134) = b(i,134) - lu(i,1027) * b(i,123) - b(i,135) = b(i,135) - lu(i,1028) * b(i,123) - b(i,125) = b(i,125) - lu(i,1045) * b(i,124) - b(i,126) = b(i,126) - lu(i,1046) * b(i,124) - b(i,127) = b(i,127) - lu(i,1047) * b(i,124) - b(i,128) = b(i,128) - lu(i,1048) * b(i,124) - b(i,129) = b(i,129) - lu(i,1049) * b(i,124) - b(i,130) = b(i,130) - lu(i,1050) * b(i,124) - b(i,131) = b(i,131) - lu(i,1051) * b(i,124) - b(i,132) = b(i,132) - lu(i,1052) * b(i,124) - b(i,133) = b(i,133) - lu(i,1053) * b(i,124) - b(i,134) = b(i,134) - lu(i,1054) * b(i,124) - b(i,135) = b(i,135) - lu(i,1055) * b(i,124) - b(i,126) = b(i,126) - lu(i,1115) * b(i,125) - b(i,127) = b(i,127) - lu(i,1116) * b(i,125) - b(i,128) = b(i,128) - lu(i,1117) * b(i,125) - b(i,129) = b(i,129) - lu(i,1118) * b(i,125) - b(i,130) = b(i,130) - lu(i,1119) * b(i,125) - b(i,131) = b(i,131) - lu(i,1120) * b(i,125) - b(i,132) = b(i,132) - lu(i,1121) * b(i,125) - b(i,133) = b(i,133) - lu(i,1122) * b(i,125) - b(i,134) = b(i,134) - lu(i,1123) * b(i,125) - b(i,135) = b(i,135) - lu(i,1124) * b(i,125) - b(i,127) = b(i,127) - lu(i,1151) * b(i,126) - b(i,128) = b(i,128) - lu(i,1152) * b(i,126) - b(i,129) = b(i,129) - lu(i,1153) * b(i,126) - b(i,130) = b(i,130) - lu(i,1154) * b(i,126) - b(i,131) = b(i,131) - lu(i,1155) * b(i,126) - b(i,132) = b(i,132) - lu(i,1156) * b(i,126) - b(i,133) = b(i,133) - lu(i,1157) * b(i,126) - b(i,134) = b(i,134) - lu(i,1158) * b(i,126) - b(i,135) = b(i,135) - lu(i,1159) * b(i,126) - b(i,128) = b(i,128) - lu(i,1172) * b(i,127) - b(i,129) = b(i,129) - lu(i,1173) * b(i,127) - b(i,130) = b(i,130) - lu(i,1174) * b(i,127) - b(i,131) = b(i,131) - lu(i,1175) * b(i,127) - b(i,132) = b(i,132) - lu(i,1176) * b(i,127) - b(i,133) = b(i,133) - lu(i,1177) * b(i,127) - b(i,134) = b(i,134) - lu(i,1178) * b(i,127) - b(i,135) = b(i,135) - lu(i,1179) * b(i,127) - b(i,129) = b(i,129) - lu(i,1197) * b(i,128) - b(i,130) = b(i,130) - lu(i,1198) * b(i,128) - b(i,131) = b(i,131) - lu(i,1199) * b(i,128) - b(i,132) = b(i,132) - lu(i,1200) * b(i,128) - b(i,133) = b(i,133) - lu(i,1201) * b(i,128) - b(i,134) = b(i,134) - lu(i,1202) * b(i,128) - b(i,135) = b(i,135) - lu(i,1203) * b(i,128) - b(i,130) = b(i,130) - lu(i,1253) * b(i,129) - b(i,131) = b(i,131) - lu(i,1254) * b(i,129) - b(i,132) = b(i,132) - lu(i,1255) * b(i,129) - b(i,133) = b(i,133) - lu(i,1256) * b(i,129) - b(i,134) = b(i,134) - lu(i,1257) * b(i,129) - b(i,135) = b(i,135) - lu(i,1258) * b(i,129) - b(i,131) = b(i,131) - lu(i,1291) * b(i,130) - b(i,132) = b(i,132) - lu(i,1292) * b(i,130) - b(i,133) = b(i,133) - lu(i,1293) * b(i,130) - b(i,134) = b(i,134) - lu(i,1294) * b(i,130) - b(i,135) = b(i,135) - lu(i,1295) * b(i,130) - b(i,132) = b(i,132) - lu(i,1390) * b(i,131) - b(i,133) = b(i,133) - lu(i,1391) * b(i,131) - b(i,134) = b(i,134) - lu(i,1392) * b(i,131) - b(i,135) = b(i,135) - lu(i,1393) * b(i,131) - b(i,133) = b(i,133) - lu(i,1435) * b(i,132) - b(i,134) = b(i,134) - lu(i,1436) * b(i,132) - b(i,135) = b(i,135) - lu(i,1437) * b(i,132) - b(i,134) = b(i,134) - lu(i,1458) * b(i,133) - b(i,135) = b(i,135) - lu(i,1459) * b(i,133) - b(i,135) = b(i,135) - lu(i,1485) * b(i,134) - enddo - END SUBROUTINE lu_slv04_vec - -#ifdef DOINLINE -!DIR$ ATTRIBUTES FORCEINLINE :: lu_slv05_vec -#else -!DIR$ ATTRIBUTES NOINLINE :: lu_slv05_vec -#endif - SUBROUTINE lu_slv05_vec(ncol,nb,nz,lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - integer :: ncol,nb,nz - REAL(KIND=r8), intent(in) :: lu(ncol,nz) - REAL(KIND=r8), intent(inout) :: b(ncol,nb) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - integer i - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... Solve U * x = y - !----------------------------------------------------------------------- -!DIR$ ASSUME_ALIGNED lu:64 -!DIR$ ASSUME_ALIGNED b:64 - - do i=1,ncol - b(i,135) = b(i,135) * lu(i,1509) - b(i,134) = b(i,134) - lu(i,1508) * b(i,135) - b(i,133) = b(i,133) - lu(i,1507) * b(i,135) - b(i,132) = b(i,132) - lu(i,1506) * b(i,135) - b(i,131) = b(i,131) - lu(i,1505) * b(i,135) - b(i,130) = b(i,130) - lu(i,1504) * b(i,135) - b(i,129) = b(i,129) - lu(i,1503) * b(i,135) - b(i,128) = b(i,128) - lu(i,1502) * b(i,135) - b(i,127) = b(i,127) - lu(i,1501) * b(i,135) - b(i,126) = b(i,126) - lu(i,1500) * b(i,135) - b(i,125) = b(i,125) - lu(i,1499) * b(i,135) - b(i,124) = b(i,124) - lu(i,1498) * b(i,135) - b(i,123) = b(i,123) - lu(i,1497) * b(i,135) - b(i,122) = b(i,122) - lu(i,1496) * b(i,135) - b(i,121) = b(i,121) - lu(i,1495) * b(i,135) - b(i,120) = b(i,120) - lu(i,1494) * b(i,135) - b(i,119) = b(i,119) - lu(i,1493) * b(i,135) - b(i,118) = b(i,118) - lu(i,1492) * b(i,135) - b(i,117) = b(i,117) - lu(i,1491) * b(i,135) - b(i,108) = b(i,108) - lu(i,1490) * b(i,135) - b(i,103) = b(i,103) - lu(i,1489) * b(i,135) - b(i,90) = b(i,90) - lu(i,1488) * b(i,135) - b(i,64) = b(i,64) - lu(i,1487) * b(i,135) - b(i,54) = b(i,54) - lu(i,1486) * b(i,135) - b(i,134) = b(i,134) * lu(i,1484) - b(i,133) = b(i,133) - lu(i,1483) * b(i,134) - b(i,132) = b(i,132) - lu(i,1482) * b(i,134) - b(i,131) = b(i,131) - lu(i,1481) * b(i,134) - b(i,130) = b(i,130) - lu(i,1480) * b(i,134) - b(i,129) = b(i,129) - lu(i,1479) * b(i,134) - b(i,128) = b(i,128) - lu(i,1478) * b(i,134) - b(i,127) = b(i,127) - lu(i,1477) * b(i,134) - b(i,126) = b(i,126) - lu(i,1476) * b(i,134) - b(i,125) = b(i,125) - lu(i,1475) * b(i,134) - b(i,124) = b(i,124) - lu(i,1474) * b(i,134) - b(i,123) = b(i,123) - lu(i,1473) * b(i,134) - b(i,122) = b(i,122) - lu(i,1472) * b(i,134) - b(i,121) = b(i,121) - lu(i,1471) * b(i,134) - b(i,120) = b(i,120) - lu(i,1470) * b(i,134) - b(i,119) = b(i,119) - lu(i,1469) * b(i,134) - b(i,118) = b(i,118) - lu(i,1468) * b(i,134) - b(i,117) = b(i,117) - lu(i,1467) * b(i,134) - b(i,116) = b(i,116) - lu(i,1466) * b(i,134) - b(i,108) = b(i,108) - lu(i,1465) * b(i,134) - b(i,99) = b(i,99) - lu(i,1464) * b(i,134) - b(i,88) = b(i,88) - lu(i,1463) * b(i,134) - b(i,36) = b(i,36) - lu(i,1462) * b(i,134) - b(i,34) = b(i,34) - lu(i,1461) * b(i,134) - b(i,26) = b(i,26) - lu(i,1460) * b(i,134) - b(i,133) = b(i,133) * lu(i,1457) - b(i,132) = b(i,132) - lu(i,1456) * b(i,133) - b(i,131) = b(i,131) - lu(i,1455) * b(i,133) - b(i,130) = b(i,130) - lu(i,1454) * b(i,133) - b(i,129) = b(i,129) - lu(i,1453) * b(i,133) - b(i,128) = b(i,128) - lu(i,1452) * b(i,133) - b(i,127) = b(i,127) - lu(i,1451) * b(i,133) - b(i,126) = b(i,126) - lu(i,1450) * b(i,133) - b(i,125) = b(i,125) - lu(i,1449) * b(i,133) - b(i,124) = b(i,124) - lu(i,1448) * b(i,133) - b(i,123) = b(i,123) - lu(i,1447) * b(i,133) - b(i,122) = b(i,122) - lu(i,1446) * b(i,133) - b(i,121) = b(i,121) - lu(i,1445) * b(i,133) - b(i,120) = b(i,120) - lu(i,1444) * b(i,133) - b(i,119) = b(i,119) - lu(i,1443) * b(i,133) - b(i,118) = b(i,118) - lu(i,1442) * b(i,133) - b(i,117) = b(i,117) - lu(i,1441) * b(i,133) - b(i,108) = b(i,108) - lu(i,1440) * b(i,133) - b(i,88) = b(i,88) - lu(i,1439) * b(i,133) - b(i,34) = b(i,34) - lu(i,1438) * b(i,133) - b(i,132) = b(i,132) * lu(i,1434) - b(i,131) = b(i,131) - lu(i,1433) * b(i,132) - b(i,130) = b(i,130) - lu(i,1432) * b(i,132) - b(i,129) = b(i,129) - lu(i,1431) * b(i,132) - b(i,128) = b(i,128) - lu(i,1430) * b(i,132) - b(i,127) = b(i,127) - lu(i,1429) * b(i,132) - b(i,126) = b(i,126) - lu(i,1428) * b(i,132) - b(i,125) = b(i,125) - lu(i,1427) * b(i,132) - b(i,124) = b(i,124) - lu(i,1426) * b(i,132) - b(i,123) = b(i,123) - lu(i,1425) * b(i,132) - b(i,122) = b(i,122) - lu(i,1424) * b(i,132) - b(i,121) = b(i,121) - lu(i,1423) * b(i,132) - b(i,120) = b(i,120) - lu(i,1422) * b(i,132) - b(i,119) = b(i,119) - lu(i,1421) * b(i,132) - b(i,118) = b(i,118) - lu(i,1420) * b(i,132) - b(i,116) = b(i,116) - lu(i,1419) * b(i,132) - b(i,115) = b(i,115) - lu(i,1418) * b(i,132) - b(i,114) = b(i,114) - lu(i,1417) * b(i,132) - b(i,113) = b(i,113) - lu(i,1416) * b(i,132) - b(i,112) = b(i,112) - lu(i,1415) * b(i,132) - b(i,111) = b(i,111) - lu(i,1414) * b(i,132) - b(i,110) = b(i,110) - lu(i,1413) * b(i,132) - b(i,109) = b(i,109) - lu(i,1412) * b(i,132) - b(i,107) = b(i,107) - lu(i,1411) * b(i,132) - b(i,106) = b(i,106) - lu(i,1410) * b(i,132) - b(i,105) = b(i,105) - lu(i,1409) * b(i,132) - b(i,104) = b(i,104) - lu(i,1408) * b(i,132) - b(i,103) = b(i,103) - lu(i,1407) * b(i,132) - b(i,102) = b(i,102) - lu(i,1406) * b(i,132) - b(i,101) = b(i,101) - lu(i,1405) * b(i,132) - b(i,99) = b(i,99) - lu(i,1404) * b(i,132) - b(i,98) = b(i,98) - lu(i,1403) * b(i,132) - b(i,97) = b(i,97) - lu(i,1402) * b(i,132) - b(i,95) = b(i,95) - lu(i,1401) * b(i,132) - b(i,94) = b(i,94) - lu(i,1400) * b(i,132) - b(i,81) = b(i,81) - lu(i,1399) * b(i,132) - b(i,73) = b(i,73) - lu(i,1398) * b(i,132) - b(i,49) = b(i,49) - lu(i,1397) * b(i,132) - b(i,47) = b(i,47) - lu(i,1396) * b(i,132) - b(i,40) = b(i,40) - lu(i,1395) * b(i,132) - b(i,39) = b(i,39) - lu(i,1394) * b(i,132) - b(i,131) = b(i,131) * lu(i,1389) - b(i,130) = b(i,130) - lu(i,1388) * b(i,131) - b(i,129) = b(i,129) - lu(i,1387) * b(i,131) - b(i,128) = b(i,128) - lu(i,1386) * b(i,131) - b(i,127) = b(i,127) - lu(i,1385) * b(i,131) - b(i,126) = b(i,126) - lu(i,1384) * b(i,131) - b(i,125) = b(i,125) - lu(i,1383) * b(i,131) - b(i,124) = b(i,124) - lu(i,1382) * b(i,131) - b(i,123) = b(i,123) - lu(i,1381) * b(i,131) - b(i,122) = b(i,122) - lu(i,1380) * b(i,131) - b(i,121) = b(i,121) - lu(i,1379) * b(i,131) - b(i,120) = b(i,120) - lu(i,1378) * b(i,131) - b(i,119) = b(i,119) - lu(i,1377) * b(i,131) - b(i,118) = b(i,118) - lu(i,1376) * b(i,131) - b(i,117) = b(i,117) - lu(i,1375) * b(i,131) - b(i,116) = b(i,116) - lu(i,1374) * b(i,131) - b(i,115) = b(i,115) - lu(i,1373) * b(i,131) - b(i,114) = b(i,114) - lu(i,1372) * b(i,131) - b(i,113) = b(i,113) - lu(i,1371) * b(i,131) - b(i,112) = b(i,112) - lu(i,1370) * b(i,131) - b(i,111) = b(i,111) - lu(i,1369) * b(i,131) - b(i,110) = b(i,110) - lu(i,1368) * b(i,131) - b(i,109) = b(i,109) - lu(i,1367) * b(i,131) - b(i,108) = b(i,108) - lu(i,1366) * b(i,131) - b(i,107) = b(i,107) - lu(i,1365) * b(i,131) - b(i,106) = b(i,106) - lu(i,1364) * b(i,131) - b(i,105) = b(i,105) - lu(i,1363) * b(i,131) - b(i,104) = b(i,104) - lu(i,1362) * b(i,131) - b(i,103) = b(i,103) - lu(i,1361) * b(i,131) - b(i,102) = b(i,102) - lu(i,1360) * b(i,131) - b(i,101) = b(i,101) - lu(i,1359) * b(i,131) - b(i,100) = b(i,100) - lu(i,1358) * b(i,131) - b(i,99) = b(i,99) - lu(i,1357) * b(i,131) - b(i,98) = b(i,98) - lu(i,1356) * b(i,131) - b(i,97) = b(i,97) - lu(i,1355) * b(i,131) - b(i,96) = b(i,96) - lu(i,1354) * b(i,131) - b(i,95) = b(i,95) - lu(i,1353) * b(i,131) - b(i,94) = b(i,94) - lu(i,1352) * b(i,131) - b(i,93) = b(i,93) - lu(i,1351) * b(i,131) - b(i,92) = b(i,92) - lu(i,1350) * b(i,131) - b(i,91) = b(i,91) - lu(i,1349) * b(i,131) - b(i,90) = b(i,90) - lu(i,1348) * b(i,131) - b(i,89) = b(i,89) - lu(i,1347) * b(i,131) - b(i,88) = b(i,88) - lu(i,1346) * b(i,131) - b(i,83) = b(i,83) - lu(i,1345) * b(i,131) - b(i,82) = b(i,82) - lu(i,1344) * b(i,131) - b(i,81) = b(i,81) - lu(i,1343) * b(i,131) - b(i,80) = b(i,80) - lu(i,1342) * b(i,131) - b(i,79) = b(i,79) - lu(i,1341) * b(i,131) - b(i,77) = b(i,77) - lu(i,1340) * b(i,131) - b(i,76) = b(i,76) - lu(i,1339) * b(i,131) - b(i,75) = b(i,75) - lu(i,1338) * b(i,131) - b(i,74) = b(i,74) - lu(i,1337) * b(i,131) - b(i,73) = b(i,73) - lu(i,1336) * b(i,131) - b(i,71) = b(i,71) - lu(i,1335) * b(i,131) - b(i,69) = b(i,69) - lu(i,1334) * b(i,131) - b(i,68) = b(i,68) - lu(i,1333) * b(i,131) - b(i,67) = b(i,67) - lu(i,1332) * b(i,131) - b(i,66) = b(i,66) - lu(i,1331) * b(i,131) - b(i,65) = b(i,65) - lu(i,1330) * b(i,131) - b(i,64) = b(i,64) - lu(i,1329) * b(i,131) - b(i,63) = b(i,63) - lu(i,1328) * b(i,131) - b(i,62) = b(i,62) - lu(i,1327) * b(i,131) - b(i,60) = b(i,60) - lu(i,1326) * b(i,131) - b(i,59) = b(i,59) - lu(i,1325) * b(i,131) - b(i,57) = b(i,57) - lu(i,1324) * b(i,131) - b(i,55) = b(i,55) - lu(i,1323) * b(i,131) - b(i,53) = b(i,53) - lu(i,1322) * b(i,131) - b(i,52) = b(i,52) - lu(i,1321) * b(i,131) - b(i,51) = b(i,51) - lu(i,1320) * b(i,131) - b(i,50) = b(i,50) - lu(i,1319) * b(i,131) - b(i,49) = b(i,49) - lu(i,1318) * b(i,131) - b(i,48) = b(i,48) - lu(i,1317) * b(i,131) - b(i,47) = b(i,47) - lu(i,1316) * b(i,131) - b(i,45) = b(i,45) - lu(i,1315) * b(i,131) - b(i,44) = b(i,44) - lu(i,1314) * b(i,131) - b(i,43) = b(i,43) - lu(i,1313) * b(i,131) - b(i,42) = b(i,42) - lu(i,1312) * b(i,131) - b(i,41) = b(i,41) - lu(i,1311) * b(i,131) - b(i,39) = b(i,39) - lu(i,1310) * b(i,131) - b(i,38) = b(i,38) - lu(i,1309) * b(i,131) - b(i,37) = b(i,37) - lu(i,1308) * b(i,131) - b(i,36) = b(i,36) - lu(i,1307) * b(i,131) - b(i,35) = b(i,35) - lu(i,1306) * b(i,131) - b(i,32) = b(i,32) - lu(i,1305) * b(i,131) - b(i,31) = b(i,31) - lu(i,1304) * b(i,131) - b(i,30) = b(i,30) - lu(i,1303) * b(i,131) - b(i,25) = b(i,25) - lu(i,1302) * b(i,131) - b(i,23) = b(i,23) - lu(i,1301) * b(i,131) - b(i,22) = b(i,22) - lu(i,1300) * b(i,131) - b(i,21) = b(i,21) - lu(i,1299) * b(i,131) - b(i,20) = b(i,20) - lu(i,1298) * b(i,131) - b(i,19) = b(i,19) - lu(i,1297) * b(i,131) - b(i,17) = b(i,17) - lu(i,1296) * b(i,131) - enddo - END SUBROUTINE lu_slv05_vec - -#ifdef DOINLINE -!DIR$ ATTRIBUTES FORCEINLINE :: lu_slv06_vec -#else -!DIR$ ATTRIBUTES NOINLINE :: lu_slv06_vec -#endif - SUBROUTINE lu_slv06_vec(ncol,nb,nz,lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - integer :: ncol,nb,nz - REAL(KIND=r8), intent(in) :: lu(ncol,nz) - REAL(KIND=r8), intent(inout) :: b(ncol,nb) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - integer :: i - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- -!DIR$ ASSUME_ALIGNED lu:64 -!DIR$ ASSUME_ALIGNED b:64 - do i=1,ncol - b(i,130) = b(i,130) * lu(i,1290) - b(i,129) = b(i,129) - lu(i,1289) * b(i,130) - b(i,128) = b(i,128) - lu(i,1288) * b(i,130) - b(i,127) = b(i,127) - lu(i,1287) * b(i,130) - b(i,126) = b(i,126) - lu(i,1286) * b(i,130) - b(i,125) = b(i,125) - lu(i,1285) * b(i,130) - b(i,124) = b(i,124) - lu(i,1284) * b(i,130) - b(i,123) = b(i,123) - lu(i,1283) * b(i,130) - b(i,122) = b(i,122) - lu(i,1282) * b(i,130) - b(i,121) = b(i,121) - lu(i,1281) * b(i,130) - b(i,120) = b(i,120) - lu(i,1280) * b(i,130) - b(i,119) = b(i,119) - lu(i,1279) * b(i,130) - b(i,118) = b(i,118) - lu(i,1278) * b(i,130) - b(i,117) = b(i,117) - lu(i,1277) * b(i,130) - b(i,116) = b(i,116) - lu(i,1276) * b(i,130) - b(i,115) = b(i,115) - lu(i,1275) * b(i,130) - b(i,114) = b(i,114) - lu(i,1274) * b(i,130) - b(i,109) = b(i,109) - lu(i,1273) * b(i,130) - b(i,105) = b(i,105) - lu(i,1272) * b(i,130) - b(i,103) = b(i,103) - lu(i,1271) * b(i,130) - b(i,100) = b(i,100) - lu(i,1270) * b(i,130) - b(i,99) = b(i,99) - lu(i,1269) * b(i,130) - b(i,92) = b(i,92) - lu(i,1268) * b(i,130) - b(i,84) = b(i,84) - lu(i,1267) * b(i,130) - b(i,81) = b(i,81) - lu(i,1266) * b(i,130) - b(i,71) = b(i,71) - lu(i,1265) * b(i,130) - b(i,70) = b(i,70) - lu(i,1264) * b(i,130) - b(i,66) = b(i,66) - lu(i,1263) * b(i,130) - b(i,60) = b(i,60) - lu(i,1262) * b(i,130) - b(i,57) = b(i,57) - lu(i,1261) * b(i,130) - b(i,40) = b(i,40) - lu(i,1260) * b(i,130) - b(i,31) = b(i,31) - lu(i,1259) * b(i,130) - b(i,129) = b(i,129) * lu(i,1252) - b(i,128) = b(i,128) - lu(i,1251) * b(i,129) - b(i,127) = b(i,127) - lu(i,1250) * b(i,129) - b(i,126) = b(i,126) - lu(i,1249) * b(i,129) - b(i,125) = b(i,125) - lu(i,1248) * b(i,129) - b(i,124) = b(i,124) - lu(i,1247) * b(i,129) - b(i,123) = b(i,123) - lu(i,1246) * b(i,129) - b(i,122) = b(i,122) - lu(i,1245) * b(i,129) - b(i,121) = b(i,121) - lu(i,1244) * b(i,129) - b(i,120) = b(i,120) - lu(i,1243) * b(i,129) - b(i,119) = b(i,119) - lu(i,1242) * b(i,129) - b(i,118) = b(i,118) - lu(i,1241) * b(i,129) - b(i,115) = b(i,115) - lu(i,1240) * b(i,129) - b(i,114) = b(i,114) - lu(i,1239) * b(i,129) - b(i,113) = b(i,113) - lu(i,1238) * b(i,129) - b(i,112) = b(i,112) - lu(i,1237) * b(i,129) - b(i,111) = b(i,111) - lu(i,1236) * b(i,129) - b(i,110) = b(i,110) - lu(i,1235) * b(i,129) - b(i,109) = b(i,109) - lu(i,1234) * b(i,129) - b(i,107) = b(i,107) - lu(i,1233) * b(i,129) - b(i,106) = b(i,106) - lu(i,1232) * b(i,129) - b(i,105) = b(i,105) - lu(i,1231) * b(i,129) - b(i,104) = b(i,104) - lu(i,1230) * b(i,129) - b(i,103) = b(i,103) - lu(i,1229) * b(i,129) - b(i,101) = b(i,101) - lu(i,1228) * b(i,129) - b(i,98) = b(i,98) - lu(i,1227) * b(i,129) - b(i,97) = b(i,97) - lu(i,1226) * b(i,129) - b(i,96) = b(i,96) - lu(i,1225) * b(i,129) - b(i,95) = b(i,95) - lu(i,1224) * b(i,129) - b(i,92) = b(i,92) - lu(i,1223) * b(i,129) - b(i,91) = b(i,91) - lu(i,1222) * b(i,129) - b(i,89) = b(i,89) - lu(i,1221) * b(i,129) - b(i,87) = b(i,87) - lu(i,1220) * b(i,129) - b(i,86) = b(i,86) - lu(i,1219) * b(i,129) - b(i,85) = b(i,85) - lu(i,1218) * b(i,129) - b(i,83) = b(i,83) - lu(i,1217) * b(i,129) - b(i,81) = b(i,81) - lu(i,1216) * b(i,129) - b(i,80) = b(i,80) - lu(i,1215) * b(i,129) - b(i,79) = b(i,79) - lu(i,1214) * b(i,129) - b(i,77) = b(i,77) - lu(i,1213) * b(i,129) - b(i,66) = b(i,66) - lu(i,1212) * b(i,129) - b(i,65) = b(i,65) - lu(i,1211) * b(i,129) - b(i,64) = b(i,64) - lu(i,1210) * b(i,129) - b(i,56) = b(i,56) - lu(i,1209) * b(i,129) - b(i,55) = b(i,55) - lu(i,1208) * b(i,129) - b(i,54) = b(i,54) - lu(i,1207) * b(i,129) - b(i,49) = b(i,49) - lu(i,1206) * b(i,129) - b(i,47) = b(i,47) - lu(i,1205) * b(i,129) - b(i,41) = b(i,41) - lu(i,1204) * b(i,129) - b(i,128) = b(i,128) * lu(i,1196) - b(i,127) = b(i,127) - lu(i,1195) * b(i,128) - b(i,126) = b(i,126) - lu(i,1194) * b(i,128) - b(i,125) = b(i,125) - lu(i,1193) * b(i,128) - b(i,124) = b(i,124) - lu(i,1192) * b(i,128) - b(i,123) = b(i,123) - lu(i,1191) * b(i,128) - b(i,122) = b(i,122) - lu(i,1190) * b(i,128) - b(i,121) = b(i,121) - lu(i,1189) * b(i,128) - b(i,120) = b(i,120) - lu(i,1188) * b(i,128) - b(i,118) = b(i,118) - lu(i,1187) * b(i,128) - b(i,117) = b(i,117) - lu(i,1186) * b(i,128) - b(i,116) = b(i,116) - lu(i,1185) * b(i,128) - b(i,99) = b(i,99) - lu(i,1184) * b(i,128) - b(i,84) = b(i,84) - lu(i,1183) * b(i,128) - b(i,70) = b(i,70) - lu(i,1182) * b(i,128) - b(i,46) = b(i,46) - lu(i,1181) * b(i,128) - b(i,33) = b(i,33) - lu(i,1180) * b(i,128) - b(i,127) = b(i,127) * lu(i,1171) - b(i,126) = b(i,126) - lu(i,1170) * b(i,127) - b(i,125) = b(i,125) - lu(i,1169) * b(i,127) - b(i,124) = b(i,124) - lu(i,1168) * b(i,127) - b(i,123) = b(i,123) - lu(i,1167) * b(i,127) - b(i,122) = b(i,122) - lu(i,1166) * b(i,127) - b(i,121) = b(i,121) - lu(i,1165) * b(i,127) - b(i,120) = b(i,120) - lu(i,1164) * b(i,127) - b(i,119) = b(i,119) - lu(i,1163) * b(i,127) - b(i,118) = b(i,118) - lu(i,1162) * b(i,127) - b(i,117) = b(i,117) - lu(i,1161) * b(i,127) - b(i,108) = b(i,108) - lu(i,1160) * b(i,127) - b(i,126) = b(i,126) * lu(i,1150) - b(i,125) = b(i,125) - lu(i,1149) * b(i,126) - b(i,124) = b(i,124) - lu(i,1148) * b(i,126) - b(i,123) = b(i,123) - lu(i,1147) * b(i,126) - b(i,122) = b(i,122) - lu(i,1146) * b(i,126) - b(i,121) = b(i,121) - lu(i,1145) * b(i,126) - b(i,120) = b(i,120) - lu(i,1144) * b(i,126) - b(i,119) = b(i,119) - lu(i,1143) * b(i,126) - b(i,118) = b(i,118) - lu(i,1142) * b(i,126) - b(i,117) = b(i,117) - lu(i,1141) * b(i,126) - b(i,115) = b(i,115) - lu(i,1140) * b(i,126) - b(i,108) = b(i,108) - lu(i,1139) * b(i,126) - b(i,104) = b(i,104) - lu(i,1138) * b(i,126) - b(i,103) = b(i,103) - lu(i,1137) * b(i,126) - b(i,100) = b(i,100) - lu(i,1136) * b(i,126) - b(i,95) = b(i,95) - lu(i,1135) * b(i,126) - b(i,93) = b(i,93) - lu(i,1134) * b(i,126) - b(i,91) = b(i,91) - lu(i,1133) * b(i,126) - b(i,83) = b(i,83) - lu(i,1132) * b(i,126) - b(i,81) = b(i,81) - lu(i,1131) * b(i,126) - b(i,74) = b(i,74) - lu(i,1130) * b(i,126) - b(i,64) = b(i,64) - lu(i,1129) * b(i,126) - b(i,63) = b(i,63) - lu(i,1128) * b(i,126) - b(i,38) = b(i,38) - lu(i,1127) * b(i,126) - b(i,37) = b(i,37) - lu(i,1126) * b(i,126) - b(i,29) = b(i,29) - lu(i,1125) * b(i,126) - b(i,125) = b(i,125) * lu(i,1114) - b(i,124) = b(i,124) - lu(i,1113) * b(i,125) - b(i,123) = b(i,123) - lu(i,1112) * b(i,125) - b(i,122) = b(i,122) - lu(i,1111) * b(i,125) - b(i,121) = b(i,121) - lu(i,1110) * b(i,125) - b(i,120) = b(i,120) - lu(i,1109) * b(i,125) - b(i,119) = b(i,119) - lu(i,1108) * b(i,125) - b(i,118) = b(i,118) - lu(i,1107) * b(i,125) - b(i,117) = b(i,117) - lu(i,1106) * b(i,125) - b(i,115) = b(i,115) - lu(i,1105) * b(i,125) - b(i,114) = b(i,114) - lu(i,1104) * b(i,125) - b(i,113) = b(i,113) - lu(i,1103) * b(i,125) - b(i,112) = b(i,112) - lu(i,1102) * b(i,125) - b(i,111) = b(i,111) - lu(i,1101) * b(i,125) - b(i,110) = b(i,110) - lu(i,1100) * b(i,125) - b(i,109) = b(i,109) - lu(i,1099) * b(i,125) - b(i,108) = b(i,108) - lu(i,1098) * b(i,125) - b(i,107) = b(i,107) - lu(i,1097) * b(i,125) - b(i,106) = b(i,106) - lu(i,1096) * b(i,125) - b(i,105) = b(i,105) - lu(i,1095) * b(i,125) - b(i,104) = b(i,104) - lu(i,1094) * b(i,125) - b(i,103) = b(i,103) - lu(i,1093) * b(i,125) - b(i,101) = b(i,101) - lu(i,1092) * b(i,125) - b(i,98) = b(i,98) - lu(i,1091) * b(i,125) - b(i,97) = b(i,97) - lu(i,1090) * b(i,125) - b(i,96) = b(i,96) - lu(i,1089) * b(i,125) - b(i,95) = b(i,95) - lu(i,1088) * b(i,125) - b(i,93) = b(i,93) - lu(i,1087) * b(i,125) - b(i,91) = b(i,91) - lu(i,1086) * b(i,125) - b(i,90) = b(i,90) - lu(i,1085) * b(i,125) - b(i,89) = b(i,89) - lu(i,1084) * b(i,125) - b(i,84) = b(i,84) - lu(i,1083) * b(i,125) - b(i,83) = b(i,83) - lu(i,1082) * b(i,125) - b(i,81) = b(i,81) - lu(i,1081) * b(i,125) - b(i,80) = b(i,80) - lu(i,1080) * b(i,125) - b(i,79) = b(i,79) - lu(i,1079) * b(i,125) - b(i,77) = b(i,77) - lu(i,1078) * b(i,125) - b(i,76) = b(i,76) - lu(i,1077) * b(i,125) - b(i,75) = b(i,75) - lu(i,1076) * b(i,125) - b(i,74) = b(i,74) - lu(i,1075) * b(i,125) - b(i,69) = b(i,69) - lu(i,1074) * b(i,125) - b(i,67) = b(i,67) - lu(i,1073) * b(i,125) - b(i,66) = b(i,66) - lu(i,1072) * b(i,125) - b(i,65) = b(i,65) - lu(i,1071) * b(i,125) - b(i,64) = b(i,64) - lu(i,1070) * b(i,125) - b(i,62) = b(i,62) - lu(i,1069) * b(i,125) - b(i,60) = b(i,60) - lu(i,1068) * b(i,125) - b(i,59) = b(i,59) - lu(i,1067) * b(i,125) - b(i,56) = b(i,56) - lu(i,1066) * b(i,125) - b(i,54) = b(i,54) - lu(i,1065) * b(i,125) - b(i,53) = b(i,53) - lu(i,1064) * b(i,125) - b(i,52) = b(i,52) - lu(i,1063) * b(i,125) - b(i,51) = b(i,51) - lu(i,1062) * b(i,125) - b(i,50) = b(i,50) - lu(i,1061) * b(i,125) - b(i,45) = b(i,45) - lu(i,1060) * b(i,125) - b(i,44) = b(i,44) - lu(i,1059) * b(i,125) - b(i,43) = b(i,43) - lu(i,1058) * b(i,125) - b(i,42) = b(i,42) - lu(i,1057) * b(i,125) - b(i,24) = b(i,24) - lu(i,1056) * b(i,125) - b(i,124) = b(i,124) * lu(i,1044) - b(i,123) = b(i,123) - lu(i,1043) * b(i,124) - b(i,122) = b(i,122) - lu(i,1042) * b(i,124) - b(i,121) = b(i,121) - lu(i,1041) * b(i,124) - b(i,120) = b(i,120) - lu(i,1040) * b(i,124) - b(i,119) = b(i,119) - lu(i,1039) * b(i,124) - b(i,118) = b(i,118) - lu(i,1038) * b(i,124) - b(i,117) = b(i,117) - lu(i,1037) * b(i,124) - b(i,116) = b(i,116) - lu(i,1036) * b(i,124) - b(i,100) = b(i,100) - lu(i,1035) * b(i,124) - b(i,99) = b(i,99) - lu(i,1034) * b(i,124) - b(i,93) = b(i,93) - lu(i,1033) * b(i,124) - b(i,46) = b(i,46) - lu(i,1032) * b(i,124) - b(i,33) = b(i,33) - lu(i,1031) * b(i,124) - b(i,29) = b(i,29) - lu(i,1030) * b(i,124) - b(i,18) = b(i,18) - lu(i,1029) * b(i,124) - enddo - END SUBROUTINE lu_slv06_vec - -#ifdef DOINLINE -!DIR$ ATTRIBUTES FORCEINLINE :: lu_slv07_vec -#else -!DIR$ ATTRIBUTES NOINLINE :: lu_slv07_vec -#endif - SUBROUTINE lu_slv07_vec(ncol,nb,nz,lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - integer :: ncol,nb,nz - REAL(KIND=r8), intent(in) :: lu(ncol,nz) - REAL(KIND=r8), intent(inout) :: b(ncol,nb) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - integer :: i - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- -!DIR$ ASSUME_ALIGNED lu:64 -!DIR$ ASSUME_ALIGNED b:64 - do i=1,ncol - b(i,123) = b(i,123) * lu(i,1016) - b(i,122) = b(i,122) - lu(i,1015) * b(i,123) - b(i,121) = b(i,121) - lu(i,1014) * b(i,123) - b(i,120) = b(i,120) - lu(i,1013) * b(i,123) - b(i,119) = b(i,119) - lu(i,1012) * b(i,123) - b(i,118) = b(i,118) - lu(i,1011) * b(i,123) - b(i,116) = b(i,116) - lu(i,1010) * b(i,123) - b(i,115) = b(i,115) - lu(i,1009) * b(i,123) - b(i,114) = b(i,114) - lu(i,1008) * b(i,123) - b(i,113) = b(i,113) - lu(i,1007) * b(i,123) - b(i,112) = b(i,112) - lu(i,1006) * b(i,123) - b(i,111) = b(i,111) - lu(i,1005) * b(i,123) - b(i,110) = b(i,110) - lu(i,1004) * b(i,123) - b(i,109) = b(i,109) - lu(i,1003) * b(i,123) - b(i,107) = b(i,107) - lu(i,1002) * b(i,123) - b(i,106) = b(i,106) - lu(i,1001) * b(i,123) - b(i,105) = b(i,105) - lu(i,1000) * b(i,123) - b(i,104) = b(i,104) - lu(i,999) * b(i,123) - b(i,103) = b(i,103) - lu(i,998) * b(i,123) - b(i,102) = b(i,102) - lu(i,997) * b(i,123) - b(i,101) = b(i,101) - lu(i,996) * b(i,123) - b(i,99) = b(i,99) - lu(i,995) * b(i,123) - b(i,98) = b(i,98) - lu(i,994) * b(i,123) - b(i,95) = b(i,95) - lu(i,993) * b(i,123) - b(i,94) = b(i,94) - lu(i,992) * b(i,123) - b(i,83) = b(i,83) - lu(i,991) * b(i,123) - b(i,82) = b(i,82) - lu(i,990) * b(i,123) - b(i,75) = b(i,75) - lu(i,989) * b(i,123) - b(i,73) = b(i,73) - lu(i,988) * b(i,123) - b(i,64) = b(i,64) - lu(i,987) * b(i,123) - b(i,63) = b(i,63) - lu(i,986) * b(i,123) - b(i,28) = b(i,28) - lu(i,985) * b(i,123) - b(i,27) = b(i,27) - lu(i,984) * b(i,123) - b(i,122) = b(i,122) * lu(i,970) - b(i,121) = b(i,121) - lu(i,969) * b(i,122) - b(i,120) = b(i,120) - lu(i,968) * b(i,122) - b(i,119) = b(i,119) - lu(i,967) * b(i,122) - b(i,118) = b(i,118) - lu(i,966) * b(i,122) - b(i,117) = b(i,117) - lu(i,965) * b(i,122) - b(i,108) = b(i,108) - lu(i,964) * b(i,122) - b(i,90) = b(i,90) - lu(i,963) * b(i,122) - b(i,88) = b(i,88) - lu(i,962) * b(i,122) - b(i,32) = b(i,32) - lu(i,961) * b(i,122) - b(i,30) = b(i,30) - lu(i,960) * b(i,122) - b(i,28) = b(i,28) - lu(i,959) * b(i,122) - b(i,25) = b(i,25) - lu(i,958) * b(i,122) - b(i,121) = b(i,121) * lu(i,943) - b(i,120) = b(i,120) - lu(i,942) * b(i,121) - b(i,119) = b(i,119) - lu(i,941) * b(i,121) - b(i,118) = b(i,118) - lu(i,940) * b(i,121) - b(i,117) = b(i,117) - lu(i,939) * b(i,121) - b(i,116) = b(i,116) - lu(i,938) * b(i,121) - b(i,108) = b(i,108) - lu(i,937) * b(i,121) - b(i,103) = b(i,103) - lu(i,936) * b(i,121) - b(i,100) = b(i,100) - lu(i,935) * b(i,121) - b(i,99) = b(i,99) - lu(i,934) * b(i,121) - b(i,93) = b(i,93) - lu(i,933) * b(i,121) - b(i,92) = b(i,92) - lu(i,932) * b(i,121) - b(i,90) = b(i,90) - lu(i,931) * b(i,121) - b(i,87) = b(i,87) - lu(i,930) * b(i,121) - b(i,86) = b(i,86) - lu(i,929) * b(i,121) - b(i,85) = b(i,85) - lu(i,928) * b(i,121) - b(i,84) = b(i,84) - lu(i,927) * b(i,121) - b(i,82) = b(i,82) - lu(i,926) * b(i,121) - b(i,78) = b(i,78) - lu(i,925) * b(i,121) - b(i,74) = b(i,74) - lu(i,924) * b(i,121) - b(i,72) = b(i,72) - lu(i,923) * b(i,121) - b(i,70) = b(i,70) - lu(i,922) * b(i,121) - b(i,61) = b(i,61) - lu(i,921) * b(i,121) - b(i,58) = b(i,58) - lu(i,920) * b(i,121) - b(i,48) = b(i,48) - lu(i,919) * b(i,121) - b(i,28) = b(i,28) - lu(i,918) * b(i,121) - b(i,27) = b(i,27) - lu(i,917) * b(i,121) - b(i,120) = b(i,120) * lu(i,903) - b(i,118) = b(i,118) - lu(i,902) * b(i,120) - b(i,116) = b(i,116) - lu(i,901) * b(i,120) - b(i,103) = b(i,103) - lu(i,900) * b(i,120) - b(i,99) = b(i,99) - lu(i,899) * b(i,120) - b(i,95) = b(i,95) - lu(i,898) * b(i,120) - b(i,92) = b(i,92) - lu(i,897) * b(i,120) - b(i,87) = b(i,87) - lu(i,896) * b(i,120) - b(i,86) = b(i,86) - lu(i,895) * b(i,120) - b(i,85) = b(i,85) - lu(i,894) * b(i,120) - b(i,82) = b(i,82) - lu(i,893) * b(i,120) - b(i,78) = b(i,78) - lu(i,892) * b(i,120) - b(i,72) = b(i,72) - lu(i,891) * b(i,120) - b(i,61) = b(i,61) - lu(i,890) * b(i,120) - b(i,58) = b(i,58) - lu(i,889) * b(i,120) - b(i,56) = b(i,56) - lu(i,888) * b(i,120) - b(i,28) = b(i,28) - lu(i,887) * b(i,120) - b(i,27) = b(i,27) - lu(i,886) * b(i,120) - b(i,119) = b(i,119) * lu(i,872) - b(i,115) = b(i,115) - lu(i,871) * b(i,119) - b(i,114) = b(i,114) - lu(i,870) * b(i,119) - b(i,113) = b(i,113) - lu(i,869) * b(i,119) - b(i,112) = b(i,112) - lu(i,868) * b(i,119) - b(i,111) = b(i,111) - lu(i,867) * b(i,119) - b(i,110) = b(i,110) - lu(i,866) * b(i,119) - b(i,109) = b(i,109) - lu(i,865) * b(i,119) - b(i,107) = b(i,107) - lu(i,864) * b(i,119) - b(i,106) = b(i,106) - lu(i,863) * b(i,119) - b(i,105) = b(i,105) - lu(i,862) * b(i,119) - b(i,104) = b(i,104) - lu(i,861) * b(i,119) - b(i,103) = b(i,103) - lu(i,860) * b(i,119) - b(i,96) = b(i,96) - lu(i,859) * b(i,119) - b(i,95) = b(i,95) - lu(i,858) * b(i,119) - b(i,91) = b(i,91) - lu(i,857) * b(i,119) - b(i,81) = b(i,81) - lu(i,856) * b(i,119) - b(i,80) = b(i,80) - lu(i,855) * b(i,119) - b(i,75) = b(i,75) - lu(i,854) * b(i,119) - b(i,68) = b(i,68) - lu(i,853) * b(i,119) - b(i,50) = b(i,50) - lu(i,852) * b(i,119) - b(i,47) = b(i,47) - lu(i,851) * b(i,119) - b(i,35) = b(i,35) - lu(i,850) * b(i,119) - b(i,118) = b(i,118) * lu(i,839) - b(i,103) = b(i,103) - lu(i,838) * b(i,118) - b(i,90) = b(i,90) - lu(i,837) * b(i,118) - b(i,117) = b(i,117) * lu(i,824) - b(i,100) = b(i,100) - lu(i,823) * b(i,117) - b(i,93) = b(i,93) - lu(i,822) * b(i,117) - b(i,84) = b(i,84) - lu(i,821) * b(i,117) - b(i,33) = b(i,33) - lu(i,820) * b(i,117) - b(i,29) = b(i,29) - lu(i,819) * b(i,117) - b(i,116) = b(i,116) * lu(i,805) - b(i,99) = b(i,99) - lu(i,804) * b(i,116) - b(i,82) = b(i,82) - lu(i,803) * b(i,116) - b(i,46) = b(i,46) - lu(i,802) * b(i,116) - b(i,115) = b(i,115) * lu(i,789) - b(i,114) = b(i,114) - lu(i,788) * b(i,115) - b(i,113) = b(i,113) - lu(i,787) * b(i,115) - b(i,112) = b(i,112) - lu(i,786) * b(i,115) - b(i,111) = b(i,111) - lu(i,785) * b(i,115) - b(i,110) = b(i,110) - lu(i,784) * b(i,115) - b(i,109) = b(i,109) - lu(i,783) * b(i,115) - b(i,107) = b(i,107) - lu(i,782) * b(i,115) - b(i,105) = b(i,105) - lu(i,781) * b(i,115) - b(i,103) = b(i,103) - lu(i,780) * b(i,115) - b(i,95) = b(i,95) - lu(i,779) * b(i,115) - b(i,81) = b(i,81) - lu(i,778) * b(i,115) - b(i,75) = b(i,75) - lu(i,777) * b(i,115) - b(i,62) = b(i,62) - lu(i,776) * b(i,115) - b(i,57) = b(i,57) - lu(i,775) * b(i,115) - b(i,47) = b(i,47) - lu(i,774) * b(i,115) - b(i,114) = b(i,114) * lu(i,760) - b(i,109) = b(i,109) - lu(i,759) * b(i,114) - b(i,105) = b(i,105) - lu(i,758) * b(i,114) - b(i,75) = b(i,75) - lu(i,757) * b(i,114) - b(i,71) = b(i,71) - lu(i,756) * b(i,114) - b(i,62) = b(i,62) - lu(i,755) * b(i,114) - b(i,113) = b(i,113) * lu(i,740) - b(i,112) = b(i,112) - lu(i,739) * b(i,113) - b(i,109) = b(i,109) - lu(i,738) * b(i,113) - b(i,105) = b(i,105) - lu(i,737) * b(i,113) - b(i,104) = b(i,104) - lu(i,736) * b(i,113) - b(i,103) = b(i,103) - lu(i,735) * b(i,113) - b(i,102) = b(i,102) - lu(i,734) * b(i,113) - b(i,112) = b(i,112) * lu(i,721) - b(i,110) = b(i,110) - lu(i,720) * b(i,112) - b(i,109) = b(i,109) - lu(i,719) * b(i,112) - b(i,105) = b(i,105) - lu(i,718) * b(i,112) - b(i,103) = b(i,103) - lu(i,717) * b(i,112) - b(i,97) = b(i,97) - lu(i,716) * b(i,112) - b(i,95) = b(i,95) - lu(i,715) * b(i,112) - b(i,68) = b(i,68) - lu(i,714) * b(i,112) - b(i,43) = b(i,43) - lu(i,713) * b(i,112) - b(i,111) = b(i,111) * lu(i,697) - b(i,110) = b(i,110) - lu(i,696) * b(i,111) - b(i,109) = b(i,109) - lu(i,695) * b(i,111) - b(i,107) = b(i,107) - lu(i,694) * b(i,111) - b(i,103) = b(i,103) - lu(i,693) * b(i,111) - b(i,97) = b(i,97) - lu(i,692) * b(i,111) - b(i,69) = b(i,69) - lu(i,691) * b(i,111) - b(i,68) = b(i,68) - lu(i,690) * b(i,111) - b(i,47) = b(i,47) - lu(i,689) * b(i,111) - b(i,110) = b(i,110) * lu(i,677) - b(i,109) = b(i,109) - lu(i,676) * b(i,110) - b(i,105) = b(i,105) - lu(i,675) * b(i,110) - b(i,103) = b(i,103) - lu(i,674) * b(i,110) - b(i,95) = b(i,95) - lu(i,673) * b(i,110) - b(i,81) = b(i,81) - lu(i,672) * b(i,110) - b(i,68) = b(i,68) - lu(i,671) * b(i,110) - b(i,45) = b(i,45) - lu(i,670) * b(i,110) - b(i,109) = b(i,109) * lu(i,662) - b(i,103) = b(i,103) - lu(i,661) * b(i,109) - b(i,108) = b(i,108) * lu(i,650) - b(i,88) = b(i,88) - lu(i,649) * b(i,108) - b(i,34) = b(i,34) - lu(i,648) * b(i,108) - b(i,107) = b(i,107) * lu(i,637) - b(i,103) = b(i,103) - lu(i,636) * b(i,107) - b(i,106) = b(i,106) * lu(i,625) - b(i,105) = b(i,105) - lu(i,624) * b(i,106) - b(i,68) = b(i,68) - lu(i,623) * b(i,106) - b(i,53) = b(i,53) - lu(i,622) * b(i,106) - b(i,105) = b(i,105) * lu(i,616) - b(i,104) = b(i,104) * lu(i,607) - b(i,103) = b(i,103) - lu(i,606) * b(i,104) - b(i,103) = b(i,103) * lu(i,602) - b(i,102) = b(i,102) * lu(i,587) - b(i,89) = b(i,89) - lu(i,586) * b(i,102) - b(i,75) = b(i,75) - lu(i,585) * b(i,102) - b(i,49) = b(i,49) - lu(i,584) * b(i,102) - enddo - END SUBROUTINE lu_slv07_vec - -#ifdef DOINLINE -!DIR$ ATTRIBUTES FORCEINLINE :: lu_slv08_vec -#else -!DIR$ ATTRIBUTES NOINLINE :: lu_slv08_vec -#endif - SUBROUTINE lu_slv08_vec(ncol,nb,nz,lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - integer :: ncol,nb,nz - REAL(KIND=r8), intent(in) :: lu(ncol,nz) - REAL(KIND=r8), intent(inout) :: b(ncol,nb) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - integer :: i - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- -!DIR$ ASSUME_ALIGNED lu:64 -!DIR$ ASSUME_ALIGNED b:64 - do i=1,ncol - b(i,101) = b(i,101) * lu(i,572) - b(i,97) = b(i,97) - lu(i,571) * b(i,101) - b(i,45) = b(i,45) - lu(i,570) * b(i,101) - b(i,100) = b(i,100) * lu(i,560) - b(i,93) = b(i,93) - lu(i,559) * b(i,100) - b(i,29) = b(i,29) - lu(i,558) * b(i,100) - b(i,99) = b(i,99) * lu(i,552) - b(i,36) = b(i,36) - lu(i,551) * b(i,99) - b(i,98) = b(i,98) * lu(i,540) - b(i,80) = b(i,80) - lu(i,539) * b(i,98) - b(i,59) = b(i,59) - lu(i,538) * b(i,98) - b(i,97) = b(i,97) * lu(i,530) - b(i,47) = b(i,47) - lu(i,529) * b(i,97) - b(i,96) = b(i,96) * lu(i,517) - b(i,80) = b(i,80) - lu(i,516) * b(i,96) - b(i,52) = b(i,52) - lu(i,515) * b(i,96) - b(i,95) = b(i,95) * lu(i,510) - b(i,81) = b(i,81) - lu(i,509) * b(i,95) - b(i,94) = b(i,94) * lu(i,494) - b(i,75) = b(i,75) - lu(i,493) * b(i,94) - b(i,93) = b(i,93) * lu(i,486) - b(i,29) = b(i,29) - lu(i,485) * b(i,93) - b(i,92) = b(i,92) * lu(i,476) - b(i,87) = b(i,87) - lu(i,475) * b(i,92) - b(i,86) = b(i,86) - lu(i,474) * b(i,92) - b(i,85) = b(i,85) - lu(i,473) * b(i,92) - b(i,72) = b(i,72) - lu(i,472) * b(i,92) - b(i,58) = b(i,58) - lu(i,471) * b(i,92) - b(i,91) = b(i,91) * lu(i,462) - b(i,68) = b(i,68) - lu(i,461) * b(i,91) - b(i,44) = b(i,44) - lu(i,460) * b(i,91) - b(i,35) = b(i,35) - lu(i,459) * b(i,91) - b(i,90) = b(i,90) * lu(i,452) - b(i,89) = b(i,89) * lu(i,442) - b(i,67) = b(i,67) - lu(i,441) * b(i,89) - b(i,88) = b(i,88) * lu(i,433) - b(i,34) = b(i,34) - lu(i,432) * b(i,88) - b(i,87) = b(i,87) * lu(i,425) - b(i,86) = b(i,86) - lu(i,424) * b(i,87) - b(i,85) = b(i,85) - lu(i,423) * b(i,87) - b(i,78) = b(i,78) - lu(i,422) * b(i,87) - b(i,61) = b(i,61) - lu(i,421) * b(i,87) - b(i,86) = b(i,86) * lu(i,414) - b(i,61) = b(i,61) - lu(i,413) * b(i,86) - b(i,85) = b(i,85) * lu(i,405) - b(i,84) = b(i,84) * lu(i,397) - b(i,33) = b(i,33) - lu(i,396) * b(i,84) - b(i,83) = b(i,83) * lu(i,388) - b(i,56) = b(i,56) - lu(i,387) * b(i,83) - b(i,24) = b(i,24) - lu(i,386) * b(i,83) - b(i,82) = b(i,82) * lu(i,379) - b(i,81) = b(i,81) * lu(i,375) - b(i,80) = b(i,80) * lu(i,369) - b(i,79) = b(i,79) * lu(i,358) - b(i,77) = b(i,77) - lu(i,357) * b(i,79) - b(i,76) = b(i,76) - lu(i,356) * b(i,79) - b(i,55) = b(i,55) - lu(i,355) * b(i,79) - b(i,49) = b(i,49) - lu(i,354) * b(i,79) - b(i,78) = b(i,78) * lu(i,344) - b(i,72) = b(i,72) - lu(i,343) * b(i,78) - b(i,61) = b(i,61) - lu(i,342) * b(i,78) - b(i,77) = b(i,77) * lu(i,335) - b(i,42) = b(i,42) - lu(i,334) * b(i,77) - b(i,76) = b(i,76) * lu(i,324) - b(i,55) = b(i,55) - lu(i,323) * b(i,76) - b(i,75) = b(i,75) * lu(i,319) - b(i,74) = b(i,74) * lu(i,312) - b(i,73) = b(i,73) * lu(i,303) - b(i,72) = b(i,72) * lu(i,296) - b(i,71) = b(i,71) * lu(i,288) - b(i,70) = b(i,70) * lu(i,280) - b(i,69) = b(i,69) * lu(i,272) - b(i,68) = b(i,68) * lu(i,268) - b(i,67) = b(i,67) * lu(i,260) - b(i,66) = b(i,66) * lu(i,254) - b(i,65) = b(i,65) * lu(i,246) - b(i,51) = b(i,51) - lu(i,245) * b(i,65) - b(i,64) = b(i,64) * lu(i,241) - b(i,63) = b(i,63) * lu(i,233) - b(i,62) = b(i,62) * lu(i,227) - b(i,61) = b(i,61) * lu(i,222) - b(i,60) = b(i,60) * lu(i,215) - b(i,59) = b(i,59) * lu(i,208) - b(i,58) = b(i,58) * lu(i,201) - b(i,57) = b(i,57) * lu(i,194) - b(i,56) = b(i,56) * lu(i,189) - b(i,55) = b(i,55) * lu(i,184) - b(i,54) = b(i,54) * lu(i,178) - b(i,53) = b(i,53) * lu(i,172) - b(i,52) = b(i,52) * lu(i,166) - b(i,51) = b(i,51) * lu(i,160) - b(i,50) = b(i,50) * lu(i,154) - b(i,49) = b(i,49) * lu(i,150) - b(i,48) = b(i,48) * lu(i,142) - b(i,47) = b(i,47) * lu(i,139) - b(i,46) = b(i,46) * lu(i,134) - b(i,45) = b(i,45) * lu(i,130) - b(i,44) = b(i,44) * lu(i,125) - b(i,43) = b(i,43) * lu(i,120) - b(i,42) = b(i,42) * lu(i,115) - b(i,41) = b(i,41) * lu(i,108) - b(i,40) = b(i,40) * lu(i,102) - b(i,39) = b(i,39) * lu(i,96) - b(i,38) = b(i,38) * lu(i,90) - b(i,37) = b(i,37) * lu(i,84) - b(i,36) = b(i,36) * lu(i,80) - b(i,26) = b(i,26) - lu(i,79) * b(i,36) - b(i,35) = b(i,35) * lu(i,75) - b(i,34) = b(i,34) * lu(i,72) - b(i,33) = b(i,33) * lu(i,69) - b(i,32) = b(i,32) * lu(i,65) - b(i,31) = b(i,31) * lu(i,61) - b(i,30) = b(i,30) * lu(i,57) - b(i,29) = b(i,29) * lu(i,55) - b(i,28) = b(i,28) * lu(i,53) - b(i,27) = b(i,27) - lu(i,52) * b(i,28) - b(i,27) = b(i,27) * lu(i,50) - b(i,26) = b(i,26) * lu(i,47) - b(i,25) = b(i,25) * lu(i,44) - b(i,24) = b(i,24) * lu(i,41) - b(i,23) = b(i,23) * lu(i,38) - b(i,22) = b(i,22) * lu(i,33) - b(i,21) = b(i,21) * lu(i,29) - b(i,20) = b(i,20) * lu(i,26) - b(i,19) = b(i,19) * lu(i,23) - b(i,18) = b(i,18) * lu(i,20) - b(i,17) = b(i,17) * lu(i,17) - b(i,16) = b(i,16) * lu(i,16) - b(i,15) = b(i,15) * lu(i,15) - b(i,14) = b(i,14) * lu(i,14) - b(i,13) = b(i,13) * lu(i,13) - b(i,12) = b(i,12) * lu(i,12) - b(i,11) = b(i,11) * lu(i,11) - b(i,10) = b(i,10) * lu(i,10) - b(i,9) = b(i,9) * lu(i,9) - b(i,8) = b(i,8) * lu(i,8) - b(i,7) = b(i,7) * lu(i,7) - b(i,6) = b(i,6) * lu(i,6) - b(i,5) = b(i,5) * lu(i,5) - b(i,4) = b(i,4) * lu(i,4) - b(i,3) = b(i,3) * lu(i,3) - b(i,2) = b(i,2) * lu(i,2) - b(i,1) = b(i,1) * lu(i,1) - enddo - END SUBROUTINE lu_slv08_vec - - SUBROUTINE lu_slv_vec(ncol,nb,nz,lu, b) - USE shr_kind_mod, ONLY: r8 => shr_kind_r8 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - integer :: ncol,nb,nz - REAL(KIND=r8), intent(in) :: lu(ncol,nz) - REAL(KIND=r8), intent(inout) :: b(ncol,nb) - call lu_slv01_vec( ncol,nb,nz,lu, b ) - call lu_slv02_vec( ncol,nb,nz,lu, b ) - call lu_slv03_vec( ncol,nb,nz,lu, b ) - call lu_slv04_vec( ncol,nb,nz,lu, b ) - call lu_slv05_vec( ncol,nb,nz,lu, b ) - call lu_slv06_vec( ncol,nb,nz,lu, b ) - call lu_slv07_vec( ncol,nb,nz,lu, b ) - call lu_slv08_vec( ncol,nb,nz,lu, b ) - END SUBROUTINE lu_slv_vec - END MODULE mo_lu_solve_vec diff --git a/test/ncar_kernels/WACCM_lu_slv/src/mo_lu_solve_vecr4.F90 b/test/ncar_kernels/WACCM_lu_slv/src/mo_lu_solve_vecr4.F90 deleted file mode 100644 index ace252f78c..0000000000 --- a/test/ncar_kernels/WACCM_lu_slv/src/mo_lu_solve_vecr4.F90 +++ /dev/null @@ -1,1783 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : mo_lu_solve.F90 -! Generated at: 2015-07-14 19:56:41 -! KGEN version: 0.4.13 - -#define FASTER 1 -#undef DOINLINE - - - MODULE mo_lu_solve_vecr4 - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - PRIVATE - PUBLIC lu_slv_vecr4 - CONTAINS - - ! write subroutines - ! No subroutines - ! No module extern variables - -#ifdef DOINLINE -!DIR$ ATTRIBUTES FORCEINLINE :: lu_slv01_vec -#else -!DIR$ ATTRIBUTES NOINLINE :: lu_slv01_vec -#endif - SUBROUTINE lu_slv01_vec(ncol,nb,nz,lu, b) - USE shr_kind_mod, ONLY: r4 => shr_kind_r4 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - integer :: ncol - integer :: nz, nb - REAL(KIND=r4), intent(in) :: lu(ncol,nz) - REAL(KIND=r4), intent(inout) :: b(ncol,nb) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - integer :: i - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- -!DIR$ ASSUME_ALIGNED lu:64 -!DIR$ ASSUME_ALIGNED b:64 -#ifdef FASTER - b(:,125) = b(:,125) - lu(:,18) * b(:,17) - b(:,131) = b(:,131) - lu(:,19) * b(:,17) -!DIR$ NOFUSION - b(:,124) = b(:,124) - lu(:,21) * b(:,18) - b(:,126) = b(:,126) - lu(:,22) * b(:,18) -!DIR$ NOFUSION - do i=1,ncol -#else - b(:,125) = b(:,125) - lu(:,18) * b(:,17) - b(:,131) = b(:,131) - lu(:,19) * b(:,17) - do i=1,ncol - b(i,124) = b(i,124) - lu(i,21) * b(i,18) - b(i,126) = b(i,126) - lu(i,22) * b(i,18) -#endif - b(i,79) = b(i,79) - lu(i,24) * b(i,19) - b(i,131) = b(i,131) - lu(i,25) * b(i,19) - b(i,41) = b(i,41) - lu(i,27) * b(i,20) - b(i,131) = b(i,131) - lu(i,28) * b(i,20) - b(i,96) = b(i,96) - lu(i,30) * b(i,21) - b(i,131) = b(i,131) - lu(i,31) * b(i,21) - b(i,134) = b(i,134) - lu(i,32) * b(i,21) - b(i,23) = b(i,23) - lu(i,34) * b(i,22) - b(i,65) = b(i,65) - lu(i,35) * b(i,22) - b(i,125) = b(i,125) - lu(i,36) * b(i,22) - b(i,131) = b(i,131) - lu(i,37) * b(i,22) - b(i,31) = b(i,31) - lu(i,39) * b(i,23) - b(i,131) = b(i,131) - lu(i,40) * b(i,23) - b(i,56) = b(i,56) - lu(i,42) * b(i,24) - b(i,131) = b(i,131) - lu(i,43) * b(i,24) - b(i,88) = b(i,88) - lu(i,45) * b(i,25) - b(i,122) = b(i,122) - lu(i,46) * b(i,25) - b(i,36) = b(i,36) - lu(i,48) * b(i,26) - b(i,134) = b(i,134) - lu(i,49) * b(i,26) - b(i,120) = b(i,120) - lu(i,51) * b(i,27) - b(i,120) = b(i,120) - lu(i,54) * b(i,28) - b(i,126) = b(i,126) - lu(i,56) * b(i,29) - b(i,122) = b(i,122) - lu(i,58) * b(i,30) - b(i,125) = b(i,125) - lu(i,59) * b(i,30) - b(i,131) = b(i,131) - lu(i,60) * b(i,30) - b(i,66) = b(i,66) - lu(i,62) * b(i,31) - b(i,125) = b(i,125) - lu(i,63) * b(i,31) - b(i,130) = b(i,130) - lu(i,64) * b(i,31) - b(i,88) = b(i,88) - lu(i,66) * b(i,32) - b(i,122) = b(i,122) - lu(i,67) * b(i,32) - b(i,126) = b(i,126) - lu(i,68) * b(i,32) - b(i,118) = b(i,118) - lu(i,70) * b(i,33) - b(i,126) = b(i,126) - lu(i,71) * b(i,33) - b(i,88) = b(i,88) - lu(i,73) * b(i,34) - b(i,127) = b(i,127) - lu(i,74) * b(i,34) - b(i,104) = b(i,104) - lu(i,76) * b(i,35) - b(i,125) = b(i,125) - lu(i,77) * b(i,35) - b(i,131) = b(i,131) - lu(i,78) * b(i,35) - b(i,99) = b(i,99) - lu(i,81) * b(i,36) - b(i,121) = b(i,121) - lu(i,82) * b(i,36) - b(i,134) = b(i,134) - lu(i,83) * b(i,36) - b(i,91) = b(i,91) - lu(i,85) * b(i,37) - b(i,117) = b(i,117) - lu(i,86) * b(i,37) - b(i,126) = b(i,126) - lu(i,87) * b(i,37) - b(i,131) = b(i,131) - lu(i,88) * b(i,37) - b(i,134) = b(i,134) - lu(i,89) * b(i,37) - b(i,64) = b(i,64) - lu(i,91) * b(i,38) - b(i,81) = b(i,81) - lu(i,92) * b(i,38) - b(i,103) = b(i,103) - lu(i,93) * b(i,38) - b(i,125) = b(i,125) - lu(i,94) * b(i,38) - b(i,131) = b(i,131) - lu(i,95) * b(i,38) - b(i,99) = b(i,99) - lu(i,97) * b(i,39) - b(i,125) = b(i,125) - lu(i,98) * b(i,39) - b(i,131) = b(i,131) - lu(i,99) * b(i,39) - b(i,132) = b(i,132) - lu(i,100) * b(i,39) - b(i,133) = b(i,133) - lu(i,101) * b(i,39) - b(i,121) = b(i,121) - lu(i,103) * b(i,40) - b(i,129) = b(i,129) - lu(i,104) * b(i,40) - b(i,130) = b(i,130) - lu(i,105) * b(i,40) - b(i,132) = b(i,132) - lu(i,106) * b(i,40) - b(i,133) = b(i,133) - lu(i,107) * b(i,40) - b(i,80) = b(i,80) - lu(i,109) * b(i,41) - b(i,104) = b(i,104) - lu(i,110) * b(i,41) - b(i,125) = b(i,125) - lu(i,111) * b(i,41) - b(i,129) = b(i,129) - lu(i,112) * b(i,41) - b(i,130) = b(i,130) - lu(i,113) * b(i,41) - b(i,135) = b(i,135) - lu(i,114) * b(i,41) - b(i,77) = b(i,77) - lu(i,116) * b(i,42) - b(i,104) = b(i,104) - lu(i,117) * b(i,42) - b(i,115) = b(i,115) - lu(i,118) * b(i,42) - b(i,131) = b(i,131) - lu(i,119) * b(i,42) - b(i,112) = b(i,112) - lu(i,121) * b(i,43) - b(i,114) = b(i,114) - lu(i,122) * b(i,43) - b(i,125) = b(i,125) - lu(i,123) * b(i,43) - b(i,131) = b(i,131) - lu(i,124) * b(i,43) - b(i,91) = b(i,91) - lu(i,126) * b(i,44) - b(i,104) = b(i,104) - lu(i,127) * b(i,44) - b(i,125) = b(i,125) - lu(i,128) * b(i,44) - b(i,131) = b(i,131) - lu(i,129) * b(i,44) - b(i,110) = b(i,110) - lu(i,131) * b(i,45) - b(i,131) = b(i,131) - lu(i,132) * b(i,45) - b(i,134) = b(i,134) - lu(i,133) * b(i,45) - b(i,99) = b(i,99) - lu(i,135) * b(i,46) - b(i,116) = b(i,116) - lu(i,136) * b(i,46) - b(i,121) = b(i,121) - lu(i,137) * b(i,46) - b(i,124) = b(i,124) - lu(i,138) * b(i,46) - b(i,110) = b(i,110) - lu(i,140) * b(i,47) - b(i,131) = b(i,131) - lu(i,141) * b(i,47) - b(i,82) = b(i,82) - lu(i,143) * b(i,48) - b(i,99) = b(i,99) - lu(i,144) * b(i,48) - b(i,103) = b(i,103) - lu(i,145) * b(i,48) - b(i,116) = b(i,116) - lu(i,146) * b(i,48) - b(i,121) = b(i,121) - lu(i,147) * b(i,48) - b(i,127) = b(i,127) - lu(i,148) * b(i,48) - b(i,131) = b(i,131) - lu(i,149) * b(i,48) - b(i,109) = b(i,109) - lu(i,151) * b(i,49) - b(i,130) = b(i,130) - lu(i,152) * b(i,49) - b(i,131) = b(i,131) - lu(i,153) * b(i,49) - b(i,119) = b(i,119) - lu(i,155) * b(i,50) - b(i,127) = b(i,127) - lu(i,156) * b(i,50) - b(i,131) = b(i,131) - lu(i,157) * b(i,50) - b(i,134) = b(i,134) - lu(i,158) * b(i,50) - b(i,135) = b(i,135) - lu(i,159) * b(i,50) - b(i,65) = b(i,65) - lu(i,161) * b(i,51) - b(i,66) = b(i,66) - lu(i,162) * b(i,51) - b(i,81) = b(i,81) - lu(i,163) * b(i,51) - b(i,109) = b(i,109) - lu(i,164) * b(i,51) - b(i,131) = b(i,131) - lu(i,165) * b(i,51) - b(i,80) = b(i,80) - lu(i,167) * b(i,52) - b(i,96) = b(i,96) - lu(i,168) * b(i,52) - b(i,125) = b(i,125) - lu(i,169) * b(i,52) - b(i,131) = b(i,131) - lu(i,170) * b(i,52) - b(i,134) = b(i,134) - lu(i,171) * b(i,52) - b(i,106) = b(i,106) - lu(i,173) * b(i,53) - b(i,115) = b(i,115) - lu(i,174) * b(i,53) - b(i,131) = b(i,131) - lu(i,175) * b(i,53) - b(i,134) = b(i,134) - lu(i,176) * b(i,53) - b(i,135) = b(i,135) - lu(i,177) * b(i,53) - b(i,64) = b(i,64) - lu(i,179) * b(i,54) - b(i,125) = b(i,125) - lu(i,180) * b(i,54) - b(i,129) = b(i,129) - lu(i,181) * b(i,54) - b(i,130) = b(i,130) - lu(i,182) * b(i,54) - b(i,135) = b(i,135) - lu(i,183) * b(i,54) - b(i,77) = b(i,77) - lu(i,185) * b(i,55) - b(i,91) = b(i,91) - lu(i,186) * b(i,55) - b(i,115) = b(i,115) - lu(i,187) * b(i,55) - b(i,131) = b(i,131) - lu(i,188) * b(i,55) - b(i,95) = b(i,95) - lu(i,190) * b(i,56) - b(i,120) = b(i,120) - lu(i,191) * b(i,56) - b(i,125) = b(i,125) - lu(i,192) * b(i,56) - b(i,135) = b(i,135) - lu(i,193) * b(i,56) - b(i,115) = b(i,115) - lu(i,195) * b(i,57) - b(i,119) = b(i,119) - lu(i,196) * b(i,57) - b(i,130) = b(i,130) - lu(i,197) * b(i,57) - b(i,131) = b(i,131) - lu(i,198) * b(i,57) - b(i,132) = b(i,132) - lu(i,199) * b(i,57) - b(i,135) = b(i,135) - lu(i,200) * b(i,57) - b(i,72) = b(i,72) - lu(i,202) * b(i,58) - b(i,85) = b(i,85) - lu(i,203) * b(i,58) - b(i,86) = b(i,86) - lu(i,204) * b(i,58) - b(i,92) = b(i,92) - lu(i,205) * b(i,58) - b(i,120) = b(i,120) - lu(i,206) * b(i,58) - b(i,121) = b(i,121) - lu(i,207) * b(i,58) - b(i,80) = b(i,80) - lu(i,209) * b(i,59) - b(i,98) = b(i,98) - lu(i,210) * b(i,59) - b(i,107) = b(i,107) - lu(i,211) * b(i,59) - b(i,113) = b(i,113) - lu(i,212) * b(i,59) - b(i,125) = b(i,125) - lu(i,213) * b(i,59) - b(i,131) = b(i,131) - lu(i,214) * b(i,59) - b(i,120) = b(i,120) - lu(i,216) * b(i,60) - b(i,125) = b(i,125) - lu(i,217) * b(i,60) - b(i,130) = b(i,130) - lu(i,218) * b(i,60) - b(i,131) = b(i,131) - lu(i,219) * b(i,60) - b(i,132) = b(i,132) - lu(i,220) * b(i,60) - b(i,134) = b(i,134) - lu(i,221) * b(i,60) - b(i,92) = b(i,92) - lu(i,223) * b(i,61) - b(i,120) = b(i,120) - lu(i,224) * b(i,61) - b(i,122) = b(i,122) - lu(i,225) * b(i,61) - b(i,129) = b(i,129) - lu(i,226) * b(i,61) - b(i,115) = b(i,115) - lu(i,228) * b(i,62) - b(i,119) = b(i,119) - lu(i,229) * b(i,62) - b(i,131) = b(i,131) - lu(i,230) * b(i,62) - b(i,134) = b(i,134) - lu(i,231) * b(i,62) - b(i,135) = b(i,135) - lu(i,232) * b(i,62) - b(i,64) = b(i,64) - lu(i,234) * b(i,63) - b(i,83) = b(i,83) - lu(i,235) * b(i,63) - b(i,103) = b(i,103) - lu(i,236) * b(i,63) - b(i,123) = b(i,123) - lu(i,237) * b(i,63) - b(i,125) = b(i,125) - lu(i,238) * b(i,63) - b(i,131) = b(i,131) - lu(i,239) * b(i,63) - b(i,135) = b(i,135) - lu(i,240) * b(i,63) - b(i,125) = b(i,125) - lu(i,242) * b(i,64) - b(i,131) = b(i,131) - lu(i,243) * b(i,64) - b(i,134) = b(i,134) - lu(i,244) * b(i,64) - b(i,66) = b(i,66) - lu(i,247) * b(i,65) - b(i,81) = b(i,81) - lu(i,248) * b(i,65) - b(i,109) = b(i,109) - lu(i,249) * b(i,65) - b(i,125) = b(i,125) - lu(i,250) * b(i,65) - b(i,129) = b(i,129) - lu(i,251) * b(i,65) - b(i,130) = b(i,130) - lu(i,252) * b(i,65) - b(i,131) = b(i,131) - lu(i,253) * b(i,65) - b(i,81) = b(i,81) - lu(i,255) * b(i,66) - b(i,103) = b(i,103) - lu(i,256) * b(i,66) - b(i,109) = b(i,109) - lu(i,257) * b(i,66) - b(i,115) = b(i,115) - lu(i,258) * b(i,66) - b(i,125) = b(i,125) - lu(i,259) * b(i,66) - b(i,89) = b(i,89) - lu(i,261) * b(i,67) - b(i,104) = b(i,104) - lu(i,262) * b(i,67) - b(i,105) = b(i,105) - lu(i,263) * b(i,67) - b(i,125) = b(i,125) - lu(i,264) * b(i,67) - b(i,131) = b(i,131) - lu(i,265) * b(i,67) - b(i,134) = b(i,134) - lu(i,266) * b(i,67) - b(i,135) = b(i,135) - lu(i,267) * b(i,67) - b(i,125) = b(i,125) - lu(i,269) * b(i,68) - b(i,131) = b(i,131) - lu(i,270) * b(i,68) - b(i,135) = b(i,135) - lu(i,271) * b(i,68) - b(i,107) = b(i,107) - lu(i,273) * b(i,69) - b(i,110) = b(i,110) - lu(i,274) * b(i,69) - b(i,111) = b(i,111) - lu(i,275) * b(i,69) - b(i,113) = b(i,113) - lu(i,276) * b(i,69) - b(i,125) = b(i,125) - lu(i,277) * b(i,69) - b(i,131) = b(i,131) - lu(i,278) * b(i,69) - b(i,135) = b(i,135) - lu(i,279) * b(i,69) - enddo - END SUBROUTINE lu_slv01_vec - -#ifdef DOINLINE -!DIR$ ATTRIBUTES FORCEINLINE :: lu_slv02_vec -#else -!DIR$ ATTRIBUTES NOINLINE :: lu_slv02_vec -#endif - SUBROUTINE lu_slv02_vec(ncol,nb,nz,lu, b) - USE shr_kind_mod, ONLY: r4 => shr_kind_r4 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - integer :: ncol,nb,nz - REAL(KIND=r4), intent(in) :: lu(ncol,nz) - REAL(KIND=r4), intent(inout) :: b(ncol,nb) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - integer :: i - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- -!DIR$ ASSUME_ALIGNED lu:64 -!DIR$ ASSUME_ALIGNED b:64 - do i=1,ncol - b(i,84) = b(i,84) - lu(i,281) * b(i,70) - b(i,118) = b(i,118) - lu(i,282) * b(i,70) - b(i,121) = b(i,121) - lu(i,283) * b(i,70) - b(i,128) = b(i,128) - lu(i,284) * b(i,70) - b(i,130) = b(i,130) - lu(i,285) * b(i,70) - b(i,132) = b(i,132) - lu(i,286) * b(i,70) - b(i,133) = b(i,133) - lu(i,287) * b(i,70) - enddo - - do i=1,ncol - b(i,105) = b(i,105) - lu(i,289) * b(i,71) - b(i,114) = b(i,114) - lu(i,290) * b(i,71) - b(i,125) = b(i,125) - lu(i,291) * b(i,71) - b(i,130) = b(i,130) - lu(i,292) * b(i,71) - b(i,131) = b(i,131) - lu(i,293) * b(i,71) - b(i,132) = b(i,132) - lu(i,294) * b(i,71) - b(i,135) = b(i,135) - lu(i,295) * b(i,71) - b(i,85) = b(i,85) - lu(i,297) * b(i,72) - b(i,86) = b(i,86) - lu(i,298) * b(i,72) - b(i,92) = b(i,92) - lu(i,299) * b(i,72) - b(i,103) = b(i,103) - lu(i,300) * b(i,72) - b(i,120) = b(i,120) - lu(i,301) * b(i,72) - b(i,121) = b(i,121) - lu(i,302) * b(i,72) - b(i,98) = b(i,98) - lu(i,304) * b(i,73) - b(i,107) = b(i,107) - lu(i,305) * b(i,73) - b(i,113) = b(i,113) - lu(i,306) * b(i,73) - b(i,123) = b(i,123) - lu(i,307) * b(i,73) - b(i,125) = b(i,125) - lu(i,308) * b(i,73) - b(i,130) = b(i,130) - lu(i,309) * b(i,73) - b(i,131) = b(i,131) - lu(i,310) * b(i,73) - b(i,132) = b(i,132) - lu(i,311) * b(i,73) - b(i,117) = b(i,117) - lu(i,313) * b(i,74) - b(i,121) = b(i,121) - lu(i,314) * b(i,74) - b(i,125) = b(i,125) - lu(i,315) * b(i,74) - b(i,126) = b(i,126) - lu(i,316) * b(i,74) - b(i,131) = b(i,131) - lu(i,317) * b(i,74) - b(i,134) = b(i,134) - lu(i,318) * b(i,74) - b(i,119) = b(i,119) - lu(i,320) * b(i,75) - b(i,131) = b(i,131) - lu(i,321) * b(i,75) - b(i,134) = b(i,134) - lu(i,322) * b(i,75) - b(i,77) = b(i,77) - lu(i,325) * b(i,76) - b(i,79) = b(i,79) - lu(i,326) * b(i,76) - b(i,80) = b(i,80) - lu(i,327) * b(i,76) - b(i,91) = b(i,91) - lu(i,328) * b(i,76) - b(i,104) = b(i,104) - lu(i,329) * b(i,76) - b(i,115) = b(i,115) - lu(i,330) * b(i,76) - b(i,125) = b(i,125) - lu(i,331) * b(i,76) - b(i,131) = b(i,131) - lu(i,332) * b(i,76) - b(i,135) = b(i,135) - lu(i,333) * b(i,76) - b(i,104) = b(i,104) - lu(i,336) * b(i,77) - b(i,115) = b(i,115) - lu(i,337) * b(i,77) - b(i,125) = b(i,125) - lu(i,338) * b(i,77) - b(i,129) = b(i,129) - lu(i,339) * b(i,77) - b(i,130) = b(i,130) - lu(i,340) * b(i,77) - b(i,131) = b(i,131) - lu(i,341) * b(i,77) - b(i,85) = b(i,85) - lu(i,345) * b(i,78) - b(i,86) = b(i,86) - lu(i,346) * b(i,78) - b(i,87) = b(i,87) - lu(i,347) * b(i,78) - b(i,92) = b(i,92) - lu(i,348) * b(i,78) - b(i,103) = b(i,103) - lu(i,349) * b(i,78) - b(i,120) = b(i,120) - lu(i,350) * b(i,78) - b(i,121) = b(i,121) - lu(i,351) * b(i,78) - b(i,122) = b(i,122) - lu(i,352) * b(i,78) - b(i,129) = b(i,129) - lu(i,353) * b(i,78) - b(i,80) = b(i,80) - lu(i,359) * b(i,79) - b(i,91) = b(i,91) - lu(i,360) * b(i,79) - b(i,104) = b(i,104) - lu(i,361) * b(i,79) - b(i,109) = b(i,109) - lu(i,362) * b(i,79) - b(i,115) = b(i,115) - lu(i,363) * b(i,79) - b(i,125) = b(i,125) - lu(i,364) * b(i,79) - b(i,129) = b(i,129) - lu(i,365) * b(i,79) - b(i,130) = b(i,130) - lu(i,366) * b(i,79) - b(i,131) = b(i,131) - lu(i,367) * b(i,79) - b(i,135) = b(i,135) - lu(i,368) * b(i,79) - b(i,106) = b(i,106) - lu(i,370) * b(i,80) - b(i,115) = b(i,115) - lu(i,371) * b(i,80) - b(i,119) = b(i,119) - lu(i,372) * b(i,80) - b(i,131) = b(i,131) - lu(i,373) * b(i,80) - b(i,134) = b(i,134) - lu(i,374) * b(i,80) - b(i,103) = b(i,103) - lu(i,376) * b(i,81) - b(i,125) = b(i,125) - lu(i,377) * b(i,81) - b(i,131) = b(i,131) - lu(i,378) * b(i,81) - b(i,116) = b(i,116) - lu(i,380) * b(i,82) - b(i,120) = b(i,120) - lu(i,381) * b(i,82) - b(i,121) = b(i,121) - lu(i,382) * b(i,82) - b(i,123) = b(i,123) - lu(i,383) * b(i,82) - b(i,127) = b(i,127) - lu(i,384) * b(i,82) - b(i,131) = b(i,131) - lu(i,385) * b(i,82) - b(i,95) = b(i,95) - lu(i,389) * b(i,83) - b(i,120) = b(i,120) - lu(i,390) * b(i,83) - b(i,125) = b(i,125) - lu(i,391) * b(i,83) - b(i,129) = b(i,129) - lu(i,392) * b(i,83) - b(i,130) = b(i,130) - lu(i,393) * b(i,83) - b(i,131) = b(i,131) - lu(i,394) * b(i,83) - b(i,135) = b(i,135) - lu(i,395) * b(i,83) - b(i,117) = b(i,117) - lu(i,398) * b(i,84) - b(i,118) = b(i,118) - lu(i,399) * b(i,84) - b(i,121) = b(i,121) - lu(i,400) * b(i,84) - b(i,126) = b(i,126) - lu(i,401) * b(i,84) - b(i,128) = b(i,128) - lu(i,402) * b(i,84) - b(i,131) = b(i,131) - lu(i,403) * b(i,84) - b(i,134) = b(i,134) - lu(i,404) * b(i,84) - b(i,86) = b(i,86) - lu(i,406) * b(i,85) - b(i,87) = b(i,87) - lu(i,407) * b(i,85) - b(i,92) = b(i,92) - lu(i,408) * b(i,85) - b(i,120) = b(i,120) - lu(i,409) * b(i,85) - b(i,121) = b(i,121) - lu(i,410) * b(i,85) - b(i,122) = b(i,122) - lu(i,411) * b(i,85) - b(i,129) = b(i,129) - lu(i,412) * b(i,85) - b(i,87) = b(i,87) - lu(i,415) * b(i,86) - b(i,92) = b(i,92) - lu(i,416) * b(i,86) - b(i,120) = b(i,120) - lu(i,417) * b(i,86) - b(i,121) = b(i,121) - lu(i,418) * b(i,86) - b(i,122) = b(i,122) - lu(i,419) * b(i,86) - b(i,129) = b(i,129) - lu(i,420) * b(i,86) - b(i,92) = b(i,92) - lu(i,426) * b(i,87) - b(i,103) = b(i,103) - lu(i,427) * b(i,87) - b(i,120) = b(i,120) - lu(i,428) * b(i,87) - b(i,121) = b(i,121) - lu(i,429) * b(i,87) - b(i,122) = b(i,122) - lu(i,430) * b(i,87) - b(i,129) = b(i,129) - lu(i,431) * b(i,87) - b(i,108) = b(i,108) - lu(i,434) * b(i,88) - b(i,119) = b(i,119) - lu(i,435) * b(i,88) - b(i,127) = b(i,127) - lu(i,436) * b(i,88) - b(i,131) = b(i,131) - lu(i,437) * b(i,88) - b(i,132) = b(i,132) - lu(i,438) * b(i,88) - b(i,133) = b(i,133) - lu(i,439) * b(i,88) - b(i,134) = b(i,134) - lu(i,440) * b(i,88) - b(i,104) = b(i,104) - lu(i,443) * b(i,89) - b(i,105) = b(i,105) - lu(i,444) * b(i,89) - b(i,120) = b(i,120) - lu(i,445) * b(i,89) - b(i,125) = b(i,125) - lu(i,446) * b(i,89) - b(i,129) = b(i,129) - lu(i,447) * b(i,89) - b(i,130) = b(i,130) - lu(i,448) * b(i,89) - b(i,131) = b(i,131) - lu(i,449) * b(i,89) - b(i,134) = b(i,134) - lu(i,450) * b(i,89) - b(i,135) = b(i,135) - lu(i,451) * b(i,89) - b(i,118) = b(i,118) - lu(i,453) * b(i,90) - b(i,121) = b(i,121) - lu(i,454) * b(i,90) - b(i,122) = b(i,122) - lu(i,455) * b(i,90) - b(i,127) = b(i,127) - lu(i,456) * b(i,90) - b(i,131) = b(i,131) - lu(i,457) * b(i,90) - b(i,134) = b(i,134) - lu(i,458) * b(i,90) - b(i,104) = b(i,104) - lu(i,463) * b(i,91) - b(i,119) = b(i,119) - lu(i,464) * b(i,91) - b(i,120) = b(i,120) - lu(i,465) * b(i,91) - b(i,125) = b(i,125) - lu(i,466) * b(i,91) - b(i,129) = b(i,129) - lu(i,467) * b(i,91) - b(i,130) = b(i,130) - lu(i,468) * b(i,91) - b(i,131) = b(i,131) - lu(i,469) * b(i,91) - b(i,135) = b(i,135) - lu(i,470) * b(i,91) - b(i,103) = b(i,103) - lu(i,477) * b(i,92) - b(i,120) = b(i,120) - lu(i,478) * b(i,92) - b(i,121) = b(i,121) - lu(i,479) * b(i,92) - b(i,122) = b(i,122) - lu(i,480) * b(i,92) - b(i,127) = b(i,127) - lu(i,481) * b(i,92) - b(i,129) = b(i,129) - lu(i,482) * b(i,92) - b(i,130) = b(i,130) - lu(i,483) * b(i,92) - b(i,131) = b(i,131) - lu(i,484) * b(i,92) - b(i,117) = b(i,117) - lu(i,487) * b(i,93) - b(i,121) = b(i,121) - lu(i,488) * b(i,93) - b(i,124) = b(i,124) - lu(i,489) * b(i,93) - b(i,126) = b(i,126) - lu(i,490) * b(i,93) - b(i,131) = b(i,131) - lu(i,491) * b(i,93) - b(i,134) = b(i,134) - lu(i,492) * b(i,93) - b(i,101) = b(i,101) - lu(i,495) * b(i,94) - b(i,102) = b(i,102) - lu(i,496) * b(i,94) - b(i,103) = b(i,103) - lu(i,497) * b(i,94) - b(i,107) = b(i,107) - lu(i,498) * b(i,94) - b(i,111) = b(i,111) - lu(i,499) * b(i,94) - b(i,113) = b(i,113) - lu(i,500) * b(i,94) - b(i,114) = b(i,114) - lu(i,501) * b(i,94) - b(i,119) = b(i,119) - lu(i,502) * b(i,94) - b(i,123) = b(i,123) - lu(i,503) * b(i,94) - b(i,125) = b(i,125) - lu(i,504) * b(i,94) - b(i,131) = b(i,131) - lu(i,505) * b(i,94) - b(i,132) = b(i,132) - lu(i,506) * b(i,94) - b(i,134) = b(i,134) - lu(i,507) * b(i,94) - b(i,135) = b(i,135) - lu(i,508) * b(i,94) - b(i,103) = b(i,103) - lu(i,511) * b(i,95) - b(i,125) = b(i,125) - lu(i,512) * b(i,95) - b(i,131) = b(i,131) - lu(i,513) * b(i,95) - b(i,135) = b(i,135) - lu(i,514) * b(i,95) - b(i,104) = b(i,104) - lu(i,518) * b(i,96) - b(i,106) = b(i,106) - lu(i,519) * b(i,96) - b(i,115) = b(i,115) - lu(i,520) * b(i,96) - b(i,119) = b(i,119) - lu(i,521) * b(i,96) - b(i,120) = b(i,120) - lu(i,522) * b(i,96) - b(i,125) = b(i,125) - lu(i,523) * b(i,96) - b(i,129) = b(i,129) - lu(i,524) * b(i,96) - b(i,130) = b(i,130) - lu(i,525) * b(i,96) - b(i,131) = b(i,131) - lu(i,526) * b(i,96) - b(i,134) = b(i,134) - lu(i,527) * b(i,96) - b(i,135) = b(i,135) - lu(i,528) * b(i,96) - b(i,103) = b(i,103) - lu(i,531) * b(i,97) - b(i,110) = b(i,110) - lu(i,532) * b(i,97) - b(i,125) = b(i,125) - lu(i,533) * b(i,97) - b(i,130) = b(i,130) - lu(i,534) * b(i,97) - b(i,131) = b(i,131) - lu(i,535) * b(i,97) - b(i,132) = b(i,132) - lu(i,536) * b(i,97) - b(i,135) = b(i,135) - lu(i,537) * b(i,97) - b(i,106) = b(i,106) - lu(i,541) * b(i,98) - b(i,107) = b(i,107) - lu(i,542) * b(i,98) - b(i,113) = b(i,113) - lu(i,543) * b(i,98) - b(i,115) = b(i,115) - lu(i,544) * b(i,98) - b(i,119) = b(i,119) - lu(i,545) * b(i,98) - b(i,125) = b(i,125) - lu(i,546) * b(i,98) - b(i,129) = b(i,129) - lu(i,547) * b(i,98) - b(i,130) = b(i,130) - lu(i,548) * b(i,98) - b(i,131) = b(i,131) - lu(i,549) * b(i,98) - b(i,134) = b(i,134) - lu(i,550) * b(i,98) - enddo - END SUBROUTINE lu_slv02_vec - -#ifdef DOINLINE -!DIR$ ATTRIBUTES FORCEINLINE :: lu_slv03_vec -#else -!DIR$ ATTRIBUTES NOINLINE :: lu_slv03_vec -#endif - SUBROUTINE lu_slv03_vec(ncol,nb,nz,lu, b) - USE shr_kind_mod, ONLY: r4 => shr_kind_r4 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - integer*4 :: ncol,nb,nz - REAL(KIND=r4), intent(in) :: lu(ncol,nz) - REAL(KIND=r4), intent(inout) :: b(ncol,nb) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - integer :: i - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- -!DIR$ ASSUME_ALIGNED lu:64 -!DIR$ ASSUME_ALIGNED b:64 - do i=1,ncol - b(i,116) = b(i,116) - lu(i,553) * b(i,99) - b(i,121) = b(i,121) - lu(i,554) * b(i,99) - b(i,125) = b(i,125) - lu(i,555) * b(i,99) - b(i,131) = b(i,131) - lu(i,556) * b(i,99) - b(i,134) = b(i,134) - lu(i,557) * b(i,99) - b(i,117) = b(i,117) - lu(i,561) * b(i,100) - b(i,121) = b(i,121) - lu(i,562) * b(i,100) - b(i,124) = b(i,124) - lu(i,563) * b(i,100) - b(i,126) = b(i,126) - lu(i,564) * b(i,100) - b(i,130) = b(i,130) - lu(i,565) * b(i,100) - b(i,131) = b(i,131) - lu(i,566) * b(i,100) - b(i,132) = b(i,132) - lu(i,567) * b(i,100) - b(i,133) = b(i,133) - lu(i,568) * b(i,100) - b(i,134) = b(i,134) - lu(i,569) * b(i,100) - b(i,103) = b(i,103) - lu(i,573) * b(i,101) - b(i,107) = b(i,107) - lu(i,574) * b(i,101) - b(i,110) = b(i,110) - lu(i,575) * b(i,101) - b(i,113) = b(i,113) - lu(i,576) * b(i,101) - b(i,125) = b(i,125) - lu(i,577) * b(i,101) - b(i,129) = b(i,129) - lu(i,578) * b(i,101) - b(i,130) = b(i,130) - lu(i,579) * b(i,101) - b(i,131) = b(i,131) - lu(i,580) * b(i,101) - b(i,132) = b(i,132) - lu(i,581) * b(i,101) - b(i,134) = b(i,134) - lu(i,582) * b(i,101) - b(i,135) = b(i,135) - lu(i,583) * b(i,101) - b(i,103) = b(i,103) - lu(i,588) * b(i,102) - b(i,104) = b(i,104) - lu(i,589) * b(i,102) - b(i,105) = b(i,105) - lu(i,590) * b(i,102) - b(i,109) = b(i,109) - lu(i,591) * b(i,102) - b(i,119) = b(i,119) - lu(i,592) * b(i,102) - b(i,120) = b(i,120) - lu(i,593) * b(i,102) - b(i,123) = b(i,123) - lu(i,594) * b(i,102) - b(i,125) = b(i,125) - lu(i,595) * b(i,102) - b(i,129) = b(i,129) - lu(i,596) * b(i,102) - b(i,130) = b(i,130) - lu(i,597) * b(i,102) - b(i,131) = b(i,131) - lu(i,598) * b(i,102) - b(i,132) = b(i,132) - lu(i,599) * b(i,102) - b(i,134) = b(i,134) - lu(i,600) * b(i,102) - b(i,135) = b(i,135) - lu(i,601) * b(i,102) - b(i,125) = b(i,125) - lu(i,603) * b(i,103) - b(i,127) = b(i,127) - lu(i,604) * b(i,103) - b(i,131) = b(i,131) - lu(i,605) * b(i,103) - b(i,115) = b(i,115) - lu(i,608) * b(i,104) - b(i,119) = b(i,119) - lu(i,609) * b(i,104) - b(i,125) = b(i,125) - lu(i,610) * b(i,104) - b(i,127) = b(i,127) - lu(i,611) * b(i,104) - b(i,131) = b(i,131) - lu(i,612) * b(i,104) - b(i,132) = b(i,132) - lu(i,613) * b(i,104) - b(i,133) = b(i,133) - lu(i,614) * b(i,104) - b(i,134) = b(i,134) - lu(i,615) * b(i,104) - b(i,109) = b(i,109) - lu(i,617) * b(i,105) - b(i,115) = b(i,115) - lu(i,618) * b(i,105) - b(i,125) = b(i,125) - lu(i,619) * b(i,105) - b(i,131) = b(i,131) - lu(i,620) * b(i,105) - b(i,135) = b(i,135) - lu(i,621) * b(i,105) - b(i,109) = b(i,109) - lu(i,626) * b(i,106) - b(i,115) = b(i,115) - lu(i,627) * b(i,106) - b(i,119) = b(i,119) - lu(i,628) * b(i,106) - b(i,120) = b(i,120) - lu(i,629) * b(i,106) - b(i,125) = b(i,125) - lu(i,630) * b(i,106) - b(i,129) = b(i,129) - lu(i,631) * b(i,106) - b(i,130) = b(i,130) - lu(i,632) * b(i,106) - b(i,131) = b(i,131) - lu(i,633) * b(i,106) - b(i,134) = b(i,134) - lu(i,634) * b(i,106) - b(i,135) = b(i,135) - lu(i,635) * b(i,106) - b(i,109) = b(i,109) - lu(i,638) * b(i,107) - b(i,112) = b(i,112) - lu(i,639) * b(i,107) - b(i,114) = b(i,114) - lu(i,640) * b(i,107) - b(i,115) = b(i,115) - lu(i,641) * b(i,107) - b(i,123) = b(i,123) - lu(i,642) * b(i,107) - b(i,125) = b(i,125) - lu(i,643) * b(i,107) - b(i,127) = b(i,127) - lu(i,644) * b(i,107) - b(i,131) = b(i,131) - lu(i,645) * b(i,107) - b(i,134) = b(i,134) - lu(i,646) * b(i,107) - b(i,135) = b(i,135) - lu(i,647) * b(i,107) - b(i,117) = b(i,117) - lu(i,651) * b(i,108) - b(i,119) = b(i,119) - lu(i,652) * b(i,108) - b(i,121) = b(i,121) - lu(i,653) * b(i,108) - b(i,122) = b(i,122) - lu(i,654) * b(i,108) - b(i,126) = b(i,126) - lu(i,655) * b(i,108) - b(i,127) = b(i,127) - lu(i,656) * b(i,108) - b(i,131) = b(i,131) - lu(i,657) * b(i,108) - b(i,132) = b(i,132) - lu(i,658) * b(i,108) - b(i,133) = b(i,133) - lu(i,659) * b(i,108) - b(i,134) = b(i,134) - lu(i,660) * b(i,108) - b(i,115) = b(i,115) - lu(i,663) * b(i,109) - b(i,125) = b(i,125) - lu(i,664) * b(i,109) - b(i,127) = b(i,127) - lu(i,665) * b(i,109) - b(i,131) = b(i,131) - lu(i,666) * b(i,109) - b(i,132) = b(i,132) - lu(i,667) * b(i,109) - b(i,133) = b(i,133) - lu(i,668) * b(i,109) - b(i,134) = b(i,134) - lu(i,669) * b(i,109) - b(i,115) = b(i,115) - lu(i,678) * b(i,110) - b(i,119) = b(i,119) - lu(i,679) * b(i,110) - b(i,125) = b(i,125) - lu(i,680) * b(i,110) - b(i,127) = b(i,127) - lu(i,681) * b(i,110) - b(i,129) = b(i,129) - lu(i,682) * b(i,110) - b(i,130) = b(i,130) - lu(i,683) * b(i,110) - b(i,131) = b(i,131) - lu(i,684) * b(i,110) - b(i,132) = b(i,132) - lu(i,685) * b(i,110) - b(i,133) = b(i,133) - lu(i,686) * b(i,110) - b(i,134) = b(i,134) - lu(i,687) * b(i,110) - b(i,135) = b(i,135) - lu(i,688) * b(i,110) - b(i,112) = b(i,112) - lu(i,698) * b(i,111) - b(i,113) = b(i,113) - lu(i,699) * b(i,111) - b(i,114) = b(i,114) - lu(i,700) * b(i,111) - b(i,115) = b(i,115) - lu(i,701) * b(i,111) - b(i,119) = b(i,119) - lu(i,702) * b(i,111) - b(i,123) = b(i,123) - lu(i,703) * b(i,111) - b(i,125) = b(i,125) - lu(i,704) * b(i,111) - b(i,127) = b(i,127) - lu(i,705) * b(i,111) - b(i,129) = b(i,129) - lu(i,706) * b(i,111) - b(i,130) = b(i,130) - lu(i,707) * b(i,111) - b(i,131) = b(i,131) - lu(i,708) * b(i,111) - b(i,132) = b(i,132) - lu(i,709) * b(i,111) - b(i,133) = b(i,133) - lu(i,710) * b(i,111) - b(i,134) = b(i,134) - lu(i,711) * b(i,111) - b(i,135) = b(i,135) - lu(i,712) * b(i,111) - b(i,114) = b(i,114) - lu(i,722) * b(i,112) - b(i,115) = b(i,115) - lu(i,723) * b(i,112) - b(i,119) = b(i,119) - lu(i,724) * b(i,112) - b(i,125) = b(i,125) - lu(i,725) * b(i,112) - b(i,127) = b(i,127) - lu(i,726) * b(i,112) - b(i,129) = b(i,129) - lu(i,727) * b(i,112) - b(i,130) = b(i,130) - lu(i,728) * b(i,112) - b(i,131) = b(i,131) - lu(i,729) * b(i,112) - b(i,132) = b(i,132) - lu(i,730) * b(i,112) - b(i,133) = b(i,133) - lu(i,731) * b(i,112) - b(i,134) = b(i,134) - lu(i,732) * b(i,112) - b(i,135) = b(i,135) - lu(i,733) * b(i,112) - b(i,114) = b(i,114) - lu(i,741) * b(i,113) - b(i,115) = b(i,115) - lu(i,742) * b(i,113) - b(i,119) = b(i,119) - lu(i,743) * b(i,113) - b(i,120) = b(i,120) - lu(i,744) * b(i,113) - b(i,123) = b(i,123) - lu(i,745) * b(i,113) - b(i,125) = b(i,125) - lu(i,746) * b(i,113) - b(i,127) = b(i,127) - lu(i,747) * b(i,113) - b(i,129) = b(i,129) - lu(i,748) * b(i,113) - b(i,130) = b(i,130) - lu(i,749) * b(i,113) - b(i,131) = b(i,131) - lu(i,750) * b(i,113) - b(i,132) = b(i,132) - lu(i,751) * b(i,113) - b(i,133) = b(i,133) - lu(i,752) * b(i,113) - b(i,134) = b(i,134) - lu(i,753) * b(i,113) - b(i,135) = b(i,135) - lu(i,754) * b(i,113) - b(i,115) = b(i,115) - lu(i,761) * b(i,114) - b(i,119) = b(i,119) - lu(i,762) * b(i,114) - b(i,120) = b(i,120) - lu(i,763) * b(i,114) - b(i,123) = b(i,123) - lu(i,764) * b(i,114) - b(i,125) = b(i,125) - lu(i,765) * b(i,114) - b(i,127) = b(i,127) - lu(i,766) * b(i,114) - b(i,129) = b(i,129) - lu(i,767) * b(i,114) - b(i,130) = b(i,130) - lu(i,768) * b(i,114) - b(i,131) = b(i,131) - lu(i,769) * b(i,114) - b(i,132) = b(i,132) - lu(i,770) * b(i,114) - b(i,133) = b(i,133) - lu(i,771) * b(i,114) - b(i,134) = b(i,134) - lu(i,772) * b(i,114) - b(i,135) = b(i,135) - lu(i,773) * b(i,114) - b(i,119) = b(i,119) - lu(i,790) * b(i,115) - b(i,120) = b(i,120) - lu(i,791) * b(i,115) - b(i,123) = b(i,123) - lu(i,792) * b(i,115) - b(i,125) = b(i,125) - lu(i,793) * b(i,115) - b(i,127) = b(i,127) - lu(i,794) * b(i,115) - b(i,129) = b(i,129) - lu(i,795) * b(i,115) - b(i,130) = b(i,130) - lu(i,796) * b(i,115) - b(i,131) = b(i,131) - lu(i,797) * b(i,115) - b(i,132) = b(i,132) - lu(i,798) * b(i,115) - b(i,133) = b(i,133) - lu(i,799) * b(i,115) - b(i,134) = b(i,134) - lu(i,800) * b(i,115) - b(i,135) = b(i,135) - lu(i,801) * b(i,115) - b(i,118) = b(i,118) - lu(i,806) * b(i,116) - b(i,120) = b(i,120) - lu(i,807) * b(i,116) - b(i,121) = b(i,121) - lu(i,808) * b(i,116) - b(i,123) = b(i,123) - lu(i,809) * b(i,116) - b(i,124) = b(i,124) - lu(i,810) * b(i,116) - b(i,125) = b(i,125) - lu(i,811) * b(i,116) - b(i,126) = b(i,126) - lu(i,812) * b(i,116) - b(i,127) = b(i,127) - lu(i,813) * b(i,116) - b(i,128) = b(i,128) - lu(i,814) * b(i,116) - b(i,129) = b(i,129) - lu(i,815) * b(i,116) - b(i,130) = b(i,130) - lu(i,816) * b(i,116) - b(i,131) = b(i,131) - lu(i,817) * b(i,116) - b(i,134) = b(i,134) - lu(i,818) * b(i,116) - b(i,118) = b(i,118) - lu(i,825) * b(i,117) - b(i,121) = b(i,121) - lu(i,826) * b(i,117) - b(i,122) = b(i,122) - lu(i,827) * b(i,117) - b(i,124) = b(i,124) - lu(i,828) * b(i,117) - b(i,126) = b(i,126) - lu(i,829) * b(i,117) - b(i,127) = b(i,127) - lu(i,830) * b(i,117) - b(i,128) = b(i,128) - lu(i,831) * b(i,117) - b(i,130) = b(i,130) - lu(i,832) * b(i,117) - b(i,131) = b(i,131) - lu(i,833) * b(i,117) - b(i,132) = b(i,132) - lu(i,834) * b(i,117) - b(i,133) = b(i,133) - lu(i,835) * b(i,117) - b(i,134) = b(i,134) - lu(i,836) * b(i,117) - b(i,120) = b(i,120) - lu(i,840) * b(i,118) - b(i,121) = b(i,121) - lu(i,841) * b(i,118) - b(i,122) = b(i,122) - lu(i,842) * b(i,118) - b(i,123) = b(i,123) - lu(i,843) * b(i,118) - b(i,125) = b(i,125) - lu(i,844) * b(i,118) - b(i,127) = b(i,127) - lu(i,845) * b(i,118) - b(i,128) = b(i,128) - lu(i,846) * b(i,118) - b(i,131) = b(i,131) - lu(i,847) * b(i,118) - b(i,134) = b(i,134) - lu(i,848) * b(i,118) - b(i,135) = b(i,135) - lu(i,849) * b(i,118) - enddo - END SUBROUTINE lu_slv03_vec - -#ifdef DOINLINE -!DIR$ ATTRIBUTES FORCEINLINE :: lu_slv04_vec -#else -!DIR$ ATTRIBUTES NOINLINE :: lu_slv04_vec -#endif - SUBROUTINE lu_slv04_vec(ncol,nb,nz,lu, b) - USE shr_kind_mod, ONLY: r4 => shr_kind_r4 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - integer :: ncol,nb,nz - REAL(KIND=r4), intent(in) :: lu(ncol,nz) - REAL(KIND=r4), intent(inout) :: b(ncol,nb) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - integer :: i - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- -!DIR$ ASSUME_ALIGNED lu:64 -!DIR$ ASSUME_ALIGNED b:64 - do i=1,ncol - b(i,120) = b(i,120) - lu(i,873) * b(i,119) - b(i,123) = b(i,123) - lu(i,874) * b(i,119) - b(i,124) = b(i,124) - lu(i,875) * b(i,119) - b(i,125) = b(i,125) - lu(i,876) * b(i,119) - b(i,126) = b(i,126) - lu(i,877) * b(i,119) - b(i,127) = b(i,127) - lu(i,878) * b(i,119) - b(i,129) = b(i,129) - lu(i,879) * b(i,119) - b(i,130) = b(i,130) - lu(i,880) * b(i,119) - b(i,131) = b(i,131) - lu(i,881) * b(i,119) - b(i,132) = b(i,132) - lu(i,882) * b(i,119) - b(i,133) = b(i,133) - lu(i,883) * b(i,119) - b(i,134) = b(i,134) - lu(i,884) * b(i,119) - b(i,135) = b(i,135) - lu(i,885) * b(i,119) - b(i,121) = b(i,121) - lu(i,904) * b(i,120) - b(i,122) = b(i,122) - lu(i,905) * b(i,120) - b(i,123) = b(i,123) - lu(i,906) * b(i,120) - b(i,124) = b(i,124) - lu(i,907) * b(i,120) - b(i,125) = b(i,125) - lu(i,908) * b(i,120) - b(i,126) = b(i,126) - lu(i,909) * b(i,120) - b(i,127) = b(i,127) - lu(i,910) * b(i,120) - b(i,128) = b(i,128) - lu(i,911) * b(i,120) - b(i,129) = b(i,129) - lu(i,912) * b(i,120) - b(i,130) = b(i,130) - lu(i,913) * b(i,120) - b(i,131) = b(i,131) - lu(i,914) * b(i,120) - b(i,134) = b(i,134) - lu(i,915) * b(i,120) - b(i,135) = b(i,135) - lu(i,916) * b(i,120) - b(i,122) = b(i,122) - lu(i,944) * b(i,121) - b(i,123) = b(i,123) - lu(i,945) * b(i,121) - b(i,124) = b(i,124) - lu(i,946) * b(i,121) - b(i,125) = b(i,125) - lu(i,947) * b(i,121) - b(i,126) = b(i,126) - lu(i,948) * b(i,121) - b(i,127) = b(i,127) - lu(i,949) * b(i,121) - b(i,128) = b(i,128) - lu(i,950) * b(i,121) - b(i,129) = b(i,129) - lu(i,951) * b(i,121) - b(i,130) = b(i,130) - lu(i,952) * b(i,121) - b(i,131) = b(i,131) - lu(i,953) * b(i,121) - b(i,132) = b(i,132) - lu(i,954) * b(i,121) - b(i,133) = b(i,133) - lu(i,955) * b(i,121) - b(i,134) = b(i,134) - lu(i,956) * b(i,121) - b(i,135) = b(i,135) - lu(i,957) * b(i,121) - b(i,123) = b(i,123) - lu(i,971) * b(i,122) - b(i,124) = b(i,124) - lu(i,972) * b(i,122) - b(i,125) = b(i,125) - lu(i,973) * b(i,122) - b(i,126) = b(i,126) - lu(i,974) * b(i,122) - b(i,127) = b(i,127) - lu(i,975) * b(i,122) - b(i,128) = b(i,128) - lu(i,976) * b(i,122) - b(i,129) = b(i,129) - lu(i,977) * b(i,122) - b(i,130) = b(i,130) - lu(i,978) * b(i,122) - b(i,131) = b(i,131) - lu(i,979) * b(i,122) - b(i,132) = b(i,132) - lu(i,980) * b(i,122) - b(i,133) = b(i,133) - lu(i,981) * b(i,122) - b(i,134) = b(i,134) - lu(i,982) * b(i,122) - b(i,135) = b(i,135) - lu(i,983) * b(i,122) - b(i,124) = b(i,124) - lu(i,1017) * b(i,123) - b(i,125) = b(i,125) - lu(i,1018) * b(i,123) - b(i,126) = b(i,126) - lu(i,1019) * b(i,123) - b(i,127) = b(i,127) - lu(i,1020) * b(i,123) - b(i,128) = b(i,128) - lu(i,1021) * b(i,123) - b(i,129) = b(i,129) - lu(i,1022) * b(i,123) - b(i,130) = b(i,130) - lu(i,1023) * b(i,123) - b(i,131) = b(i,131) - lu(i,1024) * b(i,123) - b(i,132) = b(i,132) - lu(i,1025) * b(i,123) - b(i,133) = b(i,133) - lu(i,1026) * b(i,123) - b(i,134) = b(i,134) - lu(i,1027) * b(i,123) - b(i,135) = b(i,135) - lu(i,1028) * b(i,123) - b(i,125) = b(i,125) - lu(i,1045) * b(i,124) - b(i,126) = b(i,126) - lu(i,1046) * b(i,124) - b(i,127) = b(i,127) - lu(i,1047) * b(i,124) - b(i,128) = b(i,128) - lu(i,1048) * b(i,124) - b(i,129) = b(i,129) - lu(i,1049) * b(i,124) - b(i,130) = b(i,130) - lu(i,1050) * b(i,124) - b(i,131) = b(i,131) - lu(i,1051) * b(i,124) - b(i,132) = b(i,132) - lu(i,1052) * b(i,124) - b(i,133) = b(i,133) - lu(i,1053) * b(i,124) - b(i,134) = b(i,134) - lu(i,1054) * b(i,124) - b(i,135) = b(i,135) - lu(i,1055) * b(i,124) - b(i,126) = b(i,126) - lu(i,1115) * b(i,125) - b(i,127) = b(i,127) - lu(i,1116) * b(i,125) - b(i,128) = b(i,128) - lu(i,1117) * b(i,125) - b(i,129) = b(i,129) - lu(i,1118) * b(i,125) - b(i,130) = b(i,130) - lu(i,1119) * b(i,125) - b(i,131) = b(i,131) - lu(i,1120) * b(i,125) - b(i,132) = b(i,132) - lu(i,1121) * b(i,125) - b(i,133) = b(i,133) - lu(i,1122) * b(i,125) - b(i,134) = b(i,134) - lu(i,1123) * b(i,125) - b(i,135) = b(i,135) - lu(i,1124) * b(i,125) - b(i,127) = b(i,127) - lu(i,1151) * b(i,126) - b(i,128) = b(i,128) - lu(i,1152) * b(i,126) - b(i,129) = b(i,129) - lu(i,1153) * b(i,126) - b(i,130) = b(i,130) - lu(i,1154) * b(i,126) - b(i,131) = b(i,131) - lu(i,1155) * b(i,126) - b(i,132) = b(i,132) - lu(i,1156) * b(i,126) - b(i,133) = b(i,133) - lu(i,1157) * b(i,126) - b(i,134) = b(i,134) - lu(i,1158) * b(i,126) - b(i,135) = b(i,135) - lu(i,1159) * b(i,126) - b(i,128) = b(i,128) - lu(i,1172) * b(i,127) - b(i,129) = b(i,129) - lu(i,1173) * b(i,127) - b(i,130) = b(i,130) - lu(i,1174) * b(i,127) - b(i,131) = b(i,131) - lu(i,1175) * b(i,127) - b(i,132) = b(i,132) - lu(i,1176) * b(i,127) - b(i,133) = b(i,133) - lu(i,1177) * b(i,127) - b(i,134) = b(i,134) - lu(i,1178) * b(i,127) - b(i,135) = b(i,135) - lu(i,1179) * b(i,127) - b(i,129) = b(i,129) - lu(i,1197) * b(i,128) - b(i,130) = b(i,130) - lu(i,1198) * b(i,128) - b(i,131) = b(i,131) - lu(i,1199) * b(i,128) - b(i,132) = b(i,132) - lu(i,1200) * b(i,128) - b(i,133) = b(i,133) - lu(i,1201) * b(i,128) - b(i,134) = b(i,134) - lu(i,1202) * b(i,128) - b(i,135) = b(i,135) - lu(i,1203) * b(i,128) - b(i,130) = b(i,130) - lu(i,1253) * b(i,129) - b(i,131) = b(i,131) - lu(i,1254) * b(i,129) - b(i,132) = b(i,132) - lu(i,1255) * b(i,129) - b(i,133) = b(i,133) - lu(i,1256) * b(i,129) - b(i,134) = b(i,134) - lu(i,1257) * b(i,129) - b(i,135) = b(i,135) - lu(i,1258) * b(i,129) - b(i,131) = b(i,131) - lu(i,1291) * b(i,130) - b(i,132) = b(i,132) - lu(i,1292) * b(i,130) - b(i,133) = b(i,133) - lu(i,1293) * b(i,130) - b(i,134) = b(i,134) - lu(i,1294) * b(i,130) - b(i,135) = b(i,135) - lu(i,1295) * b(i,130) - b(i,132) = b(i,132) - lu(i,1390) * b(i,131) - b(i,133) = b(i,133) - lu(i,1391) * b(i,131) - b(i,134) = b(i,134) - lu(i,1392) * b(i,131) - b(i,135) = b(i,135) - lu(i,1393) * b(i,131) - b(i,133) = b(i,133) - lu(i,1435) * b(i,132) - b(i,134) = b(i,134) - lu(i,1436) * b(i,132) - b(i,135) = b(i,135) - lu(i,1437) * b(i,132) - b(i,134) = b(i,134) - lu(i,1458) * b(i,133) - b(i,135) = b(i,135) - lu(i,1459) * b(i,133) - b(i,135) = b(i,135) - lu(i,1485) * b(i,134) - enddo - END SUBROUTINE lu_slv04_vec - -#ifdef DOINLINE -!DIR$ ATTRIBUTES FORCEINLINE :: lu_slv05_vec -#else -!DIR$ ATTRIBUTES NOINLINE :: lu_slv05_vec -#endif - SUBROUTINE lu_slv05_vec(ncol,nb,nz,lu, b) - USE shr_kind_mod, ONLY: r4 => shr_kind_r4 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - integer :: ncol,nb,nz - REAL(KIND=r4), intent(in) :: lu(ncol,nz) - REAL(KIND=r4), intent(inout) :: b(ncol,nb) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - integer i - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... Solve U * x = y - !----------------------------------------------------------------------- -!DIR$ ASSUME_ALIGNED lu:64 -!DIR$ ASSUME_ALIGNED b:64 - - do i=1,ncol - b(i,135) = b(i,135) * lu(i,1509) - b(i,134) = b(i,134) - lu(i,1508) * b(i,135) - b(i,133) = b(i,133) - lu(i,1507) * b(i,135) - b(i,132) = b(i,132) - lu(i,1506) * b(i,135) - b(i,131) = b(i,131) - lu(i,1505) * b(i,135) - b(i,130) = b(i,130) - lu(i,1504) * b(i,135) - b(i,129) = b(i,129) - lu(i,1503) * b(i,135) - b(i,128) = b(i,128) - lu(i,1502) * b(i,135) - b(i,127) = b(i,127) - lu(i,1501) * b(i,135) - b(i,126) = b(i,126) - lu(i,1500) * b(i,135) - b(i,125) = b(i,125) - lu(i,1499) * b(i,135) - b(i,124) = b(i,124) - lu(i,1498) * b(i,135) - b(i,123) = b(i,123) - lu(i,1497) * b(i,135) - b(i,122) = b(i,122) - lu(i,1496) * b(i,135) - b(i,121) = b(i,121) - lu(i,1495) * b(i,135) - b(i,120) = b(i,120) - lu(i,1494) * b(i,135) - b(i,119) = b(i,119) - lu(i,1493) * b(i,135) - b(i,118) = b(i,118) - lu(i,1492) * b(i,135) - b(i,117) = b(i,117) - lu(i,1491) * b(i,135) - b(i,108) = b(i,108) - lu(i,1490) * b(i,135) - b(i,103) = b(i,103) - lu(i,1489) * b(i,135) - b(i,90) = b(i,90) - lu(i,1488) * b(i,135) - b(i,64) = b(i,64) - lu(i,1487) * b(i,135) - b(i,54) = b(i,54) - lu(i,1486) * b(i,135) - b(i,134) = b(i,134) * lu(i,1484) - b(i,133) = b(i,133) - lu(i,1483) * b(i,134) - b(i,132) = b(i,132) - lu(i,1482) * b(i,134) - b(i,131) = b(i,131) - lu(i,1481) * b(i,134) - b(i,130) = b(i,130) - lu(i,1480) * b(i,134) - b(i,129) = b(i,129) - lu(i,1479) * b(i,134) - b(i,128) = b(i,128) - lu(i,1478) * b(i,134) - b(i,127) = b(i,127) - lu(i,1477) * b(i,134) - b(i,126) = b(i,126) - lu(i,1476) * b(i,134) - b(i,125) = b(i,125) - lu(i,1475) * b(i,134) - b(i,124) = b(i,124) - lu(i,1474) * b(i,134) - b(i,123) = b(i,123) - lu(i,1473) * b(i,134) - b(i,122) = b(i,122) - lu(i,1472) * b(i,134) - b(i,121) = b(i,121) - lu(i,1471) * b(i,134) - b(i,120) = b(i,120) - lu(i,1470) * b(i,134) - b(i,119) = b(i,119) - lu(i,1469) * b(i,134) - b(i,118) = b(i,118) - lu(i,1468) * b(i,134) - b(i,117) = b(i,117) - lu(i,1467) * b(i,134) - b(i,116) = b(i,116) - lu(i,1466) * b(i,134) - b(i,108) = b(i,108) - lu(i,1465) * b(i,134) - b(i,99) = b(i,99) - lu(i,1464) * b(i,134) - b(i,88) = b(i,88) - lu(i,1463) * b(i,134) - b(i,36) = b(i,36) - lu(i,1462) * b(i,134) - b(i,34) = b(i,34) - lu(i,1461) * b(i,134) - b(i,26) = b(i,26) - lu(i,1460) * b(i,134) - b(i,133) = b(i,133) * lu(i,1457) - b(i,132) = b(i,132) - lu(i,1456) * b(i,133) - b(i,131) = b(i,131) - lu(i,1455) * b(i,133) - b(i,130) = b(i,130) - lu(i,1454) * b(i,133) - b(i,129) = b(i,129) - lu(i,1453) * b(i,133) - b(i,128) = b(i,128) - lu(i,1452) * b(i,133) - b(i,127) = b(i,127) - lu(i,1451) * b(i,133) - b(i,126) = b(i,126) - lu(i,1450) * b(i,133) - b(i,125) = b(i,125) - lu(i,1449) * b(i,133) - b(i,124) = b(i,124) - lu(i,1448) * b(i,133) - b(i,123) = b(i,123) - lu(i,1447) * b(i,133) - b(i,122) = b(i,122) - lu(i,1446) * b(i,133) - b(i,121) = b(i,121) - lu(i,1445) * b(i,133) - b(i,120) = b(i,120) - lu(i,1444) * b(i,133) - b(i,119) = b(i,119) - lu(i,1443) * b(i,133) - b(i,118) = b(i,118) - lu(i,1442) * b(i,133) - b(i,117) = b(i,117) - lu(i,1441) * b(i,133) - b(i,108) = b(i,108) - lu(i,1440) * b(i,133) - b(i,88) = b(i,88) - lu(i,1439) * b(i,133) - b(i,34) = b(i,34) - lu(i,1438) * b(i,133) - b(i,132) = b(i,132) * lu(i,1434) - b(i,131) = b(i,131) - lu(i,1433) * b(i,132) - b(i,130) = b(i,130) - lu(i,1432) * b(i,132) - b(i,129) = b(i,129) - lu(i,1431) * b(i,132) - b(i,128) = b(i,128) - lu(i,1430) * b(i,132) - b(i,127) = b(i,127) - lu(i,1429) * b(i,132) - b(i,126) = b(i,126) - lu(i,1428) * b(i,132) - b(i,125) = b(i,125) - lu(i,1427) * b(i,132) - b(i,124) = b(i,124) - lu(i,1426) * b(i,132) - b(i,123) = b(i,123) - lu(i,1425) * b(i,132) - b(i,122) = b(i,122) - lu(i,1424) * b(i,132) - b(i,121) = b(i,121) - lu(i,1423) * b(i,132) - b(i,120) = b(i,120) - lu(i,1422) * b(i,132) - b(i,119) = b(i,119) - lu(i,1421) * b(i,132) - b(i,118) = b(i,118) - lu(i,1420) * b(i,132) - b(i,116) = b(i,116) - lu(i,1419) * b(i,132) - b(i,115) = b(i,115) - lu(i,1418) * b(i,132) - b(i,114) = b(i,114) - lu(i,1417) * b(i,132) - b(i,113) = b(i,113) - lu(i,1416) * b(i,132) - b(i,112) = b(i,112) - lu(i,1415) * b(i,132) - b(i,111) = b(i,111) - lu(i,1414) * b(i,132) - b(i,110) = b(i,110) - lu(i,1413) * b(i,132) - b(i,109) = b(i,109) - lu(i,1412) * b(i,132) - b(i,107) = b(i,107) - lu(i,1411) * b(i,132) - b(i,106) = b(i,106) - lu(i,1410) * b(i,132) - b(i,105) = b(i,105) - lu(i,1409) * b(i,132) - b(i,104) = b(i,104) - lu(i,1408) * b(i,132) - b(i,103) = b(i,103) - lu(i,1407) * b(i,132) - b(i,102) = b(i,102) - lu(i,1406) * b(i,132) - b(i,101) = b(i,101) - lu(i,1405) * b(i,132) - b(i,99) = b(i,99) - lu(i,1404) * b(i,132) - b(i,98) = b(i,98) - lu(i,1403) * b(i,132) - b(i,97) = b(i,97) - lu(i,1402) * b(i,132) - b(i,95) = b(i,95) - lu(i,1401) * b(i,132) - b(i,94) = b(i,94) - lu(i,1400) * b(i,132) - b(i,81) = b(i,81) - lu(i,1399) * b(i,132) - b(i,73) = b(i,73) - lu(i,1398) * b(i,132) - b(i,49) = b(i,49) - lu(i,1397) * b(i,132) - b(i,47) = b(i,47) - lu(i,1396) * b(i,132) - b(i,40) = b(i,40) - lu(i,1395) * b(i,132) - b(i,39) = b(i,39) - lu(i,1394) * b(i,132) - b(i,131) = b(i,131) * lu(i,1389) - b(i,130) = b(i,130) - lu(i,1388) * b(i,131) - b(i,129) = b(i,129) - lu(i,1387) * b(i,131) - b(i,128) = b(i,128) - lu(i,1386) * b(i,131) - b(i,127) = b(i,127) - lu(i,1385) * b(i,131) - b(i,126) = b(i,126) - lu(i,1384) * b(i,131) - b(i,125) = b(i,125) - lu(i,1383) * b(i,131) - b(i,124) = b(i,124) - lu(i,1382) * b(i,131) - b(i,123) = b(i,123) - lu(i,1381) * b(i,131) - b(i,122) = b(i,122) - lu(i,1380) * b(i,131) - b(i,121) = b(i,121) - lu(i,1379) * b(i,131) - b(i,120) = b(i,120) - lu(i,1378) * b(i,131) - b(i,119) = b(i,119) - lu(i,1377) * b(i,131) - b(i,118) = b(i,118) - lu(i,1376) * b(i,131) - b(i,117) = b(i,117) - lu(i,1375) * b(i,131) - b(i,116) = b(i,116) - lu(i,1374) * b(i,131) - b(i,115) = b(i,115) - lu(i,1373) * b(i,131) - b(i,114) = b(i,114) - lu(i,1372) * b(i,131) - b(i,113) = b(i,113) - lu(i,1371) * b(i,131) - b(i,112) = b(i,112) - lu(i,1370) * b(i,131) - b(i,111) = b(i,111) - lu(i,1369) * b(i,131) - b(i,110) = b(i,110) - lu(i,1368) * b(i,131) - b(i,109) = b(i,109) - lu(i,1367) * b(i,131) - b(i,108) = b(i,108) - lu(i,1366) * b(i,131) - b(i,107) = b(i,107) - lu(i,1365) * b(i,131) - b(i,106) = b(i,106) - lu(i,1364) * b(i,131) - b(i,105) = b(i,105) - lu(i,1363) * b(i,131) - b(i,104) = b(i,104) - lu(i,1362) * b(i,131) - b(i,103) = b(i,103) - lu(i,1361) * b(i,131) - b(i,102) = b(i,102) - lu(i,1360) * b(i,131) - b(i,101) = b(i,101) - lu(i,1359) * b(i,131) - b(i,100) = b(i,100) - lu(i,1358) * b(i,131) - b(i,99) = b(i,99) - lu(i,1357) * b(i,131) - b(i,98) = b(i,98) - lu(i,1356) * b(i,131) - b(i,97) = b(i,97) - lu(i,1355) * b(i,131) - b(i,96) = b(i,96) - lu(i,1354) * b(i,131) - b(i,95) = b(i,95) - lu(i,1353) * b(i,131) - b(i,94) = b(i,94) - lu(i,1352) * b(i,131) - b(i,93) = b(i,93) - lu(i,1351) * b(i,131) - b(i,92) = b(i,92) - lu(i,1350) * b(i,131) - b(i,91) = b(i,91) - lu(i,1349) * b(i,131) - b(i,90) = b(i,90) - lu(i,1348) * b(i,131) - b(i,89) = b(i,89) - lu(i,1347) * b(i,131) - b(i,88) = b(i,88) - lu(i,1346) * b(i,131) - b(i,83) = b(i,83) - lu(i,1345) * b(i,131) - b(i,82) = b(i,82) - lu(i,1344) * b(i,131) - b(i,81) = b(i,81) - lu(i,1343) * b(i,131) - b(i,80) = b(i,80) - lu(i,1342) * b(i,131) - b(i,79) = b(i,79) - lu(i,1341) * b(i,131) - b(i,77) = b(i,77) - lu(i,1340) * b(i,131) - b(i,76) = b(i,76) - lu(i,1339) * b(i,131) - b(i,75) = b(i,75) - lu(i,1338) * b(i,131) - b(i,74) = b(i,74) - lu(i,1337) * b(i,131) - b(i,73) = b(i,73) - lu(i,1336) * b(i,131) - b(i,71) = b(i,71) - lu(i,1335) * b(i,131) - b(i,69) = b(i,69) - lu(i,1334) * b(i,131) - b(i,68) = b(i,68) - lu(i,1333) * b(i,131) - b(i,67) = b(i,67) - lu(i,1332) * b(i,131) - b(i,66) = b(i,66) - lu(i,1331) * b(i,131) - b(i,65) = b(i,65) - lu(i,1330) * b(i,131) - b(i,64) = b(i,64) - lu(i,1329) * b(i,131) - b(i,63) = b(i,63) - lu(i,1328) * b(i,131) - b(i,62) = b(i,62) - lu(i,1327) * b(i,131) - b(i,60) = b(i,60) - lu(i,1326) * b(i,131) - b(i,59) = b(i,59) - lu(i,1325) * b(i,131) - b(i,57) = b(i,57) - lu(i,1324) * b(i,131) - b(i,55) = b(i,55) - lu(i,1323) * b(i,131) - b(i,53) = b(i,53) - lu(i,1322) * b(i,131) - b(i,52) = b(i,52) - lu(i,1321) * b(i,131) - b(i,51) = b(i,51) - lu(i,1320) * b(i,131) - b(i,50) = b(i,50) - lu(i,1319) * b(i,131) - b(i,49) = b(i,49) - lu(i,1318) * b(i,131) - b(i,48) = b(i,48) - lu(i,1317) * b(i,131) - b(i,47) = b(i,47) - lu(i,1316) * b(i,131) - b(i,45) = b(i,45) - lu(i,1315) * b(i,131) - b(i,44) = b(i,44) - lu(i,1314) * b(i,131) - b(i,43) = b(i,43) - lu(i,1313) * b(i,131) - b(i,42) = b(i,42) - lu(i,1312) * b(i,131) - b(i,41) = b(i,41) - lu(i,1311) * b(i,131) - b(i,39) = b(i,39) - lu(i,1310) * b(i,131) - b(i,38) = b(i,38) - lu(i,1309) * b(i,131) - b(i,37) = b(i,37) - lu(i,1308) * b(i,131) - b(i,36) = b(i,36) - lu(i,1307) * b(i,131) - b(i,35) = b(i,35) - lu(i,1306) * b(i,131) - b(i,32) = b(i,32) - lu(i,1305) * b(i,131) - b(i,31) = b(i,31) - lu(i,1304) * b(i,131) - b(i,30) = b(i,30) - lu(i,1303) * b(i,131) - b(i,25) = b(i,25) - lu(i,1302) * b(i,131) - b(i,23) = b(i,23) - lu(i,1301) * b(i,131) - b(i,22) = b(i,22) - lu(i,1300) * b(i,131) - b(i,21) = b(i,21) - lu(i,1299) * b(i,131) - b(i,20) = b(i,20) - lu(i,1298) * b(i,131) - b(i,19) = b(i,19) - lu(i,1297) * b(i,131) - b(i,17) = b(i,17) - lu(i,1296) * b(i,131) - enddo - END SUBROUTINE lu_slv05_vec - -#ifdef DOINLINE -!DIR$ ATTRIBUTES FORCEINLINE :: lu_slv06_vec -#else -!DIR$ ATTRIBUTES NOINLINE :: lu_slv06_vec -#endif - SUBROUTINE lu_slv06_vec(ncol,nb,nz,lu, b) - USE shr_kind_mod, ONLY: r4 => shr_kind_r4 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - integer :: ncol,nb,nz - REAL(KIND=r4), intent(in) :: lu(ncol,nz) - REAL(KIND=r4), intent(inout) :: b(ncol,nb) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - integer :: i - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- -!DIR$ ASSUME_ALIGNED lu:64 -!DIR$ ASSUME_ALIGNED b:64 - do i=1,ncol - b(i,130) = b(i,130) * lu(i,1290) - b(i,129) = b(i,129) - lu(i,1289) * b(i,130) - b(i,128) = b(i,128) - lu(i,1288) * b(i,130) - b(i,127) = b(i,127) - lu(i,1287) * b(i,130) - b(i,126) = b(i,126) - lu(i,1286) * b(i,130) - b(i,125) = b(i,125) - lu(i,1285) * b(i,130) - b(i,124) = b(i,124) - lu(i,1284) * b(i,130) - b(i,123) = b(i,123) - lu(i,1283) * b(i,130) - b(i,122) = b(i,122) - lu(i,1282) * b(i,130) - b(i,121) = b(i,121) - lu(i,1281) * b(i,130) - b(i,120) = b(i,120) - lu(i,1280) * b(i,130) - b(i,119) = b(i,119) - lu(i,1279) * b(i,130) - b(i,118) = b(i,118) - lu(i,1278) * b(i,130) - b(i,117) = b(i,117) - lu(i,1277) * b(i,130) - b(i,116) = b(i,116) - lu(i,1276) * b(i,130) - b(i,115) = b(i,115) - lu(i,1275) * b(i,130) - b(i,114) = b(i,114) - lu(i,1274) * b(i,130) - b(i,109) = b(i,109) - lu(i,1273) * b(i,130) - b(i,105) = b(i,105) - lu(i,1272) * b(i,130) - b(i,103) = b(i,103) - lu(i,1271) * b(i,130) - b(i,100) = b(i,100) - lu(i,1270) * b(i,130) - b(i,99) = b(i,99) - lu(i,1269) * b(i,130) - b(i,92) = b(i,92) - lu(i,1268) * b(i,130) - b(i,84) = b(i,84) - lu(i,1267) * b(i,130) - b(i,81) = b(i,81) - lu(i,1266) * b(i,130) - b(i,71) = b(i,71) - lu(i,1265) * b(i,130) - b(i,70) = b(i,70) - lu(i,1264) * b(i,130) - b(i,66) = b(i,66) - lu(i,1263) * b(i,130) - b(i,60) = b(i,60) - lu(i,1262) * b(i,130) - b(i,57) = b(i,57) - lu(i,1261) * b(i,130) - b(i,40) = b(i,40) - lu(i,1260) * b(i,130) - b(i,31) = b(i,31) - lu(i,1259) * b(i,130) - b(i,129) = b(i,129) * lu(i,1252) - b(i,128) = b(i,128) - lu(i,1251) * b(i,129) - b(i,127) = b(i,127) - lu(i,1250) * b(i,129) - b(i,126) = b(i,126) - lu(i,1249) * b(i,129) - b(i,125) = b(i,125) - lu(i,1248) * b(i,129) - b(i,124) = b(i,124) - lu(i,1247) * b(i,129) - b(i,123) = b(i,123) - lu(i,1246) * b(i,129) - b(i,122) = b(i,122) - lu(i,1245) * b(i,129) - b(i,121) = b(i,121) - lu(i,1244) * b(i,129) - b(i,120) = b(i,120) - lu(i,1243) * b(i,129) - b(i,119) = b(i,119) - lu(i,1242) * b(i,129) - b(i,118) = b(i,118) - lu(i,1241) * b(i,129) - b(i,115) = b(i,115) - lu(i,1240) * b(i,129) - b(i,114) = b(i,114) - lu(i,1239) * b(i,129) - b(i,113) = b(i,113) - lu(i,1238) * b(i,129) - b(i,112) = b(i,112) - lu(i,1237) * b(i,129) - b(i,111) = b(i,111) - lu(i,1236) * b(i,129) - b(i,110) = b(i,110) - lu(i,1235) * b(i,129) - b(i,109) = b(i,109) - lu(i,1234) * b(i,129) - b(i,107) = b(i,107) - lu(i,1233) * b(i,129) - b(i,106) = b(i,106) - lu(i,1232) * b(i,129) - b(i,105) = b(i,105) - lu(i,1231) * b(i,129) - b(i,104) = b(i,104) - lu(i,1230) * b(i,129) - b(i,103) = b(i,103) - lu(i,1229) * b(i,129) - b(i,101) = b(i,101) - lu(i,1228) * b(i,129) - b(i,98) = b(i,98) - lu(i,1227) * b(i,129) - b(i,97) = b(i,97) - lu(i,1226) * b(i,129) - b(i,96) = b(i,96) - lu(i,1225) * b(i,129) - b(i,95) = b(i,95) - lu(i,1224) * b(i,129) - b(i,92) = b(i,92) - lu(i,1223) * b(i,129) - b(i,91) = b(i,91) - lu(i,1222) * b(i,129) - b(i,89) = b(i,89) - lu(i,1221) * b(i,129) - b(i,87) = b(i,87) - lu(i,1220) * b(i,129) - b(i,86) = b(i,86) - lu(i,1219) * b(i,129) - b(i,85) = b(i,85) - lu(i,1218) * b(i,129) - b(i,83) = b(i,83) - lu(i,1217) * b(i,129) - b(i,81) = b(i,81) - lu(i,1216) * b(i,129) - b(i,80) = b(i,80) - lu(i,1215) * b(i,129) - b(i,79) = b(i,79) - lu(i,1214) * b(i,129) - b(i,77) = b(i,77) - lu(i,1213) * b(i,129) - b(i,66) = b(i,66) - lu(i,1212) * b(i,129) - b(i,65) = b(i,65) - lu(i,1211) * b(i,129) - b(i,64) = b(i,64) - lu(i,1210) * b(i,129) - b(i,56) = b(i,56) - lu(i,1209) * b(i,129) - b(i,55) = b(i,55) - lu(i,1208) * b(i,129) - b(i,54) = b(i,54) - lu(i,1207) * b(i,129) - b(i,49) = b(i,49) - lu(i,1206) * b(i,129) - b(i,47) = b(i,47) - lu(i,1205) * b(i,129) - b(i,41) = b(i,41) - lu(i,1204) * b(i,129) - b(i,128) = b(i,128) * lu(i,1196) - b(i,127) = b(i,127) - lu(i,1195) * b(i,128) - b(i,126) = b(i,126) - lu(i,1194) * b(i,128) - b(i,125) = b(i,125) - lu(i,1193) * b(i,128) - b(i,124) = b(i,124) - lu(i,1192) * b(i,128) - b(i,123) = b(i,123) - lu(i,1191) * b(i,128) - b(i,122) = b(i,122) - lu(i,1190) * b(i,128) - b(i,121) = b(i,121) - lu(i,1189) * b(i,128) - b(i,120) = b(i,120) - lu(i,1188) * b(i,128) - b(i,118) = b(i,118) - lu(i,1187) * b(i,128) - b(i,117) = b(i,117) - lu(i,1186) * b(i,128) - b(i,116) = b(i,116) - lu(i,1185) * b(i,128) - b(i,99) = b(i,99) - lu(i,1184) * b(i,128) - b(i,84) = b(i,84) - lu(i,1183) * b(i,128) - b(i,70) = b(i,70) - lu(i,1182) * b(i,128) - b(i,46) = b(i,46) - lu(i,1181) * b(i,128) - b(i,33) = b(i,33) - lu(i,1180) * b(i,128) - b(i,127) = b(i,127) * lu(i,1171) - b(i,126) = b(i,126) - lu(i,1170) * b(i,127) - b(i,125) = b(i,125) - lu(i,1169) * b(i,127) - b(i,124) = b(i,124) - lu(i,1168) * b(i,127) - b(i,123) = b(i,123) - lu(i,1167) * b(i,127) - b(i,122) = b(i,122) - lu(i,1166) * b(i,127) - b(i,121) = b(i,121) - lu(i,1165) * b(i,127) - b(i,120) = b(i,120) - lu(i,1164) * b(i,127) - b(i,119) = b(i,119) - lu(i,1163) * b(i,127) - b(i,118) = b(i,118) - lu(i,1162) * b(i,127) - b(i,117) = b(i,117) - lu(i,1161) * b(i,127) - b(i,108) = b(i,108) - lu(i,1160) * b(i,127) - b(i,126) = b(i,126) * lu(i,1150) - b(i,125) = b(i,125) - lu(i,1149) * b(i,126) - b(i,124) = b(i,124) - lu(i,1148) * b(i,126) - b(i,123) = b(i,123) - lu(i,1147) * b(i,126) - b(i,122) = b(i,122) - lu(i,1146) * b(i,126) - b(i,121) = b(i,121) - lu(i,1145) * b(i,126) - b(i,120) = b(i,120) - lu(i,1144) * b(i,126) - b(i,119) = b(i,119) - lu(i,1143) * b(i,126) - b(i,118) = b(i,118) - lu(i,1142) * b(i,126) - b(i,117) = b(i,117) - lu(i,1141) * b(i,126) - b(i,115) = b(i,115) - lu(i,1140) * b(i,126) - b(i,108) = b(i,108) - lu(i,1139) * b(i,126) - b(i,104) = b(i,104) - lu(i,1138) * b(i,126) - b(i,103) = b(i,103) - lu(i,1137) * b(i,126) - b(i,100) = b(i,100) - lu(i,1136) * b(i,126) - b(i,95) = b(i,95) - lu(i,1135) * b(i,126) - b(i,93) = b(i,93) - lu(i,1134) * b(i,126) - b(i,91) = b(i,91) - lu(i,1133) * b(i,126) - b(i,83) = b(i,83) - lu(i,1132) * b(i,126) - b(i,81) = b(i,81) - lu(i,1131) * b(i,126) - b(i,74) = b(i,74) - lu(i,1130) * b(i,126) - b(i,64) = b(i,64) - lu(i,1129) * b(i,126) - b(i,63) = b(i,63) - lu(i,1128) * b(i,126) - b(i,38) = b(i,38) - lu(i,1127) * b(i,126) - b(i,37) = b(i,37) - lu(i,1126) * b(i,126) - b(i,29) = b(i,29) - lu(i,1125) * b(i,126) - b(i,125) = b(i,125) * lu(i,1114) - b(i,124) = b(i,124) - lu(i,1113) * b(i,125) - b(i,123) = b(i,123) - lu(i,1112) * b(i,125) - b(i,122) = b(i,122) - lu(i,1111) * b(i,125) - b(i,121) = b(i,121) - lu(i,1110) * b(i,125) - b(i,120) = b(i,120) - lu(i,1109) * b(i,125) - b(i,119) = b(i,119) - lu(i,1108) * b(i,125) - b(i,118) = b(i,118) - lu(i,1107) * b(i,125) - b(i,117) = b(i,117) - lu(i,1106) * b(i,125) - b(i,115) = b(i,115) - lu(i,1105) * b(i,125) - b(i,114) = b(i,114) - lu(i,1104) * b(i,125) - b(i,113) = b(i,113) - lu(i,1103) * b(i,125) - b(i,112) = b(i,112) - lu(i,1102) * b(i,125) - b(i,111) = b(i,111) - lu(i,1101) * b(i,125) - b(i,110) = b(i,110) - lu(i,1100) * b(i,125) - b(i,109) = b(i,109) - lu(i,1099) * b(i,125) - b(i,108) = b(i,108) - lu(i,1098) * b(i,125) - b(i,107) = b(i,107) - lu(i,1097) * b(i,125) - b(i,106) = b(i,106) - lu(i,1096) * b(i,125) - b(i,105) = b(i,105) - lu(i,1095) * b(i,125) - b(i,104) = b(i,104) - lu(i,1094) * b(i,125) - b(i,103) = b(i,103) - lu(i,1093) * b(i,125) - b(i,101) = b(i,101) - lu(i,1092) * b(i,125) - b(i,98) = b(i,98) - lu(i,1091) * b(i,125) - b(i,97) = b(i,97) - lu(i,1090) * b(i,125) - b(i,96) = b(i,96) - lu(i,1089) * b(i,125) - b(i,95) = b(i,95) - lu(i,1088) * b(i,125) - b(i,93) = b(i,93) - lu(i,1087) * b(i,125) - b(i,91) = b(i,91) - lu(i,1086) * b(i,125) - b(i,90) = b(i,90) - lu(i,1085) * b(i,125) - b(i,89) = b(i,89) - lu(i,1084) * b(i,125) - b(i,84) = b(i,84) - lu(i,1083) * b(i,125) - b(i,83) = b(i,83) - lu(i,1082) * b(i,125) - b(i,81) = b(i,81) - lu(i,1081) * b(i,125) - b(i,80) = b(i,80) - lu(i,1080) * b(i,125) - b(i,79) = b(i,79) - lu(i,1079) * b(i,125) - b(i,77) = b(i,77) - lu(i,1078) * b(i,125) - b(i,76) = b(i,76) - lu(i,1077) * b(i,125) - b(i,75) = b(i,75) - lu(i,1076) * b(i,125) - b(i,74) = b(i,74) - lu(i,1075) * b(i,125) - b(i,69) = b(i,69) - lu(i,1074) * b(i,125) - b(i,67) = b(i,67) - lu(i,1073) * b(i,125) - b(i,66) = b(i,66) - lu(i,1072) * b(i,125) - b(i,65) = b(i,65) - lu(i,1071) * b(i,125) - b(i,64) = b(i,64) - lu(i,1070) * b(i,125) - b(i,62) = b(i,62) - lu(i,1069) * b(i,125) - b(i,60) = b(i,60) - lu(i,1068) * b(i,125) - b(i,59) = b(i,59) - lu(i,1067) * b(i,125) - b(i,56) = b(i,56) - lu(i,1066) * b(i,125) - b(i,54) = b(i,54) - lu(i,1065) * b(i,125) - b(i,53) = b(i,53) - lu(i,1064) * b(i,125) - b(i,52) = b(i,52) - lu(i,1063) * b(i,125) - b(i,51) = b(i,51) - lu(i,1062) * b(i,125) - b(i,50) = b(i,50) - lu(i,1061) * b(i,125) - b(i,45) = b(i,45) - lu(i,1060) * b(i,125) - b(i,44) = b(i,44) - lu(i,1059) * b(i,125) - b(i,43) = b(i,43) - lu(i,1058) * b(i,125) - b(i,42) = b(i,42) - lu(i,1057) * b(i,125) - b(i,24) = b(i,24) - lu(i,1056) * b(i,125) - b(i,124) = b(i,124) * lu(i,1044) - b(i,123) = b(i,123) - lu(i,1043) * b(i,124) - b(i,122) = b(i,122) - lu(i,1042) * b(i,124) - b(i,121) = b(i,121) - lu(i,1041) * b(i,124) - b(i,120) = b(i,120) - lu(i,1040) * b(i,124) - b(i,119) = b(i,119) - lu(i,1039) * b(i,124) - b(i,118) = b(i,118) - lu(i,1038) * b(i,124) - b(i,117) = b(i,117) - lu(i,1037) * b(i,124) - b(i,116) = b(i,116) - lu(i,1036) * b(i,124) - b(i,100) = b(i,100) - lu(i,1035) * b(i,124) - b(i,99) = b(i,99) - lu(i,1034) * b(i,124) - b(i,93) = b(i,93) - lu(i,1033) * b(i,124) - b(i,46) = b(i,46) - lu(i,1032) * b(i,124) - b(i,33) = b(i,33) - lu(i,1031) * b(i,124) - b(i,29) = b(i,29) - lu(i,1030) * b(i,124) - b(i,18) = b(i,18) - lu(i,1029) * b(i,124) - enddo - END SUBROUTINE lu_slv06_vec - -#ifdef DOINLINE -!DIR$ ATTRIBUTES FORCEINLINE :: lu_slv07_vec -#else -!DIR$ ATTRIBUTES NOINLINE :: lu_slv07_vec -#endif - SUBROUTINE lu_slv07_vec(ncol,nb,nz,lu, b) - USE shr_kind_mod, ONLY: r4 => shr_kind_r4 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - integer :: ncol,nb,nz - REAL(KIND=r4), intent(in) :: lu(ncol,nz) - REAL(KIND=r4), intent(inout) :: b(ncol,nb) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - integer :: i - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- -!DIR$ ASSUME_ALIGNED lu:64 -!DIR$ ASSUME_ALIGNED b:64 - do i=1,ncol - b(i,123) = b(i,123) * lu(i,1016) - b(i,122) = b(i,122) - lu(i,1015) * b(i,123) - b(i,121) = b(i,121) - lu(i,1014) * b(i,123) - b(i,120) = b(i,120) - lu(i,1013) * b(i,123) - b(i,119) = b(i,119) - lu(i,1012) * b(i,123) - b(i,118) = b(i,118) - lu(i,1011) * b(i,123) - b(i,116) = b(i,116) - lu(i,1010) * b(i,123) - b(i,115) = b(i,115) - lu(i,1009) * b(i,123) - b(i,114) = b(i,114) - lu(i,1008) * b(i,123) - b(i,113) = b(i,113) - lu(i,1007) * b(i,123) - b(i,112) = b(i,112) - lu(i,1006) * b(i,123) - b(i,111) = b(i,111) - lu(i,1005) * b(i,123) - b(i,110) = b(i,110) - lu(i,1004) * b(i,123) - b(i,109) = b(i,109) - lu(i,1003) * b(i,123) - b(i,107) = b(i,107) - lu(i,1002) * b(i,123) - b(i,106) = b(i,106) - lu(i,1001) * b(i,123) - b(i,105) = b(i,105) - lu(i,1000) * b(i,123) - b(i,104) = b(i,104) - lu(i,999) * b(i,123) - b(i,103) = b(i,103) - lu(i,998) * b(i,123) - b(i,102) = b(i,102) - lu(i,997) * b(i,123) - b(i,101) = b(i,101) - lu(i,996) * b(i,123) - b(i,99) = b(i,99) - lu(i,995) * b(i,123) - b(i,98) = b(i,98) - lu(i,994) * b(i,123) - b(i,95) = b(i,95) - lu(i,993) * b(i,123) - b(i,94) = b(i,94) - lu(i,992) * b(i,123) - b(i,83) = b(i,83) - lu(i,991) * b(i,123) - b(i,82) = b(i,82) - lu(i,990) * b(i,123) - b(i,75) = b(i,75) - lu(i,989) * b(i,123) - b(i,73) = b(i,73) - lu(i,988) * b(i,123) - b(i,64) = b(i,64) - lu(i,987) * b(i,123) - b(i,63) = b(i,63) - lu(i,986) * b(i,123) - b(i,28) = b(i,28) - lu(i,985) * b(i,123) - b(i,27) = b(i,27) - lu(i,984) * b(i,123) - b(i,122) = b(i,122) * lu(i,970) - b(i,121) = b(i,121) - lu(i,969) * b(i,122) - b(i,120) = b(i,120) - lu(i,968) * b(i,122) - b(i,119) = b(i,119) - lu(i,967) * b(i,122) - b(i,118) = b(i,118) - lu(i,966) * b(i,122) - b(i,117) = b(i,117) - lu(i,965) * b(i,122) - b(i,108) = b(i,108) - lu(i,964) * b(i,122) - b(i,90) = b(i,90) - lu(i,963) * b(i,122) - b(i,88) = b(i,88) - lu(i,962) * b(i,122) - b(i,32) = b(i,32) - lu(i,961) * b(i,122) - b(i,30) = b(i,30) - lu(i,960) * b(i,122) - b(i,28) = b(i,28) - lu(i,959) * b(i,122) - b(i,25) = b(i,25) - lu(i,958) * b(i,122) - b(i,121) = b(i,121) * lu(i,943) - b(i,120) = b(i,120) - lu(i,942) * b(i,121) - b(i,119) = b(i,119) - lu(i,941) * b(i,121) - b(i,118) = b(i,118) - lu(i,940) * b(i,121) - b(i,117) = b(i,117) - lu(i,939) * b(i,121) - b(i,116) = b(i,116) - lu(i,938) * b(i,121) - b(i,108) = b(i,108) - lu(i,937) * b(i,121) - b(i,103) = b(i,103) - lu(i,936) * b(i,121) - b(i,100) = b(i,100) - lu(i,935) * b(i,121) - b(i,99) = b(i,99) - lu(i,934) * b(i,121) - b(i,93) = b(i,93) - lu(i,933) * b(i,121) - b(i,92) = b(i,92) - lu(i,932) * b(i,121) - b(i,90) = b(i,90) - lu(i,931) * b(i,121) - b(i,87) = b(i,87) - lu(i,930) * b(i,121) - b(i,86) = b(i,86) - lu(i,929) * b(i,121) - b(i,85) = b(i,85) - lu(i,928) * b(i,121) - b(i,84) = b(i,84) - lu(i,927) * b(i,121) - b(i,82) = b(i,82) - lu(i,926) * b(i,121) - b(i,78) = b(i,78) - lu(i,925) * b(i,121) - b(i,74) = b(i,74) - lu(i,924) * b(i,121) - b(i,72) = b(i,72) - lu(i,923) * b(i,121) - b(i,70) = b(i,70) - lu(i,922) * b(i,121) - b(i,61) = b(i,61) - lu(i,921) * b(i,121) - b(i,58) = b(i,58) - lu(i,920) * b(i,121) - b(i,48) = b(i,48) - lu(i,919) * b(i,121) - b(i,28) = b(i,28) - lu(i,918) * b(i,121) - b(i,27) = b(i,27) - lu(i,917) * b(i,121) - b(i,120) = b(i,120) * lu(i,903) - b(i,118) = b(i,118) - lu(i,902) * b(i,120) - b(i,116) = b(i,116) - lu(i,901) * b(i,120) - b(i,103) = b(i,103) - lu(i,900) * b(i,120) - b(i,99) = b(i,99) - lu(i,899) * b(i,120) - b(i,95) = b(i,95) - lu(i,898) * b(i,120) - b(i,92) = b(i,92) - lu(i,897) * b(i,120) - b(i,87) = b(i,87) - lu(i,896) * b(i,120) - b(i,86) = b(i,86) - lu(i,895) * b(i,120) - b(i,85) = b(i,85) - lu(i,894) * b(i,120) - b(i,82) = b(i,82) - lu(i,893) * b(i,120) - b(i,78) = b(i,78) - lu(i,892) * b(i,120) - b(i,72) = b(i,72) - lu(i,891) * b(i,120) - b(i,61) = b(i,61) - lu(i,890) * b(i,120) - b(i,58) = b(i,58) - lu(i,889) * b(i,120) - b(i,56) = b(i,56) - lu(i,888) * b(i,120) - b(i,28) = b(i,28) - lu(i,887) * b(i,120) - b(i,27) = b(i,27) - lu(i,886) * b(i,120) - b(i,119) = b(i,119) * lu(i,872) - b(i,115) = b(i,115) - lu(i,871) * b(i,119) - b(i,114) = b(i,114) - lu(i,870) * b(i,119) - b(i,113) = b(i,113) - lu(i,869) * b(i,119) - b(i,112) = b(i,112) - lu(i,868) * b(i,119) - b(i,111) = b(i,111) - lu(i,867) * b(i,119) - b(i,110) = b(i,110) - lu(i,866) * b(i,119) - b(i,109) = b(i,109) - lu(i,865) * b(i,119) - b(i,107) = b(i,107) - lu(i,864) * b(i,119) - b(i,106) = b(i,106) - lu(i,863) * b(i,119) - b(i,105) = b(i,105) - lu(i,862) * b(i,119) - b(i,104) = b(i,104) - lu(i,861) * b(i,119) - b(i,103) = b(i,103) - lu(i,860) * b(i,119) - b(i,96) = b(i,96) - lu(i,859) * b(i,119) - b(i,95) = b(i,95) - lu(i,858) * b(i,119) - b(i,91) = b(i,91) - lu(i,857) * b(i,119) - b(i,81) = b(i,81) - lu(i,856) * b(i,119) - b(i,80) = b(i,80) - lu(i,855) * b(i,119) - b(i,75) = b(i,75) - lu(i,854) * b(i,119) - b(i,68) = b(i,68) - lu(i,853) * b(i,119) - b(i,50) = b(i,50) - lu(i,852) * b(i,119) - b(i,47) = b(i,47) - lu(i,851) * b(i,119) - b(i,35) = b(i,35) - lu(i,850) * b(i,119) - b(i,118) = b(i,118) * lu(i,839) - b(i,103) = b(i,103) - lu(i,838) * b(i,118) - b(i,90) = b(i,90) - lu(i,837) * b(i,118) - b(i,117) = b(i,117) * lu(i,824) - b(i,100) = b(i,100) - lu(i,823) * b(i,117) - b(i,93) = b(i,93) - lu(i,822) * b(i,117) - b(i,84) = b(i,84) - lu(i,821) * b(i,117) - b(i,33) = b(i,33) - lu(i,820) * b(i,117) - b(i,29) = b(i,29) - lu(i,819) * b(i,117) - b(i,116) = b(i,116) * lu(i,805) - b(i,99) = b(i,99) - lu(i,804) * b(i,116) - b(i,82) = b(i,82) - lu(i,803) * b(i,116) - b(i,46) = b(i,46) - lu(i,802) * b(i,116) - b(i,115) = b(i,115) * lu(i,789) - b(i,114) = b(i,114) - lu(i,788) * b(i,115) - b(i,113) = b(i,113) - lu(i,787) * b(i,115) - b(i,112) = b(i,112) - lu(i,786) * b(i,115) - b(i,111) = b(i,111) - lu(i,785) * b(i,115) - b(i,110) = b(i,110) - lu(i,784) * b(i,115) - b(i,109) = b(i,109) - lu(i,783) * b(i,115) - b(i,107) = b(i,107) - lu(i,782) * b(i,115) - b(i,105) = b(i,105) - lu(i,781) * b(i,115) - b(i,103) = b(i,103) - lu(i,780) * b(i,115) - b(i,95) = b(i,95) - lu(i,779) * b(i,115) - b(i,81) = b(i,81) - lu(i,778) * b(i,115) - b(i,75) = b(i,75) - lu(i,777) * b(i,115) - b(i,62) = b(i,62) - lu(i,776) * b(i,115) - b(i,57) = b(i,57) - lu(i,775) * b(i,115) - b(i,47) = b(i,47) - lu(i,774) * b(i,115) - b(i,114) = b(i,114) * lu(i,760) - b(i,109) = b(i,109) - lu(i,759) * b(i,114) - b(i,105) = b(i,105) - lu(i,758) * b(i,114) - b(i,75) = b(i,75) - lu(i,757) * b(i,114) - b(i,71) = b(i,71) - lu(i,756) * b(i,114) - b(i,62) = b(i,62) - lu(i,755) * b(i,114) - b(i,113) = b(i,113) * lu(i,740) - b(i,112) = b(i,112) - lu(i,739) * b(i,113) - b(i,109) = b(i,109) - lu(i,738) * b(i,113) - b(i,105) = b(i,105) - lu(i,737) * b(i,113) - b(i,104) = b(i,104) - lu(i,736) * b(i,113) - b(i,103) = b(i,103) - lu(i,735) * b(i,113) - b(i,102) = b(i,102) - lu(i,734) * b(i,113) - b(i,112) = b(i,112) * lu(i,721) - b(i,110) = b(i,110) - lu(i,720) * b(i,112) - b(i,109) = b(i,109) - lu(i,719) * b(i,112) - b(i,105) = b(i,105) - lu(i,718) * b(i,112) - b(i,103) = b(i,103) - lu(i,717) * b(i,112) - b(i,97) = b(i,97) - lu(i,716) * b(i,112) - b(i,95) = b(i,95) - lu(i,715) * b(i,112) - b(i,68) = b(i,68) - lu(i,714) * b(i,112) - b(i,43) = b(i,43) - lu(i,713) * b(i,112) - b(i,111) = b(i,111) * lu(i,697) - b(i,110) = b(i,110) - lu(i,696) * b(i,111) - b(i,109) = b(i,109) - lu(i,695) * b(i,111) - b(i,107) = b(i,107) - lu(i,694) * b(i,111) - b(i,103) = b(i,103) - lu(i,693) * b(i,111) - b(i,97) = b(i,97) - lu(i,692) * b(i,111) - b(i,69) = b(i,69) - lu(i,691) * b(i,111) - b(i,68) = b(i,68) - lu(i,690) * b(i,111) - b(i,47) = b(i,47) - lu(i,689) * b(i,111) - b(i,110) = b(i,110) * lu(i,677) - b(i,109) = b(i,109) - lu(i,676) * b(i,110) - b(i,105) = b(i,105) - lu(i,675) * b(i,110) - b(i,103) = b(i,103) - lu(i,674) * b(i,110) - b(i,95) = b(i,95) - lu(i,673) * b(i,110) - b(i,81) = b(i,81) - lu(i,672) * b(i,110) - b(i,68) = b(i,68) - lu(i,671) * b(i,110) - b(i,45) = b(i,45) - lu(i,670) * b(i,110) - b(i,109) = b(i,109) * lu(i,662) - b(i,103) = b(i,103) - lu(i,661) * b(i,109) - b(i,108) = b(i,108) * lu(i,650) - b(i,88) = b(i,88) - lu(i,649) * b(i,108) - b(i,34) = b(i,34) - lu(i,648) * b(i,108) - b(i,107) = b(i,107) * lu(i,637) - b(i,103) = b(i,103) - lu(i,636) * b(i,107) - b(i,106) = b(i,106) * lu(i,625) - b(i,105) = b(i,105) - lu(i,624) * b(i,106) - b(i,68) = b(i,68) - lu(i,623) * b(i,106) - b(i,53) = b(i,53) - lu(i,622) * b(i,106) - b(i,105) = b(i,105) * lu(i,616) - b(i,104) = b(i,104) * lu(i,607) - b(i,103) = b(i,103) - lu(i,606) * b(i,104) - b(i,103) = b(i,103) * lu(i,602) - b(i,102) = b(i,102) * lu(i,587) - b(i,89) = b(i,89) - lu(i,586) * b(i,102) - b(i,75) = b(i,75) - lu(i,585) * b(i,102) - b(i,49) = b(i,49) - lu(i,584) * b(i,102) - enddo - END SUBROUTINE lu_slv07_vec - -#ifdef DOINLINE -!DIR$ ATTRIBUTES FORCEINLINE :: lu_slv08_vec -#else -!DIR$ ATTRIBUTES NOINLINE :: lu_slv08_vec -#endif - SUBROUTINE lu_slv08_vec(ncol,nb,nz,lu, b) - USE shr_kind_mod, ONLY: r4 => shr_kind_r4 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - integer :: ncol,nb,nz - REAL(KIND=r4), intent(in) :: lu(ncol,nz) - REAL(KIND=r4), intent(inout) :: b(ncol,nb) - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - integer :: i - !----------------------------------------------------------------------- - ! ... solve L * y = b - !----------------------------------------------------------------------- -!DIR$ ASSUME_ALIGNED lu:64 -!DIR$ ASSUME_ALIGNED b:64 - do i=1,ncol - b(i,101) = b(i,101) * lu(i,572) - b(i,97) = b(i,97) - lu(i,571) * b(i,101) - b(i,45) = b(i,45) - lu(i,570) * b(i,101) - b(i,100) = b(i,100) * lu(i,560) - b(i,93) = b(i,93) - lu(i,559) * b(i,100) - b(i,29) = b(i,29) - lu(i,558) * b(i,100) - b(i,99) = b(i,99) * lu(i,552) - b(i,36) = b(i,36) - lu(i,551) * b(i,99) - b(i,98) = b(i,98) * lu(i,540) - b(i,80) = b(i,80) - lu(i,539) * b(i,98) - b(i,59) = b(i,59) - lu(i,538) * b(i,98) - b(i,97) = b(i,97) * lu(i,530) - b(i,47) = b(i,47) - lu(i,529) * b(i,97) - b(i,96) = b(i,96) * lu(i,517) - b(i,80) = b(i,80) - lu(i,516) * b(i,96) - b(i,52) = b(i,52) - lu(i,515) * b(i,96) - b(i,95) = b(i,95) * lu(i,510) - b(i,81) = b(i,81) - lu(i,509) * b(i,95) - b(i,94) = b(i,94) * lu(i,494) - b(i,75) = b(i,75) - lu(i,493) * b(i,94) - b(i,93) = b(i,93) * lu(i,486) - b(i,29) = b(i,29) - lu(i,485) * b(i,93) - b(i,92) = b(i,92) * lu(i,476) - b(i,87) = b(i,87) - lu(i,475) * b(i,92) - b(i,86) = b(i,86) - lu(i,474) * b(i,92) - b(i,85) = b(i,85) - lu(i,473) * b(i,92) - b(i,72) = b(i,72) - lu(i,472) * b(i,92) - b(i,58) = b(i,58) - lu(i,471) * b(i,92) - b(i,91) = b(i,91) * lu(i,462) - b(i,68) = b(i,68) - lu(i,461) * b(i,91) - b(i,44) = b(i,44) - lu(i,460) * b(i,91) - b(i,35) = b(i,35) - lu(i,459) * b(i,91) - b(i,90) = b(i,90) * lu(i,452) - b(i,89) = b(i,89) * lu(i,442) - b(i,67) = b(i,67) - lu(i,441) * b(i,89) - b(i,88) = b(i,88) * lu(i,433) - b(i,34) = b(i,34) - lu(i,432) * b(i,88) - b(i,87) = b(i,87) * lu(i,425) - b(i,86) = b(i,86) - lu(i,424) * b(i,87) - b(i,85) = b(i,85) - lu(i,423) * b(i,87) - b(i,78) = b(i,78) - lu(i,422) * b(i,87) - b(i,61) = b(i,61) - lu(i,421) * b(i,87) - b(i,86) = b(i,86) * lu(i,414) - b(i,61) = b(i,61) - lu(i,413) * b(i,86) - b(i,85) = b(i,85) * lu(i,405) - b(i,84) = b(i,84) * lu(i,397) - b(i,33) = b(i,33) - lu(i,396) * b(i,84) - b(i,83) = b(i,83) * lu(i,388) - b(i,56) = b(i,56) - lu(i,387) * b(i,83) - b(i,24) = b(i,24) - lu(i,386) * b(i,83) - b(i,82) = b(i,82) * lu(i,379) - b(i,81) = b(i,81) * lu(i,375) - b(i,80) = b(i,80) * lu(i,369) - b(i,79) = b(i,79) * lu(i,358) - b(i,77) = b(i,77) - lu(i,357) * b(i,79) - b(i,76) = b(i,76) - lu(i,356) * b(i,79) - b(i,55) = b(i,55) - lu(i,355) * b(i,79) - b(i,49) = b(i,49) - lu(i,354) * b(i,79) - b(i,78) = b(i,78) * lu(i,344) - b(i,72) = b(i,72) - lu(i,343) * b(i,78) - b(i,61) = b(i,61) - lu(i,342) * b(i,78) - b(i,77) = b(i,77) * lu(i,335) - b(i,42) = b(i,42) - lu(i,334) * b(i,77) - b(i,76) = b(i,76) * lu(i,324) - b(i,55) = b(i,55) - lu(i,323) * b(i,76) - b(i,75) = b(i,75) * lu(i,319) - b(i,74) = b(i,74) * lu(i,312) - b(i,73) = b(i,73) * lu(i,303) - b(i,72) = b(i,72) * lu(i,296) - b(i,71) = b(i,71) * lu(i,288) - b(i,70) = b(i,70) * lu(i,280) - b(i,69) = b(i,69) * lu(i,272) - b(i,68) = b(i,68) * lu(i,268) - b(i,67) = b(i,67) * lu(i,260) - b(i,66) = b(i,66) * lu(i,254) - b(i,65) = b(i,65) * lu(i,246) - b(i,51) = b(i,51) - lu(i,245) * b(i,65) - b(i,64) = b(i,64) * lu(i,241) - b(i,63) = b(i,63) * lu(i,233) - b(i,62) = b(i,62) * lu(i,227) - b(i,61) = b(i,61) * lu(i,222) - b(i,60) = b(i,60) * lu(i,215) - b(i,59) = b(i,59) * lu(i,208) - b(i,58) = b(i,58) * lu(i,201) - b(i,57) = b(i,57) * lu(i,194) - b(i,56) = b(i,56) * lu(i,189) - b(i,55) = b(i,55) * lu(i,184) - b(i,54) = b(i,54) * lu(i,178) - b(i,53) = b(i,53) * lu(i,172) - b(i,52) = b(i,52) * lu(i,166) - b(i,51) = b(i,51) * lu(i,160) - b(i,50) = b(i,50) * lu(i,154) - b(i,49) = b(i,49) * lu(i,150) - b(i,48) = b(i,48) * lu(i,142) - b(i,47) = b(i,47) * lu(i,139) - b(i,46) = b(i,46) * lu(i,134) - b(i,45) = b(i,45) * lu(i,130) - b(i,44) = b(i,44) * lu(i,125) - b(i,43) = b(i,43) * lu(i,120) - b(i,42) = b(i,42) * lu(i,115) - b(i,41) = b(i,41) * lu(i,108) - b(i,40) = b(i,40) * lu(i,102) - b(i,39) = b(i,39) * lu(i,96) - b(i,38) = b(i,38) * lu(i,90) - b(i,37) = b(i,37) * lu(i,84) - b(i,36) = b(i,36) * lu(i,80) - b(i,26) = b(i,26) - lu(i,79) * b(i,36) - b(i,35) = b(i,35) * lu(i,75) - b(i,34) = b(i,34) * lu(i,72) - b(i,33) = b(i,33) * lu(i,69) - b(i,32) = b(i,32) * lu(i,65) - b(i,31) = b(i,31) * lu(i,61) - b(i,30) = b(i,30) * lu(i,57) - b(i,29) = b(i,29) * lu(i,55) - b(i,28) = b(i,28) * lu(i,53) - b(i,27) = b(i,27) - lu(i,52) * b(i,28) - b(i,27) = b(i,27) * lu(i,50) - b(i,26) = b(i,26) * lu(i,47) - b(i,25) = b(i,25) * lu(i,44) - b(i,24) = b(i,24) * lu(i,41) - b(i,23) = b(i,23) * lu(i,38) - b(i,22) = b(i,22) * lu(i,33) - b(i,21) = b(i,21) * lu(i,29) - b(i,20) = b(i,20) * lu(i,26) - b(i,19) = b(i,19) * lu(i,23) - b(i,18) = b(i,18) * lu(i,20) - b(i,17) = b(i,17) * lu(i,17) - b(i,16) = b(i,16) * lu(i,16) - b(i,15) = b(i,15) * lu(i,15) - b(i,14) = b(i,14) * lu(i,14) - b(i,13) = b(i,13) * lu(i,13) - b(i,12) = b(i,12) * lu(i,12) - b(i,11) = b(i,11) * lu(i,11) - b(i,10) = b(i,10) * lu(i,10) - b(i,9) = b(i,9) * lu(i,9) - b(i,8) = b(i,8) * lu(i,8) - b(i,7) = b(i,7) * lu(i,7) - b(i,6) = b(i,6) * lu(i,6) - b(i,5) = b(i,5) * lu(i,5) - b(i,4) = b(i,4) * lu(i,4) - b(i,3) = b(i,3) * lu(i,3) - b(i,2) = b(i,2) * lu(i,2) - b(i,1) = b(i,1) * lu(i,1) - enddo - END SUBROUTINE lu_slv08_vec - - SUBROUTINE lu_slv_vecr4(ncol,nb,nz,lu, b) - USE shr_kind_mod, ONLY: r4 => shr_kind_r4 - IMPLICIT NONE - !----------------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------------- - integer :: ncol,nb,nz - REAL(KIND=r4), intent(in) :: lu(ncol,nz) - REAL(KIND=r4), intent(inout) :: b(ncol,nb) - call lu_slv01_vec( ncol,nb,nz,lu, b ) - call lu_slv02_vec( ncol,nb,nz,lu, b ) - call lu_slv03_vec( ncol,nb,nz,lu, b ) - call lu_slv04_vec( ncol,nb,nz,lu, b ) - call lu_slv05_vec( ncol,nb,nz,lu, b ) - call lu_slv06_vec( ncol,nb,nz,lu, b ) - call lu_slv07_vec( ncol,nb,nz,lu, b ) - call lu_slv08_vec( ncol,nb,nz,lu, b ) - END SUBROUTINE lu_slv_vecr4 - END MODULE mo_lu_solve_vecr4 diff --git a/test/ncar_kernels/WACCM_lu_slv/src/shr_kind_mod.F90 b/test/ncar_kernels/WACCM_lu_slv/src/shr_kind_mod.F90 deleted file mode 100644 index 9ce739c7a9..0000000000 --- a/test/ncar_kernels/WACCM_lu_slv/src/shr_kind_mod.F90 +++ /dev/null @@ -1,32 +0,0 @@ - -! KGEN-generated Fortran source file -! -! Filename : shr_kind_mod.F90 -! Generated at: 2015-07-14 19:56:41 -! KGEN version: 0.4.13 - - - - MODULE shr_kind_mod - USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - PUBLIC - INTEGER, parameter :: shr_kind_r8 = selected_real_kind(12) ! 8 byte real - integer,parameter :: SHR_KIND_R4 = selected_real_kind( 6) ! 4 byte real - ! 4 byte real - ! native real - ! 8 byte integer - ! 4 byte integer - ! native integer - ! short char - ! mid-sized char - ! long char - ! extra-long char - ! extra-extra-long char - - ! write subroutines - ! No subroutines - ! No module extern variables - END MODULE shr_kind_mod diff --git a/test/ncar_kernels/lit.local.cfg b/test/ncar_kernels/lit.local.cfg deleted file mode 100644 index d0d85cf36d..0000000000 --- a/test/ncar_kernels/lit.local.cfg +++ /dev/null @@ -1,4 +0,0 @@ -# These tests take on the order of seconds to run, so skip them unless -# we're running long tests. -if 'long_tests' not in config.available_features: - config.unsupported = True diff --git a/test/offloading/amdgpu/assumed_array.F90 b/test/offloading/amdgpu/assumed_array.F90 new file mode 100644 index 0000000000..b7da438566 --- /dev/null +++ b/test/offloading/amdgpu/assumed_array.F90 @@ -0,0 +1,55 @@ +subroutine proc(arr, n) + use iso_fortran_env + + implicit none + + integer :: n, i + real(kind=real64), dimension(*) :: arr + +!$omp target map(tofrom:arr(:n)) + do i = 1,n + arr(i) = 42.0 + end do +!$omp end target + +end subroutine + +subroutine proc1(arr, n) + use iso_fortran_env + + implicit none + + integer :: n, i + real(kind=real64), dimension(*) :: arr + +!$omp target map(tofrom:arr(5:n)) + do i = 5,n + arr(i) = 43.0 + end do +!$omp end target + +end subroutine + +program map + use iso_fortran_env + + implicit none + + integer, parameter :: N = 20 + + real(kind=real64), dimension(N) :: array + real(kind=real64), dimension(N) :: array_exp + + ! tests explicitly specified upper bound + array_exp(:) = 42.0 + array(:) = 0.0 + call proc(array, N) + call __check_int(array_exp, array, N) + + ! tests explicitly specified lower and upper bound + array_exp(:) = 0.0 + array_exp(5:N) = 43.0 + array(:) = 0.0 + call proc1(array,N) + call __check_int(array_exp, array, N) +end program diff --git a/test/offloading/amdgpu/basic.F90 b/test/offloading/amdgpu/basic.F90 new file mode 100644 index 0000000000..6fc29928d6 --- /dev/null +++ b/test/offloading/amdgpu/basic.F90 @@ -0,0 +1,36 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Adding offload regression testcases +! +! Date of Creation: 1st July 2019 +! + +PROGRAM AXPY + integer, parameter :: N = 100 + integer :: y(N), x(N), z(N), a + integer :: x_exp(N), y_exp(N), z_exp(N) + integer :: i + y(:) = 0 + x(:) = (/ (i, i=1,N) /) + z(:) = -1 + + do i = 1, N + y_exp(i) = z(i) * x(i) + end do + + x_exp = 99 + z_exp = 77 + + !$omp target data map(tofrom: x, z) + !$omp target map(tofrom: y) + y(:) = x(:) * z(:) + x(:) = 99 + z(:) = 77 + !$omp end target + !$omp end target data + + call __check_int(x_exp, x, N) + call __check_int(y_exp, y, N) + call __check_int(z_exp, z, N) +END PROGRAM diff --git a/test/offloading/amdgpu/basic_parallel_do.F90 b/test/offloading/amdgpu/basic_parallel_do.F90 new file mode 100644 index 0000000000..ff7d751d3f --- /dev/null +++ b/test/offloading/amdgpu/basic_parallel_do.F90 @@ -0,0 +1,28 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Adding offload regression testcases +! +! Date of Creation: 1st July 2019 +! + +PROGRAM AXPY + integer :: y(128), x(128), z(128) + integer :: i, j + integer :: expected(128) + i = 0 + do j = 1, 128 + y(j) = 0 + x(j) = j + z(j) = -1 * j + expected(j) = x(j) * z(j) + end do + !$omp target data map(tofrom: x, z, y) + !$omp target parallel do + do i = 1, 128 + y(i) = x(i) * z(i) + end do + !$omp end target + !$omp end target data + call __check_int(expected, y, 128) +END PROGRAM diff --git a/test/offloading/amdgpu/check.c b/test/offloading/amdgpu/check.c new file mode 100644 index 0000000000..67b13bf28e --- /dev/null +++ b/test/offloading/amdgpu/check.c @@ -0,0 +1,41 @@ +//-----------------------------------------------------------------------// +// Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. // +// // +// Adding offload regression testcases // +// // +// Date of Creation: 1st July 2019 // +// // +// Adding proper double comparision // +// Date of modification : 23rd September // +//-----------------------------------------------------------------------// + +#include +#include +#include + +#define ERROR 0.00001 + +void __check_int_(int *expected, int *result, int *n) { + for (int i = 0; i < *n; ++i) { + if (result[i] != expected[i]) { + fprintf(stderr, "Mismatch at %d, %d VS %d\n", i, result[i], expected[i]); + exit(1); + } + } +} + +static int compare_double(double d1, double d2) { + if (fabs(d1 - d2) < ERROR) + return 0; + return 1; +} + +void __check_double_(double *expected, double *result, int *n) { + for (int i = 0; i < *n; ++i) { + if (compare_double(result[i], expected[i])) { + fprintf(stderr, "Mismatch at %d, %lf VS %lf\n", + i, result[i], expected[i]); + exit(1); + } + } +} diff --git a/test/offloading/amdgpu/cmn_blk_decl_target.F90 b/test/offloading/amdgpu/cmn_blk_decl_target.F90 new file mode 100644 index 0000000000..ec63771331 --- /dev/null +++ b/test/offloading/amdgpu/cmn_blk_decl_target.F90 @@ -0,0 +1,25 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Test case for use of common block variables in declare target construct. +! Date of creation : 21th April 2020 + +program main + call foo +end +subroutine foo + common /dxyz/ var1(2) + integer :: expected(2), calculated(2) +!$omp declare target (/dxyz/) +!$omp target + var1(1) = 1 + var1(2) = 2 +!$omp end target + expected(1) = 1 + expected(2) = 2 + calculated(1) = var1(1) + calculated(2) = var1(2) + call __check_int(expected, calculated, 2) + return +end + diff --git a/test/offloading/amdgpu/common_block.F90 b/test/offloading/amdgpu/common_block.F90 new file mode 100644 index 0000000000..4fdd7de14b --- /dev/null +++ b/test/offloading/amdgpu/common_block.F90 @@ -0,0 +1,22 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Test case for use of common block variables in map clause +! Date of creation : 20th April 2020 +! +program common_block + common /blk/ var1, var2 + integer :: expected(2), calculated(2) + + expected(1) = 10 + expected(2) = 20 + !$omp target map(/blk/) + var1 = 10 + var2 = 20 + !$omp end target + + calculated(1) = var1 + calculated(2) = var2 + + call __check_int(expected, calculated, 2) +end program diff --git a/test/offloading/amdgpu/declare_target.F90 b/test/offloading/amdgpu/declare_target.F90 new file mode 100644 index 0000000000..c65f7c4a45 --- /dev/null +++ b/test/offloading/amdgpu/declare_target.F90 @@ -0,0 +1,45 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Adding offload regression test for declare_target +! +! Date of Creation: 10th April 2020 +! +subroutine decrement_val(i, beta) + !$omp declare target + real(kind=8), dimension(10), intent(inout) :: beta + integer :: i + beta(i) = beta(i) - 1 +end subroutine +! example of simple Fortran AMD GPU offloading +program main + parameter (nsize=10) + real(kind=8) a(nsize), b(nsize), c(nsize), expected(nsize) + integer i + + do i=1,nsize + a(i)=0 + b(i) = i + c(i) = 10 + expected(i) = b(i) * c(i) + i - 1 + end do + + call foo(a,b,c) + + call __check_double(expected, a, 10) + return +end +subroutine foo(a,b,c) + parameter (nsize=10) + real(kind=8) a(nsize), b(nsize), c(nsize) + integer i +!$omp declare target(decrement_val) +!$omp target map(from:a) map(to:b,c) +!$omp parallel do + do i=1,nsize + a(i) = b(i) * c(i) + i + call decrement_val(i,a) + end do +!$omp end target + return +end diff --git a/test/offloading/amdgpu/default_array_variable.F90 b/test/offloading/amdgpu/default_array_variable.F90 new file mode 100644 index 0000000000..3306962749 --- /dev/null +++ b/test/offloading/amdgpu/default_array_variable.F90 @@ -0,0 +1,66 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Adding offload regression testcases +! +! Date of Creation: 26th July 2019 +! + +!========================GENERATE CHUNK BEGIN================================= + +module mod_init_chunk_kernel + contains + + subroutine init_chunk_kernel(x_min, x_max, vertexx, fields) + INTEGER :: x_min,x_max, min_val + REAL(KIND=8), DIMENSION(x_min:x_max) :: vertexx + INTEGER, DIMENSION(x_min:x_max) :: fields + + !$omp target + !$omp teams + IF (fields(1) == 1) THEN + !$omp distribute parallel do private(j) + DO j=x_min, x_max + vertexx(j)=10*float(j) + ENDDO + ENDIF + !$omp end teams + !$omp end target + end subroutine init_chunk_kernel +end module mod_init_chunk_kernel + + +subroutine init_chunk(x_min, x_max, vertexx, fields) + use mod_init_chunk_kernel + + INTEGER :: x_min,x_max + INTEGER, DIMENSION(x_min:x_max) :: fields + REAL(KIND=8), DIMENSION(x_min:x_max) :: vertexx + + call init_chunk_kernel(x_min, x_max, vertexx, fields) +end subroutine init_chunk + +!====================INIT CHUNK END=========================================== + +program testing + implicit none + INTEGER :: x_min,x_max + REAL(KIND=8), DIMENSION(1:10) :: vertexx + INTEGER :: fields(10) + INTEGER :: i, j + REAL(KIND=8), DIMENSION(1:10) :: exp_vertexx + + fields = 0 + fields(1) = 1 + x_min = 1 + x_max = 10 + !$omp target data map(vertexx) + call init_chunk(x_min, x_max, vertexx, fields) + !$omp end target data + + do i = 1, 10 + exp_vertexx(i) = 10 * float(i) + enddo + + call __check_double(exp_vertexx, vertexx, 10) +end program testing diff --git a/test/offloading/amdgpu/default_map.F90 b/test/offloading/amdgpu/default_map.F90 new file mode 100644 index 0000000000..362ae9eb32 --- /dev/null +++ b/test/offloading/amdgpu/default_map.F90 @@ -0,0 +1,21 @@ +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Adding regression test for default map +! Date of Creation: 08th April 2020 +! +program default_map + + integer :: scalar_int + integer :: expected(1), res(1) + + scalar_int = 10 + + !$omp target defaultmap(tofrom: scalar) + scalar_int = 15 + !$omp end target + res(1) = scalar_int + expected(1) = 15 + + call __check_int(expected, res, 1); + +end program default_map diff --git a/test/offloading/amdgpu/do_simd.F90 b/test/offloading/amdgpu/do_simd.F90 new file mode 100644 index 0000000000..9d7f3cd809 --- /dev/null +++ b/test/offloading/amdgpu/do_simd.F90 @@ -0,0 +1,16 @@ +PROGRAM ompdir_40 + USE OMP_LIB + IMPLICIT NONE + INTEGER I + REAL :: A(10)=1.1, B(10)=2.2, C(10)=3.3 + + !$omp do simd + DO I=1,10 + C(I) = C(I) - A(I) + B(I) + !PRINT *, "I = ", I, "By thread ", OMP_GET_THREAD_NUM() + END DO + !$omp end do simd + + PRINT *,"PASS" + STOP "0" +END PROGRAM diff --git a/test/offloading/amdgpu/double_complex_1.F90 b/test/offloading/amdgpu/double_complex_1.F90 new file mode 100644 index 0000000000..2ea78bf878 --- /dev/null +++ b/test/offloading/amdgpu/double_complex_1.F90 @@ -0,0 +1,17 @@ +program main +complex(kind=8) :: D,D2 +real(kind=8) :: expr,expi +D=0 +D2=(1,2) +expr = 10.0 +expi = 20.0 + !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO MAP(TOFROM: D,D2) + do i=1, 10 + !$omp critical + D=D+D2 + !$omp end critical + end do + !$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO + call __check_double(DBLE(D),EXPR, 1) + call __check_double(DIMAG(D),EXPI, 1) +end program diff --git a/test/offloading/amdgpu/firstprivate1.F90 b/test/offloading/amdgpu/firstprivate1.F90 new file mode 100644 index 0000000000..cd2c9f1a27 --- /dev/null +++ b/test/offloading/amdgpu/firstprivate1.F90 @@ -0,0 +1,16 @@ +program pgm + use omp_lib + INTEGER :: compute_array(10) + INTEGER :: compute_array_exp(10) + INTEGER :: p_val + + compute_array = 0 + p_val = 11 + compute_array_exp = p_val + + !$omp target map(tofrom:compute_array(:)) firstprivate(p_val) + compute_array = p_val + !$omp end target + + call __check_int(compute_array_exp, compute_array, 10) +end diff --git a/test/offloading/amdgpu/global_transfer.F90 b/test/offloading/amdgpu/global_transfer.F90 new file mode 100644 index 0000000000..7986a64d67 --- /dev/null +++ b/test/offloading/amdgpu/global_transfer.F90 @@ -0,0 +1,69 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Adding offload regression testcases +! +! Date of Creation: 07th October 2019 +! + +!======================GLOBAL KERNEL BEGIN================================== + +module mod_global_kernel + integer :: glob + REAL(KIND=8), DIMENSION(:), allocatable :: energy + contains + + subroutine global_kernel(x_min, x_max, energy) + implicit none + INTEGER :: x_min,x_max, min_val + REAL(KIND=8), DIMENSION(x_min:x_max) :: energy + REAL(KIND=8), DIMENSION(x_min:x_max) :: expected + + INTEGER :: i, j, depth + + + depth = -1 + + !$omp target + !$omp teams + !$omp distribute parallel do private(j) collapse(1) + DO j=x_min, x_max + energy(j) = j * 10 + depth + energy(j) + glob + ENDDO + !$omp end teams + !$omp end target + + !$omp target update from (energy) + + do i=x_min, x_max + expected(i) = i * 10 + depth - 10 + glob + end do + + call __check_double(expected, energy, 10) + + + end subroutine global_kernel +end module mod_global_kernel + +!====================GLOBAL KERNEL END====================================== + +program testing + use mod_global_kernel + implicit none + INTEGER :: x_min, x_max, i, j + + x_min = 1 + x_max = 10 + + + allocate(energy(1:x_max)) + + energy = -10 + + glob = 10 + + !$omp target data map(energy) + call global_kernel(x_min, x_max, energy) + !$omp end target data + +end program testing diff --git a/test/offloading/amdgpu/kernel_in_loop.F90 b/test/offloading/amdgpu/kernel_in_loop.F90 new file mode 100644 index 0000000000..604fad3644 --- /dev/null +++ b/test/offloading/amdgpu/kernel_in_loop.F90 @@ -0,0 +1,42 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Adding offload regression testcases +! +! Date of Creation: 1st July 2019 +! + +subroutine foo(n, x, y, z) + integer :: n + integer :: y(n), x(n), z(n) + integer j + !$omp target + !$omp teams distribute parallel do simd private(j) shared(x, y) + do j = 1, 128 + y(j) = x(j) * -10 + end do + !$omp end target +end subroutine + + +PROGRAM AXPY + integer :: N = 128 + integer :: y(128), x(128), z(128) + integer :: i, j + integer :: expected(128) + i = 0 + do j = 1, N + y(j) = 0 + x(j) = j + z(:) = -1 * j + expected(j) = j * -10 + end do + !$omp target data map(tofrom: x, y, z, n) + do i = 1, 10 + call foo(n, x, y, z) + end do + !$omp end target data + + call __check_int(expected, y, N) + +END PROGRAM diff --git a/test/offloading/amdgpu/mem_no_ptr.F90 b/test/offloading/amdgpu/mem_no_ptr.F90 new file mode 100644 index 0000000000..fb8026bb0a --- /dev/null +++ b/test/offloading/amdgpu/mem_no_ptr.F90 @@ -0,0 +1,51 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! This is an unit test case addded for checking mapping of pointers +! which are allocated in global structure. +! +! Date of Creation: 28th August 2020 +! +subroutine init(asi) + integer, dimension(10, 10) :: asi + !$omp target teams distribute map(asi) + do i = 1, 10 + do j = 1, 10 + asi(i, j) = i + j + end do + end do + !$omp end target teams distribute +end subroutine + + +program foo + type my_type + integer, dimension(:, :), allocatable :: psi + end type my_type + + integer, dimension(10, 10) :: asi + integer :: i, j + + type(my_type) :: my_var + + allocate(my_var%psi(10, 10)) + + do i = 1, 10 + do j = 1, 10 + asi(i, j) = i + j + end do + end do + + !$omp target data map(my_var%psi) + call init(my_var%psi) + !$omp end target data + + do i = 1, 10 + do j = 1, 10 + if (my_var%psi(i, j) .ne. asi(i, j)) then + stop 10 + endif + end do + end do + +end program foo diff --git a/test/offloading/amdgpu/memory_check_kernel.F90 b/test/offloading/amdgpu/memory_check_kernel.F90 new file mode 100644 index 0000000000..f340e2960d --- /dev/null +++ b/test/offloading/amdgpu/memory_check_kernel.F90 @@ -0,0 +1,95 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Adding offload regression testcases +! +! Date of Creation: 11st July 2019 +! + +!============================================================================== +! Executing same kernel multiple times inorder to check if memory deallocation +! happens properly. If GPU fails to deallocate memory, at some point GPU will +! not able to allocate memory and kernel will not terminate. +!============================================================================== + +module mod_update_kernel + contains + + subroutine update_kernel(x_min, x_max, density, storage_density, fields, depth) + implicit none + INTEGER :: x_min, x_max + REAL(KIND=8), DIMENSION(x_min:x_max) :: density + REAL(KIND=8), DIMENSION(x_min:x_max) :: storage_density + INTEGER :: fields(10), depth + + + ! local variables + INTEGER, PARAMETER :: const1 = 1 + INTEGEr :: j, i + REAL(kind = 8) :: dbl_base + REAL(kind = 8) :: sum1 + REAL(kind = 8), DIMENSION(1) :: expected, res + + + sum1 = 0; + dbl_base = 0 + !$omp target map(depth, dbl_base) + !$omp teams reduction(+: dbl_base) + + !$omp distribute parallel do private(j) collapse(1) reduction(+: dbl_base) + DO j=x_min, x_max + density(j) = j * 10 + depth + dbl_base = dbl_base + density(j) + ENDDO + !$omp end teams + !$omp end target + + expected(1) = 540.000 + res(1) = dbl_base + call __check_double(expected, res, 1) + + end subroutine update_kernel +end module mod_update_kernel + +subroutine update(x_min, x_max, density, fields, depth) + use mod_update_kernel + implicit none + + INTEGER :: x_min, x_max + REAL(KIND=8), DIMENSION(x_min:x_max) :: density + REAL(KIND=8), DIMENSION(x_min:x_max) :: storage_density + INTEGER :: fields(10), depth + + ! local variables + INTEGER :: i + + do i = x_min, x_max + storage_density(i) = i*i + end do + + call update_kernel(x_min, x_max, density, storage_density, fields, depth) + +end subroutine update + +program testing + implicit none + INTEGER :: x_min,x_max, depth + REAL(KIND=8), DIMENSION(1:10) :: energy + REAL(KIND=8), DIMENSION(1:10) :: vertexx + REAL(KIND=8), DIMENSION(1:10) :: density + INTEGER :: fields(10) + INTEGER :: i + REAL(KIND = 8) :: SUM=0 + + fields = 0 + fields(1) = 1 + x_min = 1 + x_max = 10 + depth = -1 + + !$omp target data map(vertexx, energy, density, fields) + do i = 1, 30 + call update(x_min, x_max, density, fields, depth) + end do + !$omp end target data +end program testing diff --git a/test/offloading/amdgpu/mul_red.F90 b/test/offloading/amdgpu/mul_red.F90 new file mode 100644 index 0000000000..4e697ae919 --- /dev/null +++ b/test/offloading/amdgpu/mul_red.F90 @@ -0,0 +1,100 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! +! Test to validate correct code generation when two reduction +! kernels are next to each other +! Date of creation 23rd Dec +! + +!======================REDUCTION KERNEL BEGIN================================== + +module mod_reduction_kernel + contains + + subroutine reduction_kernel(x_min, x_max, energy, energy2) + implicit none + INTEGER :: x_min,x_max, y_min, y_max + REAL(KIND=8), DIMENSION(x_min:x_max, x_min:x_max) :: energy, energy2 + + INTEGER :: i, j, depth + REAL(KIND = 8), DIMENSION(2) :: expected, res + REAL(KIND = 8) :: min_energy + REAL(KIND = 8) :: max_energy + + min_energy = 9999999 + max_energy = -9999999 + depth = -1 + + + !$omp target map(to: depth) map(min_energy) + !$omp teams reduction(min: min_energy) + !$omp distribute parallel do private(j) + DO j=x_min, x_max + !$omp simd private(i) + do i=x_min, x_max + energy(i, j) = ((1000 + float (j) / float (j *j)) / 1000) + end do + ENDDO + + !$omp distribute parallel do reduction(min: min_energy) + DO j=x_min, x_max + !$omp simd private(i) + do i=x_min, x_max + min_energy = min(min_energy, energy(i, j)) + enddo + ENDDO + !$omp end teams + !$omp end target + + !$omp target map(to: depth) map(max_energy) + !$omp teams reduction(max: max_energy) + !$omp distribute parallel do private(j) + DO j=x_min, x_max + !$omp simd private(i) + do i=x_min, x_max + energy(i, j) = ((1000 + float (j) / float (j *j)) / 1000) + end do + ENDDO + + !$omp distribute parallel do reduction(max: max_energy) + DO j=x_min, x_max + !$omp simd private(i) + do i=x_min, x_max + max_energy = max(max_energy, energy(i, j)) + enddo + ENDDO + !$omp end teams + !$omp end target + + !$omp target update from(energy) + res(1) = min_energy + res(2) = max_energy + + expected(1) = minval(energy) + expected(2) = maxval(energy) + + call __check_double(expected, res, 2) + + end subroutine reduction_kernel +end module mod_reduction_kernel + +!====================REDUCTION KERNEL END====================================== + +program testing + use mod_reduction_kernel + implicit none + INTEGER :: x_min, x_max, y_min, y_max + REAL(KIND=8), DIMENSION(1:100, 1:100) :: energy + REAL(KIND=8), DIMENSION(1:100, 1:100) :: energy2 + INTEGER :: i, j + REAL(KIND=8) :: min13 + + x_min = 1 + x_max = 100 + + !$omp target data map(energy, energy2) + call reduction_kernel(x_min, x_max, energy, energy2) + !$omp end target data + +end program testing diff --git a/test/offloading/amdgpu/multi_kernel.F90 b/test/offloading/amdgpu/multi_kernel.F90 new file mode 100644 index 0000000000..1eba2df87e --- /dev/null +++ b/test/offloading/amdgpu/multi_kernel.F90 @@ -0,0 +1,115 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Adding offload regression testcases +! +! Date of Creation: 1st July 2019 +! + +!========================GENERATE CHUNK BEGIN================================= + +module mod_generate_chunk_kernel + contains + + subroutine generate_chunk_kernel(x_min, x_max, energy, storage_energy, alpha, gama) + INTEGER :: x_min,x_max, min_val + REAL(KIND=8), DIMENSION(x_min:x_max) :: energy + REAL(KIND=8), DIMENSION(x_min:x_max) :: storage_energy + INTEGER :: alpha + INTEGER :: gama + + + !$omp target map(to:storage_energy, alpha, gama) + !$omp teams + !$omp distribute parallel do private(j) + DO j=x_min, x_max + energy(j) = storage_energy(j) * alpha - gama + ENDDO + !$omp end teams + !$omp end target + end subroutine generate_chunk_kernel +end module mod_generate_chunk_kernel +subroutine generate_chunk(x_min, x_max, energy) + use mod_generate_chunk_kernel + + INTEGER :: x_min,x_max + REAL(KIND=8), DIMENSION(x_min:x_max) :: energy + REAL(KIND=8), Dimension(x_min:x_max) :: storage_energy + INTEGER :: alpha + INTEGER :: gama + integer :: i + + alpha = -2 + gama = 2 + + + do i = x_min, x_max + storage_energy(i) = i; + enddo + + call generate_chunk_kernel(x_min, x_max, energy, storage_energy, alpha, gama) +end subroutine generate_chunk +!======================GENERATE CHUNK END===================================== + +!======================INIT CHUNK BEGIN======================================= + +module mod_init_chunk_kernel + contains + + subroutine init_chunk_kernel(x_min, x_max, vertexx) + INTEGER :: x_min,x_max, min_val + REAL(KIND=8), DIMENSION(x_min:x_max) :: vertexx + + !$omp target + !$omp teams + !$omp distribute parallel do private(j) + DO j=x_min, x_max + vertexx(j)=10*float(j) + ENDDO + !$omp end teams + !$omp end target + end subroutine init_chunk_kernel +end module mod_init_chunk_kernel + + +subroutine init_chunk(x_min, x_max, vertexx) + use mod_init_chunk_kernel + + INTEGER :: x_min,x_max + REAL(KIND=8), DIMENSION(x_min:x_max) :: vertexx + + call init_chunk_kernel(x_min, x_max, vertexx) +end subroutine init_chunk + +!====================INIT CHUNK END=========================================== + +program testing + implicit none + INTEGER :: x_min,x_max, depth + REAL(KIND=8), DIMENSION(1:10) :: vertexx + REAL(KIND=8), DIMENSION(1:10) :: energy + INTEGER :: fields(10) + INTEGER :: i + REAL(KIND=8), DIMENSION(1:10) :: exp_vertexx + REAL(KIND=8), DIMENSION(1:10) :: exp_energy + + fields = 0 + fields(1) = 1 + x_min = 1 + x_max = 10 + depth = -1 + + !$omp target data map(vertexx, energy, fields) + call init_chunk(x_min, x_max, vertexx) + call generate_chunk(x_min, x_max, energy) + !$omp end target data + + do i = 1, 10 + exp_energy(i) = i * (-2) - 2 + exp_vertexx(i) = 10 * float(i) + enddo + + call __check_double(exp_energy, energy, 10) + call __check_double(exp_vertexx, vertexx, 10) + +end program testing diff --git a/test/offloading/amdgpu/nested_parallel_target1.F90 b/test/offloading/amdgpu/nested_parallel_target1.F90 new file mode 100644 index 0000000000..b4331bb1f2 --- /dev/null +++ b/test/offloading/amdgpu/nested_parallel_target1.F90 @@ -0,0 +1,33 @@ +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Adding regression test for target inside parallel construct +! Date of Creation: 08th April 2020 +! +program pgm + use omp_lib + INTEGER :: compute_array(10, 10) + INTEGER :: compute_array_exp(10, 10) + INTEGER :: p_val, fp_val + + compute_array = 0 + compute_array_exp = 101 + p_val = 1 + fp_val = 2 + call omp_set_num_threads(10) + + !$omp parallel private(p_val, fp_val) shared(actualThreadCnt) + fp_val = omp_get_thread_num() + 2 + p_val = omp_get_thread_num() + 1 + !$omp target map(tofrom:compute_array) map(to:fp_val) private(p_val) + p_val = fp_val - 1 + compute_array(p_val,:) = 100 + compute_array(p_val,:) + p_val = p_val + 99 + !$omp end target + IF (p_val == omp_get_thread_num() + 1) THEN + compute_array(p_val,:) = compute_array(p_val,:) + 1 + END IF + !$omp end parallel + + call __check_int(compute_array_exp, compute_array, 100) + +end diff --git a/test/offloading/amdgpu/pardo_reduction.F90 b/test/offloading/amdgpu/pardo_reduction.F90 new file mode 100644 index 0000000000..06e89122ec --- /dev/null +++ b/test/offloading/amdgpu/pardo_reduction.F90 @@ -0,0 +1,44 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! Notified per clause 4(b) of the license. +! +! +! Unit test for parallel do reduction +! Date of Creation: 20 July 2020 +! + + +FUNCTION almost_equal(x, gold, tol) RESULT(b) + implicit none + REAL, intent(in) :: x + INTEGER, intent(in) :: gold + REAL, intent(in) :: tol + LOGICAL :: b + b = ( gold * (1 - tol) <= x ).AND.( x <= gold * (1+tol) ) +END FUNCTION almost_equal +PROGRAM target__teams_distribute__parallel_do + implicit none + INTEGER :: N0 = 512 + INTEGER :: i0 + INTEGER :: N1 = 512 + INTEGER :: i1 + LOGICAL :: almost_equal + REAL :: counter_N0 + INTEGER :: expected_value + expected_value = N0*N1 + counter_N0 = 0 + !$OMP target map(tofrom: counter_N0) + !$XOMP teams distribute reduction(+: counter_N0) + DO i0 = 1, N0 + !$OMP parallel do reduction(+: counter_N0) + DO i1 = 1, N1 + counter_N0 = counter_N0 + 1. + END DO + END DO + !$OMP END target + IF ( .NOT.almost_equal(counter_N0,expected_value, 0.1) ) THEN + WRITE(*,*) 'Expected', expected_value, 'Got', counter_N0 + STOP 112 + ENDIF + +END PROGRAM target__teams_distribute__parallel_do diff --git a/test/offloading/amdgpu/red_nored.F90 b/test/offloading/amdgpu/red_nored.F90 new file mode 100644 index 0000000000..83afc7e677 --- /dev/null +++ b/test/offloading/amdgpu/red_nored.F90 @@ -0,0 +1,103 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! +! Test to validate correct code generation when reduction and non-reduction +! kernels are next to each other +! Date of Creation: 05th November 2019 +! + +!======================REDUCTION KERNEL BEGIN================================== + +module mod_reduction_kernel + contains + + subroutine reduction_kernel(x_min, x_max, energy, energy2) + implicit none + INTEGER :: x_min,x_max, min_val, y_min, y_max + REAL(KIND=8), DIMENSION(x_min:x_max, x_min:x_max) :: energy, energy2 + + !local varaibels + REAL(kind = 8) :: dbl_base + REAL(kind = 8) :: sum1 + INTEGER :: i, j, depth + REAL(KIND = 8), DIMENSION(1) :: expected, res + REAL(KIND = 8) :: min_tmp + + sum1 = 0 + dbl_base = 99999 + expected(1) = dbl_base + depth = -1 + + + !$omp target map(to: depth) map(dbl_base) + !$omp teams reduction(min: dbl_base) + !$omp distribute parallel do private(j) + DO j=x_min, x_max + !$omp simd private(i) + do i=x_min, x_max + energy(i, j) = ((1000 + float (j) / float (j *j)) / 1000) + end do + ENDDO + min_tmp = 99999 + dbl_base = 99999 + !$omp distribute parallel do reduction(min: dbl_base) private(j, min_tmp) + DO j=x_min, x_max + !$omp simd private(i) + do i=x_min, x_max + if ( energy(i, j) .lt. dbl_base) dbl_base = energy(i, j) + enddo + ENDDO + !$omp end teams + !$omp end target + + !$omp target + !$omp teams + !$omp distribute parallel do private(j) + DO j=x_min, x_max + !$omp simd private(i) + do i=x_min, x_max + energy2(i, j) = ((1000 + float (j) / float (j *j)) / 1000) + end do + ENDDO + !$omp end teams + !$omp end target + + !$omp target update from(energy) + res(1) = dbl_base + + DO j=x_min, x_max + do i=x_min, x_max + if (((1000 + float (j) / float (j *j)) / 1000) < expected(1)) then + expected(1) = (1000 + float (j) / float (j *j)) / 1000 + endif + end do + ENDDO + + call __check_double(expected, res, 1) + + end subroutine reduction_kernel +end module mod_reduction_kernel + +!====================REDUCTION KERNEL END====================================== + +program testing + use mod_reduction_kernel + implicit none + INTEGER :: x_min, x_max, y_min, y_max + REAL(KIND=8), DIMENSION(1:100, 1:100) :: energy + REAL(KIND=8), DIMENSION(1:100, 1:100) :: energy2 + INTEGER :: i, j + REAL(KIND=8) :: min13 + + x_min = 1 + x_max = 100 + + !$omp target data map(energy, energy2) + call reduction_kernel(x_min, x_max, energy, energy2) + !$omp end target data + + call __check_double(energy, energy2, (x_max - x_min + 1)) + + +end program testing diff --git a/test/offloading/amdgpu/reduction_add.F90 b/test/offloading/amdgpu/reduction_add.F90 new file mode 100644 index 0000000000..9cb2ca22d3 --- /dev/null +++ b/test/offloading/amdgpu/reduction_add.F90 @@ -0,0 +1,61 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Adding offload regression testcases +! +! Date of Creation: 9th July 2019 +! + +!======================REDUCTION KERNEL BEGIN================================== + +module mod_reduction_kernel + contains + + subroutine reduction_kernel(x_min, x_max, energy) + implicit none + INTEGER :: x_min,x_max, min_val + REAL(KIND=8), DIMENSION(x_min:x_max) :: energy + + !local varaibels + REAL(kind = 8) :: dbl_base + REAL(kind = 8) :: sum1 + INTEGER :: i, j, depth + REAL(kind = 8), DIMENSION(1) :: expected, res + + + sum1 = 0 + dbl_base = 0 + depth = -1 + + !$omp target map(depth, dbl_base) + !$omp teams reduction(+: dbl_base) + !$omp distribute parallel do private(j) collapse(1) reduction(+: dbl_base) + DO j=x_min, x_max + energy(j) = j * 10 + depth + dbl_base = dbl_base + energy(j) + ENDDO + !$omp end teams + !$omp end target + + expected(1) = 540.000 + res(1) = dbl_base + call __check_double(expected, res, 1) + + end subroutine reduction_kernel +end module mod_reduction_kernel + +!====================REDUCTION KERNEL END====================================== + +program testing + use mod_reduction_kernel + implicit none + INTEGER :: x_min, x_max + REAL(KIND=8), DIMENSION(1:10) :: energy + + x_min = 1 + x_max = 10 + + !$omp target data map(energy) + call reduction_kernel(x_min, x_max, energy) + !$omp end target data +end program testing diff --git a/test/offloading/amdgpu/reduction_add2.F90 b/test/offloading/amdgpu/reduction_add2.F90 new file mode 100644 index 0000000000..6f688af08e --- /dev/null +++ b/test/offloading/amdgpu/reduction_add2.F90 @@ -0,0 +1,66 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! +! Date of Creation: 06th September 2019 +! + +!======================REDUCTION KERNEL BEGIN================================== + +module mod_reduction_kernel + contains + + subroutine reduction_kernel(x_min, x_max, energy) + implicit none + INTEGER :: x_min,x_max, min_val + REAL(KIND=8), DIMENSION(x_min:x_max) :: energy + + !local varaibels + REAL(kind = 8) :: dbl_base + REAL(kind = 8) :: sum1 + INTEGER :: i, j, depth + REAL(KIND = 8) :: min_tmp + REAL(kind = 8), DIMENSION(1) :: expected, res + + dbl_base = 0 + expected = 0 + + + !$omp target map(dbl_base) + !$omp teams reduction(+: dbl_base) + !$omp distribute parallel do private(j) reduction(+: dbl_base) + DO j=x_min, x_max + energy(j) = j + dbl_base = dbl_base + energy(j) + ENDDO + !$omp end teams + !$omp end target + + DO j=x_min, x_max + expected(1) = expected(1) + j + end do + res(1) = dbl_base + call __check_double(expected, res, 1) + + end subroutine reduction_kernel +end module mod_reduction_kernel + +!====================REDUCTION KERNEL END====================================== + +program testing + use mod_reduction_kernel + implicit none + INTEGER :: x_min, x_max + REAL(KIND=8), DIMENSION(1:963) :: energy + INTEGER :: i, j + REAL(KIND=8) :: min13 + + x_min = 1 + x_max = 963 + energy = -1 + + !$omp target data map(energy) + call reduction_kernel(x_min, x_max, energy) + !$omp end target data + +end program testing diff --git a/test/offloading/amdgpu/reduction_add3.F90 b/test/offloading/amdgpu/reduction_add3.F90 new file mode 100644 index 0000000000..7156d0e790 --- /dev/null +++ b/test/offloading/amdgpu/reduction_add3.F90 @@ -0,0 +1,66 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! +! Date of Creation: 06th September 2019 +! + +!======================REDUCTION KERNEL BEGIN================================== + +module mod_reduction_kernel + contains + + subroutine reduction_kernel(x_min, x_max, energy) + implicit none + INTEGER :: x_min,x_max, min_val + INTEGER(KIND=8), DIMENSION(x_min:x_max) :: energy + + !local varaibels + INTEGER(kind = 8) :: dbl_base + INTEGER(kind = 8) :: sum1 + INTEGER :: i, j, depth + INTEGER(KIND = 8) :: min_tmp + INTEGER(kind = 8), DIMENSION(1) :: expected, res + + dbl_base = 0 + expected = 0 + + + !$omp target map(dbl_base) + !$omp teams reduction(+: dbl_base) + !$omp distribute parallel do private(j) reduction(+: dbl_base) + DO j=x_min, x_max + energy(j) = j + dbl_base = dbl_base + energy(j) + ENDDO + !$omp end teams + !$omp end target + + DO j=x_min, x_max + expected(1) = expected(1) + j + end do + res(1) = dbl_base + call __check_double(expected, res, 1) + + end subroutine reduction_kernel +end module mod_reduction_kernel + +!====================REDUCTION KERNEL END====================================== + +program testing + use mod_reduction_kernel + implicit none + INTEGER :: x_min, x_max + INTEGER(KIND=8), DIMENSION(1:963) :: energy + INTEGER :: i, j + INTEGER(KIND=8) :: min13 + + x_min = 1 + x_max = 963 + energy = -1 + + !$omp target data map(energy) + call reduction_kernel(x_min, x_max, energy) + !$omp end target data + +end program testing diff --git a/test/offloading/amdgpu/reduction_array.F90 b/test/offloading/amdgpu/reduction_array.F90 new file mode 100644 index 0000000000..3339c9c8b7 --- /dev/null +++ b/test/offloading/amdgpu/reduction_array.F90 @@ -0,0 +1,93 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! +! Adding array reduction test case +! Date of Creation: 29th November 2019 +! +! This is a regression test case for reduction of static array variable +! +!======================REDUCTION KERNEL BEGIN================================== + +module mod_reduction_kernel + REAL(KIND=8), DIMENSION(:, :), allocatable :: energy + integer :: globa + contains + + subroutine reduction_kernel(x_min, x_max, energy) + implicit none + INTEGER :: x_min,x_max, min_val + REAL(KIND=8), DIMENSION(x_min:x_max, x_min:x_max) :: energy + + !local varaibels + REAL(kind = 8) :: dbl_base(1:10) + INTEGER :: i, j, depth + REAL(kind = 8) :: expected(1:10) + + + dbl_base = 0 + depth = -1 + expected = 0 + + ! Kernel to fill energy + !$omp target map(depth, dbl_base) + !$omp teams + !$omp distribute parallel do private(j) collapse(1) + DO j=x_min, x_max + do i = x_min, x_max + energy(i, j) = j * 10 + depth + energy(i, j) + globa + ENDDO + ENDDO + !$omp end teams + !$omp end target + + ! Reduction Kenrel + !$omp target map(depth, dbl_base) + !$omp teams reduction(+:dbl_base) + !$omp distribute parallel do private(j) collapse(1) reduction(+:dbl_base) + DO j=x_min, x_max + do i = x_min, x_max + dbl_base(j) = dbl_base(j) + energy(i, j) + ENDDO + ENDDO + !$omp end teams + !$omp end target + + !$omp target update from (energy) + + DO j=x_min, x_max + do i = x_min, x_max + expected(j) = expected(j) + energy(i, j) + ENDDO + ENDDO + + call __check_double(expected, dbl_base, 10) + + + end subroutine reduction_kernel +end module mod_reduction_kernel + +!====================REDUCTION KERNEL END====================================== + +program testing + use mod_reduction_kernel + implicit none + + INTEGER :: x_min, x_max, i, j + + x_min = 1 + !x_max = 10 + + x_max = 10 + globa = 10; + + allocate(energy(1:x_max, 1:x_max)) + + energy = -10 + + !$omp target data map(energy) + call reduction_kernel(x_min, x_max, energy) + !$omp end target data + + +end program testing diff --git a/test/offloading/amdgpu/reduction_max.F90 b/test/offloading/amdgpu/reduction_max.F90 new file mode 100644 index 0000000000..3180a757b8 --- /dev/null +++ b/test/offloading/amdgpu/reduction_max.F90 @@ -0,0 +1,66 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! +! Adding max reduction test case +! Date of Creation: 20th October 2020 +! + +!======================REDUCTION KERNEL BEGIN================================== + +module mod_reduction_kernel + contains + + subroutine reduction_kernel(x_min, x_max, energy) + implicit none + INTEGER :: x_min,x_max, min_val + REAL(KIND=8), DIMENSION(x_min:x_max) :: energy + + !local varaibels + REAL(kind = 8) :: dbl_base + REAL(kind = 8) :: sum1 + INTEGER :: i, j, depth + REAL(KIND = 8), DIMENSION(1) :: expected, res + + sum1 = 0 + dbl_base = 0 + expected(1) = 0 + depth = -1 + + + !$omp target map(to: depth) map(dbl_base) + !$omp teams reduction(max: dbl_base) + !$omp distribute parallel do private(j) reduction(max: dbl_base) + DO j=x_min, x_max + energy(j) = (j + float (j) / float (j *j)) / 1000 + if (j .eq. 150) energy(j) = 10000000 !Adding max value in intermediate position + if ( energy(j) .gt. dbl_base) dbl_base = energy(j) + ENDDO + !$omp end teams + !$omp end target + + expected(1) = 10000000 + res(1) = dbl_base + call __check_double(expected, res, 1) + + end subroutine reduction_kernel +end module mod_reduction_kernel + +!====================REDUCTION KERNEL END====================================== + +program testing + use mod_reduction_kernel + implicit none + INTEGER :: x_min, x_max + REAL(KIND=8), DIMENSION(1:205) :: energy + INTEGER :: i, j + REAL(KIND=8) :: min13 + + x_min = 1 + x_max = 205 + + !$omp target data map(energy) + call reduction_kernel(x_min, x_max, energy) + !$omp end target data + +end program testing diff --git a/test/offloading/amdgpu/reduction_min.F90 b/test/offloading/amdgpu/reduction_min.F90 new file mode 100644 index 0000000000..7e8f64aeab --- /dev/null +++ b/test/offloading/amdgpu/reduction_min.F90 @@ -0,0 +1,67 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! +! Adding min reduction test case +! Date of Creation: 05th September 2019 +! + +!======================REDUCTION KERNEL BEGIN================================== + +module mod_reduction_kernel + contains + + subroutine reduction_kernel(x_min, x_max, energy) + implicit none + INTEGER :: x_min,x_max, min_val + REAL(KIND=8), DIMENSION(x_min:x_max) :: energy + + !local varaibels + REAL(kind = 8) :: dbl_base + REAL(kind = 8) :: sum1 + INTEGER :: i, j, depth + REAL(KIND = 8), DIMENSION(1) :: expected, res + REAL(KIND = 8) :: min_tmp + + sum1 = 0 + dbl_base = 666666 + expected(1) = 6666666 + depth = -1 + + + !$omp target map(to: depth) map(dbl_base) + !$omp teams reduction(min: dbl_base) + !$omp distribute parallel do private(j) reduction(min: dbl_base) + DO j=x_min, x_max + energy(j) = (j + float (j) / float (j *j)) / 1000 + if (j .eq. 150) energy(j) = 0.0000000001 !Adding min value in intermediate position + if ( energy(j) .lt. dbl_base) dbl_base = energy(j) + ENDDO + !$omp end teams + !$omp end target + + expected(1) = 0.0000000001 + res(1) = dbl_base + call __check_double(expected, res, 1) + + end subroutine reduction_kernel +end module mod_reduction_kernel + +!====================REDUCTION KERNEL END====================================== + +program testing + use mod_reduction_kernel + implicit none + INTEGER :: x_min, x_max + REAL(KIND=8), DIMENSION(1:205) :: energy + INTEGER :: i, j + REAL(KIND=8) :: min13 + + x_min = 1 + x_max = 205 + + !$omp target data map(energy) + call reduction_kernel(x_min, x_max, energy) + !$omp end target data + +end program testing diff --git a/test/offloading/amdgpu/reduction_or.F90 b/test/offloading/amdgpu/reduction_or.F90 new file mode 100644 index 0000000000..9fb121fd5e --- /dev/null +++ b/test/offloading/amdgpu/reduction_or.F90 @@ -0,0 +1,54 @@ +module test_aomp + +implicit none + +integer, parameter :: rstd = 8 +integer :: nsize +REAL(rstd), allocatable :: a_dev(:,:,:), b_dev(:,:,:), c_dev(:,:,:) +logical :: touch_limit +REAL(rstd) :: limit +!$acc declare create(a_dev,b_dev,c_dev,nsize) +!$omp declare target(a_dev,b_dev,c_dev,nsize) + +contains + subroutine dec_val_dev() + + end subroutine dec_val_dev + + subroutine _compute_dev() + integer i,j,k + +!$omp target teams +!$omp parallel do reduction(.and.:touch_limit) + do i=1,nsize + do j=1,nsize + do k=1,nsize + a_dev(i,j,k) = b_dev(i,j,k) * c_dev(i,j,k) * i * nsize*nsize + j * nsize + k + if (a_dev(i,j,k) < limit) then + touch_limit = .true. + end if + end do + end do + end do +!$omp end target teams + end subroutine _compute_dev + + subroutine compute_dev() +!$omp target update to(b_dev,c_dev,nsize) + CALL _compute_dev() +!$omp target update from(a_dev) + end subroutine compute_dev + +end module test_aomp + +program test + use test_aomp + + limit= 10000 + touch_limit= .false. + call compute_dev() + + print *, "touch limit: ", touch_limit + print *, a_dev +end program test + diff --git a/test/offloading/amdgpu/run.sh b/test/offloading/amdgpu/run.sh new file mode 100755 index 0000000000..239f86d335 --- /dev/null +++ b/test/offloading/amdgpu/run.sh @@ -0,0 +1,55 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# Adding offload regression testcases +# Date of Creation: 1st July 2019 +# +# Removing dependency on -Mx,232,0x10 +# Date of modification 1st October 2019 +# +# + +#!/bin/bash +CC=clang +FC=flang +TARGET_FLAGS="-target x86_64-pc-linux-gnu" +DEVICE_FLAGS="-fopenmp -fopenmp-targets=amdgcn-amd-amdhsa -Xopenmp-target=amdgcn-amd-amdhsa" +MARCH="-march=gfx900" +XFLAGS="-Mx,232,0x40" +FFLAGS="$TARGET_FLAGS $DEVICE_FLAGS $MARCH $XFLAGS" +total=0 +passed=0 +failed=0 +echo "Offloading to AMD GPU" +$CC check.c -c -o check.o +for file in *.F90 +do + let "total++" + basename=`basename $file .F90` + echo "Running file test $file" + $FC $FFLAGS $file check.o >& /dev/null + if [ $? -ne 0 ]; then + let "failed++" + echo "Test case failed : Compilation failure" + continue + fi + ./a.out + if [ $? -ne 0 ]; then + let "failed++" + echo "Test case failed : Runtime failure" + else + let "passed++" + echo "Test case passed" + fi + rm ./a.out +done +rm check.o +rm *.mod +echo "" +echo "########################################################################" +echo "" +echo "Total test cases $total" +echo "Passes test cases $passed" +echo "Failed test cases $failed" +echo "" +echo "########################################################################" diff --git a/test/offloading/amdgpu/run_tests.sh b/test/offloading/amdgpu/run_tests.sh new file mode 100755 index 0000000000..9b03f71f66 --- /dev/null +++ b/test/offloading/amdgpu/run_tests.sh @@ -0,0 +1,85 @@ +# +# Modifications Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# Notified per clause 4(b) of the license. +# +# Script to run regression test. +# Last modified 12th May 2020 +# +# Usage : +# ./run.sh [ testcase.F90 ] +# if testcase.F90 is specified only that test will be run. +# else all tests are run +# +# + +#!/bin/bash +CC=clang +FC=flang +TARGET_FLAGS="-target x86_64-pc-linux-gnu" +DEVICE_FLAGS="-fopenmp -fopenmp-targets=amdgcn-amd-amdhsa -Xopenmp-target=amdgcn-amd-amdhsa" +MARCH="-march=gfx900" +VERSION="-mllvm -amdhsa-code-object-version=4" +#XFLAGS="-Mx,232,0x40" +XFLAGS="" +FFLAGS="$TARGET_FLAGS $DEVICE_FLAGS $MARCH $XFLAGS $VERSION -fuse-ld=ld -nogpulib" +total=0 +passed=0 +failed=0 +echo "Offloading to AMD GPU" +$CC check.c -c -o check.o +if [[ $# -eq 0 ]]; then + for file in *.F90 + do + let "total++" + basename=`basename $file .F90` + $FC $FFLAGS $file check.o >& /dev/null + if [ $? -ne 0 ]; then + let "failed++" + echo " $file : Compilation failure" + continue + fi + ./a.out + if [ $? -ne 0 ]; then + let "failed++" + echo " $file : Runtime failure" + else + let "passed++" + echo " $file : Test case passed" + fi + rm ./a.out + done +else + #only used for developement testing + if [[ $# -ne 1 ]]; then + echo "WARNING: More than one file specified. Only compiling first one" + fi + file=$1 + let "total++" + basename=`basename $file .F90` + echo "Running file test $file" + $FC $FFLAGS $file check.o + if [ $? -ne 0 ]; then + let "failed++" + echo " $file : Compilation failure" + else + ./a.out + if [ $? -ne 0 ]; then + let "failed++" + echo " $file : Runtime failure" + else + let "passed++" + echo " $file : Test case passed" + fi + fi + rm ./a.out +fi +rm check.o +rm *.mod +echo "" +echo "########################################################################" +echo "" +echo "Total test cases $total" +echo "Passes test cases $passed" +echo "Failed test cases $failed" +echo "" +echo "########################################################################" diff --git a/test/offloading/amdgpu/shuffle_red.F90 b/test/offloading/amdgpu/shuffle_red.F90 new file mode 100644 index 0000000000..a05865f8e8 --- /dev/null +++ b/test/offloading/amdgpu/shuffle_red.F90 @@ -0,0 +1,101 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! +! This is a unit test for checking reduction across threads in a team when +! iteration value is odd number and reduction result is odd number. +! +! Date of Creation: 31st March 2020 +! + + +!======================REDUCTION KERNEL BEGIN================================== + +module mod_reduction_kernel + REAL(KIND=8), DIMENSION(:, :), allocatable :: energy + REAL(KIND=8), DIMENSION(:, :), allocatable :: hst_energy + integer :: globa + contains + + subroutine reduction_kernel(x_min, x_max, energy, hst_energy) + implicit none + INTEGER :: x_min,x_max, min_val + REAL(KIND=8), DIMENSION(x_min:x_max, x_min:x_max) :: energy + REAL(KIND=8), DIMENSION(x_min:x_max, x_min:x_max) :: hst_energy + + !local varaibels + REAL(kind = 8) :: dbl_base + REAL(kind = 8) :: red2 + REAL(kind = 8) :: hst_red2 + INTEGER :: i, j, depth + + + dbl_base = 0 + depth = -1 + + red2 = 0 + hst_red2 = 0 + + !$omp target map(depth, dbl_base) + !$omp teams + !$omp distribute parallel do private(j) collapse(2) + DO j=x_min, x_max + do i = x_min, x_max + energy(i, j) = j * 10 + depth + energy(i, j) + globa + 2 + ENDDO + ENDDO + !$omp end teams + !$omp end target + + !$omp target map(depth, red2) + !$omp teams reduction(+: red2) + !$omp distribute parallel do private(j) collapse(1) reduction(+:red2) + DO j=x_min, x_max + do i = x_min, x_max + red2 = red2 + energy(i, j) + ENDDO + ENDDO + !$omp end teams + !$omp end target + + !$omp target update from (energy) + + DO j=x_min, x_max + do i = x_min, x_max + hst_energy(i, j) = j * 10 + depth + hst_energy(i, j) + globa + 2 + hst_red2 = hst_red2 + hst_energy(i, j) + ENDDO + ENDDO + + call __check_double(hst_red2, red2, 1) + + end subroutine reduction_kernel +end module mod_reduction_kernel + +!====================REDUCTION KERNEL END====================================== + +program testing + use mod_reduction_kernel + implicit none + + INTEGER :: x_min, x_max, i, j + + x_min = 1 + !x_max = 10 + + x_max = 777 + globa = 10; + + allocate(energy(1:x_max, 1:x_max)) + allocate(hst_energy(1:x_max, 1:x_max)) + + + energy = -10 + hst_energy = -10 + + !$omp target data map(energy) + call reduction_kernel(x_min, x_max, energy, hst_energy) + !$omp end target data + + +end program testing diff --git a/test/offloading/amdgpu/simple_red.F90 b/test/offloading/amdgpu/simple_red.F90 new file mode 100644 index 0000000000..0fb420d9d1 --- /dev/null +++ b/test/offloading/amdgpu/simple_red.F90 @@ -0,0 +1,27 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Test to check teams distribute without parallel do +! Date of creation 04th Feb 2020 +! +program simple_red + real (kind=8) :: array(10) + real(kind=8) :: red = 0, hst=0 + integer i + real(kind = 8), dimension(1) :: expected, res + + + do i = 1, 10 + array(i) = i + hst = hst + array(i) + end do + + !$omp target teams distribute reduction(+:red) map(tofrom:red, array) + do i = 1, 10 + red = red + array(i) + end do + + expected(1) = hst + res(1) = red + call __check_double(expected, res, 1) +end program simple_red diff --git a/test/offloading/amdgpu/struct_test_i_sia_dia.F90 b/test/offloading/amdgpu/struct_test_i_sia_dia.F90 new file mode 100644 index 0000000000..32c356cf80 --- /dev/null +++ b/test/offloading/amdgpu/struct_test_i_sia_dia.F90 @@ -0,0 +1,50 @@ +module test_m + implicit none + public test_type + type test_type + integer :: num + integer, dimension(10) :: iarr + integer, pointer :: p1(:) + end type +end module + +program loop_test + use test_m + + implicit none + integer :: i, C, C1, C2, ex, ex1, ex2 + type(test_type), target :: obj + obj%num = 111 + C=0 + C1=0 + C2=0 + ex=0 + ex1=0 + ex2=0 + allocate(obj%p1(10)) + + do i=1, 10 + obj%iarr(i)=i + obj%p1(i)=i*2 + end do + + do i=1, 10 + ex=ex+obj%iarr(i) + ex1=ex1+obj%num + ex2=ex2+obj%p1(i) + end do + + !$OMP TARGET MAP(TOFROM: C, C1, C2) MAP(TOFROM: obj, obj%p1) + !$OMP PARALLEL DO REDUCTION(+: C, C1, C2) + do i=1, 10 + C=C+obj%iarr(i) + C1=C1+obj%num + C2=C2+obj%p1(i) + end do + !$OMP END PARALLEL DO + !$OMP END TARGET + + call __check_int(ex, C, 1) + call __check_int(ex1, C1, 1) + call __check_int(ex2, C2, 1) +end program loop_test diff --git a/test/offloading/amdgpu/struct_test_i_sia_dia1.F90 b/test/offloading/amdgpu/struct_test_i_sia_dia1.F90 new file mode 100644 index 0000000000..495f296008 --- /dev/null +++ b/test/offloading/amdgpu/struct_test_i_sia_dia1.F90 @@ -0,0 +1,51 @@ +module test_m + implicit none + public test_type + type test_type + integer :: num + integer, dimension(10) :: iarr + integer, pointer :: p1(:) + end type +end module + +program loop_test + use test_m + + implicit none + integer :: i, C, C1, C2, ex, ex1, ex2 + type(test_type), target :: obj + obj%num = 111 + C=0 + C1=0 + C2=0 + ex=0 + ex1=0 + ex2=0 + allocate(obj%p1(10)) + + do i=1, 10 + obj%iarr(i) = i + obj%p1(i) = i*2 + end do + + do i=1, 10 + ex=ex+obj%num + ex1=ex1+obj%iarr(i) + ex2=ex2+obj%p1(i) + end do + + !$OMP TARGET ENTER DATA MAP(TO: obj, obj%p1) + !$OMP TARGET PARALLEL DO REDUCTION(+:C, C1, C2) + do i=1, 10 + C=C+obj%num + C1=C1+obj%iarr(i) + C2=C2+obj%p1(i) + end do + !$OMP END TARGET PARALLEL DO + !$OMP TARGET EXIT DATA MAP(RELEASE:obj, obj%p1) + + call __check_int(ex, C, 1) + call __check_int(ex1, C1, 1) + call __check_int(ex2, C2, 1) + +end program loop_test diff --git a/test/offloading/amdgpu/swdev280342.F90 b/test/offloading/amdgpu/swdev280342.F90 new file mode 100644 index 0000000000..da8cc9aa8d --- /dev/null +++ b/test/offloading/amdgpu/swdev280342.F90 @@ -0,0 +1,71 @@ +module unit_test_0 + +implicit none + +integer, parameter :: rstd = 8 +integer :: nsize +integer :: sum_dev +REAL(rstd), allocatable :: a_dev(:,:,:), b_dev(:,:,:), c_dev(:,:,:) +integer :: def_async_q = 0 +!$omp declare target(a_dev,b_dev,c_dev,sum_dev,nsize) + +contains + subroutine _compute_dev() + integer i,j,k +!$omp declare target + do i=1,nsize + do j=1,nsize + do k=1,nsize + a_dev(i,j,k) = b_dev(i,j,k) * c_dev(i,j,k) * i * nsize*nsize + j * nsize + k + sum_dev = sum_dev + b_dev(i,j,k) * c_dev(i,j,k) + end do + end do + end do + + end subroutine _compute_dev + + subroutine compute_dev() + +!$omp declare target(_compute_dev) + +!$omp target update to(b_dev,c_dev,sum_dev,nsize) + +!$omp target + CALL _compute_dev() +!$omp end target + +!$omp target update from(a_dev,sum_dev) + end subroutine compute_dev + + subroutine init(n_size) + integer n_size + integer i,j,k + + nsize = n_size + allocate(a_dev(nsize,nsize,nsize), b_dev(nsize,nsize,nsize), c_dev(nsize,nsize,nsize)) + sum_dev = 0 + do i=1,nsize + do j=1,nsize + do k=1,nsize + b_dev(i,j,k) = 1 + c_dev(i,j,k) = 2 + end do + end do + end do + end subroutine init + + subroutine deinit() + + deallocate(a_dev, b_dev, c_dev) + end subroutine deinit + +end module unit_test_0 + +program test + use unit_test_0 + + call init(100) + call compute_dev + + call deinit() +end program test diff --git a/test/offloading/amdgpu/swdev288160.F90 b/test/offloading/amdgpu/swdev288160.F90 new file mode 100644 index 0000000000..a737bb8e5f --- /dev/null +++ b/test/offloading/amdgpu/swdev288160.F90 @@ -0,0 +1,129 @@ +module test_aomp + +implicit none + +integer, parameter :: rstd = 8 +integer :: nsize +integer :: sum_cpu, sum_dev +REAL(rstd), allocatable :: a_cpu(:,:,:), b_cpu(:,:,:), c_cpu(:,:,:) +REAL(rstd), allocatable :: a_dev(:,:,:), b_dev(:,:,:), c_dev(:,:,:) +integer :: def_async_q = 0 + +contains + subroutine dec_val_dev() + + end subroutine dec_val_dev + + subroutine _compute_dev() + integer i,j,k,l,m + + +!$omp target + do i=1,nsize +!$omp parallel do + do j=1,nsize + do k=1,nsize + a_dev(i,j,k) = b_dev(i,j,k) * c_dev(i,j,k) * i * nsize*nsize + j * nsize + k + end do + end do +!$omp parallel do + do l=1,nsize + do m=1,nsize + sum_dev = sum_dev + a_dev(i,l,m) + end do + end do + end do +!$omp end target + end subroutine _compute_dev + + subroutine compute_dev() + + +!$omp target update to(b_dev,c_dev,sum_dev,nsize) + + + CALL _compute_dev() + +!$omp target update from(a_dev,sum_dev) + + end subroutine compute_dev + + subroutine compute_cpu() + integer i,j,k + + do i=1,nsize + do j=1,nsize + do k=1,nsize + a_cpu(i,j,k) = b_cpu(i,j,k) * c_cpu(i,j,k) * i * nsize*nsize + j * nsize + k + sum_cpu = sum_cpu + b_cpu(i,j,k) * c_cpu(i,j,k) + end do + end do + end do + end subroutine compute_cpu + + subroutine init(n_size) + integer n_size + integer i,j,k + + nsize = n_size + allocate(a_cpu(nsize,nsize,nsize), b_cpu(nsize,nsize,nsize), c_cpu(nsize,nsize,nsize)) + allocate(a_dev(nsize,nsize,nsize), b_dev(nsize,nsize,nsize), c_dev(nsize,nsize,nsize)) + sum_cpu = 0 + sum_dev = 0 + do i=1,nsize + do j=1,nsize + do k=1,nsize + b_dev(i,j,k) = 1 + b_cpu(i,j,k) = 1 + c_dev(i,j,k) = 2 + c_cpu(i,j,k) = 2 + end do + end do + end do + end subroutine init + + subroutine deinit() + + deallocate(a_cpu, b_cpu, c_cpu) + deallocate(a_dev, b_dev, c_dev) + end subroutine deinit + + subroutine compare_results() + integer i,j,k + double precision :: error + double precision, parameter :: error_max = 1.0d-10 + integer :: num_error = 0 + + print *, nsize + do i=1,nsize + do j=1,nsize + do k=1,nsize + error = abs(a_dev(i,j,k) - a_cpu(i,j,k)) + if (error > error_max) then + print *,"[Error]: a_dev(", i, ",", j, ",", k, ",", ") : ", a_dev(i,j,k), " <> ", a_cpu(i,j,k) + num_error = num_error + 1 + if (num_error > 10) then + exit + endif + end if + end do + end do + end do + if (num_error > 0) then + print *,"TEST FAILED" + else + print *,"TEST PASS" + endif + end subroutine compare_results + +end module test_aomp + +program test + use test_aomp + call init(100) + call compute_cpu() + call compute_dev() + call compare_results() + call deinit() + +end program test diff --git a/test/offloading/amdgpu/swdev288446.F90 b/test/offloading/amdgpu/swdev288446.F90 new file mode 100644 index 0000000000..743fed02a3 --- /dev/null +++ b/test/offloading/amdgpu/swdev288446.F90 @@ -0,0 +1,49 @@ +subroutine _compute_dev(sum_dev, a_dev, b_dev, c_dev) + integer i,j,k + REAL(8), dimension(100,100,100), intent(in) :: b_dev, c_dev + REAL(8), dimension(100,100,100), intent(out) :: a_dev + REAL(8), intent(inout) :: sum_dev + integer :: nsize = 100 + +!$omp declare target +!$omp parallel do + do i=1,nsize + do j=1,nsize + do k=1,nsize + a_dev(i,j,k) = b_dev(i,j,k) * c_dev(i,j,k) * i * nsize*nsize + j * nsize + k + end do + end do + end do +!$xomp end target +end subroutine _compute_dev + +program main + integer :: nsize + REAL(8) :: sum_dev = 0 + REAL(8), dimension(100,100,100) :: a_dev, b_dev, c_dev + integer :: nsize = 100 +!$omp declare target(_compute_dev) + do i=1,nsize + do j=1,nsize + do k=1,nsize + b_dev(i,j,k) = 1 + c_dev(i,j,k) = 2 + end do + end do + end do + +!$omp target update to(b_dev,c_dev,sum_dev,nsize) +!$omp target + CALL _compute_dev(sum_dev, a_dev, b_dev, c_dev) +!$omp end target +!$omp target update from(a_dev,sum_dev) + + do i=1,3 + do j=1,3 + do k=1,3 + print *, a_dev(i,j,k) + end do + end do + end do +end program main + diff --git a/test/offloading/amdgpu/target_implied_do.F90 b/test/offloading/amdgpu/target_implied_do.F90 new file mode 100644 index 0000000000..1185952a04 --- /dev/null +++ b/test/offloading/amdgpu/target_implied_do.F90 @@ -0,0 +1,20 @@ +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Adding offload regression testcases +! +! Date of Creation: 28th October 2019 +! +PROGRAM test_target_ido + INTEGER :: c(1:1024), c_exp(1:1024) + INTEGER :: a(1:1024) + INTEGER :: s,j + s = 10 + j = 1 + a(:) = 11 + c_exp(1:s) = 12 + + !$omp target map(tofrom: c(1:s), a(1:s), j, s) + c(1:s) = (/ (a(j)+1, j = 1, s) /) + !$omp end target + call __check_int(c_exp, c, s) +END PROGRAM test_target_ido diff --git a/test/offloading/amdgpu/target_map.F90 b/test/offloading/amdgpu/target_map.F90 new file mode 100644 index 0000000000..c8aa93ccb7 --- /dev/null +++ b/test/offloading/amdgpu/target_map.F90 @@ -0,0 +1,30 @@ +program TargetReduction_3D + + implicit none + + integer, dimension ( 3,3,3 ) :: iV, MaxSpeed + integer i,j,k,temp + +! !$OMP target enter data map ( from : iV) + + print*,'Starting' + !$OMP target MAP(from:iV) + !$OMP teams + !$OMP distribute private (i) + do i = 1, 3 + !$omp parallel private ( j, k ) + do j = 1, 3 + !$omp do + do k = 1, 3 + iV(i,j,k) = i+j+k + end do + !$omp end do + end do + !$omp end parallel + end do + !$OMP end distribute + !$OMP END TEAMS + !$OMP END TARGET +! print *, "MaxSpeed: " +! print *, iV +end program TargetReduction_3D diff --git a/test/offloading/amdgpu/target_parallel_if.F90 b/test/offloading/amdgpu/target_parallel_if.F90 new file mode 100644 index 0000000000..a27907cea5 --- /dev/null +++ b/test/offloading/amdgpu/target_parallel_if.F90 @@ -0,0 +1,46 @@ +program test + use omp_lib + integer :: i,k + real(kind=8),pointer :: x(:) + real(kind=8) :: expected(10) + logical ::FLAG + allocate(x(10)) + x=0 + k=3 + expected=1 + + !$omp target parallel do if(k>1) + do i=1, 10 + x(i)=1.0+omp_is_initial_device() + enddo + !$omp end target parallel do + call __check_double(expected, x, 10) + + k=0 + expected=2 + !$omp target parallel do if(k>1) + do i=1, 10 + x(i)=1.0+omp_is_initial_device() + enddo + !$omp end target parallel do + call __check_double(expected, x, 10) + + FLAG=.true. + expected=1 +!$omp target parallel do if (target:FLAG) + do i=1, 10 + x(i)=1+omp_is_initial_device() + enddo +!$omp end target parallel do + call __check_double(expected, x, 10) + + FLAG=.false. + expected=2 +!$omp target parallel do if (target:FLAG) + do i=1, 10 + x(i)=1+omp_is_initial_device() + enddo +!$omp end target parallel do + call __check_double(expected, x, 10) + +end program test diff --git a/test/offloading/amdgpu/target_parallel_if_2.F90 b/test/offloading/amdgpu/target_parallel_if_2.F90 new file mode 100644 index 0000000000..12bfed0944 --- /dev/null +++ b/test/offloading/amdgpu/target_parallel_if_2.F90 @@ -0,0 +1,58 @@ +program test +use omp_lib + integer :: i,k + real(kind=8),pointer :: x(:) + real(kind=8) :: expected(10) + allocate(x(10)) + k=1 + expected=1 + x=0 + !$omp target if(k > 0) map(from:x) + k=2 + !$omp parallel do + do i=1, 10 + x(i)=1+omp_is_initial_device() + enddo + !$omp end parallel do + k=2 + !$omp end target + call __check_double(expected, x, 10) + + k=0 + expected=2 + !$omp target if(k > 0) map(from:x) + k=2 + !$omp parallel do + do i=1, 10 + x(i)=1+omp_is_initial_device() + enddo + !$omp end parallel do + k=2 + !$omp end target + call __check_double(expected, x, 10) + + k=0 + expected=2 + !$omp target if(k > 0) map(from:x) + !$omp parallel do + do i=1, 10 + x(i)=1+omp_is_initial_device() + enddo + !$omp end parallel do + !$omp end target + call __check_double(expected, x, 10) + + k=1 + expected=1 + !$omp target if(k > 0) map(from:x) + !$omp parallel do + do i=1, 10 + x(i)=1+omp_is_initial_device() + enddo + !$omp end parallel do + !$omp end target + call __check_double(expected, x, 10) + +end program test + + diff --git a/test/offloading/amdgpu/target_parallel_if_3.F90 b/test/offloading/amdgpu/target_parallel_if_3.F90 new file mode 100644 index 0000000000..c55c596610 --- /dev/null +++ b/test/offloading/amdgpu/target_parallel_if_3.F90 @@ -0,0 +1,51 @@ +program test +use omp_lib + integer :: i,k + real(kind=8),pointer :: x(:) + real(kind=8),pointer :: y(:) + real(kind=8) :: expected(10) + allocate(x(10)) + allocate(y(10)) + k=2 + expected=1 + x=0 + y=0 + + !$omp target if(k > 0) map(from:x) + k=2 + !$omp parallel do + do i=1, 10 + x(i)=1+omp_is_initial_device() + enddo + !$omp end parallel do + k=2 + !$omp parallel do + do i=1, 10 + y(i)=1+omp_is_initial_device() + enddo + !$omp end parallel do + !$omp end target + call __check_double(expected, x, 10) + call __check_double(expected, y, 10) + + k=0 + expected=2 + !$omp target if(k > 0) map(from:x) + k=2 + !$omp parallel do + do i=1, 10 + x(i)=1+omp_is_initial_device() + enddo + !$omp end parallel do + k=2 + !$omp parallel do + do i=1, 10 + y(i)=1+omp_is_initial_device() + enddo + !$omp end parallel do + !$omp end target + call __check_double(expected, x, 10) + call __check_double(expected, y, 10) +end program test + + diff --git a/test/offloading/amdgpu/target_parallel_if_4.F90 b/test/offloading/amdgpu/target_parallel_if_4.F90 new file mode 100644 index 0000000000..59158adde3 --- /dev/null +++ b/test/offloading/amdgpu/target_parallel_if_4.F90 @@ -0,0 +1,44 @@ +program test + use omp_lib + integer :: i,k,N + real(8) :: T1,T2 + real(kind=8), dimension(:), allocatable :: x + real(kind=8) :: expected(10) + + k=0 + N=10 + allocate(x(N)) + + expected=2 + !$omp target teams distribute parallel do if(target:k) + do i=1, N + x(i)=0 + enddo + !$omp end target teams distribute parallel do + + T1= omp_get_wtime() + !$omp target teams distribute parallel do if(target:k) + do i=1, N + x(i)=1+omp_is_initial_device() + enddo + + call __check_double(expected, x, 10) + + k=1 + expected=1 + N=10 + !$omp target teams distribute parallel do if(target:k) + do i=1, N + x(i)=0 + enddo + !$omp end target teams distribute parallel do + + !$omp target teams distribute parallel do if(target:k) + do i=1, N + x(i)=1+omp_is_initial_device() + enddo + !$omp end target teams distribute parallel do + call __check_double(expected, x, 10) + +end program test + diff --git a/test/offloading/amdgpu/target_ptr.F90 b/test/offloading/amdgpu/target_ptr.F90 new file mode 100644 index 0000000000..e5f1c3f236 --- /dev/null +++ b/test/offloading/amdgpu/target_ptr.F90 @@ -0,0 +1,34 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! +! Unit test for use of static variables inside target region +! Date of Creation: 22nd June 2020 +! +program foo + integer, allocatable:: a(:) + integer, target:: b(100) + integer, pointer::c(:) + integer :: success = 1 + + allocate(a(100)) + c=>b + + c = 100 + + a = 4 + +!$omp target + a(50) = b(50) + 2 + a(49) = c(49) + 1 + b(48) = 0 + c(47) = 99 +!$omp end target + + if (a(48).eq.4 .and. a(49).eq.101 .and. a(50).eq.102 .and. b(47).eq.99 .and. & +& b(48).eq. 0 .and. c(46).eq.100 .and. c(47).eq.99) then + success = 0 + else + Stop -1 + endif +end diff --git a/test/offloading/amdgpu/target_simd.F90 b/test/offloading/amdgpu/target_simd.F90 new file mode 100644 index 0000000000..7f28a3f16e --- /dev/null +++ b/test/offloading/amdgpu/target_simd.F90 @@ -0,0 +1,27 @@ +FUNCTION almost_equal(x, gold, tol) RESULT(b) + implicit none + REAL, intent(in) :: x + INTEGER, intent(in) :: gold + REAL, intent(in) :: tol + LOGICAL :: b + b = ( gold * (1 - tol) <= x ).AND.( x <= gold * (1+tol) ) +END FUNCTION almost_equal +PROGRAM target_simd + implicit none + INTEGER :: N0 = 32768 + INTEGER :: i0 + LOGICAL :: almost_equal + REAL :: counter_N0 + INTEGER :: expected_value + expected_value = N0 + counter_N0 = 0 + !$OMP TARGET SIMD map(tofrom: counter_N0) + DO i0 = 1, N0 + !$OMP atomic update + counter_N0 = counter_N0 + 1. + END DO + IF ( .NOT.almost_equal(counter_N0,expected_value, 0.1) ) THEN + WRITE(*,*) 'Expected', expected_value, 'Got', counter_N0 + STOP 112 + ENDIF +END PROGRAM target_simd diff --git a/test/offloading/amdgpu/target_update.F90 b/test/offloading/amdgpu/target_update.F90 new file mode 100644 index 0000000000..075e34b933 --- /dev/null +++ b/test/offloading/amdgpu/target_update.F90 @@ -0,0 +1,61 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Adding offload regression testcases +! +! Date of Creation: 23rd September 2019 +! + +!======================UPDATE KERNEL BEGIN================================== + +module mod_update_kernel + + INTEGER, PARAMETER :: x_min=1, x_max=10 + contains + + subroutine update_kernel(energy) + implicit none + REAL(KIND=8), DIMENSION(x_min:x_max) :: energy + + !local varaibels + REAL(kind = 8) :: dbl_base + REAL(kind = 8) :: sum1 + INTEGER :: i, j, depth + REAL(kind = 8) :: expected(x_min:x_max) + + + depth = -1 + + !$omp target map(depth) + !$omp teams + !$omp distribute parallel do private(j) collapse(1) + DO j=x_min, x_max + energy(j) = j * 10 + depth + ENDDO + !$omp end teams + !$omp end target + + !$omp target update from (energy) + + + do i = x_min, x_max + expected(i) = i * 10 - 1 + end do + + call __check_double(expected, energy, x_max - x_min + 1) + + end subroutine update_kernel +end module mod_update_kernel + +!====================UPDATE KERNEL END====================================== + +program testing + use mod_update_kernel + implicit none + INTEGER :: j + REAL(KIND=8), DIMENSION(x_min:x_max) :: energy + + !$omp target data map(energy) + call update_kernel(energy) + !$omp end target data +end program testing diff --git a/test/offloading/amdgpu/teams_distribute_parallel_do.F90 b/test/offloading/amdgpu/teams_distribute_parallel_do.F90 new file mode 100644 index 0000000000..891bb6ba35 --- /dev/null +++ b/test/offloading/amdgpu/teams_distribute_parallel_do.F90 @@ -0,0 +1,15 @@ +program test +integer::c(10) +integer::c_exp(10) + do i=1, 10 + c_exp(i)=i + enddo + !$omp teams distribute parallel do + do i=1, 10 + c(i)=i + enddo + !$omp end teams distribute parallel do + call __check_int(c_exp, c, 10) + end program + + diff --git a/test/offloading/amdgpu/test-nested-implied-do.F90 b/test/offloading/amdgpu/test-nested-implied-do.F90 new file mode 100644 index 0000000000..b1539db86a --- /dev/null +++ b/test/offloading/amdgpu/test-nested-implied-do.F90 @@ -0,0 +1,16 @@ +PROGRAM test_target + INTEGER :: s = 4 + INTEGER :: j + INTEGER :: c1(1:6), c2(1:6), c_exp(1:6) + + c_exp = (/ 1, 2, 3, 4, 5, 6 /) + + c1 = (/ 1, (j+1, j=1, s ), 6/) + !$omp target map(tofrom: c2(1:s), j, s) + c2 = (/ 1, (j+1, j=1, s ), 6/) + !$omp end target + + call __check_int(c_exp, c1, s) + call __check_int(c_exp, c2, s) + +END PROGRAM test_target diff --git a/test/offloading/amdgpu/test_in_reduction.F90 b/test/offloading/amdgpu/test_in_reduction.F90 new file mode 100644 index 0000000000..57ff44a3b0 --- /dev/null +++ b/test/offloading/amdgpu/test_in_reduction.F90 @@ -0,0 +1,23 @@ +program target_reduction + use omp_lib + + implicit none + + integer :: counter + integer :: ex_counter + + counter = 0 + ex_counter = 0 + + !$OMP PARALLEL REDUCTION(+: ex_counter) + ex_counter = ex_counter + 1 + !$OMP END PARALLEL + + !$OMP PARALLEL REDUCTION(+: counter) + !$OMP TARGET IN_REDUCTION(+: counter) + counter = counter + 1 + !$OMP END TARGET + !$OMP END PARALLEL + + call __check_int(ex_counter, counter, 1) +end program target_reduction diff --git a/test/offloading/amdgpu/test_reshape_ido.F90 b/test/offloading/amdgpu/test_reshape_ido.F90 new file mode 100644 index 0000000000..f2559f233c --- /dev/null +++ b/test/offloading/amdgpu/test_reshape_ido.F90 @@ -0,0 +1,28 @@ + +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Adding offload regression testcases +! +! Date of Creation: 23rd January 2020 +! +PROGRAM test_reshape + + INTEGER :: c(1:6), c_exp(1:6) + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: arr + INTEGER :: i,j + allocate(arr(3,2)) + arr(:,:) = 0 + c_exp = (/ 1, 4, 2, 5, 3, 6 /) + !$omp target map(tofrom: arr(:,:)) + arr(:,:) = RESHAPE((/ (i , i = 1,6) /), (/ 3,2 /)) + !$omp end target + do i=1,3 + do j=1,2 + c((i-1)*2+j) = arr(i,j) + end do + end do + deallocate(arr) + call __check_int(c_exp, c, s) + +END PROGRAM test_reshape + diff --git a/test/offloading/amdgpu/use_device_addr.F90 b/test/offloading/amdgpu/use_device_addr.F90 new file mode 100644 index 0000000000..247541140a --- /dev/null +++ b/test/offloading/amdgpu/use_device_addr.F90 @@ -0,0 +1,10 @@ +program useDeviceAddr + + use, intrinsic :: iso_c_binding + integer, target :: b = 4660 + type(c_ptr) :: x + !$omp target data use_device_addr(b) map(to:b) + x = c_loc(b) + !$omp end target data + +end program useDeviceAddr diff --git a/test/offloading/amdgpu/use_device_ptr.F90 b/test/offloading/amdgpu/use_device_ptr.F90 new file mode 100644 index 0000000000..a68b05a7e6 --- /dev/null +++ b/test/offloading/amdgpu/use_device_ptr.F90 @@ -0,0 +1,65 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! Test case for USE_DEVICE_PTR clause. +! Date of creation: 29th April 2020 +! +program main + + use omp_lib + implicit none + + integer :: nx,x + integer, parameter :: sp = kind(1.0_8) + real(sp), target, allocatable :: arr1(:), crr1(:) + real(sp), target, allocatable :: hst_arr1(:), hst_crr1(:) + nx = 16 +!!!!!!!! allocate arrays !!!!!!!! + + allocate(arr1(nx)) + allocate(crr1(nx)) + + allocate(hst_arr1(nx)) + allocate(hst_crr1(nx)) + +!!!!!!!!! Initialise arrays !!!!!!!! + + arr1(:)=0. + hst_arr1(:)=0. + + + !$OMP TARGET DATA MAP(tofrom:arr1) MAP(from:crr1) + + !$OMP TARGET DATA USE_DEVICE_PTR(arr1) + !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO PRIVATE(x) + do x=1,nx + arr1(x)=(x-1)*2.0 + end do + !$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO + !$OMP END TARGET DATA + + + !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO PRIVATE(x) & + !$OMP DEPEND(IN:var) NOWAIT + do x=1,nx + crr1(x)=arr1(x)+1.0 + end do + !$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO + + !$OMP TASKWAIT + + !$OMP END TARGET DATA + + do x=1,nx + hst_arr1(x)=(x-1)*2.0 + end do + do x=1,nx + hst_crr1(x)=hst_arr1(x)+1.0 + end do + call __check_double(hst_crr1, crr1, nx) + call __check_double(hst_arr1, arr1, nx) + deallocate(arr1) + deallocate(crr1) + deallocate(hst_arr1) + deallocate(hst_crr1) +end program main diff --git a/test/openmp_examples/lit/Example_critical_atomic.1f.sh b/test/openmp_examples/lit/Example_critical_atomic.1f.sh new file mode 100644 index 0000000000..516adaf22c --- /dev/null +++ b/test/openmp_examples/lit/Example_critical_atomic.1f.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# openmp_examples test-suite +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/openmp_examples/sources/Example_critical_atomic.1f.f b/test/openmp_examples/sources/Example_critical_atomic.1f.f new file mode 100644 index 0000000000..a9ff244689 --- /dev/null +++ b/test/openmp_examples/sources/Example_critical_atomic.1f.f @@ -0,0 +1,31 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! openmp_example test-suite +! +! Date of Modification: 11/11/2019 +! +! @@name: critical_atomic.1f +! @@type: F-fixed +! @@compilable: yes +! @@linkable: no +! @@expect: success + + SUBROUTINE CRITICAL_ATOMIC_EXAMPLE() + integer,parameter::max_n_size=20 + integer(kind=8),save::plan_array(max_n_size)=0 + integer(kind=8):: N, fftw_plan +!$OMP ATOMIC READ + fftw_plan=plan_array(N) +!$OMP CRITICAL + if (plan_array(N)<=0) then +!$OMP ATOMIC WRITE + plan_array(N)=fftw_plan + else +!$OMP ATOMIC READ + fftw_plan=plan_array(N) + endif +!$OMP END CRITICAL + fftw_plan=plan_array(N) + + END SUBROUTINE CRITICAL_ATOMIC_EXAMPLE diff --git a/test/openmp_examples/sources/inc/Example_critical_atomic.1f.mk b/test/openmp_examples/sources/inc/Example_critical_atomic.1f.mk new file mode 100644 index 0000000000..28c138b06e --- /dev/null +++ b/test/openmp_examples/sources/inc/Example_critical_atomic.1f.mk @@ -0,0 +1,8 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# openmp_example test-suite +# +# + +include $(INCLUDES)/fixed-compile.mk diff --git a/test/tools/check_compilation.py b/test/tools/check_compilation.py index 50e187bcfc..20d46b342d 100644 --- a/test/tools/check_compilation.py +++ b/test/tools/check_compilation.py @@ -22,6 +22,7 @@ """ import re +import sys import argparse from collections import namedtuple from os.path import basename @@ -101,7 +102,8 @@ def getLogErrors(log): elif terminatedError.search(line): terminated = True else: - print line, + sys.stdout.write (line) + sys.stdout.write (" ") return terminated, errorList def getFileSet(source, logErrors): @@ -166,14 +168,14 @@ def checkErrorsMatch(terminated, logErrors, sourceErrors, compiler): for e in logErrors: if not removeMatch(e, sourceErrors, compiler): fail = True - print "Unexpected:", e.sev, e.file, e.lineno, e.text + print ("Unexpected:", e.sev, e.file, e.lineno, e.text) for e in sourceErrors: fail = True - print "Missed:", e.sev, e.file, e.lineno, e.text + print ("Missed:", e.sev, e.file, e.lineno, e.text) if fail or terminated: - print "FAIL" + print ("FAIL") else: - print "PASS" + print ("PASS") def removeMatch(e, errors, compiler): """ @@ -204,12 +206,12 @@ def dumpErrorSet(errors, title): :param title: optional title """ if title: - print title + print (title) if len(errors) == 0: - print " (none)" + print (" (none)") else: for e in errors: - print " ", e.sev, e.file, e.lineno, e.prefix if e.prefix != None else "", e.text if e.text != None else "" + print (" ", e.sev, e.file, e.lineno, e.prefix) if e.prefix != None else "", e.text if e.text != None else "" if __name__=="__main__": diff --git a/test/x86_64_offloading/inc/alloc1.mk b/test/x86_64_offloading/inc/alloc1.mk new file mode 100644 index 0000000000..73cc94cf7d --- /dev/null +++ b/test/x86_64_offloading/inc/alloc1.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +########## Make rule for test alloc1 ######## + + +alloc1: alloc1.run + +alloc1.$(OBJX): $(SRC)/alloc1.f90 + -$(RM) alloc1.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/alloc1.f90 -o alloc1.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) alloc1.$(OBJX) check.$(OBJX) $(LIBS) -o alloc1.$(EXESUFFIX) + + +alloc1.run: alloc1.$(OBJX) + @echo ------------------------------------ executing test alloc1 + alloc1.$(EXESUFFIX) + +build: alloc1.$(OBJX) + +verify: ; + +run: alloc1.$(OBJX) + @echo ------------------------------------ executing test alloc1 + alloc1.$(EXESUFFIX) diff --git a/test/x86_64_offloading/inc/alloc2.mk b/test/x86_64_offloading/inc/alloc2.mk new file mode 100644 index 0000000000..019a95bf07 --- /dev/null +++ b/test/x86_64_offloading/inc/alloc2.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +########## Make rule for test alloc2 ######## + + +alloc2: alloc2.run + +alloc2.$(OBJX): $(SRC)/alloc2.f90 + -$(RM) alloc2.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/alloc2.f90 -o alloc2.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) alloc2.$(OBJX) check.$(OBJX) $(LIBS) -o alloc2.$(EXESUFFIX) + + +alloc2.run: alloc2.$(OBJX) + @echo ------------------------------------ executing test alloc2 + alloc2.$(EXESUFFIX) + +build: alloc2.$(OBJX) + +verify: ; + +run: alloc2.$(OBJX) + @echo ------------------------------------ executing test alloc2 + alloc2.$(EXESUFFIX) diff --git a/test/x86_64_offloading/inc/data_transfer.mk b/test/x86_64_offloading/inc/data_transfer.mk new file mode 100644 index 0000000000..fc4878c447 --- /dev/null +++ b/test/x86_64_offloading/inc/data_transfer.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +########## Make rule for test data_transfer ######## + + +data_transfer: data_transfer.run + +data_transfer.$(OBJX): $(SRC)/data_transfer.f90 + -$(RM) data_transfer.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/data_transfer.f90 -o data_transfer.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) data_transfer.$(OBJX) check.$(OBJX) $(LIBS) -o data_transfer.$(EXESUFFIX) + + +data_transfer.run: data_transfer.$(OBJX) + @echo ------------------------------------ executing test data_transfer + data_transfer.$(EXESUFFIX) + +build: data_transfer.$(OBJX) + +verify: ; + +run: data_transfer.$(OBJX) + @echo ------------------------------------ executing test data_transfer + data_transfer.$(EXESUFFIX) diff --git a/test/x86_64_offloading/inc/misc1.mk b/test/x86_64_offloading/inc/misc1.mk new file mode 100644 index 0000000000..70f90777b4 --- /dev/null +++ b/test/x86_64_offloading/inc/misc1.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +########## Make rule for test misc1 ######## + + +misc1: misc1.run + +misc1.$(OBJX): $(SRC)/misc1.f90 + -$(RM) misc1.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/misc1.f90 -o misc1.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) misc1.$(OBJX) check.$(OBJX) $(LIBS) -o misc1.$(EXESUFFIX) + + +misc1.run: misc1.$(OBJX) + @echo ------------------------------------ executing test misc1 + misc1.$(EXESUFFIX) + +build: misc1.$(OBJX) + +verify: ; + +run: misc1.$(OBJX) + @echo ------------------------------------ executing test misc1 + misc1.$(EXESUFFIX) diff --git a/test/x86_64_offloading/inc/misc2.mk b/test/x86_64_offloading/inc/misc2.mk new file mode 100644 index 0000000000..b924078041 --- /dev/null +++ b/test/x86_64_offloading/inc/misc2.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2020, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +########## Make rule for test misc2 ######## + + +misc2: misc2.run + +misc2.$(OBJX): $(SRC)/misc2.f90 + -$(RM) misc2.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/misc2.f90 -o misc2.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) misc2.$(OBJX) check.$(OBJX) $(LIBS) -o misc2.$(EXESUFFIX) + + +misc2.run: misc2.$(OBJX) + @echo ------------------------------------ executing test misc2 + misc2.$(EXESUFFIX) + +build: misc2.$(OBJX) + +verify: ; + +run: misc2.$(OBJX) + @echo ------------------------------------ executing test misc2 + misc2.$(EXESUFFIX) diff --git a/test/x86_64_offloading/inc/misc3.mk b/test/x86_64_offloading/inc/misc3.mk new file mode 100644 index 0000000000..d53ed48af5 --- /dev/null +++ b/test/x86_64_offloading/inc/misc3.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2020, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +########## Make rule for test misc3 ######## + + +misc3: misc3.run + +misc3.$(OBJX): $(SRC)/misc3.f90 + -$(RM) misc3.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c -Mx,232,0x1 $(FFLAGS) $(LDFLAGS) $(SRC)/misc3.f90 -o misc3.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) misc3.$(OBJX) check.$(OBJX) $(LIBS) -o misc3.$(EXESUFFIX) + + +misc3.run: misc3.$(OBJX) + @echo ------------------------------------ executing test misc3 + misc3.$(EXESUFFIX) + +build: misc3.$(OBJX) + +verify: ; + +run: misc3.$(OBJX) + @echo ------------------------------------ executing test misc3 + misc3.$(EXESUFFIX) diff --git a/test/x86_64_offloading/inc/misc4.mk b/test/x86_64_offloading/inc/misc4.mk new file mode 100644 index 0000000000..9a34ec489b --- /dev/null +++ b/test/x86_64_offloading/inc/misc4.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2020, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +########## Make rule for test misc4 ######## + + +misc4: misc4.run + +misc4.$(OBJX): $(SRC)/misc4.f90 + -$(RM) misc4.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/misc4.f90 -o misc4.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) misc4.$(OBJX) check.$(OBJX) $(LIBS) -o misc4.$(EXESUFFIX) + + +misc4.run: misc4.$(OBJX) + @echo ------------------------------------ executing test misc4 + misc4.$(EXESUFFIX) + +build: misc4.$(OBJX) + +verify: ; + +run: misc4.$(OBJX) + @echo ------------------------------------ executing test misc4 + misc4.$(EXESUFFIX) diff --git a/test/x86_64_offloading/inc/nested_parallel1.mk b/test/x86_64_offloading/inc/nested_parallel1.mk new file mode 100644 index 0000000000..9b43a8bac9 --- /dev/null +++ b/test/x86_64_offloading/inc/nested_parallel1.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2020, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +########## Make rule for test nested_parallel1 ######## + + +nested_parallel1: nested_parallel1.run + +nested_parallel1.$(OBJX): $(SRC)/nested_parallel1.f90 + -$(RM) nested_parallel1.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/nested_parallel1.f90 -o nested_parallel1.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) nested_parallel1.$(OBJX) check.$(OBJX) $(LIBS) -o nested_parallel1.$(EXESUFFIX) + + +nested_parallel1.run: nested_parallel1.$(OBJX) + @echo ------------------------------------ executing test nested_parallel1 + nested_parallel1.$(EXESUFFIX) + +build: nested_parallel1.$(OBJX) + +verify: ; + +run: nested_parallel1.$(OBJX) + @echo ------------------------------------ executing test nested_parallel1 + nested_parallel1.$(EXESUFFIX) diff --git a/test/x86_64_offloading/inc/parallel.mk b/test/x86_64_offloading/inc/parallel.mk new file mode 100644 index 0000000000..2122f4d6d8 --- /dev/null +++ b/test/x86_64_offloading/inc/parallel.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +########## Make rule for test parallel ######## + + +parallel: parallel.run + +parallel.$(OBJX): $(SRC)/parallel.f90 + -$(RM) parallel.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/parallel.f90 -o parallel.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) parallel.$(OBJX) check.$(OBJX) $(LIBS) -o parallel.$(EXESUFFIX) + + +parallel.run: parallel.$(OBJX) + @echo ------------------------------------ executing test parallel + parallel.$(EXESUFFIX) + +build: parallel.$(OBJX) + +verify: ; + +run: parallel.$(OBJX) + @echo ------------------------------------ executing test parallel + parallel.$(EXESUFFIX) diff --git a/test/x86_64_offloading/inc/reduction1.mk b/test/x86_64_offloading/inc/reduction1.mk new file mode 100644 index 0000000000..7c799ec107 --- /dev/null +++ b/test/x86_64_offloading/inc/reduction1.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +########## Make rule for test reduction1 ######## + + +reduction1: reduction1.run + +reduction1.$(OBJX): $(SRC)/reduction1.f90 + -$(RM) reduction1.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/reduction1.f90 -o reduction1.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) reduction1.$(OBJX) check.$(OBJX) $(LIBS) -o reduction1.$(EXESUFFIX) + + +reduction1.run: reduction1.$(OBJX) + @echo ------------------------------------ executing test reduction1 + reduction1.$(EXESUFFIX) + +build: reduction1.$(OBJX) + +verify: ; + +run: reduction1.$(OBJX) + @echo ------------------------------------ executing test reduction1 + reduction1.$(EXESUFFIX) diff --git a/test/x86_64_offloading/inc/reduction2.mk b/test/x86_64_offloading/inc/reduction2.mk new file mode 100644 index 0000000000..95815e39cf --- /dev/null +++ b/test/x86_64_offloading/inc/reduction2.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +########## Make rule for test reduction2 ######## + + +reduction2: reduction2.run + +reduction2.$(OBJX): $(SRC)/reduction2.f90 + -$(RM) reduction2.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/reduction2.f90 -o reduction2.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) reduction2.$(OBJX) check.$(OBJX) $(LIBS) -o reduction2.$(EXESUFFIX) + + +reduction2.run: reduction2.$(OBJX) + @echo ------------------------------------ executing test reduction2 + reduction2.$(EXESUFFIX) + +build: reduction2.$(OBJX) + +verify: ; + +run: reduction2.$(OBJX) + @echo ------------------------------------ executing test reduction2 + reduction2.$(EXESUFFIX) diff --git a/test/x86_64_offloading/inc/target_if1.mk b/test/x86_64_offloading/inc/target_if1.mk new file mode 100644 index 0000000000..72661933a9 --- /dev/null +++ b/test/x86_64_offloading/inc/target_if1.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +########## Make rule for test target_if1 ######## + + +target_if1: target_if1.run + +target_if1.$(OBJX): $(SRC)/target_if1.f90 + -$(RM) target_if1.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/target_if1.f90 -o target_if1.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) target_if1.$(OBJX) check.$(OBJX) $(LIBS) -o target_if1.$(EXESUFFIX) + + +target_if1.run: target_if1.$(OBJX) + @echo ------------------------------------ executing test target_if1 + target_if1.$(EXESUFFIX) + +build: target_if1.$(OBJX) + +verify: ; + +run: target_if1.$(OBJX) + @echo ------------------------------------ executing test target_if1 + target_if1.$(EXESUFFIX) diff --git a/test/x86_64_offloading/inc/target_update1.mk b/test/x86_64_offloading/inc/target_update1.mk new file mode 100644 index 0000000000..b2a5bfca5c --- /dev/null +++ b/test/x86_64_offloading/inc/target_update1.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +########## Make rule for test target_update1 ######## + + +target_update1: target_update1.run + +target_update1.$(OBJX): $(SRC)/target_update1.f90 + -$(RM) target_update1.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/target_update1.f90 -o target_update1.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) target_update1.$(OBJX) check.$(OBJX) $(LIBS) -o target_update1.$(EXESUFFIX) + + +target_update1.run: target_update1.$(OBJX) + @echo ------------------------------------ executing test target_update1 + target_update1.$(EXESUFFIX) + +build: target_update1.$(OBJX) + +verify: ; + +run: target_update1.$(OBJX) + @echo ------------------------------------ executing test target_update1 + target_update1.$(EXESUFFIX) diff --git a/test/x86_64_offloading/inc/teams_distribute1.mk b/test/x86_64_offloading/inc/teams_distribute1.mk new file mode 100644 index 0000000000..262ba64d31 --- /dev/null +++ b/test/x86_64_offloading/inc/teams_distribute1.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +########## Make rule for test teams_distribute1 ######## + + +teams_distribute1: teams_distribute1.run + +teams_distribute1.$(OBJX): $(SRC)/teams_distribute1.f90 + -$(RM) teams_distribute1.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/teams_distribute1.f90 -o teams_distribute1.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) teams_distribute1.$(OBJX) check.$(OBJX) $(LIBS) -o teams_distribute1.$(EXESUFFIX) + + +teams_distribute1.run: teams_distribute1.$(OBJX) + @echo ------------------------------------ executing test teams_distribute1 + teams_distribute1.$(EXESUFFIX) + +build: teams_distribute1.$(OBJX) + +verify: ; + +run: teams_distribute1.$(OBJX) + @echo ------------------------------------ executing test teams_distribute1 + teams_distribute1.$(EXESUFFIX) diff --git a/test/x86_64_offloading/inc/teams_distribute2.mk b/test/x86_64_offloading/inc/teams_distribute2.mk new file mode 100644 index 0000000000..0df04a6313 --- /dev/null +++ b/test/x86_64_offloading/inc/teams_distribute2.mk @@ -0,0 +1,30 @@ +# +# Copyright (c) 2020, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +########## Make rule for test teams_distribute2 ######## + + +teams_distribute2: teams_distribute2.run + +teams_distribute2.$(OBJX): $(SRC)/teams_distribute2.f90 + -$(RM) teams_distribute2.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.* + @echo ------------------------------------ building test $@ + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + -$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/teams_distribute2.f90 -o teams_distribute2.$(OBJX) + -$(FC) $(FFLAGS) $(LDFLAGS) teams_distribute2.$(OBJX) check.$(OBJX) $(LIBS) -o teams_distribute2.$(EXESUFFIX) + + +teams_distribute2.run: teams_distribute2.$(OBJX) + @echo ------------------------------------ executing test teams_distribute2 + teams_distribute2.$(EXESUFFIX) + +build: teams_distribute2.$(OBJX) + +verify: ; + +run: teams_distribute2.$(OBJX) + @echo ------------------------------------ executing test teams_distribute2 + teams_distribute2.$(EXESUFFIX) diff --git a/test/x86_64_offloading/lit/alloc1.sh b/test/x86_64_offloading/lit/alloc1.sh new file mode 100644 index 0000000000..328fbdd72c --- /dev/null +++ b/test/x86_64_offloading/lit/alloc1.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/x86_64_offloading/lit/alloc2.sh b/test/x86_64_offloading/lit/alloc2.sh new file mode 100644 index 0000000000..328fbdd72c --- /dev/null +++ b/test/x86_64_offloading/lit/alloc2.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/x86_64_offloading/lit/data_transfer.sh b/test/x86_64_offloading/lit/data_transfer.sh new file mode 100644 index 0000000000..6a3aec5845 --- /dev/null +++ b/test/x86_64_offloading/lit/data_transfer.sh @@ -0,0 +1,9 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +# Shared lit script for each tests. Run bash commands that run tests with make. +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/x86_64_offloading/lit/misc1.sh b/test/x86_64_offloading/lit/misc1.sh new file mode 100644 index 0000000000..328fbdd72c --- /dev/null +++ b/test/x86_64_offloading/lit/misc1.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/x86_64_offloading/lit/misc2.sh b/test/x86_64_offloading/lit/misc2.sh new file mode 100644 index 0000000000..af875e73b3 --- /dev/null +++ b/test/x86_64_offloading/lit/misc2.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2020, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/x86_64_offloading/lit/misc3.sh b/test/x86_64_offloading/lit/misc3.sh new file mode 100644 index 0000000000..498fcc4626 --- /dev/null +++ b/test/x86_64_offloading/lit/misc3.sh @@ -0,0 +1,11 @@ +# +# Copyright (c) 2020, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +UNSUPPORTED: +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/x86_64_offloading/lit/misc4.sh b/test/x86_64_offloading/lit/misc4.sh new file mode 100644 index 0000000000..af875e73b3 --- /dev/null +++ b/test/x86_64_offloading/lit/misc4.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2020, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/x86_64_offloading/lit/nested_parallel1.sh b/test/x86_64_offloading/lit/nested_parallel1.sh new file mode 100644 index 0000000000..af875e73b3 --- /dev/null +++ b/test/x86_64_offloading/lit/nested_parallel1.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2020, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/x86_64_offloading/lit/parallel.sh b/test/x86_64_offloading/lit/parallel.sh new file mode 100644 index 0000000000..328fbdd72c --- /dev/null +++ b/test/x86_64_offloading/lit/parallel.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/x86_64_offloading/lit/reduction1.sh b/test/x86_64_offloading/lit/reduction1.sh new file mode 100644 index 0000000000..328fbdd72c --- /dev/null +++ b/test/x86_64_offloading/lit/reduction1.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/x86_64_offloading/lit/reduction2.sh b/test/x86_64_offloading/lit/reduction2.sh new file mode 100644 index 0000000000..328fbdd72c --- /dev/null +++ b/test/x86_64_offloading/lit/reduction2.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/x86_64_offloading/lit/runmake b/test/x86_64_offloading/lit/runmake new file mode 100644 index 0000000000..bba2267a84 --- /dev/null +++ b/test/x86_64_offloading/lit/runmake @@ -0,0 +1,27 @@ +#! /bin/bash +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +test_name=${TEST_SRC##*/} # Strip path. +test_name=${test_name%.*} # Strip extension. + +temp_dir="$test_name" +rm -rf $temp_dir + +MAKE_FILE=$MAKE_FILE_DIR/makefile + +mkdir $temp_dir +if [[ ! $KEEP_FILES ]]; then + # If keep files is not specified, remove these files at the end. + trap "rm -rf $(pwd)/$temp_dir" EXIT +fi +cd $temp_dir +export PATH=$PATH:$(pwd) + +make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" build 2>&1 +make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" run 2>&1 +make -f $MAKE_FILE HOMEQA=$MAKE_FILE_DIR TEST=$test_name OPT="$FLAGS" verify 2>&1 +# CHECK: {{([1-9][0-9]* tests PASSED\. 0 tests failed|[[:space:]]*PASS(ED)?[[:space:]]*$)}} diff --git a/test/x86_64_offloading/lit/target_if1.sh b/test/x86_64_offloading/lit/target_if1.sh new file mode 100644 index 0000000000..328fbdd72c --- /dev/null +++ b/test/x86_64_offloading/lit/target_if1.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/x86_64_offloading/lit/target_update1.sh b/test/x86_64_offloading/lit/target_update1.sh new file mode 100644 index 0000000000..328fbdd72c --- /dev/null +++ b/test/x86_64_offloading/lit/target_update1.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/x86_64_offloading/lit/teams_distribute1.sh b/test/x86_64_offloading/lit/teams_distribute1.sh new file mode 100644 index 0000000000..328fbdd72c --- /dev/null +++ b/test/x86_64_offloading/lit/teams_distribute1.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/x86_64_offloading/lit/teams_distribute2.sh b/test/x86_64_offloading/lit/teams_distribute2.sh new file mode 100644 index 0000000000..af875e73b3 --- /dev/null +++ b/test/x86_64_offloading/lit/teams_distribute2.sh @@ -0,0 +1,10 @@ +# +# Copyright (c) 2020, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +# Shared lit script for each tests. Run bash commands that run tests with make. + +# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t +# RUN: cat %t | FileCheck %S/runmake diff --git a/test/x86_64_offloading/makefile b/test/x86_64_offloading/makefile new file mode 100644 index 0000000000..b8f3904934 --- /dev/null +++ b/test/x86_64_offloading/makefile @@ -0,0 +1,45 @@ +# +# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +# +# x86_64 offloading regression test-suite +# + +BASE_DIR=$(HOMEQA) +SRC=$(BASE_DIR)/src +SRC2=$(BASE_DIR)/src/src # For regression_cpu +FC=flang +CC=clang +CXX=clang++ +OBJX=o +EXESUFFIX=out +LD=$(FC) +OPT=-O +OMP_FLAGS=-fopenmp -fopenmp-targets=x86_64-pc-linux-gnu +FFLAGS=-I$(SRC) $(OPT) $(KIEE) $(EXTRA_FFLAGS) $(EXTRA_HFLAGS) $(OMP_FLAGS) +LDFLAGS=$(EXTRA_LDFLAGS) -fuse-ld=ld +LIBS=$(EXTRA_LIBS) +CFLAGS=$(EXTRA_CFLAGS) $(OMP_FLAGS) +TEST= +COMP_CHECK=python $(HOMEQA)/../tools/check_compilation.py + +RM=rm -f +CP=cp -f +UNAME := $(shell uname -a) + +INCLUDES=$(BASE_DIR)/inc + +check: check.$(OBJX) + +check.$(OBJX) : $(SRC)/check.c + -$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX) + +clean.run: clean.$(OBJX) + a.out + +clean: + -$(RM) a.out *.$(OBJX) *.mod *.qdbg core + +run.run: run.$(OBJX) + a.out + +include $(INCLUDES)/$(TEST).mk diff --git a/test/x86_64_offloading/src/alloc1.f90 b/test/x86_64_offloading/src/alloc1.f90 new file mode 100644 index 0000000000..6eddef2028 --- /dev/null +++ b/test/x86_64_offloading/src/alloc1.f90 @@ -0,0 +1,27 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! x86_64 offloading regression test-suite +! +! Last modified: Nov 2019 +! + +module mod1 + integer(4), allocatable :: send_buffer_back(:) +end module mod1 + +program foo + use mod1 + integer(4) :: exp(5) = (/12, 13, 14, 0, 0/) + + allocate(send_buffer_back(5)) + + send_buffer_back = 0 + !$omp target map(tofrom: send_buffer_back) + send_buffer_back(1) = 12 + send_buffer_back(2) = 13 + send_buffer_back(3) = 14 + !$omp end target + + call check_int(send_buffer_back, exp, 5) +end program diff --git a/test/x86_64_offloading/src/alloc2.f90 b/test/x86_64_offloading/src/alloc2.f90 new file mode 100644 index 0000000000..fd9789a7bc --- /dev/null +++ b/test/x86_64_offloading/src/alloc2.f90 @@ -0,0 +1,50 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! x86_64 offloading regression test-suite +! +! Last modified: Dec 2019 +! + +module mod1 + double precision, dimension (:,:,:,:), allocatable::u + double precision, dimension ( :,:,:), allocatable::rho_i +end module mod1 + +subroutine subr1 + use mod1 + integer i, j, k, m, err + integer :: gp31 = 2, gp21 = 2, gp11 = 2 + double precision rho_inv + + u = 0; + rho_i = 0; + !$omp target teams distribute parallel do collapse(2) & + !$omp private(k, j, i, rho_inv) + do k = 0, gp31 + do j = 0, gp21 + !$omp simd private(rho_inv) + do i = 0, gp11 + rho_i(i,j,k) = 12 + end do + end do + end do + !$omp end target teams distribute parallel do + +end subroutine subr1 + +program foo + use mod1 + integer, parameter :: sz = 2 + double precision exp(0:sz, 0:sz, 0:sz) + + exp = 12 + allocate(u(0:sz, 0:sz, 0:sz, 0:sz)) + allocate(rho_i(0:sz, 0:sz, 0:sz)) + + !$omp target data map(tofrom:rho_i) + call subr1 + !$omp end target data + + call check_double(rho_i, exp, sz + 1) +end program foo diff --git a/test/x86_64_offloading/src/check.c b/test/x86_64_offloading/src/check.c new file mode 100644 index 0000000000..85a65646b4 --- /dev/null +++ b/test/x86_64_offloading/src/check.c @@ -0,0 +1,52 @@ +/* + * Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. + * + * x86_64 offloading regression test-suite + * + * Last modified: Oct 2019 + */ + +#include +#include + +// We don't summarize the test results in the dump functions, since lit already +// does that. Not sure why flang-devs are attempting to summarize it +// "progressively" in other test-suites. +// +// There's a FileCheck directive "CHECK:" in runmake that matches the +// string printed by dump_passed()/dump_failed(). It's case sensitive! You've been +// warned. +// +void dump_passed() { + printf("1 tests PASSED. 0 tests failed.\n"); +} + +void dump_failed() { + printf("0 tests passed. 1 tests FAILED.\n"); +} + +void check_int_(int *res, int *exp, int *n) { + if (!res || !exp || !n) { + dump_failed(); + exit(1); + } + + for (int i = 0; i < *n; i++) { + if (res[i] != exp[i]) { dump_failed(); exit (1); } + } + + dump_passed(); +} + +void check_double_(double *res, double *exp, int *n) { + if (!res || !exp || !n) { + dump_failed(); + exit(1); + } + + for (int i = 0; i < *n; i++) { + if (res[i] != exp[i]) { dump_failed(); exit (1); } + } + + dump_passed(); +} diff --git a/test/x86_64_offloading/src/data_transfer.f90 b/test/x86_64_offloading/src/data_transfer.f90 new file mode 100644 index 0000000000..2ef99aaa2b --- /dev/null +++ b/test/x86_64_offloading/src/data_transfer.f90 @@ -0,0 +1,42 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! x86_64 offloading regression test-suite +! +! Last modified: Aug 2019 +! + +program foo + integer, parameter :: SZ = 7 + integer, allocatable :: send(:) + integer, allocatable :: f_data(:,:) + integer :: exp(4), res(4) + integer :: iterat = 1, max_iterat = 3 + + allocate(send(SZ)) + allocate(f_data(SZ, SZ)) + + f_data(iterat, iterat) = 10 + iterat + send(iterat) = 20 + iterat + + !$omp target data map(tofrom:f_data), map(to:send) + !$omp target + f_data(iterat, iterat) = 100 + iterat + send(iterat) = 200 + iterat + !$omp end target + !$omp end target data + exp(1) = 101; res(1) = f_data(iterat, iterat) + exp(2) = 21; res(2) = send(iterat) + + !$omp target data map(to:f_data), map(tofrom:send) + !$omp target + f_data(iterat, iterat) = 1000 + iterat + send(iterat) = 2000 + iterat + !$omp end target + !$omp end target data + + exp(3) = 101; res(3) = f_data(iterat, iterat) + exp(4) = 2001; res(4) = send(iterat) + + call check_int(res, exp, 4) +end program foo diff --git a/test/x86_64_offloading/src/misc1.f90 b/test/x86_64_offloading/src/misc1.f90 new file mode 100644 index 0000000000..9a565e8de9 --- /dev/null +++ b/test/x86_64_offloading/src/misc1.f90 @@ -0,0 +1,102 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! x86_64 offloading regression test-suite +! +! Last modified: Jan 2020 +! + +! This is a test to check if flang can compile this. Flang's original +! symbol-replacer seems to segfault with this test-case. + +module mod1 + real :: wall_a_factor = 2.1, atmos_ocean_sign = 1.0 + integer :: nzb = 2, nzt = 3, nysg = 3, nyng = 2, & + i_left = 1, i_right = 2, j_s = 1, j_n = 2, & + nxlg = 1, nxrg = 3 + + real, dimension(:), allocatable :: ddzu, ddzw, zu, zw, dd2zu, l_grid + integer, dimension(:,:), allocatable, target :: nzb_s_inner + real, dimension(:,:,:), allocatable, target :: e, km, tend, diss + + logical :: wall_a = .true., xyzkernel = .true., & + usr = .true. + !$omp declare target(wall_a_factor, atmos_ocean_sign, nzb, nzt, nysg, nyng, & + !$omp i_left, i_right, j_s, j_n, nxlg, nxrg, ddzu, ddzw, zu, zw, dd2zu, & + !$omp l_grid, nzb_s_inner, e, km, tend, diss) +end module mod1 + +MODULE diff_e_mod + CONTAINS + SUBROUTINE diff_e_acc( var, var_reference ) + + use mod1 + + IMPLICIT NONE + + INTEGER :: i, j, k + REAL :: dissipation, dvar_dz, l, ll, l_stable, var_reference + + REAL, DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: var + + + IF ( usr ) THEN + !$omp target !present( ddzu, ddzw, dd2zu, diss, e, km, l_grid, nzb_s_inner, tend, var, zu, zw ) + !$omp teams + !$omp distribute parallel do collapse(2) private(dvar_dz,l_stable,l,ll,dissipation) + DO i = i_left, i_right + DO j = j_s, j_n + !$omp simd private(dvar_dz,l_stable,l,ll,dissipation) + DO k = 1, nzt + IF ( k > nzb_s_inner(j,i) ) THEN + dvar_dz = atmos_ocean_sign * & + ( var(k+1,j,i) - var(k-1,j,i) ) * dd2zu(k) + IF ( wall_a ) THEN + l = MIN( wall_a_factor * & + ( zu(k) - zw(nzb_s_inner(j,i)) ), & + l_grid(k), l_stable ) + ll = MIN( wall_a_factor * & + ( zu(k) - zw(nzb_s_inner(j,i)) ), & + l_grid(k) ) + ELSE + l = MIN( l_grid(k), l_stable ) + ll = l_grid(k) + ENDIF + dissipation = ( 0.19 + 0.74 * l / ll ) * & + e(k,j,i) * SQRT( e(k,j,i) ) / l + + tend(k,j,i) = tend(k,j,i) & + + ( & + ( km(k,j,i)+km(k,j,i+1) ) * ( e(k,j,i+1)-e(k,j,i) ) & + - ( km(k,j,i)+km(k,j,i-1) ) * ( e(k,j,i)-e(k,j,i-1) ) & + ) & + + ( & + ( km(k,j,i)+km(k,j+1,i) ) * ( e(k,j+1,i)-e(k,j,i) ) & + - ( km(k,j,i)+km(k,j-1,i) ) * ( e(k,j,i)-e(k,j-1,i) ) & + ) & + + ( & + ( km(k,j,i)+km(k+1,j,i) ) * ( e(k+1,j,i)-e(k,j,i) ) * ddzu(k+1) & + - ( km(k,j,i)+km(k-1,j,i) ) * ( e(k,j,i)-e(k-1,j,i) ) * ddzu(k) & + ) * ddzw(k) & + - dissipation + + IF (xyzkernel) then + diss(k,j,i) = dissipation + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + !$omp end teams + !$omp end target + ENDIF + + END SUBROUTINE diff_e_acc +END MODULE diff_e_mod + +program foo + integer :: exp(1) = (/1/) + integer :: res(1) = (/1/) + + call check_int(exp, res, 1) +end program foo diff --git a/test/x86_64_offloading/src/misc2.f90 b/test/x86_64_offloading/src/misc2.f90 new file mode 100644 index 0000000000..38d30624ec --- /dev/null +++ b/test/x86_64_offloading/src/misc2.f90 @@ -0,0 +1,51 @@ +! +! Copyright (c) 2020, Advanced Micro Devices, Inc. All rights reserved. +! +! x86_64 offloading regression test-suite +! +! Last modified: Feb 2020 +! + +! +! Flang, prior to writing this test-case, "fuses" the parallel loops in the target +! region's outlined function. Since this outlined function will be executed +! parallelly, there can be cases where threads can be in different loops +! at the same time without honoring the data dependence between the loops. This +! test-case has 3 loops where the 1st loop depends on the 2nd loop, the 2nd loop +! depends on the 1st loop and the 3rd loop depends on the 2nd loop. +! + +program foo + integer, parameter :: N = 300 + integer :: arr(N), i, k + integer :: exp(N) + + exp(1:100) = 19 + exp(101:200) = 20 + exp(201:300) = 21 + + arr(1:9) = 0 + arr(10:19) = 1 + arr(20:29) = 2 + + do k = 1, 10 + !$omp target teams + !$omp distribute parallel do + do i = 1, 100 + arr(i) = arr(i + 100) + 1 + end do + + !$omp distribute parallel do + do i = 101, 200 + arr(i) = arr(i - 100) + 1 + end do + + !$omp distribute parallel do + do i = 201, 300 + arr(i) = arr(i - 100) + 1 + end do + !$omp end target teams + end do + + call check_int(arr, exp, N) +end program foo diff --git a/test/x86_64_offloading/src/misc3.f90 b/test/x86_64_offloading/src/misc3.f90 new file mode 100644 index 0000000000..e12d9ba6ba --- /dev/null +++ b/test/x86_64_offloading/src/misc3.f90 @@ -0,0 +1,61 @@ +! +! Copyright (c) 2020, Advanced Micro Devices, Inc. All rights reserved. +! +! x86_64 offloading regression test-suite +! +! Last modified: Apr 2020 +! + +! +! This test-case validates the implementation of -Mx,232,0x1. The first target +! region shows the limitation the default offloading mechanism that only creates +! one outlined function for the whole target region. Presence of parallel region +! in those target region causes the whole target region to be parallelized. +! -Mx,232,0x1 fixes this with an entry-function that's serial in non teams +! target and outlining is done for each parallel region. +! + +program foo + integer, parameter :: n = 10 + integer :: i, cond + real(8) :: arr(n), exp(n) + real :: f0, f1 + + do i = 1, n + exp(i) = 2 * i + end do + exp(1) = 2 * exp(1) + exp(2) = 3.14 + + cond = 1 + + !$omp target + if (cond == 1) then + !$omp parallel do + do i = 1, n + arr(i) = i + end do + elseif (cond == 2) then + !$omp parallel do + do i = 1, n + arr(i) = i + 10 + end do + endif + + ! This must be executed serially exactly once. + arr(1) = arr(1) + 1 + + !$omp parallel do + do i = 1, n + arr(i) = arr(i) + arr(i) + end do + + !$omp end target + + f0 = 3.14 + !$omp target map(to: f0) + arr(2) = 3.14 + !$omp end target + + call check_double(arr, exp, n) +end program foo diff --git a/test/x86_64_offloading/src/misc4.f90 b/test/x86_64_offloading/src/misc4.f90 new file mode 100644 index 0000000000..f1d86f55b3 --- /dev/null +++ b/test/x86_64_offloading/src/misc4.f90 @@ -0,0 +1,30 @@ +! +! Copyright (c) 2020, Advanced Micro Devices, Inc. All rights reserved. +! +! x86_64 offloading regression test-suite +! +! Last modified: Apr 2020 +! + +program foo + integer, parameter :: n = 100 + integer(8) :: arr(n), sum + integer :: i + + arr = 0 + sum = 0 + + !$omp target teams map(tofrom: sum) reduction(+:sum) + !$omp distribute parallel do + do i = 1, n + arr(i) = 3 + end do + + !$omp distribute parallel do reduction(+:sum) + do i = 1, n + sum = sum + arr(i) + end do + !$omp end target teams + + call check_int(sum, 300, 1) +end program foo diff --git a/test/x86_64_offloading/src/nested_parallel1.f90 b/test/x86_64_offloading/src/nested_parallel1.f90 new file mode 100644 index 0000000000..be44559255 --- /dev/null +++ b/test/x86_64_offloading/src/nested_parallel1.f90 @@ -0,0 +1,31 @@ +! +! Copyright (c) 2020, Advanced Micro Devices, Inc. All rights reserved. +! +! x86_64 offloading regression test-suite +! +! Last modified: May 2020 +! + +program foo + integer, parameter :: ni = 5, nj = 3 + integer :: i, j + integer :: arr(ni, nj) ,res(ni, nj) + + do j = 1, nj + do i = 1, ni + res(i, j) = i + j; + end do + end do + + !$omp target + !$omp parallel do + do j = 1, nj + !$omp parallel do + do i = 1, ni + arr(i, j) = i + j; + end do + end do + !$omp end target + + call check_int(res, arr, ni * nj) +end program foo diff --git a/test/x86_64_offloading/src/parallel.f90 b/test/x86_64_offloading/src/parallel.f90 new file mode 100644 index 0000000000..f094bac257 --- /dev/null +++ b/test/x86_64_offloading/src/parallel.f90 @@ -0,0 +1,40 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! x86_64 offloading regression test-suite +! +! Last modified: Sept 2019 +! + +program foo + integer, parameter :: N = 8 + integer :: res(N), i, a = 1, b = 10 + integer :: exp(N) + + exp(1:3) = (/12, 2, 3/) + exp(4) = 4; exp(5) = 5; + exp(6) = 60; exp(7) = 70; exp(8) = 80 + + !$omp target parallel do map(tofrom: res) + do i = 1, 5 + res(i) = i + end do + !$omp end target + + ! The codegen should be able to distinguish the following target + ! region from above for fork-call + !$omp target data map (tofrom: res) + !$omp target + res(1) = 12 + !$omp end target + !$omp end target data + + ! similarly, the following section shouldn't be mistaken for a + ! device outlined fork-call + !$omp parallel do + do i = 6, 8 + res(i) = i * 10 + end do + + call check_int(res, exp, N) +end program foo diff --git a/test/x86_64_offloading/src/reduction1.f90 b/test/x86_64_offloading/src/reduction1.f90 new file mode 100644 index 0000000000..3ab75c6b30 --- /dev/null +++ b/test/x86_64_offloading/src/reduction1.f90 @@ -0,0 +1,31 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! x86_64 offloading regression test-suite +! +! Last modified: Oct 2019 +! + +program foo + integer, parameter :: n = 2 + real(8) :: vol = 12.0, mass = 13.0 + real(8) :: arr(1000) + real(8) :: exp(n), res(n) + integer :: i + + arr = 1 + + !$omp target map(tofrom: vol) map(tofrom: mass) map(to: arr) + !$omp teams distribute parallel do reduction(+:vol, mass) + do i = 1, 1000 + vol = vol + arr(i) + mass = mass + arr(i) + end do + !$omp end target + + res(1) = vol + res(2) = mass + exp(1) = 1012 + exp(2) = 1013 + call check_double(res, exp, n) +end program foo diff --git a/test/x86_64_offloading/src/reduction2.f90 b/test/x86_64_offloading/src/reduction2.f90 new file mode 100644 index 0000000000..70e758b859 --- /dev/null +++ b/test/x86_64_offloading/src/reduction2.f90 @@ -0,0 +1,36 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! x86_64 offloading regression test-suite +! +! Last modified: Jan 2020 +! + +module mod1 + integer, parameter :: sz = 4_8 + integer, allocatable :: sums_l(:, :, :) +end module mod1 + +program foo + use mod1 + integer :: i, j, k + integer :: exp(4) = (/1777, 1778, 1779, 1780/) + + allocate(sums_l(sz, 2, 2)) + + sums_l(:, 1, 1) = (/1, 2, 3, 4/) + !$omp target + !$omp teams reduction(+: sums_l) + !$omp distribute parallel do private( i, j, k ) collapse(2) reduction(+:sums_l) + do i = 1, sz + do j = 1, sz + do k = 1, sz + sums_l(k, 1, 1) = sums_l(k, 1, 1) + 111 + end do + end do + end do + !$omp end teams + !$omp end target + + call check_int(sums_l, exp, 4) +end program foo diff --git a/test/x86_64_offloading/src/target_if1.f90 b/test/x86_64_offloading/src/target_if1.f90 new file mode 100644 index 0000000000..9ba84e3e51 --- /dev/null +++ b/test/x86_64_offloading/src/target_if1.f90 @@ -0,0 +1,50 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! x86_64 offloading regression test-suite +! +! Last modified: Jan 2020 +! + +module mod + logical :: isHost + integer :: numDevices +end module mod + +subroutine tgt(isTarget) + use mod + use omp_lib + integer :: isTarget + + !$omp target map(tofrom: isHost, numDevices) if (isTarget == 1) + isHost = omp_is_initial_device() + numDevices = omp_get_num_devices() + !$omp end target +end subroutine + +program foo + use mod + integer :: res(3), exp(3) + + isHost = .true. + numDevices = 0 + res = 0 + exp = (/0, 1, 1/) + + call tgt(1) + if (isHost) then + res(1) = 1 + else + res(1) = 0 + end if + res(3) = numDevices + + call tgt(0) + if (isHost) then + res(2) = 1 + else + res(2) = 0 + end if + + call check_int(res, exp, 3) +end program foo diff --git a/test/x86_64_offloading/src/target_update1.f90 b/test/x86_64_offloading/src/target_update1.f90 new file mode 100644 index 0000000000..0a71fee734 --- /dev/null +++ b/test/x86_64_offloading/src/target_update1.f90 @@ -0,0 +1,50 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! x86_64 offloading regression test-suite +! +! Last modified: Oct 2019 +! + +module mod_update_kernel + integer, parameter :: x_min = 1, x_max = 10 + +contains + subroutine update_kernel(energy) + real(kind = 8), dimension(x_min:x_max) :: energy + real(kind = 8) :: dbl_base, sum1 + integer :: i, j, depth + real(kind = 8) :: expected(x_min:x_max) + + depth = -1 + + !$omp target map(depth) + !$omp teams + !$omp distribute parallel do private(j) collapse(1) + do j = x_min, x_max + energy(j) = j * 10 + depth + enddo + !$omp end teams + !$omp end target + + !$omp target update from (energy) + + do i = x_min, x_max + expected(i) = i * 10 - 1 + end do + + print *, expected + print *, energy + call check_double(expected, energy, x_max - x_min + 1) + end subroutine update_kernel +end module mod_update_kernel + +program foo + use mod_update_kernel + integer :: j + real(kind = 8), dimension(x_min:x_max) :: energy + + !$omp target data map(energy) + call update_kernel(energy) + !$omp end target data +end program diff --git a/test/x86_64_offloading/src/teams_distribute1.f90 b/test/x86_64_offloading/src/teams_distribute1.f90 new file mode 100644 index 0000000000..8a4d702c2e --- /dev/null +++ b/test/x86_64_offloading/src/teams_distribute1.f90 @@ -0,0 +1,93 @@ +! +! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. +! +! x86_64 offloading regression test-suite +! +! Last modified: Jul 2020 +! + +subroutine subr1(curr_arr, next_arr, send, n, shared_0, x) + integer, intent(in) :: n, send(n) + real(8), intent(in) :: curr_arr(n), shared_0, x + real(8), intent(out) :: next_arr(n) + + integer i_ct + real(8) :: tmp_1, tmp_2, tmp_3 + real(8) :: shared_1, shared_2 + real(8) :: sym,asym,feq_common + + shared_1 = 0.5 + shared_0 + shared_2 = 2 * x + + !$omp target + !$omp teams distribute parallel do simd private(tmp_1,tmp_2,tmp_3) & + !$omp shared(shared_1,shared_2,curr_arr,next_arr,n,shared_0,send) + do i_ct = 1, n + tmp_1 = 13 + shared_1 + shared_2; ! 20 + tmp_2 = shared_0 + tmp_1 ! 21.5 + tmp_3 = 1.5 + next_arr(send(i_ct)) = tmp_1 + tmp_2 + tmp_3 + end do + !$omp end target +end subroutine + +program foo + integer, parameter :: n = 11 + integer :: send(n) + integer :: iterat, max_iterat = 1 + real(8) :: arr1(n, 0:1) + real(8) :: res(n), exp(n) + real(8) :: y = 1.5, x = 2.5 + integer :: i_ct, i, j, sum1 + + do i = 1, n + send(i) = i + arr1(i, 0) = i + arr1(i, 1) = 0 + exp(i) = 43.0 + end do + + !$omp target data map(tofrom:arr1), map(to:send) + do iterat=1, max_iterat + call subr1(arr1(:,0), arr1(:,1),send, n, y, x) + end do + !$omp end target data + + res = arr1(:, 1) + + !$omp target teams map(tofrom: sum1) + !$omp distribute + do i = 1, 10 + !$omp parallel do + do j = 1, 10 + !$omp atomic update + sum1 = sum1 + 1 + end do + end do + !$omp end target teams + + !$omp target teams map(tofrom: sum1) + !$omp distribute + do i = 1, 10 + !$omp parallel + !$omp do + do j = 1, 10 + !$omp atomic update + sum1 = sum1 + 1 + end do + !$omp end parallel + end do + !$omp end target teams + + !$omp target teams map(tofrom: sum1) + !$omp distribute + do i = 1, 10 + !$omp atomic update + sum1 = sum1 + 1 + end do + !$omp end target teams + + res(n) = sum1 + exp(n) = 210 + call check_double(res, exp, 10) +end program foo diff --git a/test/x86_64_offloading/src/teams_distribute2.f90 b/test/x86_64_offloading/src/teams_distribute2.f90 new file mode 100644 index 0000000000..865fc2275e --- /dev/null +++ b/test/x86_64_offloading/src/teams_distribute2.f90 @@ -0,0 +1,20 @@ +! +! Copyright (c) 2020, Advanced Micro Devices, Inc. All rights reserved. +! +! x86_64 offloading regression test-suite +! +! Last modified: Jan 2020 +! + +program foo + integer :: led, zeppelin = 0 + + !$omp target teams distribute map(tofrom: zeppelin) + do led = 1, 10 + !$omp atomic + zeppelin = led + zeppelin + end do + !$omp end target teams distribute + + call check_int(zeppelin, (/55/), 1) +end program foo diff --git a/tools/flang1/CMakeLists.txt b/tools/flang1/CMakeLists.txt index 42124d0090..a9d7671948 100644 --- a/tools/flang1/CMakeLists.txt +++ b/tools/flang1/CMakeLists.txt @@ -4,6 +4,12 @@ # SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception # +# +# Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +# Notified per clause 4(b) of the license. +# +# Last Modified: May 2020 +# set(FLANG1_SRC_DIR ${CMAKE_CURRENT_SOURCE_DIR}/flang1exe) set(FLANG1_DOC_SRC_DIR ${CMAKE_CURRENT_SOURCE_DIR}/docs) @@ -26,6 +32,13 @@ if (FLANG_OPENMP_GPU_NVIDIA) add_definitions("-DOMP_OFFLOAD_LLVM") endif() +#AOCC Begin +option(FLANG_OPENMP_GPU_AMD "Enable OpenMP AMD Accelerator Offload." OFF) +if (FLANG_OPENMP_GPU_AMD) + add_definitions("-DOMP_OFFLOAD_AMD") +endif() +#AOCC End + add_subdirectory(include) add_subdirectory(utils) add_subdirectory(flang1exe) diff --git a/tools/flang1/docs/dinit.n b/tools/flang1/docs/dinit.n index db470d8026..58ea2e1fc0 100644 --- a/tools/flang1/docs/dinit.n +++ b/tools/flang1/docs/dinit.n @@ -3,6 +3,12 @@ .\" * See https://llvm.org/LICENSE.txt for license information. .\" * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception .\" * +.\" * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +.\" * Notified per clause 4(b) of the license. +.\" * +.\" * Added support for quad precision +.\" * Last modified: Feb 2020 +.\" * .\" */ .NS 14 "Data Initialization File" .lp @@ -88,6 +94,13 @@ in the corresponding DINIT_LOC, DINIT_FMT, or DINIT_NML. Indicates that 2 32-bit words are to be initialized with a 64-bit double precision floating point value. \*(cfconval\*(rf is a symbol table pointer to a double precision constant. +.\" AOCC begin +.IP "dtype = DT_QUAD" CW +.br +Indicates that 2 32-bit words are to be initialized with +a 128-bit quad precision floating point value. +\*(cfconval\*(rf is a symbol table pointer to a quad precision constant. +.\* AOCC end .IP "dtype = DT_CMPLX" CW .br Indicates that 2 32-bit words are to be initialized with diff --git a/tools/flang1/flang1exe/CMakeLists.txt b/tools/flang1/flang1exe/CMakeLists.txt index bfa23c68c9..db146085f5 100644 --- a/tools/flang1/flang1exe/CMakeLists.txt +++ b/tools/flang1/flang1exe/CMakeLists.txt @@ -4,6 +4,13 @@ # SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception # +# +# Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +# Notified per clause 4(b) of the license. +# +# Last Modified: May 2020 +# + set(SOURCES accpp.c assem.c @@ -131,8 +138,8 @@ add_dependencies(flang1 ) if (FLANG_INCLUDE_DOCS) - add_dependencies(flang1_gen_sphinx_docs - flang1 + add_dependencies(flang1 + flang1_gen_sphinx_docs ) endif() @@ -154,7 +161,7 @@ target_link_libraries(flang1 # Install flang1 executable install(TARGETS flang1 - RUNTIME DESTINATION bin) + RUNTIME DESTINATION ${DEVEL_PACKAGE}${CMAKE_INSTALL_BINDIR}) # Local Variables: # mode: cmake diff --git a/tools/flang1/flang1exe/ast.c b/tools/flang1/flang1exe/ast.c index bdb20b0cac..11d354d43b 100644 --- a/tools/flang1/flang1exe/ast.c +++ b/tools/flang1/flang1exe/ast.c @@ -1,7 +1,18 @@ -/* + /* * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. * See https://llvm.org/LICENSE.txt for license information. * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading + * Date of modification 12th February 2020 + * Date of modification 04th April 2020 + * Added support for quad precision - Feb 2020 + * Date of modification February 2020 + * Last modified: Jun 2020 * */ @@ -32,6 +43,7 @@ #include "rte.h" #include "extern.h" #include "rtlRtns.h" +#include "semant.h" static int reduce_iadd(int, INT); static int reduce_i8add(int, int); @@ -40,6 +52,7 @@ static SPTR sym_of_ast2(int); static LOGICAL bounds_match(int, int, int); static INT _fdiv(INT, INT); static void _ddiv(INT *, INT *, INT *); +static void _qdiv(INT *, INT *, INT *); static int hex2char(INT *); static int hex2nchar(INT *); static void truncation_warning(int); @@ -47,6 +60,12 @@ static void conversion_warning(void); static int atemps; /* temp counter for bounds' temporaries */ +// AOCC begin +extern int asz_status; +extern int asz_id_elem_start; +int asz_id_elem_count_tot; +// AOCC end + #define MIN_INT64(n) \ (((n[0] & 0xffffffff) == 0x80000000) && ((n[1] & 0xffffffff) == 0)) @@ -58,7 +77,7 @@ ast_init(void) int i; #if DEBUG - assert(sizeof(AST) / sizeof(int) == 19, "bad AST size", + assert(sizeof(AST) / sizeof(int) == 20, "bad AST size", sizeof(AST) / sizeof(int), 4); #endif @@ -82,7 +101,7 @@ ast_init(void) assert(astb.asd.stg_base, "ast_init: no room for ASD", astb.asd.stg_size, 4); #endif } - BZERO(astb.asd.hash, int, 7); + BZERO(astb.asd.hash, int, MAXSUBS); /* AOCC */ astb.asd.stg_base[0] = 0; astb.asd.stg_avail = 1; @@ -93,7 +112,7 @@ ast_init(void) assert(astb.shd.stg_base, "ast_init: no room for SHD", astb.shd.stg_size, 4); #endif } else - BZERO(astb.shd.hash, int, 7); + BZERO(astb.shd.hash, int, MAXSUBS); /* AOCC */ astb.shd.stg_base[0].lwb = 0; astb.shd.stg_base[0].upb = 0; astb.shd.stg_base[0].stride = 0; @@ -508,8 +527,20 @@ int mk_id(int id) { int ast = mk_id_noshape(id); - if (A_SHAPEG(ast) == 0) + + // AOCC begin + /* adding the sizes of the repeated variable array's + * elements to assumed size array + */ + if ((asz_id_elem_start == 1) && (A_SHAPEG(ast) != 0)) { + asz_id_elem_count_tot += asz_id_elem_count_tot; + asz_id_elem_start = 0; + } + else if (A_SHAPEG(ast) == 0) { A_SHAPEP(ast, mkshape(DTYPEG(id))); + } + // AOCC end + return ast; } @@ -634,9 +665,11 @@ mk_cval1(INT v, DTYPE dtype) case TY_INT8: case TY_LOG8: case TY_DBLE: + case TY_QUAD: case TY_DWORD: case TY_CMPLX: case TY_DCMPLX: + case TY_QCMPLX: // AOCC case TY_NCHAR: case TY_HOLL: case TY_CHAR: @@ -717,6 +750,7 @@ mk_binop(int optype, int lop, int rop, DTYPE dtype) case OP_LNEQV: case OP_LOR: case OP_LAND: + case OP_LXOR: // AOCC commutable = TRUE; /***** fall through *****/ default: @@ -739,7 +773,11 @@ mk_binop(int optype, int lop, int rop, DTYPE dtype) rop = tmp; c2 = c1; c1 = 0; - } else if (ncons == 0 && lop > rop) { + } else if (ncons == 0 && optype != OP_LAND && lop > rop) { + // AOCC logic seem to be flawed above + // added LAND condition above to fix the issue + // faliling case present(c) .and. c/d. reordering this is wrong + // for LAND we need to follw the lexical order of evaluation tmp = lop; lop = rop; rop = tmp; @@ -939,6 +977,20 @@ mk_binop(int optype, int lop, int rop, DTYPE dtype) return rop; /* something .or. .true. is .true */ return lop; /* something .or. .false. is something */ break; + // AOCC begin + case OP_LXOR: + v1 = CONVAL2G(A_SPTRG(lop)); + v2 = CONVAL2G(A_SPTRG(rop)); + if (v1 != v2) { + if (v1 == 0) + return rop; + return lop; + } + if (v1 == 0) + return lop; + return rop; + break; + // AOCC end default: break; } @@ -1268,8 +1320,10 @@ mk_unop(int optype, int lop, DTYPE dtype) break; case TY_DBLE: + case TY_QUAD: // AOCC case TY_CMPLX: case TY_DCMPLX: + case TY_QCMPLX: // AOCC case TY_INT8: case TY_LOG8: conval = A_SPTRG(lop); @@ -1488,6 +1542,18 @@ convert_cnst(int cnst, int newtyp) num[1] = CONVAL2G(sptr); xdfix(num, &result); break; + // AOCC begin + case TY_QCMPLX: + sptr = CONVAL1G(sptr); + case TY_QUAD: + num[0] = CONVAL1G(sptr); + num[1] = CONVAL2G(sptr); + num[2] = CONVAL3G(sptr); + num[3] = CONVAL4G(sptr); + xqfix(num, &result); + break; + // AOCC end + default: /* TY_HOLL, TY_CHAR, TY_NCHAR */ return cnst; } @@ -1532,6 +1598,17 @@ convert_cnst(int cnst, int newtyp) num1[1] = CONVAL2G(sptr); xdfix64(num1, num); break; + // AOCC begin + case TY_QCMPLX: + sptr = CONVAL1G(sptr); + case TY_QUAD: + num1[0] = CONVAL1G(sptr); + num1[1] = CONVAL2G(sptr); + num1[2] = CONVAL3G(sptr); + num1[3] = CONVAL4G(sptr); + xqfix64(num1, num); + break; + // AOCC end default: /* TY_HOLL, TY_CHAR, TY_NCHAR */ return cnst; } @@ -1562,6 +1639,17 @@ convert_cnst(int cnst, int newtyp) num[1] = CONVAL2G(sptr); xsngl(num, &result); break; + // AOCC begin + case TY_QCMPLX: + sptr = CONVAL1G(sptr); + case TY_QUAD: + num[0] = CONVAL1G(sptr); + num[1] = CONVAL2G(sptr); + num[2] = CONVAL3G(sptr); + num[3] = CONVAL4G(sptr); + xqtof(num, &num[0]); + break; + // AOCC end default: /* TY_HOLL, TY_CHAR, TY_NCHAR */ return cnst; } @@ -1595,6 +1683,12 @@ convert_cnst(int cnst, int newtyp) case TY_DCMPLX: result = CONVAL1G(sptr); goto call_mk_cval1; + // AOCC begin + case TY_QCMPLX: + result = CONVAL1G(sptr); + xdble(oldval, num); + break; + // AOCC end case TY_CMPLX: oldval = CONVAL1G(sptr); xdble(oldval, num); @@ -1610,6 +1704,53 @@ convert_cnst(int cnst, int newtyp) result = getcon(num, DT_REAL8); break; + // AOCC begin + case TY_QUAD: + if (from == TY_WORD) { + return cnst; + } else if (from == TY_DWORD) { + return cnst; + } else if (from == TY_INT8 || from == TY_LOG8) { + num1[0] = CONVAL1G(sptr); + num1[1] = CONVAL2G(sptr); + num1[2] = CONVAL3G(sptr); + num1[3] = CONVAL4G(sptr); + xqflt64(num1, num); + } else if (TY_ISINT(from)) + xqfloat(CONVAL2G(sptr), num); + else { + /* if a special 'named' constant, don't evaluate */ + if ((XBIT(49, 0x400000) || XBIT(51, 0x40)) && NMPTRG(sptr)) + return cnst; + switch (from) { + case TY_QCMPLX: + result = CONVAL1G(sptr); + goto call_mk_cval1; + case TY_DCMPLX: + oldval = CONVAL1G(sptr); + xdtoq(oldval, num); + break; + case TY_CMPLX: + oldval = CONVAL1G(sptr); + xdtoq(oldval, num); + break; + case TY_REAL: + oldval = CONVAL2G(sptr); + xftoq(oldval, num); + break; + case TY_DBLE: + num1[0] = CONVAL1G(sptr); + num1[1] = CONVAL2G(sptr); + xdtoq(num1, num); + break; + default: /* TY_HOLL, TY_CHAR, TY_NCHAR */ + return cnst; + } + } + result = getcon(num, DT_QUAD); + break; + // AOCC end + case TY_CMPLX: /* num[0] = real part * num[1] = imaginary part @@ -1653,6 +1794,23 @@ convert_cnst(int cnst, int newtyp) num1[1] = CONVAL2G(CONVAL2G(sptr)); xsngl(num1, &num[1]); break; + // AOCC begin + case TY_QUAD: + num1[0] = CONVAL1G(sptr); + num1[1] = CONVAL2G(sptr); + num1[2] = CONVAL3G(sptr); + num1[3] = CONVAL4G(sptr); + xqtof(num1, &num[0]); + break; + case TY_QCMPLX: + num1[0] = CONVAL1G(CONVAL1G(sptr)); + num1[1] = CONVAL2G(CONVAL1G(sptr)); + xsngl(num1, &num[0]); + num1[0] = CONVAL1G(CONVAL2G(sptr)); + num1[1] = CONVAL2G(CONVAL2G(sptr)); + xsngl(num1, &num[1]); + break; + // AOCC end default: /* TY_HOLL, TY_CHAR, TY_NCHAR */ return cnst; } @@ -1698,6 +1856,22 @@ convert_cnst(int cnst, int newtyp) num[0] = sptr; num[1] = stb.dbl0; break; + // AOCC begin + case TY_QUAD: + num[0] = sptr; + num[1] = stb.dbl0; + num[2] = stb.dbl1; + num[3] = stb.dbl2; + break; + case TY_QCMPLX: + num1[0] = CONVAL1G(CONVAL1G(sptr)); + num1[1] = CONVAL2G(CONVAL1G(sptr)); + xdble(num1, &num[0]); + num1[0] = CONVAL1G(CONVAL2G(sptr)); + num1[1] = CONVAL2G(CONVAL2G(sptr)); + xdble(num1, &num[1]); + break; + // AOCC end case TY_CMPLX: xdble(CONVAL1G(sptr), num1); num[0] = getcon(num1, DT_REAL8); @@ -1710,7 +1884,64 @@ convert_cnst(int cnst, int newtyp) } result = getcon(num, DT_CMPLX16); break; - + // AOCC begin + case TY_QCMPLX: + if (from == TY_WORD) { + return cnst; /* don't convert typeless for now */ + } else if (from == TY_DWORD) { + return cnst; /* don't convert typeless for now */ + } else if (from == TY_INT8 || from == TY_LOG8) { + num1[0] = CONVAL1G(sptr); + num1[1] = CONVAL2G(sptr); + num1[2] = CONVAL3G(sptr); + num1[3] = CONVAL4G(sptr); + xqflt64(num1, num); + num[0] = getcon(num, DT_QUAD); + num[1] = stb.quad0; + } else if (TY_ISINT(from)) { + xqfloat(CONVAL2G(sptr), num); + num[0] = getcon(num, DT_QUAD); + num[1] = stb.quad0; + num[2] = stb.quad1; + num[3] = stb.quad2; + } else { + switch (from) { + case TY_REAL: + xftoq(CONVAL1G(sptr), num1); + num[0] = getcon(num1, DT_QUAD); + num[1] = stb.quad0; + break; + case TY_DBLE: + num[0] = sptr; + num[1] = stb.quad0; + break; + case TY_QUAD: + num[0] = sptr; + num[1] = stb.quad0; + num[2] = stb.quad1; + num[3] = stb.quad2; + break; + case TY_CMPLX: + xftoq(CONVAL1G(sptr), num1); + num[0] = getcon(num1, DT_QUAD); + xftoq(CONVAL2G(sptr), num1); + num[1] = getcon(num1, DT_QUAD); + break; + case TY_DCMPLX: + num1[0] = CONVAL1G(CONVAL1G(sptr)); + num1[1] = CONVAL2G(CONVAL1G(sptr)); + xdtoq(num1, &num[0]); + num1[0] = CONVAL1G(CONVAL2G(sptr)); + num1[1] = CONVAL2G(CONVAL2G(sptr)); + xdtoq(num1, &num[1]); + break; + default: /* TY_HOLL, TY_CHAR, TY_NCHAR */ + return cnst; + } + } + result = getcon(num, DT_CMPLX32); + break; + // AOCC end } call_mk_cval1: @@ -1826,8 +2057,8 @@ mk_asd(int *subs, int numdim) { int i; int asd; - assert(numdim > 0 && numdim <= MAXSUBS, "mk_subscr: bad numdim", numdim, - ERR_Fatal); + assert(is_legal_numdim(numdim), "mk_subscr: bad numdim", numdim, + ERR_Fatal); /* AOCC */ /* search the existing ASDs with the same number of dimensions */ for (asd = astb.asd.hash[numdim - 1]; asd != 0; asd = ASD_NEXT(asd)) { for (i = 0; i < numdim; i++) { @@ -2030,11 +2261,14 @@ mkshape(DTYPE dtype) { int numdim, i; int lwb, upb, stride; + int asz_id_elem_count = 0; + SPTR asz_sptr; + if (DTY(dtype) != TY_ARRAY) return 0; numdim = ADD_NUMDIM(dtype); - if (numdim > 7 || numdim < 1) { + if (!is_legal_numdim(numdim)) { /* AOCC */ interr("mkshape: bad numdim", numdim, 3); numdim = 1; add_shape_rank(numdim); @@ -2045,7 +2279,18 @@ mkshape(DTYPE dtype) add_shape_rank(numdim); for (i = 0; i < numdim; ++i) { lwb = lbound_of(dtype, i); - upb = ADD_UPAST(dtype, i); + upb = ADD_UPAST(dtype, i); + // AOCC begin + /* copying the ast holding the size of the variable + * elements of an assumed size array + */ + if (asz_id_elem_start == 1) { + asz_sptr = A_SPTRG(upb); + asz_id_elem_count = CONVAL2G(asz_sptr); + asz_id_elem_count_tot += asz_id_elem_count; + asz_id_elem_start = 0; + } + // AOCC end stride = astb.bnd.one; add_shape_spec(lwb, upb, stride); } @@ -2072,7 +2317,7 @@ mk_mem_ptr_shape(int parent, int mem, DTYPE dtype) if (DTY(dtype) != TY_ARRAY) return 0; numdim = ADD_NUMDIM(dtype); - if (numdim > 7 || numdim < 1) { + if (!is_legal_numdim(numdim)) { /* AOCC */ interr("mkshape: bad numdim", numdim, 3); numdim = 1; add_shape_rank(numdim); @@ -3234,7 +3479,7 @@ contiguous_array_section(int subscr_ast) state = TRIPLE_SNGL_ELEM_SEEN; break; case TRIPLE_SNGL_ELEM_SEEN: - if (tkn != DIM_ELMNT) + if (tkn != DIM_ELMNT && tkn != DONT_CARE) return FALSE; break; } @@ -4345,7 +4590,7 @@ ast_rewrite(int ast) changes = TRUE; asd = A_ASDG(ast); numdim = ASD_NDIM(asd); - assert(numdim > 0 && numdim <= 7, "ast_rewrite: bad numdim", ast, 4); + assert(is_legal_numdim(numdim), "ast_rewrite: bad numdim", ast, 4); /* AOCC */ for (i = 0; i < numdim; ++i) { sub = ast_rewrite((int)ASD_SUBS(asd, i)); if (sub != ASD_SUBS(asd, i)) @@ -5050,6 +5295,10 @@ ast_rewrite(int ast) case A_MP_EREDUCTION: case A_MP_BREDUCTION: case A_MP_REDUCTIONITEM: + case A_MP_DEFAULTMAP: // AOCC + case A_MP_TARGETDECLARE: // AOCC + case A_MP_USE_DEVICE_PTR: // AOCC + case A_MP_USE_DEVICE_ADDR: // AOCC break; case A_MP_ATOMICWRITE: rop = ast_rewrite(A_ROPG(ast)); @@ -5165,6 +5414,7 @@ ast_rewrite(int ast) case A_MP_EORDERED: case A_MP_ENDTASK: case A_MP_ETASKLOOP: + case A_MP_REQUIRESUNIFIEDSHAREDMEMORY: // AOCC break; case A_PREFETCH: lop = ast_rewrite(A_LOPG(ast)); @@ -5249,7 +5499,7 @@ ast_clear_repl(int ast) ast_clear_repl((int)A_LOPG(ast)); asd = A_ASDG(ast); numdim = ASD_NDIM(asd); - assert(numdim > 0 && numdim <= 7, "ast_clear_repl: bad numdim", ast, 4); + assert(is_legal_numdim(numdim), "ast_clear_repl: bad numdim", ast, 4); /* AOCC */ for (i = 0; i < numdim; ++i) ast_clear_repl((int)ASD_SUBS(asd, i)); break; @@ -5912,6 +6162,12 @@ ast_trav_recurse(int ast, int *extra_arg) case A_MP_EREDUCTION: case A_MP_BREDUCTION: case A_MP_REDUCTIONITEM: + case A_MP_DEFAULTMAP: // AOCC + case A_MP_TARGETDECLARE: // AOCC + case A_MP_USE_DEVICE_PTR: // AOCC + case A_MP_IS_DEVICE_PTR: // AOCC + case A_MP_USE_DEVICE_ADDR: //AOCC + case A_MP_REQUIRESUNIFIEDSHAREDMEMORY: // AOCC break; case A_MP_BMPSCOPE: #if DEBUG @@ -5967,6 +6223,8 @@ ast_trav_recurse(int ast, int *extra_arg) case A_MP_EPDO: case A_MP_BORDERED: case A_MP_EORDERED: + case A_MP_LOOP: + case A_MP_ELOOP: break; case A_PREFETCH: #if DEBUG @@ -6490,6 +6748,7 @@ _dump_one_ast(int i, FILE *file) case A_MP_BORDERED: case A_MP_EORDERED: case A_MP_FLUSH: + case A_MP_REQUIRESUNIFIEDSHAREDMEMORY: // AOCC break; case A_MP_PRE_TLS_COPY: case A_MP_COPYIN: @@ -6534,6 +6793,25 @@ dump_one_ast(int i) _dump_one_ast(i, gbl.dbgfil); } +// AOCC Begin +/* routine must be externally visible */ +void +get_subtree(int ast, int* par, int* sib) +{ + int i; + int astp, asts; + + for (i = 1; i < astb.stg_avail; i++) { + if (i == ast) + break; + + astp = i; + } + *par = astp; + *sib = i + 1; +} +// AOCC End + /* routine must be externally visible */ void dump_ast_tree(int i) @@ -6910,6 +7188,7 @@ dump_ast_tree(int i) case A_MP_COPYPRIVATE: case A_MP_ECOPYPRIVATE: case A_MP_FLUSH: + case A_MP_REQUIRESUNIFIEDSHAREDMEMORY: // AOCC break; default: fprintf(gbl.dbgfil, "NO DUMP AVL"); @@ -7069,12 +7348,22 @@ ast_intr(int i_intr, DTYPE dtype, int cnt, ...) case TY_DBLE: sptr = GDBLEG(sptr); break; + // AOCC begin + case TY_QUAD: + sptr = GQUADG(sptr); + break; + // AOCC end case TY_CMPLX: sptr = GCMPLXG(sptr); break; case TY_DCMPLX: sptr = GDCMPLXG(sptr); break; + // AOCC begin + case TY_QCMPLX: + sptr = GQCMPLXG(sptr); + break; + // AOCC end default: sptr = 0; break; @@ -7158,6 +7447,23 @@ _huge(DTYPE dtype) val[1] = 0xffffffff; } goto const_dble_val; +// AOCC begin + case TY_QUAD: + sname = "huge(1.0_16)"; + if (XBIT(49, 0x40000)) { /* C90 */ +#define C90_HUGE "0.1363435169524269911828730305882e+2466L" + /* 0577757777777777777777 */ + atoxq(C90_HUGE, &val[0], strlen(C90_HUGE)); /* 7777777777777776 */ + } else { + /* 1.189731495357231765085759326628007016E+4932 */ + val[0] = 0x7ffeffff; + val[1] = 0xffffffff; + val[2] = 0xffffffff; + val[3] = 0xffffffff; + } + goto const_quad_val; +// AOCC end + default: return 0; /* caller must check */ } @@ -7187,7 +7493,16 @@ _huge(DTYPE dtype) if (NMPTRG(sptr) == 0 && (XBIT(49, 0x400000) || XBIT(51, 0x40))) NMPTRP(sptr, putsname(sname, strlen(sname))); return ast; - +// AOCC end +const_quad_val: + tmp = getcon(val, DT_QUAD); + ast = mk_cnst(tmp); + sptr = A_SPTRG(ast); + /* just added? */ + if (NMPTRG(sptr) == 0 && (XBIT(49, 0x400000) || XBIT(51, 0x40))) + NMPTRP(sptr, putsname(sname, strlen(sname))); + return ast; +// AOCC end } /* utility function to ensure that an expression has type dt_needed. @@ -7273,6 +7588,7 @@ mk_smallest_val(DTYPE dtype) return (mk_cval1(tmp, DT_INT8)); case TY_REAL: case TY_DBLE: + case TY_QUAD: // AOCC tmp = _huge(dtype); tmp = mk_unop(OP_SUB, tmp, dtype); return tmp; @@ -7767,6 +8083,16 @@ negate_const(INT conval, DTYPE dtype) xdneg(num, dresult); return getcon(dresult, DT_REAL8); + // AOCC begin + case TY_QUAD: + num[0] = CONVAL1G(conval); + num[1] = CONVAL2G(conval); + num[2] = CONVAL3G(conval); + num[3] = CONVAL4G(conval); + xqneg(num, qresult); + return getcon(qresult, DT_QUAD); + // AOCC end + case TY_CMPLX: xfneg(CONVAL1G(conval), &realrs); xfneg(CONVAL2G(conval), &imagrs); @@ -7785,6 +8111,23 @@ negate_const(INT conval, DTYPE dtype) num[1] = getcon(dimagrs, DT_REAL8); return getcon(num, DT_CMPLX16); + // AOCC begin + case TY_QCMPLX: + qresult[0] = CONVAL1G(CONVAL1G(conval)); + qresult[1] = CONVAL2G(CONVAL1G(conval)); + qresult[2] = CONVAL3G(CONVAL1G(conval)); + qresult[3] = CONVAL4G(CONVAL1G(conval)); + xqneg(qresult, qrealrs); + qresult[0] = CONVAL1G(CONVAL2G(conval)); + qresult[1] = CONVAL2G(CONVAL2G(conval)); + qresult[2] = CONVAL3G(CONVAL2G(conval)); + qresult[3] = CONVAL4G(CONVAL2G(conval)); + xqneg(qresult, qimagrs); + num[0] = getcon(qrealrs, DT_QUAD); + num[1] = getcon(qimagrs, DT_QUAD); + return getcon(num, DT_CMPLX32); + // AOCC end + default: interr("negate_const: bad dtype", dtype, 3); return (0); @@ -7959,6 +8302,41 @@ const_fold(int opr, INT conval1, INT conval2, DTYPE dtype) } return getcon(dresult, DT_REAL8); +// AOCC begin + case TY_QUAD: + qnum1[0] = CONVAL1G(conval1); + qnum1[1] = CONVAL2G(conval1); + qnum1[2] = CONVAL3G(conval1); + qnum1[3] = CONVAL4G(conval1); + qnum2[0] = CONVAL1G(conval2); + qnum2[1] = CONVAL2G(conval2); + qnum2[2] = CONVAL3G(conval2); + qnum2[3] = CONVAL4G(conval2); + switch (opr) { + case OP_ADD: + xqadd(qnum1, qnum2, qresult); + break; + case OP_SUB: + xqsub(qnum1, qnum2, qresult); + break; + case OP_MUL: + xqmul(qnum1, qnum2, qresult); + break; + case OP_DIV: + xqdiv(qnum1, qnum2, qresult); + break; + case OP_CMP: + return xqcmp(qnum1, qnum2); + case OP_XTOI: + case OP_XTOX: + xqpow(qnum1, qnum2, qresult); + break; + default: + goto err_exit; + } + return getcon(qresult, DT_QUAD); +// AOCC end + case TY_CMPLX: real1 = CONVAL1G(conval1); imag1 = CONVAL2G(conval1); @@ -8177,6 +8555,121 @@ const_fold(int opr, INT conval1, INT conval2, DTYPE dtype) num1[1] = getcon(dimagrs, DT_REAL8); return getcon(num1, DT_CMPLX16); + // AOCC begin + case TY_QCMPLX: + qreal1[0] = CONVAL1G(CONVAL1G(conval1)); + qreal1[1] = CONVAL2G(CONVAL1G(conval1)); + qimag1[0] = CONVAL1G(CONVAL2G(conval1)); + qimag1[1] = CONVAL2G(CONVAL2G(conval1)); + qreal2[0] = CONVAL1G(CONVAL1G(conval2)); + qreal2[1] = CONVAL2G(CONVAL1G(conval2)); + qimag2[0] = CONVAL1G(CONVAL2G(conval2)); + qimag2[1] = CONVAL2G(CONVAL2G(conval2)); + switch (opr) { + case OP_ADD: + xqadd(qreal1, qreal2, qrealrs); + xqadd(qimag1, qimag2, qimagrs); + break; + case OP_SUB: + xqsub(qreal1, qreal2, qrealrs); + xqsub(qimag1, qimag2, qimagrs); + break; + case OP_MUL: + /* (a + bi) * (c + di) ==> (ac-bd) + (ad+cb)i */ + xqmul(qreal1, qreal2, qtemp1); + xqmul(qimag1, qimag2, qtemp); + xqsub(qtemp1, qtemp, qrealrs); + xqmul(qreal1, qimag2, qtemp1); + xqmul(qreal2, qimag1, qtemp); + xqadd(qtemp1, qtemp, qimagrs); + break; + case OP_DIV: + qtemp2[0] = CONVAL1G(stb.quad0); + qtemp2[1] = CONVAL2G(stb.quad0); + /* qrealrs = qreal2; + * if (qrealrs < 0) + * qrealrs = -qrealrs; + * qimagrs = qimag2; + * if (qimagrs < 0) + * qimagrs = -qimagrs; + */ + if (xqcmp(qreal2, qtemp2) < 0) + xqsub(qtemp2, qreal2, qrealrs); + else { + qrealrs[0] = qreal2[0]; + qrealrs[1] = qreal2[1]; + } + if (xqcmp(qimag2, qtemp2) < 0) + xqsub(qtemp2, qimag2, qimagrs); + else { + qimagrs[0] = qimag2[0]; + qimagrs[1] = qimag2[1]; + } + + /* avoid overflow */ + + qtemp2[0] = CONVAL1G(stb.quad1); + qtemp2[1] = CONVAL2G(stb.quad1); + if (xqcmp(qrealrs, qimagrs) <= 0) { + /* if (qrealrs <= qimagrs) { + * qtemp = qreal2 / qimag2; + * qtemp1 = 1.0 / (qimag2 * (1 + qtemp * dtemp)); + * qrealrs = (qreal1 * qtemp + qimag1) * qtemp1; + * qimagrs = (qimag1 * qtemp - qreal1) * qtemp1; + * } + */ + _qdiv(qreal2, qimag2, qtemp); + + xqmul(qtemp, qtemp, qtemp1); + xqadd(qtemp2, qtemp1, qtemp1); + xqmul(qimag2, qtemp1, qtemp1); + _qdiv(qtemp2, qtemp1, qtemp1); + + xqmul(qreal1, qtemp, qrealrs); + xqadd(qrealrs, qimag1, qrealrs); + xqmul(qrealrs, qtemp1, qrealrs); + + xqmul(qimag1, qtemp, qimagrs); + xqsub(qimagrs, qreal1, qimagrs); + xqmul(qimagrs, qtemp1, qimagrs); + } else { + /* else { + * qtemp = qimag2 / qreal2; + * qtemp1 = 1.0 / (qreal2 * (1 + qtemp * dtemp)); + * qrealrs = (qreal1 + qimag1 * qtemp) * qtemp1; + * qimagrs = (qimag1 - qreal1 * qtemp) * qtemp1; + * } + */ + _qdiv(qimag2, qreal2, qtemp); + + xqmul(qtemp, qtemp, qtemp1); + xqadd(qtemp2, qtemp1, qtemp1); + xqmul(qreal2, qtemp1, qtemp1); + _qdiv(qtemp2, qtemp1, qtemp1); + + xqmul(qimag1, qtemp, qrealrs); + xqadd(qreal1, qrealrs, qrealrs); + xqmul(qrealrs, qtemp1, qrealrs); + + xqmul(qreal1, qtemp, qimagrs); + xqsub(qimag1, qimagrs, qimagrs); + xqmul(qimagrs, qtemp1, qimagrs); + } + break; + case OP_CMP: + /* + * for complex, only EQ and NE comparisons are allowed, so return + * 0 if the two constants are the same, else 1: + */ + return (conval1 != conval2); + default: + goto err_exit; + } + num1[0] = getcon(qrealrs, DT_QUAD); + num1[1] = getcon(qimagrs, DT_QUAD); + return getcon(num1, DT_CMPLX32); + // AOCC end + case TY_BLOG: case TY_SLOG: case TY_LOG: @@ -8431,6 +8924,17 @@ cngcon(INT oldval, int oldtyp, int newtyp) num[1] = CONVAL2G(oldval); xdfix(num, &result); return result; + // AOCC begin + case TY_QCMPLX: + oldval = CONVAL1G(oldval); + case TY_QUAD: + num[0] = CONVAL1G(oldval); + num[1] = CONVAL2G(oldval); + num[2] = CONVAL3G(oldval); + num[3] = CONVAL4G(oldval); + xqfix(num, &result); + return result; + // AOCC end case TY_HOLL: cp = stb.n_base + CONVAL1G(CONVAL1G(oldval)); goto char_to_int; @@ -8486,6 +8990,17 @@ cngcon(INT oldval, int oldtyp, int newtyp) num1[1] = CONVAL2G(oldval); xdfix64(num1, num); return getcon(num, newtyp); + // AOCC begin + case TY_QCMPLX: + oldval = CONVAL1G(oldval); + case TY_QUAD: + num1[0] = CONVAL1G(oldval); + num1[1] = CONVAL2G(oldval); + num1[2] = CONVAL3G(oldval); + num1[3] = CONVAL4G(oldval); + xqfix64(num1, num); + return getcon(num, newtyp); + // AOCC end case TY_HOLL: cp = stb.n_base + CONVAL1G(CONVAL1G(oldval)); goto char_to_int8; @@ -8538,6 +9053,17 @@ cngcon(INT oldval, int oldtyp, int newtyp) num[1] = CONVAL2G(oldval); xsngl(num, &result); return result; + // AOCC begin + case TY_QCMPLX: + oldval = CONVAL1G(oldval); + case TY_QUAD: + num[0] = CONVAL1G(oldval); + num[1] = CONVAL2G(oldval); + num[2] = CONVAL3G(oldval); + num[3] = CONVAL4G(oldval); + xqtof(num1, &num[0]); + return result; + // AOCC end case TY_HOLL: cp = stb.n_base + CONVAL1G(CONVAL1G(oldval)); goto char_to_real; @@ -8576,6 +9102,17 @@ cngcon(INT oldval, int oldtyp, int newtyp) case TY_REAL: xdble(oldval, num); break; + // AOCC begin + case TY_QCMPLX: + oldval = CONVAL1G(oldval); + case TY_QUAD: + num[0] = CONVAL1G(oldval); + num[1] = CONVAL2G(oldval); + num[2] = CONVAL3G(oldval); + num[3] = CONVAL4G(oldval); + xdble(oldval, num); + break; + // AOCC end case TY_HOLL: cp = stb.n_base + CONVAL1G(CONVAL1G(oldval)); goto char_to_dble; @@ -8602,6 +9139,64 @@ cngcon(INT oldval, int oldtyp, int newtyp) } return getcon(num, DT_REAL8); +// AOCC begin + case TY_QUAD: + if (from == TY_WORD) { + num[0] = 0; + num[1] = oldval; + } else if (from == TY_DWORD) { + num[0] = CONVAL1G(oldval); + num[1] = CONVAL2G(oldval); + } else if (from == TY_INT8 || from == TY_LOG8) { + num1[0] = CONVAL1G(oldval); + num1[1] = CONVAL2G(oldval); + xqflt64(num1, num); + } else if (TY_ISINT(from)) + xqfloat(oldval, num); + else { + switch (from) { + case TY_QCMPLX: + return CONVAL1G(oldval); + case TY_DCMPLX: + oldval = CONVAL1G(oldval); + case TY_REAL: + xftoq(oldval, num); + break; + case TY_DBLE: + num1[0] = CONVAL1G(oldval); + num1[1] = CONVAL2G(oldval); + xdtoq(num1, &num); + break; + case TY_CMPLX: + oldval = CONVAL1G(oldval); + case TY_HOLL: + cp = stb.n_base + CONVAL1G(CONVAL1G(oldval)); + goto char_to_quad; + case TY_CHAR: + if (flg.standard) + conversion_warning(); + cp = stb.n_base + CONVAL1G(oldval); + return getcon(&num[2], DT_QUAD); + char_to_quad: + holtonum(cp, num, 16); + if (flg.endian == 0) { + /* for little endian, need to swap words in each double word + * quantity. Order of bytes in a word is okay, but not the + * order of words. + */ + swap = num[2]; + num[2] = num[3]; + num[3] = swap; + } + return getcon(&num[2], DT_QUAD); + default: + errsev(91); + return (stb.quad0); + } + } + return getcon(num, DT_QUAD); +// AOCC end + case TY_CMPLX: /* num[0] = real part * num[1] = imaginary part @@ -8631,6 +9226,28 @@ cngcon(INT oldval, int oldtyp, int newtyp) num1[1] = CONVAL2G(oldval); xsngl(num1, &num[0]); break; + // AOCC begin + case TY_QUAD: + num1[0] = CONVAL1G(oldval); + num1[1] = CONVAL2G(oldval); + num1[2] = CONVAL3G(oldval); + num1[3] = CONVAL4G(oldval); + xqtof(num1, &num[0]); + break; + case TY_QCMPLX: + num1[0] = CONVAL1G(CONVAL1G(oldval)); + num1[1] = CONVAL2G(CONVAL1G(oldval)); + num1[2] = CONVAL3G(CONVAL1G(oldval)); + num1[3] = CONVAL4G(CONVAL1G(oldval)); + xsngl(num1, &num[0]); + num1[0] = CONVAL1G(CONVAL2G(oldval)); + num1[1] = CONVAL2G(CONVAL2G(oldval)); + num1[2] = CONVAL3G(CONVAL2G(oldval)); + num1[3] = CONVAL4G(CONVAL2G(oldval)); + xsngl(num1, &num[1]); + break; + // AOCC end + case TY_DCMPLX: num1[0] = CONVAL1G(CONVAL1G(oldval)); num1[1] = CONVAL2G(CONVAL1G(oldval)); @@ -8689,6 +9306,21 @@ cngcon(INT oldval, int oldtyp, int newtyp) num[0] = oldval; num[1] = stb.dbl0; break; + // AOCC begin + case TY_QUAD: + xdble(oldval, num); + num1[0] = oldval; + num1[1] = stb.dbl0; + break; + case TY_QCMPLX: + num1[0] = CONVAL1G(CONVAL1G(oldval)); + num1[1] = CONVAL2G(CONVAL1G(oldval)); + xdble(num1, &num[0]); + num1[0] = CONVAL1G(CONVAL2G(oldval)); + num1[1] = CONVAL2G(CONVAL2G(oldval)); + xdble(num1, &num[1]); + break; + // AOCC end case TY_CMPLX: xdble(CONVAL1G(oldval), num1); num[0] = getcon(num1, DT_REAL8); @@ -8727,6 +9359,97 @@ cngcon(INT oldval, int oldtyp, int newtyp) } return getcon(num, DT_CMPLX16); + // AOCC begin "CMPLEX32 need to modify" + case TY_QCMPLX: + if (from == TY_WORD) { + num[0] = 0; + num[1] = oldval; + num[0] = getcon(num, DT_QUAD); + num[1] = stb.quad0; + } else if (from == TY_DWORD) { + num[0] = CONVAL1G(oldval); + num[1] = CONVAL2G(oldval); + num[0] = getcon(num, DT_QUAD); + num[1] = stb.quad0; + } else if (from == TY_INT8 || from == TY_LOG8) { + num1[0] = CONVAL1G(oldval); + num1[1] = CONVAL2G(oldval); + xqflt64(num1, num); + num[0] = getcon(num, DT_QUAD); + num[1] = stb.quad0; + } else if (TY_ISINT(from)) { + xqfloat(oldval, num); + num[0] = getcon(num, DT_QUAD); + num[1] = stb.quad0; + num[2] = stb.quad1; + num[3] = stb.quad2; + } else { + switch (from) { + case TY_REAL: + xftoq(oldval, num); + num[0] = getcon(num, DT_QUAD); + num[1] = stb.quad0; + break; + case TY_DBLE: + num1[0] = CONVAL1G(oldval); + num1[1] = CONVAL2G(oldval); + xdtoq(num1, &num); + num[0] = getcon(num, DT_QUAD); + num[1] = stb.quad0; + break; + case TY_QUAD: + num[0] = oldval; + num[1] = stb.quad0; + break; + case TY_CMPLX: + xftoq(CONVAL1G(oldval), num1); + num[0] = getcon(num1, DT_QUAD); + xftoq(CONVAL2G(oldval), num1); + num[1] = getcon(num1, DT_QUAD); + break; + case TY_DCMPLX: + num1[0] = CONVAL1G(CONVAL1G(oldval)); + num1[1] = CONVAL2G(CONVAL1G(oldval)); + xdtoq(num1, &result); + num[0] = getcon(&result, DT_QUAD); + + num1[0] = CONVAL1G(CONVAL2G(oldval)); + num1[1] = CONVAL2G(CONVAL2G(oldval)); + xdtoq(num1, &result); + num[1] = getcon(&result, DT_QUAD); + break; + case TY_HOLL: + cp = stb.n_base + CONVAL1G(CONVAL1G(oldval)); + goto char_to_qcmplx; + case TY_CHAR: + if (flg.standard) + conversion_warning(); + cp = stb.n_base + CONVAL1G(oldval); + char_to_qcmplx: + holtonum(cp, num1, 32); + if (flg.endian == 0) { + /* for little endian, need to swap words in each double word + * quantity. Order of bytes in a word is okay, but not the + * order of words. + */ + swap = num1[0]; + num1[0] = num1[1]; + num1[1] = swap; + swap = num1[2]; + num1[2] = num1[3]; + num1[3] = swap; + } + num[0] = getcon(&num1[0], DT_QUAD); + num[1] = getcon(&num1[2], DT_QUAD); + break; + default: + num[0] = 0; + num[1] = 0; + errsev(91); + } + } + return getcon(num, DT_CMPLX32); + // AOCC end case TY_NCHAR: if (from == TY_WORD) { num[0] = 0; @@ -8905,6 +9628,14 @@ _ddiv(INT *dividend, INT *divisor, INT *quotient) #endif } +// AOCC begin +static void +_qdiv(INT *dividend, INT *divisor, INT *quotient) +{ + xqdiv(dividend, divisor, quotient); +} +// AOCC end + /** \brief Convert doubleword hex/octal value to a character. \param hexval two-element array of [0] msw, [1] lsw \return the symbol table entry of the character constant diff --git a/tools/flang1/flang1exe/astout.c b/tools/flang1/flang1exe/astout.c index 39ae933f65..bd67b1423e 100644 --- a/tools/flang1/flang1exe/astout.c +++ b/tools/flang1/flang1exe/astout.c @@ -5,6 +5,23 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading + * Date of modification 12th February 2020 + * Date of modification 04th April 2020 + * + * Support for TRAILZ intrinsic. + * Month of Modification: July 2019 + * Added support for quad precision + * Last modified: Feb 2020 + * + * Support for real*16 intrinsics + * Date of modification: !8th July 2020 + */ + /** \file \brief Abstract syntax tree output module. @@ -42,7 +59,7 @@ static int indent; /* number of indentation levels */ #define CARDB_SIZE 300 /* make it large enough */ static char lbuff[CARDB_SIZE]; -#define MAX_FNAME_LEN 258 +#define MAX_FNAME_LEN 4096 static LOGICAL ast_is_comment = FALSE; static LOGICAL op_space = TRUE; @@ -100,6 +117,7 @@ static void put_int8(int); static void put_logical(LOGICAL, int); static void put_float(INT); static void put_double(int); +static void put_quad(int); // AOCC static void char_to_text(int); static void put_u_to_l(char *); static void put_l_to_u(char *); @@ -241,6 +259,7 @@ negative_constant(int ast) { DBLINT64 inum1, inum2; DBLE dnum1, dnum2; + QUAD qnum1, qnum2; // AOCC if (A_TYPEG(ast) == A_CNST) { int sptr; @@ -262,6 +281,20 @@ negative_constant(int ast) if (xdcmp(dnum1, dnum2) < 0) return TRUE; break; + // AOCC begin + case TY_QUAD: + dnum1[0] = CONVAL1G(sptr); + dnum1[1] = CONVAL2G(sptr); + dnum1[2] = CONVAL3G(sptr); + dnum1[3] = CONVAL4G(sptr); + dnum2[0] = CONVAL1G(stb.quad0); + dnum2[1] = CONVAL2G(stb.quad0); + dnum2[2] = CONVAL3G(stb.quad0); + dnum2[3] = CONVAL4G(stb.quad0); + if (xqcmp(dnum1, dnum2) < 0) + return TRUE; + break; + // AOCC end case TY_INT8: inum1[0] = CONVAL1G(sptr); inum1[1] = CONVAL2G(sptr); @@ -430,6 +463,12 @@ print_ast(int ast) o = ".or."; commutable = TRUE; break; + // AOCC begin + case OP_LXOR: + o = ".xor."; + commutable = TRUE; + break; + // AOCC end case OP_LAND: case OP_SCAND: o = ".and."; @@ -912,6 +951,12 @@ print_ast(int ast) /* since LOP may be aimag, force the name 'dimag' */ put_call(ast, 0, "dimag", 0); break; + // AOCC begin + case I_QIMAG: + /* since LOP may be aimag, force the name 'qimag' */ + put_call(ast, 0, "qimag", 0); + break; + // AOCC end case I_INDEX: if (A_ARGCNTG(ast) != 2) { rtlRtn = RTE_indexa; @@ -944,7 +989,9 @@ print_ast(int ast) case I_FRACTION: if (DTY(DDTG(A_DTYPEG(ast))) == TY_REAL) rtlRtn = RTE_frac; - else + else if (DTY(DDTG(A_DTYPEG(ast))) == TY_QUAD) + rtlRtn = RTE_fracq; + else //AOCC rtlRtn = RTE_fracd; goto make_func_name; case I_IACHAR: @@ -953,32 +1000,42 @@ print_ast(int ast) case I_RRSPACING: if (DTY(DDTG(A_DTYPEG(ast))) == TY_REAL) rtlRtn = RTE_rrspacing; + else if (DTY(DDTG(A_DTYPEG(ast))) == TY_QUAD) + rtlRtn = RTE_rrspacingq; else - rtlRtn = RTE_rrspacingd; + rtlRtn = RTE_rrspacingd; //AOCC goto make_func_name; case I_SPACING: if (DTY(DDTG(A_DTYPEG(ast))) == TY_REAL) rtlRtn = RTE_spacing; + else if (DTY(DDTG(A_DTYPEG(ast))) == TY_QUAD) + rtlRtn = RTE_spacingq; else - rtlRtn = RTE_spacingd; + rtlRtn = RTE_spacingd; //AOCC goto make_func_name; case I_NEAREST: if (DTY(DDTG(A_DTYPEG(ast))) == TY_REAL) rtlRtn = RTE_nearest; + else if (DTY(DDTG(A_DTYPEG(ast))) == TY_QUAD) + rtlRtn = RTE_nearestq; else - rtlRtn = RTE_nearestd; + rtlRtn = RTE_nearestd; //AOCC goto make_func_name; case I_SCALE: if (DTY(DDTG(A_DTYPEG(ast))) == TY_REAL) rtlRtn = RTE_scale; + else if (DTY(DDTG(A_DTYPEG(ast))) == TY_QUAD) + rtlRtn = RTE_scaleq; else - rtlRtn = RTE_scaled; + rtlRtn = RTE_scaled; //AOCC goto make_func_name; case I_SET_EXPONENT: if (DTY(DDTG(A_DTYPEG(ast))) == TY_REAL) rtlRtn = RTE_setexp; + else if (DTY(DDTG(A_DTYPEG(ast))) == TY_QUAD) + rtlRtn = RTE_setexpq; else - rtlRtn = RTE_setexpd; + rtlRtn = RTE_setexpd; //AOCC goto make_func_name; case I_VERIFY: argt = A_ARGSG(ast); @@ -1018,6 +1075,18 @@ print_ast(int ast) rtlRtn = RTE_leadz; goto make_func_name; #endif +/* AOCC begin */ +#ifdef I_TRAILZ + case I_TRAILZ: + if (XBIT(49, 0x1040000)) { + /* T3D/T3E or C90 Cray targets */ + put_call(ast, 0, NULL, 0); + break; + } + rtlRtn = RTE_trailz; + goto make_func_name; +#endif +/* AOCC end */ #ifdef I_POPCNT case I_POPCNT: if (XBIT(49, 0x1040000)) { @@ -1970,7 +2039,11 @@ print_ast(int ast) put_string("end atomic "); break; case A_MP_ATOMIC: + lbuff[0] = '!'; + put_string("mp atomic" ); case A_MP_ENDATOMIC: + lbuff[0] = '!'; + put_string("end mp atomic "); break; case A_MP_ATOMICREAD: lbuff[0] = '!'; @@ -2236,6 +2309,14 @@ print_ast(int ast) case A_MP_TARGETLOOPTRIPCOUNT: put_string("target loop tripcount"); break; + // AOCC Begin + case A_MP_DEFAULTMAP: + put_string("defaultmap"); + break; + case A_MP_TARGETDECLARE: + put_string("target declare"); + break; + // AOCC End case A_MP_MAP: put_string("map"); break; @@ -3880,6 +3961,15 @@ put_const(int sptr) } put_double(sptr); return; + // AOCC begin + case TY_QUAD: + if (NMPTRG(sptr)) { + put_string(SYMNAME(sptr)); + return; + } + put_quad(sptr); + return; + // AOCC end case TY_CMPLX: if (NMPTRG(sptr)) { @@ -3905,6 +3995,20 @@ put_const(int sptr) put_char(')'); return; + // AOCC begin + case TY_QCMPLX: + if (NMPTRG(sptr)) { + put_string(SYMNAME(sptr)); + return; + } + put_char('('); + put_const((int)CONVAL1G(sptr)); + put_char(','); + put_const((int)CONVAL2G(sptr)); + put_char(')'); + return; + // AOCC end + case TY_HOLL: sptr2 = CONVAL1G(sptr); dtype = DTYPEG(sptr2); @@ -4204,6 +4308,80 @@ put_double(int sptr) put_string(start); } +// AOCC begin +static void +put_quad(int sptr) +{ + INT num[4]; + char b[128]; + char *start; + char *end; + char *exp; + int expw; + int i; + + num[0] = CONVAL1G(sptr); + num[1] = CONVAL2G(sptr); + num[2] = CONVAL3G(sptr); + num[3] = CONVAL4G(sptr); + + + if (XBIT(49, 0x40000)) /* C90 */ + cprintf(b, "%.15Lf", num); + else + cprintf(b, "%.37Lf", num); + + for (start = b; *start == ' '; start++) /* skip leading blanks */ + ; + /* only leave the sign if it's '-' */ + if (*start == '+') + start++; + + /* locate beginning of exponent */ + exp = &b[strlen(b) - 1]; + expw = -1; /* width of exponent less 'D' and the sign */ + while (*exp != 'E' && *exp != 'e' && *exp != 'Q' && *exp != 'q') { + if (exp <= start) { + /* output from cprintf is [-]INF */ + if (*start == '-') + put_char('-'); + put_string("1d+309"); + return; + } + exp--; + expw++; + } + + i = (exp - b) - 1; /* last decimal digit */ + /* + * omit trailing 0's; don't omit digit after the decimal point. + */ + while (b[i] == '0' && i > 3) + i--; + end = &b[i + 1]; + /* exp locates 'D' */ + if (DTY(DT_REAL) == TY_QUAD && XBIT(49, 0x800000)) + /* change 'f' to 'e' only if default real is quad precision for + * the cray systems. + */ + *end++ = 'e'; + else + *end++ = 'q'; + if (*++exp == '-') /* sign */ + *end++ = '-'; + if (expw == 2) { + if (*++exp != '0') + *end++ = *exp; + *end++ = *++exp; + } else { + while (expw--) + *end++ = *++exp; + } + *end = '\0'; + put_string(start); +} +// AOCC end + /* * emit a character with consideration given to the ', escape sequences, * unprintable characters, etc. diff --git a/tools/flang1/flang1exe/bblock.c b/tools/flang1/flang1exe/bblock.c index dc68a25e27..39a0a0cb3a 100644 --- a/tools/flang1/flang1exe/bblock.c +++ b/tools/flang1/flang1exe/bblock.c @@ -4,6 +4,21 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading + * Implemented diagnostics for simpler case of uninitialized variable use. + * Last modified: Dec 2020 + * + * Implemented pass to move all allocations outside target region + * Last modified: Jan 2021 + * + * Support for x86-64 OpenMP offloading + * Last modified: May 2020 + * + */ /** \file bblock.c \brief Fortran front-end basic block module. @@ -24,6 +39,11 @@ #include "direct.h" #include "pd.h" #include "rtlRtns.h" +#include "gramtk.h" +/* AOCC begin */ +#include "flang/ADT/hash.h" +#include "llmputil.h" +/* AOCC end */ static int entry_point; static int par; /* in OpenMp parallel region */ @@ -1879,3 +1899,1304 @@ eliminate_unused_variables(int which) VISITP(sptr, 0); } /* eliminate_unused_variables */ +/* AOCC begin */ +static hash_value_t int_hash(hash_key_t key) { + hash_accu_t hacc = HASH_ACCU_INIT; + + HASH_ACCU_ADD(hacc, (int) key); + HASH_ACCU_FINISH(hacc); + + return HASH_ACCU_VALUE(hacc); +} + +static int int_equal(hash_key_t key1, hash_key_t key2) { + return ((int) key1 == (int) key2); +} + +static const hash_functions_t int_hash_functions = { + int_hash, int_equal}; + + +/* Map between ru (or subprogram/program-unit) and it's symbol-count. + * It's populated as we traverse each subprogram. Flang doesn't promise + * unique sptr value across the whole compilation-unit, but within a scope + * (including nested scope by the use of contains), the sptr values are unique for + * each symbols. This map is maintained for all RU_XXX kinds and it's + * suppose to be used by subprogram whose scope is under another (ie. within a + * module/subroutine/function etc.) + */ +static hashmap_t ru_to_symcnt_map; + +/* returns true if the symbol pointed to by sptr is generated by the compiler. + * (Unfortunately CCSYMG(sptr) on these symbols sometimes don't work) + */ +static bool is_compiler_generated_sym(int sptr) { + char *symname; + int i; + + if (!sptr) + return true; + symname = getprint(sptr); + + /* Unfortunately, flang uses hardcoded z_*** variables during sema, we + * silently ignore their entries in the symtab */ + if (strcmp(symname, "z__io") == 0) { + return true; + + } else if (strcmp(symname, "z__io_p") == 0) { + return true ; + + } else if (strcmp(symname, "z__fmt") == 0) { + return true; + + } else if (strcmp(symname, "z__ret") == 0) { + return true; + + } else if (strcmp(symname, "z__ent") == 0) { + return true; + + } else if (symname[0] == 'z' && symname[1] == '_' && + isalpha(symname[2]) && symname[3] == '_') { + if (symname[4] == '0' || atol(symname + 4)) + return true; + + } else { + for (i = 0; symname[i]; i++) { + if (!(isalnum(symname[i]) || symname[i] == '_')) + return true; + } + } + + return false; +} + +/* returns true if we can decide the "initalized status" of a variable pointed + * to by sptr better with the current approach. Some of the guards in this + * function will go away once the approach is sophisticated enough */ +static bool is_sptr_init_status_decideable(int sptr) { + if (!sptr) + return false; + + if (sptr >= stb.stg_avail) + return false; + + if (is_compiler_generated_sym(sptr)) + return false; + + if (SCOPEG(sptr) != stb.curr_scope) + return false; + + if (SCG(sptr) == SC_CMBLK) + return false; + + if (!ST_ISVAR(STYPEG(sptr))) + return false; + + if (STYPEG(sptr) == ST_ARRAY) + return false; + + + return true; +} + +/* returns the "reduced" variable form of the ast_var recursively. ie. If the ast_var is + * conversion-operator, or a unary-op-val expression, that can be trivially + * reduced to the variable subject to it's operation, we return it; else 0 + * */ +static int reduce_to_var(int ast_var) { + /* There are cases, for example, in a binop where an op could be a compiler + * inserted object (like z__io) that would be zero */ + if (!ast_var) + return 0; + + /* If ast_var is inside a type-conversion */ + if (A_TYPEG(ast_var) == A_CONV) + return reduce_to_var(A_LOPG(ast_var)); + + /* If ast_var is OP_VAL() unary-expression */ + if (A_TYPEG(ast_var) == A_UNOP && A_OPTYPEG(ast_var) == OP_VAL) + return reduce_to_var(A_LOPG(ast_var)); + + if (A_TYPEG(ast_var) == A_ID) + return ast_var; + else + return 0; +} + +/* Tracks the symbols initialized so far during the STD traversal of a + * subprogram */ +static hashset_t initsyms_set; + +/* returns true if sptr is initiazlied at the current traversal */ +static bool is_var_initialized(int sptr) { + if (!is_sptr_init_status_decideable(sptr)) + return true; + + if (SCG(sptr) == SC_STATIC) + return true; + + /* Declaration stmts won't be traversed in our STD traversal, so we use this + * macro instead (note that declaration infortran can never follow an + * action-stmt) */ + if (DINITG(sptr)) + return true; + + if (initsyms_set && hashset_lookup(initsyms_set, INT2HKEY(sptr))) + return true; + + return false; +} + +/* resets initsyms for a new program-unit */ +static clear_initsyms() { + if (initsyms_set) + hashset_clear(initsyms_set); + return 0; +} + +/* marks the variable pointed to by sptr as initiazlied */ +static void add_sptr_to_initsyms(int sptr) { + if (!is_sptr_init_status_decideable(sptr)) + return; + + if (!initsyms_set) + initsyms_set = hashset_alloc(int_hash_functions); + + hashset_insert(initsyms_set, INT2HKEY(sptr)); +} + +/* marks the "relevant" symbol in ast_var as initialized */ +static void add_to_initsyms(int ast_var) { + int sptr; + + ast_var = reduce_to_var(ast_var); + if (!ast_var) + return; + + sptr = A_SPTRG(ast_var); + + add_sptr_to_initsyms(sptr); +} + +/* emits warning if ast_var present in ast_stmt is not defined at the current + * traversal of ast nodes in the STD with line-number as curr_lineno */ +static inline void warn_if_var_uninit(int ast_stmt, int ast_var, int curr_lineno) { + int sptr, std; + + int x = ast_var; + ast_var = reduce_to_var(ast_var); + if (!ast_var) + return; + + sptr = A_SPTRG(ast_var); + std = A_STDG(ast_stmt); + + if (is_sptr_init_status_decideable(sptr) && !is_var_initialized(sptr)) { + error(1220, 2, curr_lineno, SYMNAME(sptr), + SYMNAME(gbl.currsub)); + } +} + +/* The main function to be called for each program-unit that emits warnings for + * use of uninitialized variables */ +static void +warn_uninit_use_visitor(int ast, int *_curr_lineno) +{ + int arg, argt, argcnt; + int sptr, curr_lineno = *_curr_lineno, i; + int lhs, rhs, lop, rop; + int asd, ss, ndim; + int dovar; + + switch (A_TYPEG(ast)) { + case A_ALLOC: + add_to_initsyms(A_LOPG(ast)); + break; + + case A_ASN: + lhs = A_DESTG(ast); + rhs = A_SRCG(ast); + + /* To catch = cases, we must check the rhs before we add + * this as an assigned sym */ + if (lhs == rhs) { + warn_if_var_uninit(ast, lhs, curr_lineno); + break; + } + + add_to_initsyms(lhs); + warn_if_var_uninit(ast, rhs, curr_lineno); + break; + + case A_BINOP: + lop = A_LOPG(ast); + rop = A_ROPG(ast); + + warn_if_var_uninit(ast, lop, curr_lineno); + warn_if_var_uninit(ast, rop, curr_lineno); + break; + + case A_DO: + dovar = A_DOVARG(ast); + add_to_initsyms(dovar); + break; + + case A_FORALL: + add_sptr_to_initsyms((ASTLI_SPTR(A_LISTG(ast)))); + break; + + /* Mark variables subject to a call as uninitialized */ + case A_ICALL: + case A_CALL: + case A_FUNC: + argt = A_ARGSG(ast); + argcnt = A_ARGCNTG(ast); + + for (i = 0; i < argcnt; i++) { + arg = ARGT_ARG(argt, i); + add_to_initsyms(arg); + } + break; + + case A_INTR: + argt = A_ARGSG(ast); + argcnt = A_ARGCNTG(ast); + + for (i = 0; i < argcnt; i++) { + arg = ARGT_ARG(argt, i); + warn_if_var_uninit(ast, arg, curr_lineno); + } + break; + + case A_SUBSCR: + asd = A_ASDG(ast); + ndim = ASD_NDIM(asd); + + for (i = 0; i < ndim; ++i) { + ss = ASD_SUBS(asd, i); + warn_if_var_uninit(ast, ss, curr_lineno); + } + break; + + case A_SUBSTR: + add_to_initsyms(A_LOPG(ast)); + break; + + case A_UNOP: + if (A_OPTYPEG(ast) == OP_VAL) + break; + + lop = A_LOPG(ast); + warn_if_var_uninit(ast, lop, curr_lineno); + break; + } +} + +/* returns symcnt for subprogram (sptr) if sptr is processed and valid, else + * returns -1 */ +static int get_symcnt(int sptr) { + hash_data_t data; + + if(!hashmap_lookup(ru_to_symcnt_map, INT2HKEY(sptr), &data)) + return -1; + return data; +} + +/* remembers the curr subprogram's symbol count so that it can be queried again + * (ie. when we process it's child-subprogram) */ +void remember_curr_symcnt() { + if (!gbl.currsub) + return; + + if (!ru_to_symcnt_map) + ru_to_symcnt_map= hashmap_alloc(int_hash_functions); + + /* For some reason hashmap_replace is not working like it's suppose to, + * hence we do the replacing manually */ + if (hashmap_lookup(ru_to_symcnt_map, INT2HKEY(gbl.currsub), NULL)) { + hashmap_erase(ru_to_symcnt_map, INT2HKEY(gbl.currsub), NULL); + } + + hashmap_insert(ru_to_symcnt_map, INT2HKEY(gbl.currsub), (stb.stg_avail - gbl.currsub)); +} + +/* The main function to warn all uninit var use for the current (ie. gbl.currsub) + * subprogram */ +void warn_uninit_use() { + int std, sptr; + int outersub_symcnt, mod_symcnt; + int i; + + clear_initsyms(); + + ast_visit(1, 1); + + /* If subroutine/function, then add the dummy-vars as initialized */ + if (gbl.rutype == RU_SUBR || gbl.rutype == RU_FUNC) { + for (sptr = stb.firstusym; sptr < stb.stg_avail; ++sptr) { + if (SCG(sptr) == SC_DUMMY) { + add_sptr_to_initsyms(sptr); + } + } + } + + /* If current subprogram is contained in a parent subprogram */ + if (gbl.outersub) { + /* outersub's symbols are inherited down to currsub, we leave them as + * initialized */ + + /* get_symcnt might return -1 on an unprocessed program-unit, it will be + * skipped in the following loop-condition */ + outersub_symcnt = get_symcnt(gbl.outersub); + + /* gbl.outersub points to the subprogram name itself, skipping that with + * an initial increment */ + for (i = 1, sptr = gbl.outersub + 1; i < outersub_symcnt; ++sptr, i++) { + add_sptr_to_initsyms(sptr); + } + } + + /* If current subprogram is contained in a module */ + if (gbl.currmod) { + mod_symcnt = get_symcnt(gbl.currmod); + + for (i = 1, sptr = gbl.currmod + 1; i < mod_symcnt; ++sptr, i++) { + add_sptr_to_initsyms(sptr); + } + } + + /* Traversing the STD in the order of the input source can help us catch a use + * before an assignment in a linear fashion (ie. it will miss the "maybe + * initialized" kinds when use/def are under conditional blocks). + */ + for (std = STD_NEXT(0); std > 0; std = STD_NEXT(std)) { + int ast; + int curr_lineno = STD_LINENO(std); + + ast = STD_AST(std); + ast_traverse(ast, NULL, warn_uninit_use_visitor, &curr_lineno); + } + + ast_unvisit(); +} +/* AOCC end */ + +/* AOCC begin */ +#ifdef OMP_OFFLOAD_LLVM +static int emit_toplevel_std(int atype) { + int ast; + + ast = new_node(atype); + return mk_std(ast); +} + +/* return true if \p std is a parallel section closure */ +static bool is_end_omp_parsec_std(int std) { + switch (A_TYPEG(STD_AST(std))) { + case A_MP_ENDPDO: case A_MP_ENDDISTRIBUTE: case A_MP_ENDTEAMS: + case A_MP_ENDPARALLEL: + return true; + default: + return false; + } + return false; +} + +/* return true if \p std is a parallel section beginning */ +static bool is_beg_omp_parsec_std(int std) { + switch (A_TYPEG(STD_AST(std))) { + case A_MP_PDO: case A_MP_DISTRIBUTE: case A_MP_TEAMS: + case A_MP_PARALLEL: + return true; + default: + return false; + } + return false; +} + +/* + * returns the next target std starting from + * \p std + */ +static int get_next_target_std(int std) { + for (; std > 0; std = STD_NEXT(std)) { + int ast = STD_AST(std); + int asttype = A_TYPEG(ast); + + if (asttype == A_MP_TARGET) { + return std; + } + } + + return -1; +} + +/* + * returns the next parallel section beginning starting + * from \p std + */ +static int get_next_beg_omp_parsec_std(int std) { + for (; std > 0; std = STD_NEXT(std)) { + if (is_beg_omp_parsec_std(std)) { + return std; + } + } + + return -1; +} + +/* + * returns the next parallel section closure starting + * from \p std + */ +static int get_next_end_omp_parsec_std(int std) { + for (; std > 0; std = STD_NEXT(std)) { + if (is_end_omp_parsec_std(std)) { + return std; + } + } + + return -1; +} + +/* + * returns the std after the parallel section closure at + * \p std + */ +static int get_std_after_end_omp_parsec(int std) { + for (; std > 0; std = STD_NEXT(std)) { + if (A_TYPEG(STD_AST(std)) == A_MP_EMPSCOPE) + continue; + if (!is_end_omp_parsec_std(std)) + return std; + } + + return -1; +} + +/* + * returns the std by skipping end-if's, end-do's etc. starting + * from \p std + */ +static int get_std_after_closures(int std) { + for (; std > 0; std = STD_NEXT(std)) { + int asttype = A_TYPEG(STD_AST(std)); + switch (asttype) { + case A_ENDIF: case A_ENDDO: + continue; + default: + return std; + } + } + return std; +} + +/* + * returns the std by skipping else-if ladder starting + * from \p std + */ +static int get_std_after_switches(int std) { + int asttype = A_TYPEG(STD_AST(std)); + switch (asttype) { + case A_ELSEIF: case A_ELSE: case A_GOTO: + break; + default: + return std; + } + + int nesting = 0; + int next_ast = 0; + + for (; std > 0; std = STD_NEXT(std)) { + asttype = A_TYPEG(STD_AST(std)); + switch (asttype) { + case A_IF: + nesting++; + break; + + case A_ENDIF: + next_ast = STD_AST(STD_NEXT(std)); + if (A_TYPEG(next_ast) == A_IFTHEN) { + break; + } + + nesting--; + + if (nesting == -1) { + return STD_NEXT(std); + } + } + } + return std; +} + +/* + * returns the std after the parallel section beginning at + * \p std + */ +static int get_std_after_beg_omp_parsec(int std) { + for (; std > 0; std = STD_NEXT(std)) { + if (A_TYPEG(STD_AST(std)) == A_MP_BMPSCOPE) + continue; + if (!is_beg_omp_parsec_std(std)) + return std; + } + + return -1; +} + +/* returns the related omp-std of \p std */ +static int get_omp_buddy_std(int std) { + return A_STDG(A_LOPG(STD_AST(std))); +} + +/* returns true if \p std has MAP clause */ +static bool has_map(int std) { + int std_next = STD_NEXT(std); + if (std_next > 0) { + int ast = STD_AST(std_next); + if (A_TYPEG(ast) == A_MP_MAP) + return true; + } + return false; +} + +/* return the TEAMS std of TARGET \p std */ +static int get_target_teams_std(int std) { + /* Skip the target-std */ + std = STD_NEXT(std); + + for (; std > 0; std = STD_NEXT(std)) { + int asttype = A_TYPEG(STD_AST(std)); + if (asttype == A_MP_MAP || asttype == A_MP_EMAP || + asttype == A_MP_BMPSCOPE) + continue; + if (asttype == A_MP_TEAMS) + return std; + else + return -1; + } + + return -1; +} + +/* return true if \p std is TARGET */ +static bool is_target_teams(int std) { + if (get_target_teams_std(std) == -1) + return false; + return true; +} + +/* returns the BMPSCOPE of TARGET \p std */ +static int get_target_scope_std(int std) { + return STD_PREV(std); +} + +/* returns the BMPSCOPE of TEAMS std of target at \p std */ +static int get_target_teams_scope_std(int std) { + return STD_PREV(std); +} + +/* returns the BMPSCOPE of PARALLEL std at \p std */ +static int get_parallel_scope_std(int std) { + return STD_PREV(std); +} + +/* returns a cloned TARGET of \p std */ +static int clone_target_std(int std) { + int new_ast = new_node(A_MP_TARGET); + A_IFPARP(new_ast, A_IFPARG(STD_AST(std))); + A_COMBINEDTYPEP(new_ast, A_COMBINEDTYPEG(STD_AST(std))); + A_LOOPTRIPCOUNTP(new_ast, A_LOOPTRIPCOUNTG(STD_AST(std))); + A_LOPP(new_ast, A_LOPG(STD_AST(std))); + + return mk_std(new_ast); +} + +/* returns a cloned EMAP of \p std */ +static int clone_emap_std() { + int new_ast = new_node(A_MP_EMAP); + + return mk_std(new_ast); +} + +/* returns a cloned stblk of \p ast */ +static int clone_stblk(int ast) { + bool debug_me = false; + int orig_scope_sptr = A_SPTRG(ast); + + static int counter = 0; + /* create the scope sptr */ + int cloned_scope_sptr = getccssym("uplevelCloned", counter++, ST_BLOCK); + PARSYMSCTP(cloned_scope_sptr, 0); + PARSYMSP(cloned_scope_sptr, 0); + + /* create the uplevel sptr */ + int cloned_uplevel_sptr = getccssym("uplevelCloned", counter++, ST_BLOCK); + PARSYMSCTP(cloned_uplevel_sptr, 0); + PARSYMSP(cloned_uplevel_sptr, 0); + + /* link uplevel and scope sptr */ + PARUPLEVELP(cloned_scope_sptr, cloned_uplevel_sptr); + LLUplevel *cloned_uplevel = llmp_create_uplevel(cloned_uplevel_sptr); + + int orig_uplevel_sptr = PARUPLEVELG(orig_scope_sptr); + + /* populate target-region sptr in the cloned uplevel sptr */ + if (PARSYMSG(orig_uplevel_sptr)) { + LLUplevel *orig_uplevel = llmp_get_uplevel(orig_uplevel_sptr); + + for (int i = 0; i < orig_uplevel->vals_count; ++i) { + if (orig_uplevel->vals[i] && STYPEG(orig_uplevel->vals[i]) == ST_ARRDSC) + continue; + if (debug_me) { + printf("[ompaccel-ast] mapping %s\n", getprint(orig_uplevel->vals[i])); + } + if (ENCLFUNCG(orig_uplevel->vals[i])) + ENCLFUNCP(orig_uplevel->vals[i], cloned_scope_sptr-2); + + llmp_add_shared_var(cloned_uplevel, orig_uplevel->vals[i]); + } + } + + if (debug_me) { + printf("[ompaccel-ast] made uplevel-sptr %d whose " + "parent is %d\n", cloned_uplevel_sptr, orig_uplevel_sptr); + } + + int cloned_ast = mk_id(cloned_scope_sptr); + return cloned_ast; +} + +/* returns a cloned BMPSCOPE of \p std */ +int clone_bmpscope_std(int std) { + int new_ast = new_node(A_MP_BMPSCOPE); + int new_stblk = clone_stblk(A_STBLKG(STD_AST(std))); + + int old_stblk = A_STBLKG(STD_AST(std)); + A_STBLKP(new_ast, new_stblk); + A_LOPP(new_ast, A_LOPG(STD_AST(std))); + + return mk_std(new_ast); +} + +/* + * links omp asts \p ast1 and ast2 by their LOP. This establishes their + * relationship + */ +static void make_omp_buddies_ast(int ast1, int ast2) { + A_LOPP(ast1, ast2); + A_LOPP(ast2, ast1); +} + +/* Does the same as make_omp_buddies_ast() but for STD */ +static void make_omp_buddies_std(int std1, int std2) { + int ast1 = STD_AST(std1); + int ast2 = STD_AST(std2); + make_omp_buddies_ast(ast1, ast2); +} + +/* + * closes the target region of \p curr_target_std at \p + * at_std + */ +static void end_target_std(int curr_target_std, int at_std) { + bool debug_me = false; + + if (debug_me) { + printf("[ompaccel-ast] ending target at ast:%s:%d\n", + astb.atypes[A_TYPEG(STD_AST(at_std))], STD_LINENO(at_std)); + } + + int curr_endtarget_std = emit_toplevel_std(A_MP_ENDTARGET); + make_omp_buddies_std(curr_target_std, curr_endtarget_std); + insert_stmt_before(curr_endtarget_std, at_std); + + int curr_target_bmpscope_std = get_target_scope_std(curr_target_std); + int curr_target_empscope_std = emit_toplevel_std(A_MP_EMPSCOPE); + make_omp_buddies_std(curr_target_bmpscope_std, curr_target_empscope_std); + insert_stmt_before(curr_target_empscope_std, at_std); +} + +/* + * emits STDs to begin a new target region by cloning \p curr_target_std + * at \p at_std + */ +static int begin_target_std(int curr_target_std, int at_std) { + bool debug_me = false; + int curr_target_ast = STD_AST(curr_target_std); + int new_target_bmpscope_std = + clone_bmpscope_std(get_target_scope_std(curr_target_std)); + A_LOPP(STD_AST(new_target_bmpscope_std), 0); + insert_stmt_before(new_target_bmpscope_std, at_std); + + int new_target_std = clone_target_std(curr_target_std); + A_LOPP(STD_AST(new_target_std), 0); + insert_stmt_before(new_target_std, at_std); + + /* flang2's symbol replacer relies on this EMAP */ + int new_emap_std = clone_emap_std(); + insert_stmt_before(new_emap_std, at_std); + + if (debug_me) + printf("[ompaccel-ast] creating a new target region at %s:%d\n", + gbl.src_file, STD_LINENO(new_target_std)); + + return new_target_std; +} + +/* returns the MP_ENDPDO of \p pdo_std */ +int get_pdo_buddy_std(int pdo_std) { + int std = STD_NEXT(pdo_std); + + for (; std > 0; std = STD_NEXT(std)) { + int asttype = A_TYPEG(STD_AST(std)); + if (asttype == A_MP_ENDPDO) { + return std; + } + } + return 0; +} + +/* returns the parallel std of \p pdo_std */ +int get_pdo_parallel_std(int pdo_std) { + int std = STD_PREV(pdo_std); + + for (; std > 0; std = STD_PREV(std)) { + int asttype = A_TYPEG(STD_AST(std)); + if (asttype == A_MP_PARALLEL) { + return std; + } + } + return 0; +} + +/* + * Converts MP_PDO std \p pdo_std to the corresponding DO std by stripping off + * the parallel std's + */ +static void conv_pdo_to_do_std(int pdo_std) { + /* convert MP_PDO */ + int pdo_ast = STD_AST(pdo_std); + A_TYPEP(pdo_ast, A_DO); + + /*convert MP_ENDPDO */ + int endpdo_std = get_pdo_buddy_std(pdo_std); + int endpdo_ast = STD_AST(endpdo_std); + A_TYPEP(endpdo_ast, A_ENDDO); + + /* remove MP_PARALLEL */ + int parallel_std = get_pdo_parallel_std(pdo_std); + int end_parallel_std = A_STDG(A_LOPG(STD_AST(parallel_std))); + remove_stmt(parallel_std); + remove_stmt(end_parallel_std); +} + +/* + * Returns true if the target region has multiple parallel sections + * in an else-if ladder + */ +static bool ompaccel_has_switched_parsec() { + bool debug_me = false; + ast_visit(1, 1); + + bool intarget = false, has_multi_parsec = false; + bool has_switches = false; + + int curr_target_ast = 0; + int curr_target_std = -1; + int curr_end_target_std = -1; + int std_next = -1; + + for (int std = STD_NEXT(0); std > 0; std = std_next) { + int ast = STD_AST(std); + int asttype = A_TYPEG(ast); + std_next = STD_NEXT(std); + + if (asttype == A_MP_TARGET) { + curr_target_ast = ast; + curr_target_std = std; + + if (get_omp_buddy_std(curr_target_std)) + curr_end_target_std = get_omp_buddy_std(curr_target_std); + + intarget = true; + + } else if (asttype == A_MP_ENDTARGET) { + intarget = false; + + } else if (intarget) { + switch (asttype) { + case A_ELSEIF: case A_GOTO: + has_switches = true; + break; + default: + if (is_end_omp_parsec_std(std)) { + int next_beg_parsec_std = get_next_beg_omp_parsec_std(std); + + if (next_beg_parsec_std > 0) { + if (STD_LINENO(next_beg_parsec_std) < STD_LINENO(curr_end_target_std)) { + has_multi_parsec = true; + } + } + } + break; + } + } + + if (has_switches && has_multi_parsec) + return true; + } + + ast_unvisit(); + return false; +} + +typedef struct { + int std; + int move_after; +} MoveCandidate2; + +// Pass to move all allocations outside target region. This pass will move +// only standalone allocations. ompaccel_ast_alloc_array will move +// allocations inside if construct +void ompaccel_ast_alloc_array2() { + ast_visit(1, 1); + + bool in_target = false; + int btarget_std = -1; + int etarget_std = -1; + int last_std = -1; + int btarget_prevstd = -1; + int alloc_sptr = -1; + int num_candidates = 0; + const int max_candidates = 100; + MoveCandidate2 candidates[max_candidates]; + + for (int std = STD_NEXT(0); std > 0; std = STD_NEXT(std)) { + int ast = STD_AST(std); + int asttype = A_TYPEG(ast); + + if (asttype == A_MP_TARGET) { + in_target = true; + btarget_std = std; + btarget_prevstd = last_std; + } else if (asttype == A_MP_ENDTARGET) { + in_target = false; + etarget_std = std; + // TODO: Optimise this! + for (unsigned int i = 0; i < num_candidates; ++i) { + if (candidates[i].move_after == -1) { + candidates[i].move_after = std; + } + } + } + + if (in_target && asttype == A_ALLOC) { + if (A_TKNG(ast) == TK_ALLOCATE) { + int subscr_ast = A_SRCG(ast); + if (A_TYPEG(subscr_ast) == A_SUBSCR) { + int sptr_ast = A_LOPG(subscr_ast); + alloc_sptr = A_SPTRG(sptr_ast); + } + if (alloc_sptr != -1) { + int stblk_ast = A_STBLKG(STD_AST(btarget_prevstd)); + int uplevel_sptr = PARUPLEVELG(A_SPTRG(stblk_ast)); + if (PARSYMSG(uplevel_sptr)) { + LLUplevel *uplevel = llmp_get_uplevel(uplevel_sptr); + if (MIDNUMG(alloc_sptr)) { + alloc_sptr = MIDNUMG(alloc_sptr); + if (SCG(alloc_sptr) == SC_PRIVATE) + SCP(alloc_sptr, SC_LOCAL); + } + llmp_add_shared_var(uplevel, alloc_sptr); + } + alloc_sptr = -1; + } + + MoveCandidate2 cand; + cand.std = std; + cand.move_after = btarget_prevstd; + candidates[num_candidates++] = cand; + assert(num_candidates < max_candidates, "More than expected candidates", + num_candidates, ERR_Fatal); + } else if (A_TKNG(ast) == TK_DEALLOCATE) { + MoveCandidate2 cand; + cand.std = std; + cand.move_after = -1; + candidates[num_candidates++] = cand; + assert(num_candidates < max_candidates, "More than expected candidates", + num_candidates, ERR_Fatal); + } + } + + last_std = std; + } + + for (unsigned i = 0; i < num_candidates; ++i) { + remove_stmt(candidates[i].std); + insert_stmt_after(candidates[i].std, candidates[i].move_after); + } + + ast_unvisit(); +} + +typedef struct { + int begin; + int end; + int move_after; +} MoveCandidate; + +void ompaccel_ast_alloc_array() { + bool debug_me = false; + ast_visit(1, 1); + + bool in_target = false; + bool alloc_found = false; + bool dealloc_found = false; + bool allocated_found = false; + bool in_if = false; + int if_nest = 0; + int btarget_std = -1; + int etarget_std = -1; + int last_std = -1; + int btarget_prevstd = -1; + int ifbegin_std = -1; + int ifend_std = -1; + int alloc_sptr = -1; + MoveCandidate candidates[25]; + int num_candidates = 0; + + for (int std = STD_NEXT(0); std > 0; std = STD_NEXT(std)) { + int ast = STD_AST(std); + int asttype = A_TYPEG(ast); + + if (asttype == A_MP_TARGET) { + in_target = true; + btarget_std = std; + btarget_prevstd = last_std; + } else if (asttype == A_MP_ENDTARGET) { + in_target = false; + etarget_std = std; + } + + if (in_target && asttype == A_ALLOC && in_if) { + if (A_TKNG(ast) == TK_ALLOCATE) { + alloc_found = true; + int subscr_ast = A_SRCG(ast); + if (A_TYPEG(subscr_ast) == A_SUBSCR) { + int sptr_ast = A_LOPG(subscr_ast); + alloc_sptr = A_SPTRG(sptr_ast); + } + } else if (A_TKNG(ast) == TK_DEALLOCATE) { + dealloc_found = true; + } + } + + if (asttype == A_ICALL) { + if (A_OPTYPEG(ast) == I_NULLIFY && in_target) { + MoveCandidate cand; + cand.begin = std; + cand.end = std; + cand.move_after = btarget_prevstd; + candidates[num_candidates++] = cand; + } + } + + if (asttype == A_IFTHEN && in_target) { + if (!in_if) { + ifbegin_std = std; + in_if = true; + } else { + if_nest++; + } + } + + if (asttype == A_ENDIF && in_target && (alloc_found || allocated_found)) { + if (if_nest) { + if_nest--; + continue; + } + + MoveCandidate cand; + cand.begin = ifbegin_std; + cand.end = std; + cand.move_after = btarget_prevstd; + candidates[num_candidates++] = cand; + assert(num_candidates < 25, "More than expected candidates", + num_candidates, ERR_Fatal); + in_if = false; + alloc_found = alloc_found ? false : alloc_found; + allocated_found = allocated_found ? false : allocated_found; + + if (A_TYPEG(STD_AST(btarget_prevstd)) == A_MP_BMPSCOPE) { + if (alloc_sptr != -1) { + int stblk_ast = A_STBLKG(STD_AST(btarget_prevstd)); + int uplevel_sptr = PARUPLEVELG(A_SPTRG(stblk_ast)); + if (PARSYMSG(uplevel_sptr)) { + LLUplevel *uplevel = llmp_get_uplevel(uplevel_sptr); + if (MIDNUMG(alloc_sptr)) { + alloc_sptr = MIDNUMG(alloc_sptr); + if (SCG(alloc_sptr) == SC_PRIVATE) + SCP(alloc_sptr, SC_LOCAL); + } + llmp_add_shared_var(uplevel, alloc_sptr); + } + + alloc_sptr = -1; + } + } + } + + if (asttype == A_ENDIF && in_target && dealloc_found) { + + if (if_nest) { + if_nest--; + continue; + } + + MoveCandidate cand; + cand.begin = ifbegin_std; + cand.end = std; + cand.move_after = -1; + candidates[num_candidates++] = cand; + assert(num_candidates < 25, "More than expected candidates", + num_candidates, ERR_Fatal); + in_if = false; + dealloc_found = false; + } + + if (asttype == A_ENDIF) { + in_if = false; + ifend_std = std; + } + + last_std = std; + } + + for (unsigned i = 0; i < num_candidates; ++i) { + if (candidates[i].move_after == -1) + candidates[i].move_after = etarget_std; + if (candidates[i].move_after == -1) + candidates[i].move_after = etarget_std; + move_range_after(candidates[i].begin, candidates[i].end, + candidates[i].move_after); + } + + ast_unvisit(); +} + +/* + * AST transformation that transforms multi-nested parallel region to + * single-nested ones + */ +static bool ompaccel_ast_simplify_nested_parsec() { + bool debug_me = false; + ast_visit(1, 1); + + bool in_target = false, in_target_parallel = false; + + int std_next = -1; + int target_parallel_do_nesting = 0; + + for (int std = STD_NEXT(0); std > 0; std = std_next) { + int ast = STD_AST(std); + int asttype = A_TYPEG(ast); + std_next = STD_NEXT(std); + + if (asttype == A_MP_TARGET) { + in_target = true; + + } else if (asttype == A_MP_ENDTARGET) { + in_target = false; + + } else if (asttype == A_MP_PARALLEL && in_target) { + in_target_parallel = true; + + } else if (asttype == A_MP_ENDPARALLEL && in_target) { + in_target_parallel = false; + + } else if (in_target_parallel) { + switch (asttype) { + case A_MP_PDO: + target_parallel_do_nesting++; + + if (target_parallel_do_nesting == 2) { + if (debug_me) { + printf("[ompaccel-ast] Found nested parallel region in %s:%d\n", + gbl.src_file, STD_LINENO(std)); + } + conv_pdo_to_do_std(std); + target_parallel_do_nesting--; + } + break; + + case A_MP_ENDPDO: + target_parallel_do_nesting--; + break; + } + } + } + + ast_unvisit(); + return false; +} + +/* + * AST transformation pass that serialize a target region if it has multiple + * parallel sections + */ +static void ompaccel_ast_serialize_parsec() { + bool debug_me = false; + ast_visit(1, 1); + + bool intarget = false; + int curr_target_ast = 0; + int curr_target_std = -1; + int curr_end_target_std = -1; + int std_next = -1; + + for (int std = STD_NEXT(0); std > 0; std = std_next) { + int ast = STD_AST(std); + int asttype = A_TYPEG(ast); + std_next = STD_NEXT(std); + + if (asttype == A_MP_TARGET) { + curr_target_ast = ast; + curr_target_std = std; + + if (get_omp_buddy_std(curr_target_std)) + curr_end_target_std = get_omp_buddy_std(curr_target_std); + + intarget = true; + + } else if (asttype == A_MP_ENDTARGET) { + if (A_LOPG(curr_target_ast) <= 0) { + make_omp_buddies_std(curr_target_std, std); + make_omp_buddies_std(get_target_scope_std(curr_target_std), + STD_NEXT(std)); + } + intarget = false; + } + + if (intarget && is_end_omp_parsec_std(std)) { + int next_beg_parsec_std = get_next_beg_omp_parsec_std(std); + + if (next_beg_parsec_std > 0) { + if (!has_map(curr_target_std) && + STD_LINENO(next_beg_parsec_std) < STD_LINENO(curr_end_target_std)) { + if (debug_me) { + printf("[ompaccel-ast] in %s, non first parsec at %d " + "where target region ends at %d\n", + gbl.src_file, STD_LINENO(next_beg_parsec_std), + STD_LINENO(curr_end_target_std)); + } + + if (is_target_teams(curr_target_std)) { + int target_teams_std = get_target_teams_std(curr_target_std); + A_THRLIMITP(STD_AST(target_teams_std), mk_cnst(stb.i1)); + A_NTEAMSP(STD_AST(target_teams_std), mk_cnst(stb.i1)); + } + + std_next = get_omp_buddy_std(curr_target_std); + } + } + } + } + ast_unvisit(); +} + +/* + * AST transformation pass that segregates different parallel and + * serial section in a single target region into multiple target region. + * Currently, we bail out if it has complex else-if ladder due to the difficulty + * in doing this due to the linearized AST of flang. + * TODO: handle more complex cases + */ +static void ompaccel_ast_segregate_parsec() { + bool debug_me = false; + + if (ompaccel_has_switched_parsec()) { + if (debug_me) + printf("[ompaccel-ast] switch/else-if found amid multiple parallel " + "sections\n"); + return; + } + + ast_visit(1, 1); + bool intarget = false; + int curr_target_ast = 0; + int curr_target_std = -1; + int curr_end_target_std = -1; + int std_next = -1; + + for (int std = STD_NEXT(0); std > 0; std = std_next) { + int ast = STD_AST(std); + int asttype = A_TYPEG(ast); + std_next = STD_NEXT(std); + + if (asttype == A_MP_TARGET) { + curr_target_ast = ast; + curr_target_std = std; + + if (get_omp_buddy_std(curr_target_std)) + curr_end_target_std = get_omp_buddy_std(curr_target_std); + + intarget = true; + + } else if (asttype == A_MP_ENDTARGET) { + if (A_LOPG(curr_target_ast) <= 0) { + make_omp_buddies_std(curr_target_std, std); + make_omp_buddies_std(get_target_scope_std(curr_target_std), + STD_NEXT(std)); + } + + intarget = false; + } + + if (intarget && is_end_omp_parsec_std(std)) { + int next_beg_parsec_std = get_next_beg_omp_parsec_std(std); + + if (next_beg_parsec_std > 0) { + if (!has_map(curr_target_std) && + STD_LINENO(next_beg_parsec_std) < STD_LINENO(curr_end_target_std)) { + if (debug_me) { + printf("[ompaccel-ast] in %s, non first parsec at %d " + "where target region ends at %d\n", + gbl.src_file, STD_LINENO(next_beg_parsec_std), + STD_LINENO(curr_end_target_std)); + } + + int insert_pt = get_std_after_end_omp_parsec(std); + insert_pt = get_std_after_closures(insert_pt); + insert_pt = get_std_after_switches(insert_pt); + + end_target_std(curr_target_std, insert_pt); + curr_target_std = begin_target_std(curr_target_std, insert_pt); + curr_target_ast = STD_AST(curr_target_std); + + std_next = get_std_after_beg_omp_parsec(next_beg_parsec_std); + + if (STD_LINENO(curr_target_std) > STD_LINENO(std_next)) { + std_next = STD_NEXT(curr_target_std); + } + } + } + } + } + + ast_unvisit(); +} + +/* The main driver for openmp offloading AST transformation */ +void ompaccel_ast_transform() { + if (flg.x86_64_omptarget && XBIT(232, 0x1)) + return; + + if (flg.omptarget) { +// ompaccel_ast_segregate_parsec(); + ompaccel_ast_simplify_nested_parsec(); + } +} +#endif +/* AOCC end */ diff --git a/tools/flang1/flang1exe/comm.c b/tools/flang1/flang1exe/comm.c index 246edf14cb..9e25854865 100644 --- a/tools/flang1/flang1exe/comm.c +++ b/tools/flang1/flang1exe/comm.c @@ -4,6 +4,12 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified: May 2020 + */ /** \file @@ -53,9 +59,9 @@ static void emit_scatterx(int); static void emit_scatterx_gatherx(int std, int result, int array, int mask, int allocstd, int tempast0, int lhssec, int comm_type); -static void compute_permute(int lhs, int rhs, int list, int order[7]); -static int put_data(int permute[7], int no); -static LOGICAL is_permuted(int array, int per[7], int per1[7], int *nper1); +static void compute_permute(int lhs, int rhs, int list, int order[MAXSUBS]); /* AOCC */ +static int put_data(int permute[MAXSUBS], int no); /* AOCC */ +static LOGICAL is_permuted(int array, int per[MAXSUBS], int per1[MAXSUBS], int *nper1); /* AOCC */ static int scalar_communication(int ast, int std); static int tag_call_comm(int std, int forall); static void call_comm(int cstd, int fstd, int forall); @@ -459,7 +465,7 @@ is_same_number_of_idx(int dest, int src, int list) int reference_for_temp(int sptr, int a, int forall) { - int subs[7]; + int subs[MAXSUBS]; /* AOCC */ int list; int i, ndim, k; int astnew, vector; @@ -700,7 +706,7 @@ forall_opt1(int ast) FT_IGNORE(nd) = 0; FT_SECTL(nd) = 0; FT_CYCLIC(nd) = getcyclic(); - for (i = 0; i < 7; i++) { + for (i = 0; i < MAXSUBS; i++) { /* AOCC */ FT_NFUSE(nd, i) = 0; for (j = 0; j < MAXFUSE; j++) FT_FUSELP(nd, i, j) = 0; @@ -989,7 +995,7 @@ is_scatter(int std) static int simple_reference_for_temp(int sptr, int a, int forall) { - int subs[7]; + int subs[MAXSUBS]; /* AOCC */ int list; int i, ndim, k; int astnew; @@ -1042,7 +1048,7 @@ static int temp_gatherx(int std, int forall, int lhs, int rhs, int dty, int *allocast) { int sptr; - int subscr[7]; + int subscr[MAXSUBS]; /* AOCC */ int ast; int nd; int astnew; @@ -1074,7 +1080,7 @@ static int temp_copy_section(int std, int forall, int lhs, int rhs, int dty, int *allocast) { int sptr; - int subscr[7]; + int subscr[MAXSUBS]; /* AOCC */ int ast; int nd; int astnew; @@ -1111,7 +1117,7 @@ temp_copy_section(int std, int forall, int lhs, int rhs, int dty, int *allocast) static int gatherx_temp_before(int sptr, int rhs, int forall) { - int subs[7]; + int subs[MAXSUBS]; /* AOCC */ int k, j; int asd; int ndim; @@ -1227,7 +1233,7 @@ forall_2_sec(int a, int forall) int triple; int l, u, s; int t1, t2, t3; - int subs[7]; + int subs[MAXSUBS]; /* AOCC */ int sptr; int astli; int base; @@ -1576,7 +1582,7 @@ insert_forall_comm(int ast) int rhs_is_dist; int sptr; int asd, ndim; - int subs[7]; + int subs[MAXSUBS]; /* AOCC */ int nd, nd1, nd2; int src; int cnt; @@ -1781,7 +1787,7 @@ emit_copy_section(int a, int std) int nd; int sptr; int allocast; - int order2[7]; + int order2[MAXSUBS]; /* AOCC */ int no; int header; int lhssec; @@ -1925,7 +1931,7 @@ emit_permute_section(int a, int std) int asd; int ndim; int ast1; - int subs[7]; + int subs[MAXSUBS]; /* AOCC */ int astnew; int tempast, tempast0; int argt, nargs; @@ -1936,7 +1942,7 @@ emit_permute_section(int a, int std) int arref; int lhs; LOGICAL use_lhs; - int order2[7]; + int order2[MAXSUBS]; /* AOCC */ int no; int func; int new_a; @@ -2019,7 +2025,7 @@ emit_permute_section(int a, int std) static int copy_section_temp_before(int sptr, int rhs, int forall) { - int subs[7]; + int subs[MAXSUBS]; /* AOCC */ int k, j; int asd; int ndim; @@ -2054,7 +2060,7 @@ copy_section_temp_before(int sptr, int rhs, int forall) static int eliminate_extra_idx(int lhs, int a, int forall) { - int subs[7]; + int subs[MAXSUBS]; /* AOCC */ int k, i; int asd; int ndim; @@ -2110,20 +2116,20 @@ eliminate_extra_idx(int lhs, int a, int forall) * bit can be zeroed and the axis argument omitted. */ static void -permute_axis(int result, int array, int list, int permute[7]) +permute_axis(int result, int array, int list, int permute[MAXSUBS]) /* AOCC */ { - int order2[7]; + int order2[MAXSUBS]; /* AOCC */ int no; - int subs[7]; + int subs[MAXSUBS]; /* AOCC */ int newresult; int astli, nidx; int asd, ndim; int i, j; - int per[7], per1[7]; + int per[MAXSUBS], per1[MAXSUBS]; /* AOCC */ int nper1; - for (i = 0; i < 7; i++) + for (i = 0; i < MAXSUBS; i++) /* AOCC */ permute[i] = 0; /* find out for indirection array */ @@ -2182,7 +2188,7 @@ get_pertbl(void) } static int -put_data(int permute[7], int no) +put_data(int permute[MAXSUBS], int no) /* AOCC */ { ADSC *ad; int dtype; @@ -2247,17 +2253,17 @@ put_data(int permute[7], int no) * permute will be /0,3,1,2/ */ static void -compute_permute(int lhs, int rhs, int list, int order[7]) +compute_permute(int lhs, int rhs, int list, int order[MAXSUBS]) /* AOCC */ { int asd, ndim; int i, j; int count, count1; - int order1[7]; + int order1[MAXSUBS]; /* AOCC */ LOGICAL found; int astli, nidx; int iloc; - for (j = 0; j < 7; j++) + for (j = 0; j < MAXSUBS; j++) /* AOCC */ order[j] = 0; assert(!is_duplicate(lhs, list), "compute_permute:something is wrong", lhs, @@ -2310,7 +2316,7 @@ compute_permute(int lhs, int rhs, int list, int order[7]) } static LOGICAL -is_permuted(int array, int per[7], int per1[7], int *nper1) +is_permuted(int array, int per[MAXSUBS], int per1[MAXSUBS], int *nper1) /* AOCC */ { int asd; int ndim; @@ -2348,7 +2354,7 @@ emit_sum_scatterx(int std) int asd1; int ndim1; int ast1; - int subs[7]; + int subs[MAXSUBS]; /* AOCC */ int astnew; int tempast, tempast0; int argt, nargs; @@ -2368,7 +2374,7 @@ emit_sum_scatterx(int std) int base; int array; int func; - int permute[7]; + int permute[MAXSUBS]; /* AOCC */ int npermute; int ndim, asd; int nv; @@ -2607,7 +2613,7 @@ emit_scatterx_gatherx(int std, int result, int array, int mask, int allocstd, int asd1; int ndim1; int ast1; - int subs[7]; + int subs[MAXSUBS]; /* AOCC */ int astnew; int tempast; int argt, nargs; @@ -2624,7 +2630,7 @@ emit_scatterx_gatherx(int std, int result, int array, int mask, int allocstd, int result_sec, base_sec, array_sec, mask_sec; int newresult; int func; - int permute[7]; + int permute[MAXSUBS]; /* AOCC */ int npermute; int ndim, asd; int newbase; @@ -3070,7 +3076,7 @@ emit_overlap(int a) int cp, xfer; int nd; int sptr; - int subs[7]; + int subs[MAXSUBS]; /* AOCC */ int forall; int std; int ns, ps; @@ -3174,7 +3180,7 @@ getcyclic(void) ct->ifast = 0; ct->endifast = 0; ct->inner_cyclic = clist(); - for (i = 0; i < 7; i++) { + for (i = 0; i < MAXSUBS; i++) { /* AOCC */ ct->c_lof[i] = 0; ct->c_dupl[i] = 0; ct->idx[i] = 0; @@ -3454,7 +3460,7 @@ construct_list_for_pure(int arg, int mask, int list) static int reference_for_pure_temp(int sptr, int lhs, int arg, int forall) { - int subs[7]; + int subs[MAXSUBS]; /* AOCC */ int list; int i, j; int asd; @@ -3546,7 +3552,7 @@ handle_pure_temp_too_large(int expr, int std) int shape, std1; int sptr; int eledtype; - int subs[7]; + int subs[MAXSUBS]; /* AOCC */ int asn; if (expr == 0) @@ -3929,7 +3935,7 @@ forall_dependency_scalarize(int std, int *std1, int *std2) int ast, ast1, ast2; int asn; int asd; - int subs[7]; + int subs[MAXSUBS]; /* AOCC */ int i; int ndim; int sptr; @@ -4052,7 +4058,7 @@ canonical_conversion(int ast) int i, k; int zero = astb.bnd.zero; int ifexpr; - int subs[7]; + int subs[MAXSUBS]; /* AOCC */ int newdest; int nd, nd1; int ip, pstd, past; @@ -4212,7 +4218,7 @@ scalar_communication(int ast, int std) int rhs_is_dist; int sptr; int asd, ndim; - int subs[7]; + int subs[MAXSUBS]; /* AOCC */ int nd, nd1, nd2; int src; int cnt; diff --git a/tools/flang1/flang1exe/commgen.c b/tools/flang1/flang1exe/commgen.c index 5f7735bc1f..fc11df0942 100644 --- a/tools/flang1/flang1exe/commgen.c +++ b/tools/flang1/flang1exe/commgen.c @@ -4,6 +4,12 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified: May 2020 + */ /** \file @@ -177,7 +183,7 @@ generate_hallobnds(int ast) int newalloc, newdealloc, deallocstd; int i; int asd, ndim; - int subs[7]; + int subs[MAXSUBS]; /* AOCC */ int arr; int std; int nd; @@ -217,7 +223,7 @@ generate_sect(int ast) int sptr; int i; int asd, ndim; - int subs[7]; + int subs[MAXSUBS]; /* AOCC */ int arr; int std; int nd; @@ -385,7 +391,7 @@ generate_gather(int ast) int vsub, nvsub, vsub_ast; int vsubstd, nvsubstd, sectvsub, sectnvsub; int nvsub_ast, vsub_sec_ast, nvsub_sec_ast; - int vec[7], vecsec[7], permute[7]; + int vec[MAXSUBS], vecsec[MAXSUBS], permute[MAXSUBS]; /* AOCC */ int array_sec_ast, result_sec_ast, result_ast, array_ast; int vflag, pflag, nvec, nper; int vdim, pdim; @@ -585,7 +591,7 @@ generate_shift(int ast) int asn; int ns, ps; int align; - int subs[7]; + int subs[MAXSUBS]; /* AOCC */ int type, boundary; int atp; @@ -1149,7 +1155,7 @@ generate_hcycliclp(int ast) u = mk_default_int(A_UPBDG(itriple)); if (normalize_bounds(sptr_lhs)) { dim = get_int_cval(A_SPTRG(A_DIMG(ast))) - 1; - assert(0 <= dim && dim < 7, "generate_hcycliclp: bad dim", dim, 4); + assert(is_legal_numdim(dim), "generate_hcycliclp: bad dim", dim, 4); /* AOCC */ l = sub_lbnd(DTYPEG(sptr_lhs), dim, l, astmem); u = sub_lbnd(DTYPEG(sptr_lhs), dim, u, astmem); } @@ -1430,7 +1436,7 @@ rhs_cyclic(int ast, int std, int ifexpr) int forall; int asd; int ndim; - int subs[7]; + int subs[MAXSUBS]; /* AOCC */ int sptr, align; a = ast; @@ -1657,7 +1663,7 @@ inline_hlocalizebnds(int i1, int i2, int lb, int ub, int sptr_lhs, int descr, assert(A_TYPEG(i1) == A_ID, "inline_hlocalizebnds: not A_ID", i1, 4); assert(A_TYPEG(i2) == A_ID, "inline_hlocalizebnds: not A_ID", i2, 4); - assert(dim >= 0 && dim <= 7, "inline_hlocalizebnds: illegal dim", dim, 4); + assert(is_legal_numdim(dim), "inline_hlocalizebnds: illegal dim", dim, 4); /* AOCC */ /* find array lower and upper bound */ lb = mk_default_int(lb); @@ -1756,7 +1762,7 @@ pointer_squeezer(int ast) int dtype; int asd; int numdim; - int subs[7]; + int subs[MAXSUBS]; /* AOCC */ int arg; int argt; int argcnt; @@ -1851,7 +1857,7 @@ pointer_squeezer(int ast) } break; } - assert(numdim > 0 && numdim <= 7, "pointer_squeezer: bad numdim", ast, 4); + assert(is_legal_numdim(numdim), "pointer_squeezer: bad numdim", ast, 4); /* AOCC */ for (i = 0; i < numdim; ++i) { int t; l = pointer_squeezer((int)ASD_SUBS(asd, i)); diff --git a/tools/flang1/flang1exe/commopt.c b/tools/flang1/flang1exe/commopt.c index a0592fd6de..895e99e5ce 100644 --- a/tools/flang1/flang1exe/commopt.c +++ b/tools/flang1/flang1exe/commopt.c @@ -5,6 +5,13 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified: Jan 2021 + */ + /** \file \brief Fortran communications optimizer module @@ -437,7 +444,7 @@ fuse_forall(int nested) static LOGICAL is_same_idx(int std, int std1) { - int idx[7], idx1[7]; + int idx[MAXSUBS], idx1[MAXSUBS]; /* AOCC */ int list, list1, listp; int forall, forall1; int nidx, nidx1; @@ -479,7 +486,7 @@ is_same_idx(int std, int std1) LOGICAL same_forall_size(int lp1, int lp2, int nested) { - int idx1[7], idx2[7]; + int idx1[MAXSUBS], idx2[MAXSUBS]; /* AOCC */ int itriple1, itriple2; int lb1, ub1, st1; int lb2, ub2, st2; @@ -492,7 +499,7 @@ same_forall_size(int lp1, int lp2, int nested) int i, k; int asd1, asd2; int ndim1, ndim2; - int order2[7]; + int order2[MAXSUBS]; /* AOCC */ int no; int lhs1, lhs2, newlhs2, l, l2; int sptr1, sptr2; @@ -568,7 +575,7 @@ same_forall_size(int lp1, int lp2, int nested) static LOGICAL same_forall_bnds(int lp1, int lp2, int nested) { - int idx1[7], idx2[7]; + int idx1[MAXSUBS], idx2[MAXSUBS]; /* AOCC */ int itriple1, itriple2; int lb1, ub1, st1; int lb2, ub2, st2; @@ -581,7 +588,7 @@ same_forall_bnds(int lp1, int lp2, int nested) int i, k; int asd1, asd2; int ndim1, ndim2; - int order2[7]; + int order2[MAXSUBS]; /* AOCC */ int no; int lhs1, lhs2, newlhs2, l, l2; int sptr1, sptr2; @@ -995,7 +1002,7 @@ is_fusable(int lp, int lp1, int nested) int fuselp; int oldast, newast; int triple; - int idx[7]; + int idx[MAXSUBS]; /* AOCC */ int cnt; LOGICAL fuse_cnst_rhs; @@ -1249,6 +1256,25 @@ smp_conflict(int fg1, int fg2) } } + // AOCC Begin + // do not fuse the loops which are offload targets + if (flg.omptarget) { + for (fg = fg1; fg != fg2; fg = FG_LNEXT(fg)) { + rdilts(fg); + for (std = FG_STDFIRST(fg); std; std = STD_NEXT(std)) { + ast = STD_AST(std); + switch (A_TYPEG(ast)) { + case A_MP_TARGET: + case A_MP_MAP: + case A_MP_EMAP: + wrilts(fg); + return TRUE; + } + } + wrilts(fg); + } + } + // AOCC End return FALSE; } @@ -2348,7 +2374,7 @@ eliminate_shift(int lp, int lp1, int rt_std, int rt1_std) int sptr, sptr1; int v, v1, cv, cv1, ns, ns1; int nmax, pmax; - int sub[7]; + int sub[MAXSUBS]; /* AOCC */ int new; if (XBIT(47, 0x100000)) @@ -2955,6 +2981,10 @@ alloc2ast(void) void optimize_alloc(void) { + // AOCC Begin + if (flg.amdgcn_target) + return; + // AOCC End comm_optimize_init(); flowgraph(); /* build the flowgraph for the function */ postdominators(); /* need these as well */ @@ -2988,7 +3018,7 @@ opt_allocate(void) int i; int ndim; int stdnext; - int sub[MAXSUBS]; + int sub[MAXSUBS]; /* AOCC */ LITEMF *defs_to_propagate = clist(); LITEMF *shape_exceptions = clist(); /* don't propagate into these shapes */ @@ -3608,7 +3638,7 @@ static void forall_make_same_idx(int std) { - int idx[7]; + int idx[MAXSUBS]; /* AOCC */ int list, list1, listp; int forall; int nidx; @@ -3631,7 +3661,7 @@ forall_make_same_idx(int std) idx[nidx] = listp; nidx++; } - assert(nidx <= 7, "make_same_idx: illegal forall", 2, forall); + assert(nidx <= get_legal_maxdim(), "make_same_idx: illegal forall", 2, forall); /* AOCC */ /* if it is already changed, don't do any thing */ cnt = 0; diff --git a/tools/flang1/flang1exe/commopt.h b/tools/flang1/flang1exe/commopt.h index d6ae481424..53179d3670 100644 --- a/tools/flang1/flang1exe/commopt.h +++ b/tools/flang1/flang1exe/commopt.h @@ -16,19 +16,21 @@ typedef struct { int ifast; int endifast; LITEMF *inner_cyclic; - int c_lof[7]; - int idx[7]; - int cb_init[7]; /* cyclic_block initilization asts */ - int cb_do[7]; - int cb_block[7]; - int cb_inc[7]; - int cb_enddo[7]; + // AOCC begin + int c_lof[MAXSUBS]; + int idx[MAXSUBS]; + int cb_init[MAXSUBS]; /* cyclic_block initilization asts */ + int cb_do[MAXSUBS]; + int cb_block[MAXSUBS]; + int cb_inc[MAXSUBS]; + int cb_enddo[MAXSUBS]; - int c_init[7]; /* cyclic initilization asts */ - int c_inc[7]; - int c_dupl[7]; - int c_idx[7]; - int c_dstt[7]; + int c_init[MAXSUBS]; /* cyclic initilization asts */ + int c_inc[MAXSUBS]; + int c_dupl[MAXSUBS]; + int c_idx[MAXSUBS]; + int c_dstt[MAXSUBS]; + // AOCC end } CTYPE; typedef union { @@ -70,9 +72,11 @@ typedef union { int sectvsub; int sectnvsub; int sectm; - int sectv[7]; - int v[7]; - int permute[7]; + // AOCC begin + int sectv[MAXSUBS]; + int v[MAXSUBS]; + int permute[MAXSUBS]; + // AOCC end int vflag; int pflag; int vdim; @@ -155,9 +159,11 @@ typedef union { int nsget; LITEMF *sget; CTYPE *cyclic; - int fuselp[7][MAXFUSE]; - int fusedstd[7][MAXFUSE]; - int nfuse[7]; + // AOCC begin + int fuselp[MAXSUBS][MAXFUSE]; + int fusedstd[MAXSUBS][MAXFUSE]; + int nfuse[MAXSUBS]; + // AOCC end int header; int barr1; int barr2; diff --git a/tools/flang1/flang1exe/dinit.c b/tools/flang1/flang1exe/dinit.c index 2c0c645944..eb2a068924 100644 --- a/tools/flang1/flang1exe/dinit.c +++ b/tools/flang1/flang1exe/dinit.c @@ -5,6 +5,15 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ + /** \file \brief Process data initialization statements. Called by semant. @@ -603,6 +612,9 @@ setConval(int sptr, int conval, int op) case AC_LOR: val |= conval; break; + case AC_LXOR: // AOCC + val ^= conval; + break; case AC_LAND: val &= conval; break; @@ -640,10 +652,11 @@ setConval(int sptr, int conval, int op) static void process_real_kind(int sptr, ACL *ict, int op) { - int ast, con1, conval; + int ast, con1, conval, p, r; ast = ict->u1.ast; - conval = 0; + conval = 4; + p = 0, r = 0; // AOCC if (A_TYPEG(ast) == A_CNST) { con1 = A_SPTRG(ast); @@ -652,10 +665,12 @@ process_real_kind(int sptr, ACL *ict, int op) conval = 4; else if (con1 <= 15) conval = 8; - else if (con1 <= 31 && !XBIT(57, 4)) + else if (con1 <= 31 && (!XBIT(57, 0x4))) conval = 16; - else + else { conval = -1; + p = -1; + } } ict = ict->next; @@ -668,35 +683,75 @@ process_real_kind(int sptr, ACL *ict, int op) if (XBIT(49, 0x40000)) { /* Cray C90 */ if (con1 <= 37) { - if (conval > 0 && conval < 4) + if (conval > 0 && conval <= 4) conval = 4; } else if (con1 <= 2465) { - if (conval > 0 && conval < 8) + if (conval > 0 && conval <= 8) conval = 8; } else { if (conval > 0) conval = 0; - conval -= 2; + conval = -2; + r = -2; } } else { /* ANSI */ if (con1 <= 37) { - if (conval > 0 && conval < 4) + if (conval > 0 && conval <= 4) conval = 4; } else if (con1 <= 307) { - if (conval > 0 && conval < 8) + if (conval > 0 && conval <= 8) conval = 8; - } else if (con1 <= 4931 && !XBIT(57, 4)) { - if (conval > 0 && conval < 16) + } else if ((con1 <= 4931) && (!XBIT(57, 0x4))) { + if (conval > 0 && conval <= 16) conval = 16; } else { if (conval > 0) conval = 0; - conval -= 2; + conval = -2; + r = -2; } } } } + // AOCC begin + ict = ict->next; + if (ict) { + ast = ict->u1.ast; + + if (A_TYPEG(ast) == A_CNST) { + con1 = A_SPTRG(ast); + con1 = CONVAL2G(con1); + if (XBIT(49, 0x40000)) { + /* Cray C90 */ + if (con1 == 2) { + if (conval > 0 && conval <= 4) + conval = 4; + else if (conval > 0 && conval <= 8) + conval = 8; + else if (p < 0 && r < 0) + conval = -3; + } + else if (con1 != 2) + conval = -5; + } else { + /* ANSI */ + if (con1 == 2 || con1 == 0) { + if (conval > 0 && conval <= 4) + conval = 4; + else if (conval > 0 && conval <= 8) + conval = 8; + else if (conval > 0 && conval <= 16) + conval = 16; + else if (p < 0 && r < 0) + conval = -3; + } + else if (con1 != 2) + conval = -5; + } + } + } + // AOCC end if (conval) { setConval(sptr, conval, op); } @@ -720,6 +775,7 @@ dinit_acl_val2(int sptr, int dtype, ACL *ict, int op) case AC_DIV: case AC_EXP: case AC_LOR: + case AC_LXOR: // AOCC case AC_LAND: case AC_LEQV: case AC_LNEQV: @@ -771,7 +827,6 @@ dinit_acl_val2(int sptr, int dtype, ACL *ict, int op) case AC_I_selected_real_kind: process_real_kind(sptr, subict, op); break; - } case AC_I_selected_char_kind: ast = subict->u1.ast; if (A_TYPEG(ast) == A_CNST) { @@ -785,11 +840,9 @@ dinit_acl_val2(int sptr, int dtype, ACL *ict, int op) } setConval(sptr, conval, op); break; - default: - error(155, 3, gbl.lineno, - "Invalid initialization of kind type parameter", SYMNAME(sptr)); } } + } dinit_intr_call(sptr, dtype, ict); break; } @@ -1306,6 +1359,9 @@ ac_opname(int id) case AC_LOR: strcpy(bf, "LOR"); break; + case AC_LXOR: // AOCC + strcpy(bf, "XOR"); + break; case AC_LAND: strcpy(bf, "LAND"); break; diff --git a/tools/flang1/flang1exe/dpm_out.c b/tools/flang1/flang1exe/dpm_out.c index 5d5612dc21..c02e38692b 100644 --- a/tools/flang1/flang1exe/dpm_out.c +++ b/tools/flang1/flang1exe/dpm_out.c @@ -5,6 +5,14 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Month of Modification: November 2019 + * + */ + /** \file \brief Fortran data partitioning module, output. @@ -69,7 +77,7 @@ static void do_change_mk_id(void); static void finish_fl(void); static void add_fl(int); -static void emit_alnd(int sptr, int memberast, LOGICAL free_flag, +static bool emit_alnd(int sptr, int memberast, LOGICAL free_flag, LOGICAL for_allocate, int allocbounds); static void emit_secd(int sptr, int memberast, LOGICAL free_flag, LOGICAL for_allocate); @@ -932,7 +940,8 @@ make_secd_for_members(int dtype) LOGICAL want_descriptor_anyway(int sptr) { - if (gbl.internal == 1) { + // AOCC added check for function results + if (gbl.internal == 1 || RESULTG(sptr)) { int dtype; dtype = DTYPEG(sptr); if (DTY(dtype) != TY_ARRAY) @@ -945,7 +954,7 @@ want_descriptor_anyway(int sptr) if (ALLOCG(sptr)) return TRUE; } - if (flg.debug && !XBIT(123, 0x400) && !HCCSYMG(sptr) && !CCSYMG(sptr)) { + if (flg.debug && (!XBIT(123, 0x400) && !HCCSYMG(sptr) && !CCSYMG(sptr))) { /* only need non-fixed bounds */ int dtype; dtype = DTYPEG(sptr); @@ -1270,6 +1279,12 @@ wrap_symbol(int sptr, int memberast, int basesptr) case TY_ARRAY: /* if an unused symbol from the containing routine, skip it */ if (gbl.internal > 1 && !INTERNALG(sptr)) { + // AOCC BEGIN + // Do not assume that the array descriptor is initialized + // for the derived type members. + if (STYPEG(sptr) == ST_MEMBER) + SDSCINITP(DESCRG(sptr),0); + // AOCC END if (DESCRG(sptr) && SDSCINITG(DESCRG(sptr)) && (arrd = SECDSCG(DESCRG(sptr))) && SCOPEG(arrd) == SCOPEG(sptr) && STYPEG(SCOPEG(sptr)) != ST_MODULE) { @@ -1283,7 +1298,11 @@ wrap_symbol(int sptr, int memberast, int basesptr) SCOPEG(arrd) == SCOPEG(gbl.currsub) && STYPEG(SCOPEG(sptr)) == ST_MODULE) { change_mk_id(DESCRG(sptr), arrd); - return; + // AOCC BEGIN + // Derived type members still need to be initialized. + if (STYPEG(sptr) != ST_MEMBER) + // AOCC END + return; } } /* if a variable or array, this was handled by allocate_one_auto */ @@ -1297,7 +1316,7 @@ wrap_symbol(int sptr, int memberast, int basesptr) if (!POINTERG(sptr) && !ALLOCG(sptr) && alloc && (ADJARRG(sptr) || RUNTIMEG(sptr) || ADJLENG(sptr))) { if (!ALIGNG(sptr) && !POINTERG(sptr)) { - int ast, i, ndim, subscr[7]; + int ast, i, ndim, subscr[MAXSUBS]; // AOCC /* make the subscripts */ ndim = ADD_NUMDIM(dtype); for (i = 0; i < ndim; ++i) { @@ -1748,10 +1767,11 @@ void emit_alnd_secd(int sptr, int memberast, LOGICAL free_flag, int std, int allocbounds) { - int alnd, secd; + int alnd, secd, ast; int old_desc, old_desc1; int savefreeing; int saveEntryStd, saveExitStd; + bool tmplcall; if (free_flag) { init_change_mk_id(); @@ -1767,6 +1787,18 @@ emit_alnd_secd(int sptr, int memberast, LOGICAL free_flag, int std, else old_desc = 0; alnd = make_alnd(sptr); + /* Copy the type length of a string array pointer from a target string + array during pointer association. */ + ast = STD_AST(std); + if (A_TYPEG(ast) == A_ICALL && A_OPTYPEG(ast) == I_PTR2_ASSIGN && + POINTERG(sptr)) { + int target_ast, dtype; + target_ast = ARGT_ARG(A_ARGSG(ast), 1); + dtype = A_DTYPEG(target_ast); + if (DTY(dtype) == TY_ARRAY && DTY(DTY(dtype + 1)) == TY_CHAR) { + TMPL_FLAG(alnd) = string_length(DTY(dtype + 1)); + } + } ALNDP(DESCRG(sptr), alnd); if (alnd) { if (SECDSCG(DESCRG(sptr))) @@ -1779,7 +1811,31 @@ emit_alnd_secd(int sptr, int memberast, LOGICAL free_flag, int std, } if (free_flag) ast_visit(1, 1); - emit_alnd(sptr, memberast, free_flag, TRUE, allocbounds); + tmplcall = emit_alnd(sptr, memberast, free_flag, TRUE, allocbounds); + /* Copy the type length of a string array pointer from a target string + array during pointer association. */ + ast = STD_AST(std); + if (XBIT(57, 0x200000) && A_TYPEG(ast) == A_ICALL && + A_OPTYPEG(ast) == I_PTR2_ASSIGN && POINTERG(sptr)) { + int target_ast, dtype; + target_ast = ARGT_ARG(A_ARGSG(ast), 1); + dtype = A_DTYPEG(target_ast); + if (DTY(dtype) == TY_ARRAY && DTY(DTY(dtype + 1)) == TY_CHAR) { + /* The 5th argument to RTE_template is the type length. Pass the length + if known, otherwise pass the result of a run-time LEN() call. */ + assert(tmplcall, "emit_alnd_secd: expected template call", 0, ERR_Fatal); + if (string_length(DTY(dtype + 1)) != 0) { + ARGT_ARG(A_ARGSG(STD_AST(STD_PREV(std))), 4) = + mk_isz_cval(string_length(DTY(dtype + 1)), astb.bnd.dtype); + } else { + int sizeAst; + sizeAst = sym_mkfunc_nodesc(mkRteRtnNm(RTE_lena), astb.bnd.dtype); + sizeAst = begin_call(A_FUNC, sizeAst, 1); + add_arg(target_ast); + ARGT_ARG(A_ARGSG(STD_AST(STD_PREV(std))), 4) = sizeAst; + } + } + } if (free_flag) ast_unvisit(); /* Added second condition to `if' below. @@ -2209,7 +2265,7 @@ set_type_in_descriptor(int descriptor_ast, int sptr, DTYPE dtype0, * { __INT4_T *lb, * [ __INT4_T *ub, ] }* */ -static void +static bool emit_alnd(int sptr, int memberast, LOGICAL free_flag, LOGICAL for_allocate, int allocbounds) { @@ -2223,13 +2279,13 @@ emit_alnd(int sptr, int memberast, LOGICAL free_flag, LOGICAL for_allocate, int entryStd = EntryStd; if (is_bad_dtype(DTYPEG(sptr))) - return; + return false; if (NODESCG(sptr)) - return; + return false; if (!DESCUSEDG(sptr)) - return; + return false; if (normalize_bounds(sptr) && SCG(sptr) == SC_DUMMY && !SEQG(sptr)) { - return; + return false; } arrdsc = DESCRG(sptr); @@ -2253,10 +2309,10 @@ emit_alnd(int sptr, int memberast, LOGICAL free_flag, LOGICAL for_allocate, /* don't have to initialize descriptors for host subprogram symbols */ if (SDSCINITG(arrdsc) && !realign && !redistribute && !for_allocate && gbl.internal > 1 && !INTERNALG(descr) && stype != ST_MEMBER) - return; + return false; if (VISITG(descr)) - return; + return false; VISITP(descr, 1); /* don't call recursively pghpf_realign and pghpf_redistribute */ @@ -2284,6 +2340,7 @@ emit_alnd(int sptr, int memberast, LOGICAL free_flag, LOGICAL for_allocate, argt = mk_argt(nargs); ARGT_ARG(argt, cargs++) = check_member(memberast, mk_id(TMPL_DESCR(alnd))); ARGT_ARG(argt, cargs++) = mk_isz_cval(TMPL_RANK(alnd), astb.bnd.dtype); + ARGT_ARG(argt, cargs++) = mk_isz_cval(TMPL_FLAG(alnd), astb.bnd.dtype); if (XBIT(57, 0x200000)) { /* leave room for kind/len */ ARGT_ARG(argt, cargs++) = mk_isz_cval(0, astb.bnd.dtype); ARGT_ARG(argt, cargs++) = mk_isz_cval(0, astb.bnd.dtype); @@ -2322,6 +2379,8 @@ emit_alnd(int sptr, int memberast, LOGICAL free_flag, LOGICAL for_allocate, if (STYPEG(sptr) == ST_MEMBER) set_type_in_descriptor(check_member(memberast, mk_id(TMPL_DESCR(alnd))), sptr, typed_alloc, 0 /* no parent AST */, entryStd); + + return true; } void @@ -2396,8 +2455,7 @@ fill_argt_with_alnd(int sptr, int memberast, int argt, int alnd, int j, } } } - ARGT_ARG(argt, j) = mk_isz_cval(TMPL_FLAG(alnd), astb.bnd.dtype); - j++; + if (TMPL_DIST_TARGET_DESCR(alnd)) { ARGT_ARG(argt, j) = check_member( memberast, ast_rewrite(mk_id(TMPL_DIST_TARGET_DESCR(alnd)))); @@ -3140,6 +3198,10 @@ emit_kopy_in(int arg, int this_entry, int actual) srcAst = check_member(actual, mk_id(newarg)); + flag = TMPL_FLAG(alnd); + flag |= __NO_OVERLAPS; + TMPL_FLAG(alnd) = flag; + ARGT_ARG(argt, 0) = pointerAst; ARGT_ARG(argt, 1) = offsetAst; ARGT_ARG(argt, 2) = baseAst; @@ -3149,11 +3211,9 @@ emit_kopy_in(int arg, int this_entry, int actual) ARGT_ARG(argt, 6) = mk_cval(TMPL_RANK(alnd), DT_INT); ARGT_ARG(argt, 7) = mk_cval(dtype_to_arg(dtype), DT_INT); ARGT_ARG(argt, 8) = size_of_dtype(dtype, arg, 0); + ARGT_ARG(argt, 9) = mk_isz_cval(flag, astb.bnd.dtype); - flag = TMPL_FLAG(alnd); - flag |= __NO_OVERLAPS; - TMPL_FLAG(alnd) = flag; - nargs = fill_argt_with_alnd(arg, 0, argt, alnd, 9, 0, 0); + nargs = fill_argt_with_alnd(arg, 0, argt, alnd, 10, 0, 0); if (TMPL_TYPE(alnd) != REPLICATED && !is_set(flag, __NO_OVERLAPS)) { collapse = TMPL_COLLAPSE(alnd) | TMPL_ISSTAR(alnd); @@ -3645,7 +3705,7 @@ make_sec_from_ast_chk(int ast, int std, int stdafter, int sec_ast, int sectflag, int triple; int sptr, fsptr; int shape; - int subs[7]; + int subs[MAXSUBS]; // AOCC LOGICAL rhs_is_dist; int bogus; int strd1_cnt; @@ -4348,7 +4408,7 @@ allocate_one_auto(int sptr) if (!ALIGNG(sptr) ) { ADSC *ad; - int r, i, ast, subscr[7]; + int r, i, ast, subscr[MAXSUBS]; // AOCC ad = AD_DPTR(DTYPEG(sptr)); /* make the subscripts */ r = AD_NUMDIM(ad); @@ -4446,7 +4506,7 @@ get_allobnds(int sptr, int ast) { int i; int ndim; - int subs[7]; + int subs[MAXSUBS]; // AOCC int lb, ub; int arrdsc; int sdsc; diff --git a/tools/flang1/flang1exe/dtypeutl.c b/tools/flang1/flang1exe/dtypeutl.c index 9989ea8c96..3e7560f513 100644 --- a/tools/flang1/flang1exe/dtypeutl.c +++ b/tools/flang1/flang1exe/dtypeutl.c @@ -5,6 +5,17 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + * Support for assumed size array as parameter + * Date of modification 9th June 2020 + */ + /** \file \brief Fortran data type utility functions. @@ -2242,6 +2253,9 @@ getop(int op, char *string) case OP_LOR: s = ".or."; break; + case OP_LXOR: // AOCC + s = ".xor."; + break; case OP_LAND: s = ".and."; break; @@ -2534,7 +2548,7 @@ getdtype(DTYPE dtype, char *ptr) } else { ad = AD_DPTR(dtype); numdim = AD_NUMDIM(ad); - if (numdim < 1 || numdim > 7) { + if (!is_legal_numdim(numdim)) { /* AOCC */ sprintf(p, "ndim=%d", numdim); numdim = 0; p += strlen(p); @@ -2787,7 +2801,7 @@ _dmp_dent(DTYPE dtypeind, FILE *outfile) fprintf(outfile, " assumrank:%d\n", AD_ASSUMRANK(ad)); fprintf(outfile, " zbase: %d numelm: %d\n", AD_ZBASE(ad), AD_NUMELM(ad)); - if (numdim < 1 || numdim > 7) + if (!is_legal_numdim(numdim)) /* AOCC */ numdim = 0; for (i = 0; i < numdim; i++) fprintf(outfile, " %1d: mlpyr: %d lwbd: %d upbd: %d" @@ -2917,6 +2931,7 @@ scale_of(DTYPE dtype, INT *size) case TY_BINT: case TY_BLOG: case TY_DBLE: + case TY_QUAD: // AOCC case TY_CMPLX: case TY_DCMPLX: case TY_QCMPLX: @@ -3415,7 +3430,7 @@ typedef enum { __REAL2 = 45, /* F real*2, half */ __REAL4 = 27, /* F real*4, real */ __REAL8 = 28, /* F real*8, double precision */ - __REAL16 = 29, /* F real*16 */ + __REAL16 = 29, /* F real*16 quad precision */ __CPLX32 = 30, /* F complex*32 (2x real*16) */ __WORD16 = 31, /* F quad typeless */ __INT1 = 32, /* F byte (integer*1) */ diff --git a/tools/flang1/flang1exe/dtypeutl.h b/tools/flang1/flang1exe/dtypeutl.h index 1e93cf8857..1b05091766 100644 --- a/tools/flang1/flang1exe/dtypeutl.h +++ b/tools/flang1/flang1exe/dtypeutl.h @@ -4,6 +4,12 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified: May 2020 + */ /** \file diff --git a/tools/flang1/flang1exe/dump.c b/tools/flang1/flang1exe/dump.c index 3a52649b5a..b1a5912712 100644 --- a/tools/flang1/flang1exe/dump.c +++ b/tools/flang1/flang1exe/dump.c @@ -4,6 +4,16 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading + * Date of modification 12th February 2020 + * Date of modification 04th April 2020 + * Added support for quad precision + * Last modified: Feb 2020 + */ /** \file dump.c @@ -1684,6 +1694,8 @@ dastreex(int astx, int l, int notlast) case A_MP_EREDUCTION: case A_MP_BREDUCTION: case A_MP_REDUCTIONITEM: + case A_MP_DEFAULTMAP: // AOCC + case A_MP_TARGETDECLARE: // AOCC break; default: fprintf(gbl.dbgfil, "NO DUMP AVL"); @@ -1926,6 +1938,15 @@ printname(int sptr) break; case TY_QUAD: + // AOCC begin + num[0] = CONVAL1G(sptr); + num[1] = CONVAL2G(sptr); + num[2] = CONVAL3G(sptr); + num[3] = CONVAL4G(sptr); + cprintf(b, "%.37Lf", num); + break; + // AOCC end + case TY_DBLE: num[0] = CONVAL1G(sptr); num[1] = CONVAL2G(sptr); @@ -4310,7 +4331,7 @@ dumpdt(int dt) putbit("nobounds", ADD_NOBOUNDS(dt)); putast("zbase", ADD_ZBASE(dt)); putast("numelm", ADD_NUMELM(dt)); - if (numdim < 1 || numdim > 7) { + if (!is_legal_numdim(numdim)) { // AOCC numdim = 0; } for (i = 0; i < numdim; ++i) { diff --git a/tools/flang1/flang1exe/exterf.c b/tools/flang1/flang1exe/exterf.c index 140ebc23e0..1d0d8e18f4 100644 --- a/tools/flang1/flang1exe/exterf.c +++ b/tools/flang1/flang1exe/exterf.c @@ -5,6 +5,11 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ + /** \file \brief Routines for exporting symbols to .mod files and to IPA. */ @@ -89,7 +94,7 @@ static LOGICAL for_contained = FALSE; static LOGICAL exporting_module = FALSE; static lzhandle *outlz; static int exportmode = 0; -#define MAX_FNAME_LEN 258 +#define MAX_FNAME_LEN 4096 static int out_platform = MOD_ANY; @@ -366,13 +371,17 @@ static void export(FILE *export_fd, char *export_name, int cleanup) if (!IGNOREG(sptr) && SCOPEG(sptr) == sym_module) { queue_symbol(sptr); } + if (SCG(sptr) == SC_DUMMY && SCOPEG(SCOPEG(sptr)) != sym_module && + TBP_BOUND_TO_SMPG(sptr)) { + queue_symbol(sptr); + } } break; case ST_IDENT: if (for_module) { if (SCG(sptr) == SC_DUMMY && SCOPEG(SCOPEG(sptr)) != sym_module && - TBP_BOUND_TO_SMPG(SCOPEG(sptr))) { - queue_symbol(sptr); + TBP_BOUND_TO_SMPG(sptr)) { + queue_symbol(sptr); } } break; diff --git a/tools/flang1/flang1exe/extern.h b/tools/flang1/flang1exe/extern.h index 3b9b107100..9a568e859d 100644 --- a/tools/flang1/flang1exe/extern.h +++ b/tools/flang1/flang1exe/extern.h @@ -252,3 +252,12 @@ struct pure_gbl { }; extern struct pure_gbl pure_gbl; + +struct collapse_loop { + int distributed_loop; + int instruction_range_start; + int instruction_range_end; + int parallel_loop; +}; + +extern struct collapse_loop collapse_loop; diff --git a/tools/flang1/flang1exe/fenddf.c b/tools/flang1/flang1exe/fenddf.c index 80a9331ecf..b0ac7a3662 100644 --- a/tools/flang1/flang1exe/fenddf.c +++ b/tools/flang1/flang1exe/fenddf.c @@ -4,6 +4,17 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading + * + * Added support for quad precision + * Last modified: Feb 2020 + * Last Modified: Jun 2020 + * + */ /** \file \brief Data definitions for Fortran front-end data structures. @@ -53,11 +64,11 @@ INT cast_types[NTYPE][2][2] = { /* DT_REAL2 */ {{1, 1}, {1, 1}}, /* DT_REAL */ {{1, 1}, {1, 1}}, /* DT_DBLE */ {{1, 1}, {1, 1}}, - /* DT_QUAD */ {{-1, -1}, {-1, -1}}, + /* DT_QUAD */ {{1, 1}, {1, 1}}, // AOCC /* DT_CMPLX4 */ {{-1, -1}, {1, -1}}, /* DT_CMPLX */ {{-1, -1}, {1, -1}}, /* DT_DCMPLX */ {{-1, -1}, {1, -1}}, - /* DT_QCMPLX */ {{-1, -1}, {-1, -1}}, + /* DT_QCMPLX */ {{-1, -1}, {1, -1}}, /* DT_BLOG */ {{1, 1}, {1, 1}}, /* DT_SLOG */ {{1, 1}, {1, 1}}, /* DT_LOG */ {{1, 1}, {1, 1}}, diff --git a/tools/flang1/flang1exe/fgraph.c b/tools/flang1/flang1exe/fgraph.c index dd2c9b5b90..33419dc9e4 100644 --- a/tools/flang1/flang1exe/fgraph.c +++ b/tools/flang1/flang1exe/fgraph.c @@ -4,6 +4,13 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + */ /** \file @@ -353,6 +360,7 @@ flowgraph(void) break; case TY_REAL: case TY_DBLE: + case TY_QUAD: // AOCC /* don't check non-integer do loops */ default: break; diff --git a/tools/flang1/flang1exe/flgdf.h b/tools/flang1/flang1exe/flgdf.h index b0903573da..8d78d119e8 100644 --- a/tools/flang1/flang1exe/flgdf.h +++ b/tools/flang1/flang1exe/flgdf.h @@ -4,6 +4,12 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified: May 2020 + */ /* flgdf.h - data definitions for FTN compiler flags */ @@ -46,6 +52,7 @@ FLG flg = { FALSE, /* not terse for summary, etc. */ '_', /* default is to change '$' to '_' */ {0}, /* x flags */ + {0}, /* z flags */ FALSE, /* don't quad align "unconstrained objects" ; use natural alignment */ FALSE, /* anno - default to no annotation of .s files */ diff --git a/tools/flang1/flang1exe/flow.c b/tools/flang1/flang1exe/flow.c index f0845c58d3..cd1a51316f 100644 --- a/tools/flang1/flang1exe/flow.c +++ b/tools/flang1/flang1exe/flow.c @@ -5,6 +5,21 @@ * */ +/* + * + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading + * Support for DNORM intrinsic + * + * Date of Modification: 21st February 2019 + * + * Support for parity and bit transformational intrinsic iparity, iany, iall + * Date of Modification: July 2019 + * + */ + /** \file \brief Optimizer submodule responsible for performing flow analysis @@ -683,6 +698,10 @@ bld_ud(int ast, int *dummy) switch (A_OPTYPEG(ast)) { case I_ALL: case I_ANY: + case I_IALL: // AOCC + case I_IANY: // AOCC + case I_IPARITY: // AOCC + case I_PARITY: // AOCC case I_COUNT: case I_PRODUCT: case I_SUM: @@ -690,6 +709,9 @@ bld_ud(int ast, int *dummy) case I_MAXVAL: case I_MINVAL: case I_CSHIFT: + // AOCC Begin + case I_NORM2: + // AOCC Begin case I_DOT_PRODUCT: case I_EOSHIFT: case I_MAXLOC: @@ -1774,7 +1796,7 @@ new_storeitem(int nme) int store; store = opt.storeb.stg_avail++; - if (store > 32767) + if (store > 32767 * 4 ) // AOCC increasing limit error(7, 4, 0, CNULL, CNULL); OPT_NEED(opt.storeb, STORE, 100); STORE_TYPE(store) = 0; @@ -2737,7 +2759,7 @@ const_prop(void) Q_ITEM *q; int dvl; - if (XBIT(6, 0x1)) + if (true || XBIT(6, 0x1)) // AOCC return FALSE; #if DEBUG if (OPTDBG(9, 32768)) { diff --git a/tools/flang1/flang1exe/fpp.c b/tools/flang1/flang1exe/fpp.c index 23606fe5de..06abc9d604 100644 --- a/tools/flang1/flang1exe/fpp.c +++ b/tools/flang1/flang1exe/fpp.c @@ -186,7 +186,7 @@ static char ctable[256] = { #define FORMALMAX 31 #define ARGST 0xFE /* * * * * MAX_FNAME_LEN MUST be less than scan.c:CARDB_SIZE * * * * */ -#define MAX_FNAME_LEN 258 +#define MAX_FNAME_LEN 4096 #define MAXINC 20 #define MACSTK_MAX 100 diff --git a/tools/flang1/flang1exe/func.c b/tools/flang1/flang1exe/func.c index 77632cfefe..c9c155fc90 100644 --- a/tools/flang1/flang1exe/func.c +++ b/tools/flang1/flang1exe/func.c @@ -5,6 +5,56 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Implemented the minloc/maxloc inlining support + * Date of Modification: August 2018 + * + * Support for DNORM intrinsic + * Date of Modification: 21st February 2019 + * + * Support for array expression in norm2 + * Date of Modification: 28th October 2019 + * + * Support for Bit Sequence Comparsion intrinsic + * Month of Modification: May 2019 + * + * Support for Bit Masking intrinsics. + * Month of Modification: May 2019 + * + * Support for Bit Shifting intrinsics. + * Month of Modification: June 2019 + * + * Support for MERGE_BITS intrinsic. + * Month of Modification: July 2019 + * + * Support for F2008 EXECUTE_COMMAND_LINE intrinsic subroutine. + * Month of Modification: July 2019 + * + * Support for Combined Bit Shifting intrinsic. + * Month of Modification: July 2019 + * + * Support for parity intrinsic. + * Month of Modification: July 2019 + * + * Support for Bit transformational intrinsic iany, iall, iparity. + * Month of Modification: July 2019 + * + * Changes to support AMDGPU OpenMP offloading + * Date of modification 12th February 2020 + * Date of modification 04th April 2020 + * + * Support for "nearest" intrinsic + * Last modified: Feb 2020 + * + * Last modified: Jun 2020 + * + * Support for CPU_TIME for real128 + * Last modified: Sept 2020 + */ + /** \file \brief rewrite function args, etc @@ -55,6 +105,9 @@ static int rewrite_sub_ast(int, int); static int mk_result_sptr(int, int, int *, int, int, int *); static LOGICAL take_out_user_def_func(int); static int matmul(int, int, int); +// AOCC Begin +static int emit_norm2(int, int, int); +// AOOC End static int mmul(int, int, int); /* fast matmul */ static int reshape(int, int, int); static int _reshape(int, DTYPE, int); @@ -64,6 +117,8 @@ static int inline_reduction_craft(int, int, int); static void nop_dealloc(int, int); static void handle_shift(int s); +static LOGICAL contains_any_call(int astx); + /*------ Argument & Expression Rewriting ----------*/ int @@ -1836,6 +1891,10 @@ rewrite_func_ast(int func_ast, int func_args, int lhs) return -1; case I_NULLIFY: return -1; + /* AOCC begin */ + case I_MM_PREFETCH: + return -1; + /* AOCC end */ #ifdef I_C_F_POINTER case I_C_F_POINTER: transform_c_f_pointer(func_ast, func_args); @@ -1864,6 +1923,165 @@ rewrite_func_ast(int func_ast, int func_args, int lhs) * is just a function call */ goto ret_norm; + + /* AOCC begin */ + case I_BGE: + case I_BGT: + case I_BLE: + case I_BLT: { + FtnRtlEnum bitcmp_rtlRtn = RTE_bitcmp; + + char *bitcmp_name = mkRteRtnNm(bitcmp_rtlRtn); + int bitcmp_sptr = sym_mkfunc(bitcmp_name, DT_INT); + + int bitcmp_argt = mk_argt(4); + + ARGT_ARG(bitcmp_argt, 0) = ARGT_ARG(func_args, 0); + ARGT_ARG(bitcmp_argt, 1) = ARGT_ARG(func_args, 1); + + int bits_in_arg0 = bits_in(A_DTYPEG(ARGT_ARG(bitcmp_argt, 0))); + int bits_in_arg1 = bits_in(A_DTYPEG(ARGT_ARG(bitcmp_argt, 1))); + ARGT_ARG(bitcmp_argt, 2) = mk_cval1(bits_in_arg0, DT_INT); + ARGT_ARG(bitcmp_argt, 3) = mk_cval1(bits_in_arg1, DT_INT); + + int bitcmp_func = mk_func_node(A_FUNC, mk_id(bitcmp_sptr), 4, bitcmp_argt); + A_OPTYPEP(bitcmp_func, A_OPTYPEG(func_ast)); + + int bitcmp_temp_result = mk_id(sym_get_scalar("bitcmp_tmp", "i", DT_INT)); + int bitcmp_assign = mk_assn_stmt(bitcmp_temp_result, bitcmp_func, DT_INT); + add_stmt_before(bitcmp_assign, arg_gbl.std); + + int ret_ast; + switch (optype) { + case I_BGE: + return mk_binop(OP_GE, bitcmp_temp_result, mk_cnst(stb.i0), DT_INT); + case I_BGT: + return mk_binop(OP_GT, bitcmp_temp_result, mk_cnst(stb.i0), DT_INT); + case I_BLE: + return mk_binop(OP_LE, bitcmp_temp_result, mk_cnst(stb.i0), DT_INT); + case I_BLT: + return mk_binop(OP_LT, bitcmp_temp_result, mk_cnst(stb.i0), DT_INT); + } + } + + case I_MASKL: + case I_MASKR: { + FtnRtlEnum bitmask_rtlRtn = RTE_bitmask; + + nargs = 2; + if (ARGT_ARG(func_args, 1) == 0) { + nargs = 1; + } + + char *bitmask_name = mkRteRtnNm(bitmask_rtlRtn); + int bitmask_sptr = sym_mkfunc(bitmask_name, DT_INT8); + + /* set n */ + int bitmask_argt = mk_argt(3); + ARGT_ARG(bitmask_argt, 0) = ARGT_ARG(func_args, 0); + + /* if KIND argument */ + if (nargs == 2) { + ARGT_ARG(bitmask_argt, 1) = ARGT_ARG(func_args, 1); + } else { + ARGT_ARG(bitmask_argt, 1) = mk_cval1(4, DT_INT); + } + + /* set is_left */ + switch (optype) { + case I_MASKL: /* then set is_left as 1 */ + ARGT_ARG(bitmask_argt, 2) = mk_cval1(1, DT_INT); + break; + + case I_MASKR: /* else set is_left as 0 */ + ARGT_ARG(bitmask_argt, 2) = mk_cval1(0, DT_INT); + } + + int bitmask_func = mk_func_node(A_FUNC, mk_id(bitmask_sptr), 3, bitmask_argt); + A_OPTYPEP(bitmask_func, A_OPTYPEG(func_ast)); + + int bitmask_temp_result = mk_id(sym_get_scalar("bitmask_tmp", "i", DT_INT8)); + int bitmask_assign = mk_assn_stmt(bitmask_temp_result, bitmask_func, DT_INT8); + add_stmt_before(bitmask_assign, arg_gbl.std); + return bitmask_temp_result; + } + + case I_SHIFTL: { + int val = ARGT_ARG(func_args, 0); + int shift = ARGT_ARG(func_args, 1); + + int shift_func = ast_intr(I_ISHFT, A_DTYPEG(val), 2, val, shift); + return shift_func; + } + + case I_SHIFTR: { + int val = ARGT_ARG(func_args, 0); + int shift = ARGT_ARG(func_args, 1); + int negated_shift = mk_binop(OP_SUB, mk_cnst(stb.i0), shift, A_DTYPEG(shift)); + + int shift_func = ast_intr(I_ISHFT, A_DTYPEG(val), 2, val, negated_shift); + return shift_func; + } + + case I_MERGE_BITS: { + int i = ARGT_ARG(func_args, 0); + int j = ARGT_ARG(func_args, 1); + int mask = ARGT_ARG(func_args, 2); + + int not_mask = ast_intr(I_NOT, A_DTYPEG(mask), 1, mask); + int iand_i = ast_intr(I_IAND, A_DTYPEG(i), 2, i, mask); + int iand_j = ast_intr(I_IAND, A_DTYPEG(j), 2, j, not_mask); + + return ast_intr(I_IOR, A_DTYPEG(i), 2, iand_i, iand_j); + } + //AOCC Begin + case I_NEAREST: { + int i = ARGT_ARG(func_args, 0); + int j = ARGT_ARG(func_args, 1); + return ast_intr(I_NEAREST , A_DTYPEG(i), 2 , j , i); + } + //AOCC End + case I_DSHIFTL: + case I_DSHIFTR: { + if (flg.std != F2008) { + break; // Default to flang's "dshift(l/r)" lowering (not the F2008 one) + } + + int i = ARGT_ARG(func_args, 0); + int j = ARGT_ARG(func_args, 1); + int shift = ARGT_ARG(func_args, 2); + + int bit_size_i = mk_cval(bits_in(A_DTYPEG(i)), A_DTYPEG(i)); + int bit_size_j = mk_cval(bits_in(A_DTYPEG(j)), A_DTYPEG(j)); + + if (optype == I_DSHIFTL) { + /* Rewriting the ast as IOR(SHIFTL(I, SHIFT), SHIFTR(J, BIT_SIZE(J) - SHIFT)). */ + + /* computing ast for IOR's lhs */ + int shiftl_i = ast_intr(I_ISHFT, A_DTYPEG(i), 2, i, shift); + + /* computing ast for IOR's rhs */ + int negated_shiftval = mk_binop(OP_SUB, mk_cnst(stb.i0), + mk_binop(OP_SUB, bit_size_j, shift, A_DTYPEG(shift)) , A_DTYPEG(shift)); + int shiftr_bs_j = ast_intr(I_ISHFT, A_DTYPEG(j), 2, j, negated_shiftval); + + return ast_intr(I_IOR, A_DTYPEG(i), 2, shiftl_i, shiftr_bs_j); + + } else { + /* Rewriting the ast as IOR(SHIFTL(I, BIT_SIZE(I) - SHIFT), SHIFTR(J, SHIFT)) */ + + /* computing ast for IOR's lhs */ + int shiftl_bs_i = ast_intr(I_ISHFT, A_DTYPEG(i), 2, i, + mk_binop(OP_SUB, bit_size_i, shift, A_DTYPEG(shift))); + + /* computing ast for IOR's rhs */ + int negated_shiftval = mk_binop(OP_SUB, mk_cnst(stb.i0), shift, A_DTYPEG(shift)); + int shiftr_j = ast_intr(I_ISHFT, A_DTYPEG(j), 2, j, negated_shiftval); + + return ast_intr(I_IOR, A_DTYPEG(i), 2, shiftl_bs_i, shiftr_j); + } + } + /* AOCC end */ default: if (INKINDG(A_SPTRG(A_LOPG(func_ast))) == IK_ELEMENTAL) goto ret_norm; @@ -1876,6 +2094,7 @@ rewrite_func_ast(int func_ast, int func_args, int lhs) A_DTYPEP(retval, DT_INT); A_SHAPEP(retval, 0); return retval; + case I_PARITY:/* parity(mask, [dim]) AOCC */ case I_ALL: /* all(mask, [dim]) */ case I_ANY: /* any(mask, [dim]) */ case I_COUNT: /* count(mask, [dim]) */ @@ -1911,6 +2130,37 @@ rewrite_func_ast(int func_ast, int func_args, int lhs) ARGT_ARG(newargt, 2) = dim; } goto ret_new; + // AOCC begin + case I_IPARITY: /* iparity(array, [dim, mask]) */ + case I_IALL: /* iany(array, [dim, mask]) */ + case I_IANY: /* iany(array, [dim, mask]) */ + mask = ARGT_ARG(func_args, 2); + srcarray = ARGT_ARG(func_args, 0); + dim = ARGT_ARG(func_args, 1); + + if (mask == 0) { + mask = mk_cval(1, DT_LOG); + } + mask = misalignment(srcarray, mask, arg_gbl.std); + rtlRtn = RTE_iany; + + if (dim == 0) { + rtlRtn = + optype == I_IALL ? RTE_ialls : optype == I_ANY ? RTE_ianys : RTE_iparitys; + nargs = 3; + } else { + rtlRtn = + optype == I_IALL ? RTE_iall : optype == I_IANY ? RTE_iany : RTE_iparity; + nargs = 4; + } + newargt = mk_argt(nargs); + ARGT_ARG(newargt, 1) = srcarray; + ARGT_ARG(newargt, 2) = mask; + if (nargs == 4) { + ARGT_ARG(newargt, 3) = dim; + } + goto ret_new; + // AOCC end case I_PRODUCT: /* product(array, [dim, mask]) */ case I_SUM: /* sum(array, [dim, mask]) */ mask = ARGT_ARG(func_args, 2); @@ -2089,6 +2339,13 @@ rewrite_func_ast(int func_ast, int func_args, int lhs) ARGT_ARG(newargt, 1) = srcarray; ARGT_ARG(newargt, 2) = ARGT_ARG(func_args, 1); goto ret_new; +#if 0 + // AOCC Begin + case I_NORM2: /* norm2(array[, dim]) */ + return emit_norm2(func_ast, func_args, lhs); + // AOCC End +#endif + case I_EOSHIFT: /* eoshift(array, shift, [boundary, dim]); */ if (A_SHAPEG(ARGT_ARG(func_args, 1))) goto eoshiftcall; /* shift not a scalar */ @@ -2601,13 +2858,16 @@ rewrite_func_ast(int func_ast, int func_args, int lhs) case I_CPU_TIME: is_icall = FALSE; arg1 = ARGT_ARG(func_args, 0); - rtlRtn = DTYG(A_DTYPEG(arg1)) == TY_DBLE ? RTE_cpu_timed : RTE_cpu_time; + //AOCC + rtlRtn = DTYG(A_DTYPEG(arg1)) == TY_DBLE ? RTE_cpu_timed : + DTYG(A_DTYPEG(arg1)) == TY_QUAD ? RTE_cpu_timeq : RTE_cpu_time; nargs = 1; goto opt_common; case I_RANDOM_NUMBER: is_icall = FALSE; arg1 = ARGT_ARG(func_args, 0); - rtlRtn = DTYG(A_DTYPEG(arg1)) == TY_DBLE ? RTE_rnumd : RTE_rnum; + rtlRtn = DTYG(A_DTYPEG(arg1)) == TY_DBLE ? RTE_rnumd : + DTYG(A_DTYPEG(arg1)) == TY_QUAD ? RTE_rnumq : RTE_rnum; nargs = 1; goto opt_common; case I_RANDOM_SEED: @@ -2849,6 +3109,7 @@ rewrite_func_ast(int func_ast, int func_args, int lhs) ARGT_ARG(newargt, 5) = mk_cval(size_of(stb.user.dt_int), DT_INT4); is_icall = FALSE; goto ret_call; + default: goto ret_norm; } @@ -3235,6 +3496,7 @@ leave_arg(int ast, int i, int *parg, int lc) case I_ALL: case I_ANY: case I_COUNT: + case I_PARITY: // AOCC if (i != 0) return 0; args = A_ARGSG(ast); @@ -3244,6 +3506,19 @@ leave_arg(int ast, int i, int *parg, int lc) case I_NORM2: if (i != 0) return 0; + + // AOCC Begin + // Argument with expression has to be rewritten + switch(A_TYPEG(arg)) { + default: + break; + case A_BINOP: + case A_UNOP: + case A_PAREN: + return 0; + } + // AOCC End + args = A_ARGSG(ast); astdim = ARGT_ARG(args, 1); break; @@ -3292,6 +3567,7 @@ leave_elemental_argument(int func_ast, int argnum) { if (A_TYPEG(func_ast) == A_INTR) { if (A_OPTYPEG(func_ast) == I_TRANSPOSE || + (A_OPTYPEG(func_ast) == I_MINLOC && argnum == 2) || (A_OPTYPEG(func_ast) == I_SPREAD && argnum == 0)) { return TRUE; } @@ -3341,6 +3617,69 @@ copy_scalar_intent_in(int arg, int dummy_sptr, int std) return mk_id(newsptr); } /* copy_scalar_intent_in */ +// AOCC Begin +static bool +can_inline_minloc(int dest, int args) { + + int dim = 0; + int srcarray = ARGT_ARG(args, 0); + int astdim = ARGT_ARG(args, 1); + int mask = ARGT_ARG(args, 2); + + if (!dest) return false; + if (!srcarray) return false; + int shape = A_SHAPEG(dest); + if (!shape) return false; + if (A_TYPEG(dest) == A_SUBSCR) { + return false; + } else if (A_TYPEG(dest) != A_ID) { + return false; + } + + if (arg_gbl.inforall) + if (contiguous_section_array(srcarray)) + return false; + + if (astdim) { + if (A_TYPEG(astdim) != A_CNST) { + return false; + } + dim = get_int_cval(A_SPTRG(astdim)); + } + + int astback = ARGT_ARG(args, 3); + if (astback) { + if (A_TYPEG(astback) != A_CNST) { + return false; + } + int back = get_int_cval(A_SPTRG(astback)); + if (back != 0) return false; + } + + if (dim >= 1) { + if (A_TYPEG(dest) == A_SUBSCR) { + return false; + } else if (A_TYPEG(dest) == A_ID) { + int sptr = A_SPTRG(dest); + if (is_array_type(sptr)) { + if (SHD_NDIM(shape) != 1 || SHD_LWB(shape, 0) != SHD_UPB(shape, 0)) + return false; + } + } else return false; + } + + if (!XBIT(70, 0x1000000) && dim == 1 && arg_gbl.inforall) { + return false; + } + + if (mask && contains_any_call(mask)) return false; + + if (contains_any_call(srcarray)) + return false; + + return true; +} +// AOCC End /* * rewrite arguments of a function or subroutine call */ @@ -3506,7 +3845,17 @@ rewrite_sub_args(int arg_ast, int lc) * leave the elemental expressions in place, don't assign * to a temp. They will be expanded when the transpose or spread * are inlined */ - if (leave_elemental_argument(arg_ast, i)) { + // AOCC Begin + bool inline_minloc=false; + if (A_OPTYPEG(arg_ast) == I_MINLOC) { + bool inline_minloc = can_inline_minloc(arg_gbl.lhs, argt); + if (inline_minloc && leave_elemental_argument(arg_ast, i)) { + ARGT_ARG(newargt, i) = arg; + continue; + } + } + // AOCC End + else if (leave_elemental_argument(arg_ast, i)) { ARGT_ARG(newargt, i) = arg; continue; } @@ -3676,7 +4025,7 @@ rewrite_sub_ast(int ast, int lc) dtype = A_DTYPEG(ast); asd = A_ASDG(ast); numdim = ASD_NDIM(asd); - assert(numdim > 0 && numdim <= 7, "rewrite_sub_ast: bad numdim", ast, 4); + assert(is_legal_numdim(numdim), "rewrite_sub_ast: bad numdim", ast, 4); /* AOCC */ for (i = 0; i < numdim; ++i) { l = rewrite_sub_ast(ASD_SUBS(asd, i), lc); subs[i] = l; @@ -3695,8 +4044,12 @@ rewrite_sub_ast(int ast, int lc) return ast; args = rewrite_sub_args(ast, lc); + /* try again to inline it */ - ast = inline_reduction_f90(ast, 0, lc, NULL); + if (A_OPTYPEG(ast) == I_MINLOC) + ast = inline_reduction_f90(ast, arg_gbl.lhs, lc, NULL); + else + ast = inline_reduction_f90(ast, 0, lc, NULL); l = rewrite_func_ast(ast, args, 0); return l; case A_ICALL: @@ -3951,7 +4304,7 @@ rewrite_calls(void) } sptr_lhs = memsym_of_ast(A_SRCG(ast)); if (allocatable_member(sptr_lhs)) { - rewrite_deallocate(A_SRCG(ast), false, std); + rewrite_deallocate(A_SRCG(ast), false, std, true); if (!ALLOCG(sptr_lhs) && !ALLOCATTRG(sptr_lhs) && !POINTERG(sptr_lhs)) { /* Has allocatable members but item itself is not @@ -4082,6 +4435,7 @@ rewrite_calls(void) case A_MP_TASKREG: case A_MP_TASKDUP: case A_MP_ETASKDUP: + case A_MP_REQUIRESUNIFIEDSHAREDMEMORY: // AOCC break; case A_MP_TASKLOOPREG: case A_MP_ETASKLOOPREG: @@ -4214,6 +4568,16 @@ rewrite_calls(void) case A_MP_EREDUCTION: case A_MP_BREDUCTION: case A_MP_REDUCTIONITEM: + case A_MP_DEFAULTMAP: // AOCC + case A_MP_TARGETDECLARE: // AOCC + case A_MP_USE_DEVICE_PTR: // AOCC + case A_MP_IS_DEVICE_PTR: // AOCC + case A_MP_USE_DEVICE_ADDR: // AOCC + case A_MP_LOOP: // AOCC + case A_MP_ELOOP: // AOCC + case A_ID: // AOCC + case A_SUBSCR: // AOCC + case A_BINOP: // AOCC break; default: interr("rewrite_subroutine: unknown stmt found", ast, 4); @@ -4315,8 +4679,12 @@ mk_result_sptr(int func_ast, int func_args, int *subscr, int elem_dty, int lhs, case I_MINLOC: case I_MAXLOC: case I_FINDLOC: + case I_PARITY: // AOCC case I_ALL: case I_ANY: + case I_IALL: // AOCC + case I_IANY: // AOCC + case I_IPARITY: // AOCC case I_COUNT: case I_MAXVAL: case I_MINVAL: @@ -4439,6 +4807,10 @@ mk_result_sptr(int func_ast, int func_args, int *subscr, int elem_dty, int lhs, temp_sptr = mk_shape_sptr(shape, subscr, elem_dty); *retval = mk_id(temp_sptr); break; + // AOCC BEGIN + case I_ISNAN: + break; + // AOCC END default: interr("mk_result_sptr: can't handle intrinsic", func_ast, 4); break; @@ -4516,6 +4888,13 @@ search_conform_array(int ast, int flag) case I_MAXVAL: case I_MINVAL: case I_DOT_PRODUCT: + // AOCC Begin + case I_NORM2: + case I_IALL: + case I_IANY: + case I_IPARITY: + case I_PARITY: + // AOCC End case I_ALL: case I_ANY: case I_COUNT: @@ -5732,6 +6111,10 @@ inline_reduction_f90(int ast, int dest, int lc, LOGICAL *doremove) switch (A_OPTYPEG(ast)) { case I_ALL: case I_ANY: + case I_IALL: // AOCC + case I_IANY: // AOCC + case I_IPARITY: // AOCC + case I_PARITY: // AOCC case I_COUNT: case I_DOT_PRODUCT: case I_MAXVAL: @@ -5742,17 +6125,13 @@ inline_reduction_f90(int ast, int dest, int lc, LOGICAL *doremove) *doremove = TRUE; break; case I_MAXLOC: - case I_MINLOC: return ast; + case I_MINLOC: /* simple cases only */ - if (dest) { - if (A_TYPEG(dest) == A_SUBSCR) { - shape = A_SHAPEG(dest); - if (SHD_NDIM(shape) != 1 || SHD_LWB(shape, 0) != SHD_UPB(shape, 0)) - return ast; - } else if (A_TYPEG(dest) != A_ID) - return ast; - } + // AOCC Begin + if (!can_inline_minloc(dest, A_ARGSG(ast))) + // AOCC End + return ast; if (doremove) *doremove = TRUE; break; @@ -5784,6 +6163,8 @@ inline_reduction_f90(int ast, int dest, int lc, LOGICAL *doremove) case I_MAXLOC: case I_MINLOC: dtypeval = DDTG(A_DTYPEG(ARGT_ARG(args, 0))); + if (DTYG(dtypeval) == TY_CHAR || DTYG(dtypeval) == TY_NCHAR) + return ast; /* fall through */ case I_MAXVAL: case I_MINVAL: @@ -5818,6 +6199,10 @@ inline_reduction_f90(int ast, int dest, int lc, LOGICAL *doremove) conjg = I_CONJG; } else if (dtyperes == DT_CMPLX16) { conjg = I_DCONJG; + // AOCC begin + } else if (dtyperes == DT_CMPLX32) { + conjg = I_QCONJG; + // AOCC end } else { return ast; } @@ -5830,6 +6215,7 @@ inline_reduction_f90(int ast, int dest, int lc, LOGICAL *doremove) } srcarray = mk_binop(operator, src1, src2, dtype); break; + case I_PARITY: // AOCC case I_ALL: case I_ANY: case I_COUNT: @@ -5839,8 +6225,85 @@ inline_reduction_f90(int ast, int dest, int lc, LOGICAL *doremove) if (contiguous_section_array(srcarray)) return ast; break; + // AOCC begin + case I_IPARITY: + case I_IALL: + case I_IANY: + astdim = ARGT_ARG(args, 1); + mask = ARGT_ARG(args, 2); + srcarray = ARGT_ARG(args, 0); + if (DTYG(dtype) == TY_CHAR || DTYG(dtype) == TY_NCHAR) + return ast; + if (arg_gbl.inforall) + if (contiguous_section_array(srcarray)) + return ast; + break; } + /* Inlining nint intrinsic + // if (d > 0) + return (int)(d + 0.5f); + else + return (int)(d - 0.5f); + */ + if (A_OPTYPEG(ast) == I_NINT) { + int tmp; + stdnext = arg_gbl.std; + tmp = mk_cval(0, DT_INT); + tmp = mk_binop(OP_GT, argt, tmp, astb.bnd.dtype); + + operand = mk_binop(OP_ADD, argt, mk_cnst(stb.flthalf), A_DTYPEG(argt)); + asn = mk_assn_stmt(dest, operand, DT_INT); + + ifast = mk_stmt(A_IFTHEN, 0); + A_IFEXPRP(ifast, tmp); + std = add_stmt_before(ifast, stdnext); + STD_LINENO(std) = lineno; + STD_LOCAL(std) = 1; + STD_PAR(std) = STD_PAR(stdnext); + STD_TASK(std) = STD_TASK(stdnext); + STD_ACCEL(std) = STD_ACCEL(stdnext); + STD_KERNEL(std) = STD_KERNEL(stdnext); + std = add_stmt_before(asn, stdnext); + STD_LINENO(std) = lineno; + STD_LOCAL(std) = 1; + STD_PAR(std) = STD_PAR(stdnext); + STD_TASK(std) = STD_TASK(stdnext); + STD_ACCEL(std) = STD_ACCEL(stdnext); + STD_KERNEL(std) = STD_KERNEL(stdnext); + + tmp = mk_stmt(A_ELSE, 0); + std = add_stmt_before(tmp, stdnext); + STD_LINENO(std) = lineno; + STD_LOCAL(std) = 1; + STD_PAR(std) = STD_PAR(stdnext); + STD_TASK(std) = STD_TASK(stdnext); + STD_ACCEL(std) = STD_ACCEL(stdnext); + STD_KERNEL(std) = STD_KERNEL(stdnext); + + operand = mk_binop(OP_SUB, argt, mk_cnst(stb.flthalf), A_DTYPEG(argt)); + asn = mk_assn_stmt(dest, operand, DT_INT); + std = add_stmt_before(asn, stdnext); + + STD_LINENO(std) = lineno; + STD_LOCAL(std) = 1; + STD_PAR(std) = STD_PAR(stdnext); + STD_TASK(std) = STD_TASK(stdnext); + STD_ACCEL(std) = STD_ACCEL(stdnext); + STD_KERNEL(std) = STD_KERNEL(stdnext); + + endif = mk_stmt(A_ENDIF, 0); + std = add_stmt_before(endif, stdnext); + STD_LINENO(std) = lineno; + STD_LOCAL(std) = 1; + STD_PAR(std) = STD_PAR(stdnext); + STD_TASK(std) = STD_TASK(stdnext); + STD_ACCEL(std) = STD_ACCEL(stdnext); + STD_KERNEL(std) = STD_KERNEL(stdnext); + + return dest; + } + // AOCC end if (astdim) { if (A_TYPEG(astdim) != A_CNST) { return ast; @@ -5850,8 +6313,22 @@ inline_reduction_f90(int ast, int dest, int lc, LOGICAL *doremove) dim = 0; } - if ((A_OPTYPEG(ast) == I_MAXLOC || A_OPTYPEG(ast) == I_MINLOC) && dim > 1) - return ast; + if ((A_OPTYPEG(ast) == I_MAXLOC || A_OPTYPEG(ast) == I_MINLOC) && dim >= 1) { + if (A_TYPEG(dest) == A_SUBSCR) { + int shape = A_SHAPEG(dest); + if (!shape) return ast; + if (SHD_NDIM(shape) != 1 || SHD_LWB(shape, 0) != SHD_UPB(shape, 0)) + return ast; + } else if (A_TYPEG(dest) == A_ID) { + int sptr = A_SPTRG(dest); + if (is_array_type(sptr)) { + int shape = A_SHAPEG(dest); + if (!shape) return ast; + if (SHD_NDIM(shape) != 1 || SHD_LWB(shape, 0) != SHD_UPB(shape, 0)) + return ast; + } + } else return ast; + } if (!XBIT(70, 0x1000000) && dim == 1 && arg_gbl.inforall) { return ast; @@ -5905,6 +6382,23 @@ inline_reduction_f90(int ast, int dest, int lc, LOGICAL *doremove) } } } + + stdnext = arg_gbl.std; + if ((A_OPTYPEG(ast) == I_MAXLOC || A_OPTYPEG(ast) == I_MINLOC) && dest) { + // incase of zero sized arrays and when mask is all false return 0 + dtsclr = DDTG(dtyperes); + newast = mk_cval(0, dtyperes); + asn = mk_assn_stmt(dest, newast, dtsclr); + std = add_stmt_before(asn, stdnext); + + STD_LINENO(std) = lineno; + STD_LOCAL(std) = 1; + STD_PAR(std) = STD_PAR(stdnext); + STD_TASK(std) = STD_TASK(stdnext); + STD_ACCEL(std) = STD_ACCEL(stdnext); + STD_KERNEL(std) = STD_KERNEL(stdnext); + } + ast2 = convert_subscript_in_expr(srcarray); home = convert_subscript(home); if (mask) { @@ -5928,7 +6422,6 @@ inline_reduction_f90(int ast, int dest, int lc, LOGICAL *doremove) ndim = ASD_NDIM(asd); /* MORE ndim and nbrloops are NOT the same!!! */ nbrloops = SHD_NDIM(shape); - stdnext = arg_gbl.std; lineno = STD_LINENO(stdnext); if (A_OPTYPEG(ast) == I_MAXLOC || A_OPTYPEG(ast) == I_MINLOC) { @@ -6146,6 +6639,24 @@ inline_reduction_f90(int ast, int dest, int lc, LOGICAL *doremove) ReducType = I_REDUCE_ANY; astInit = mk_cval(SCFTN_FALSE, DDTG(dtypetmp)); break; + // AOCC begin + case I_PARITY: + ReducType = I_REDUCE_PARITY; + astInit = mk_cval(SCFTN_FALSE, DDTG(dtypetmp)); + break; + case I_IALL: + ReducType = I_REDUCE_IALL; + astInit = mk_cval(SCFTN_TRUE, DDTG(dtypetmp)); + break; + case I_IANY: + ReducType = I_REDUCE_IANY; + astInit = mk_cval(SCFTN_FALSE, DDTG(dtypetmp)); + break; + case I_IPARITY: + ReducType = I_REDUCE_IPARITY; + astInit = mk_cval(SCFTN_FALSE, DDTG(dtypetmp)); + break; + // AOCC end default: assert(0, "inline_reduction_f90: unknown type", ast, 4); } @@ -6375,7 +6886,35 @@ inline_reduction_f90(int ast, int dest, int lc, LOGICAL *doremove) subscr = mk_cval(j + 1, astb.bnd.dtype); ast2 = mk_subscr(astsubscrtmp, &subscr, 1, dtyperes); - asn = mk_assn_stmt(ast2, A_DOVARG(DOs[j]), dtyperes); + // AOCC Begin + int lb = A_M1G(DOs[j]); + int ub = A_M2G(DOs[j]); + int st = A_M3G(DOs[j]); + + int lbval = 0; + int ubval = 0; + int stval = 0; + + if (lb != 0 && A_TYPEG(lb) == A_CNST) + lbval = get_int_cval(A_SPTRG(A_ALIASG(lb))); + if (ub != 0 && A_TYPEG(ub) == A_CNST) + ubval = get_int_cval(A_SPTRG(A_ALIASG(ub))); + if (st != 0 && A_TYPEG(st) == A_CNST) + stval = get_int_cval(A_SPTRG(A_ALIASG(st))); + + if ( stval < 0 ) { + int constone = mk_cval(1 , astb.bnd.dtype); + int lbplusoneexp = mk_binop(OP_ADD, constone, lb, astb.bnd.dtype); + int normalizeexp = mk_binop(OP_SUB, lbplusoneexp, A_DOVARG(DOs[j]), astb.bnd.dtype); + asn = mk_assn_stmt(ast2, normalizeexp, dtyperes); + } else { + int constone = mk_cval(1 , astb.bnd.dtype); + int indexexp = mk_binop(OP_ADD, constone, A_DOVARG(DOs[j]), astb.bnd.dtype); + int normalizeexp = mk_binop(OP_SUB, indexexp,lb, astb.bnd.dtype); + asn = mk_assn_stmt(ast2, normalizeexp, dtyperes); + } + // AOCC End + std = add_stmt_before(asn, stdnext); STD_LINENO(std) = lineno; STD_LOCAL(std) = 1; @@ -6443,6 +6982,72 @@ inline_reduction_f90(int ast, int dest, int lc, LOGICAL *doremove) STD_ACCEL(std) = STD_ACCEL(stdnext); STD_KERNEL(std) = STD_KERNEL(stdnext); break; + // AOCC begin + case I_PARITY: + newast = ast2; + operand = mk_binop(OP_LXOR, astsubscrtmp, ast2, DT_LOG); + asn = mk_assn_stmt(astsubscrtmp, operand, dtsclr); + + ifast = mk_stmt(A_IFTHEN, 0); + A_IFEXPRP(ifast, ast2); + std = add_stmt_before(ifast, stdnext); + STD_LINENO(std) = lineno; + STD_LOCAL(std) = 1; + STD_PAR(std) = STD_PAR(stdnext); + STD_TASK(std) = STD_TASK(stdnext); + STD_ACCEL(std) = STD_ACCEL(stdnext); + STD_KERNEL(std) = STD_KERNEL(stdnext); + + std = add_stmt_before(asn, stdnext); + STD_LINENO(std) = lineno; + STD_LOCAL(std) = 1; + STD_PAR(std) = STD_PAR(stdnext); + STD_TASK(std) = STD_TASK(stdnext); + STD_ACCEL(std) = STD_ACCEL(stdnext); + STD_KERNEL(std) = STD_KERNEL(stdnext); + + endif = mk_stmt(A_ENDIF, 0); + std = add_stmt_before(endif, stdnext); + STD_LINENO(std) = lineno; + STD_LOCAL(std) = 1; + STD_PAR(std) = STD_PAR(stdnext); + STD_TASK(std) = STD_TASK(stdnext); + STD_ACCEL(std) = STD_ACCEL(stdnext); + STD_KERNEL(std) = STD_KERNEL(stdnext); + break; + + case I_IALL: + case I_IANY: + if (A_OPTYPEG(ast) == I_IALL) + operand = mk_binop(OP_LAND, ast2, astsubscrtmp, DT_LOG); + else + operand = mk_binop(OP_LOR, ast2, astsubscrtmp, DT_LOG); + + asn = mk_assn_stmt(astsubscrtmp, operand, dtsclr); + + std = add_stmt_before(asn, stdnext); + STD_LINENO(std) = lineno; + STD_LOCAL(std) = 1; + STD_PAR(std) = STD_PAR(stdnext); + STD_TASK(std) = STD_TASK(stdnext); + STD_ACCEL(std) = STD_ACCEL(stdnext); + STD_KERNEL(std) = STD_KERNEL(stdnext); + + break; + case I_IPARITY: + operand = mk_binop(OP_LXOR, ast2, astsubscrtmp, DT_LOG); + asn = mk_assn_stmt(astsubscrtmp, operand, dtsclr); + + std = add_stmt_before(asn, stdnext); + STD_LINENO(std) = lineno; + STD_LOCAL(std) = 1; + STD_PAR(std) = STD_PAR(stdnext); + STD_TASK(std) = STD_TASK(stdnext); + STD_ACCEL(std) = STD_ACCEL(stdnext); + STD_KERNEL(std) = STD_KERNEL(stdnext); + + break; + // AOCC end default: assert(0, "inline_reduction_f90: unknown type", ast, 4); } @@ -6555,7 +7160,6 @@ inline_reduction_f90(int ast, int dest, int lc, LOGICAL *doremove) } } } - if (ALLOCG(sptrtmp)) { newast = mk_stmt(A_ALLOC, 0); A_TKNP(newast, TK_DEALLOCATE); @@ -6632,6 +7236,97 @@ subscript_lhs(int arr, int *subs, int dim, DTYPE dtype, int origlhs, return ast; } +// AOCC Begin +/* + * Emit AST for PD_NORM2 + * + * func_ast: A_FUNC + * func_args: rewritten args + */ + +static int +emit_norm2(int func_ast, int func_args, int lhs) { + + int nargs; + int srcarray; + int newargt; + int temp_sclr; + int retval; + int newsym; + char *name; + int ast; + int arg1, arg2; + int shape; + int rank; + int temp_arr; + int subscr[MAXSUBS]; + int lhs_ast; + + nargs = 3; + + arg1 = ARGT_ARG(func_args, 0); + check_arg_isalloc(arg1); + if (ARGT_ARG(func_args, 1) == 0) + nargs--; + DTYPE dtype = A_DTYPEG(func_ast); + FtnRtlEnum rtlRtn; + + // Define the return type, based on which fucnton name is formed. + switch (DTY(A_DTYPEG(func_ast))) { + case TY_REAL: + if (nargs == 3) + rtlRtn = RTE_norm2_real4_dim; + else + rtlRtn = RTE_norm2_real4; + break; + + case TY_DBLE: + if (nargs == 3) + rtlRtn = RTE_norm2_real8_dim; + else + rtlRtn = RTE_norm2_real8; + break; + + case TY_QUAD: + if (nargs == 3) + rtlRtn = RTE_norm2_real16_dim; + else + rtlRtn = RTE_norm2_real16; + break; + + default: + error(456, 3, gbl.lineno, CNULL, CNULL); + // AOCC end + } + + newargt = mk_argt(nargs); + srcarray = ARGT_ARG(func_args, 0); + ARGT_ARG(newargt, 1) = srcarray; + if (nargs == 3) { + // Not suported yet. + // Should not reach here + // Create lhs array to hold the result + assert(0, "norm2 for two arguments not supported : should not reach here", + 2, func_ast); + } + else { + // Create a scalar variable to store the result. + temp_sclr = sym_get_scalar("tmp", "r", dtype); + retval = mk_id(temp_sclr); + ARGT_ARG(newargt, 0) = retval; + } + + name = mkRteRtnNm(rtlRtn); + newsym = sym_mkfunc(name, DT_NONE); + + ast = mk_func_node(A_ICALL, mk_id(newsym), nargs, newargt); + A_OPTYPEP(ast, A_OPTYPEG(func_ast)); + add_stmt_before(ast, arg_gbl.std); + return retval; +} +// AOCC End + + /* * func_ast: A_FUNC or A_INTR * func_args: rewritten args @@ -6672,9 +7367,11 @@ matmul(int func_ast, int func_args, int lhs) LOGICAL tmp_lhs_array; LOGICAL matmul_transpose; - retval = mmul(func_ast, func_args, lhs); - if (retval >= 0) - return retval; + if (flg.opt >= 2) { // AOCC + retval = mmul(func_ast, func_args, lhs); + if (retval >= 0) + return retval; + } tmp_lhs_array = FALSE; /* it only handles calls */ @@ -6715,6 +7412,15 @@ matmul(int func_ast, int func_args, int lhs) rtlRtn = RTE_matmul_real8; } break; + // AOCC begin + case TY_QUAD: + if (matmul_transpose) { + rtlRtn = RTE_matmul_real16mxv_t; + } else { + rtlRtn = RTE_matmul_real16; + } + break; + // AOCC end case TY_CMPLX: if (matmul_transpose) { rtlRtn = RTE_matmul_cplx8mxv_t; @@ -6729,6 +7435,15 @@ matmul(int func_ast, int func_args, int lhs) rtlRtn = RTE_matmul_cplx16; } break; + // AOCC begin + case TY_QCMPLX: + if (matmul_transpose) { + rtlRtn = RTE_matmul_cplx32mxv_t; + } else { + rtlRtn = RTE_matmul_cplx32; + } + break; + // AOCC end case TY_BLOG: rtlRtn = RTE_matmul_log1; break; @@ -6945,6 +7660,17 @@ mmul(int func_ast, int func_args, int lhs) beta = getcon(num, DT_CMPLX16); rtlRtn = RTE_mmul_cmplx16; break; + // AOCC begin + case DT_CMPLX32: + num[0] = stb.quad0; + num[1] = stb.quad0; + alpha = getcon(num, DT_CMPLX32); + num[0] = stb.quad0; + num[1] = stb.quad0; + beta = getcon(num, DT_CMPLX32); + rtlRtn = RTE_mmul_cmplx32; + break; + // AOCC end default: return -1; } @@ -7113,8 +7839,7 @@ mmul_arg(int arr, int transpose, MMUL *mm) } /* ldim must be before any tranpose */ if (STYPEG(sptr) == ST_MEMBER) { - ldim = ADD_EXTNTAST(DTYPEG(sptr), 0); - ldim = check_member(mm->addr, ldim); + return FALSE; } #ifdef NOEXTENTG else if (HCCSYMG(sptr) && SCG(sptr) == SC_LOCAL && ALLOCG(sptr) && @@ -7135,9 +7860,8 @@ mmul_arg(int arr, int transpose, MMUL *mm) ldim = mk_extent_expr(AD_LWBD(tad, 0), AD_UPBD(tad, 0)); } #endif - else { - ldim = ADD_EXTNTAST(DTYPEG(sptr), 0); - } + else + return FALSE; if (transpose) { /* extents are post-tranposed */ m = mm->extent[0]; diff --git a/tools/flang1/flang1exe/gbldefs.h b/tools/flang1/flang1exe/gbldefs.h index 8b6efe40b9..72a8bafdbb 100644 --- a/tools/flang1/flang1exe/gbldefs.h +++ b/tools/flang1/flang1exe/gbldefs.h @@ -4,6 +4,12 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified: May 2020 + */ /** * \file gbldefs.h @@ -41,6 +47,7 @@ #define GBL_SIZE_T_FORMAT "zu" #define XBIT(n, m) (flg.x[n] & m) +#define ZBIT(n, m) (flg.z[n] & m) #define F77OUTPUT XBIT(49, 0x80) /* This x-bit controls the insertion of scope labels. On by default. */ #define XBIT_USE_SCOPE_LABELS !XBIT(198, 0x40000) @@ -65,7 +72,7 @@ #define MAX_FILENAME_LEN 256 /* maximum number of array subscripts */ -#define MAXSUBS 7 +#define MAXSUBS 15 /* AOCC */ typedef int8_t INT8; typedef int16_t INT16; @@ -262,4 +269,19 @@ void fpp(void); /* fpp.c */ #define snprintf _snprintf #endif +enum OpenMPOffloadingRequiresDirFlags { + /// flag undefined. + OMP_REQ_UNDEFINED = 0x000, + /// no requires clause present. + OMP_REQ_NONE = 0x001, + /// reverse_offload clause. + OMP_REQ_REVERSE_OFFLOAD = 0x002, + /// unified_address clause. + OMP_REQ_UNIFIED_ADDRESS = 0x004, + /// unified_shared_memory clause. + OMP_REQ_UNIFIED_SHARED_MEMORY = 0x008, + /// dynamic_allocators clause. + OMP_REQ_DYNAMIC_ALLOCATORS = 0x010 +}; + #endif /* FE_GBLDEFS_H */ diff --git a/tools/flang1/flang1exe/global.h b/tools/flang1/flang1exe/global.h index 6554cbd36b..429ce8fe13 100644 --- a/tools/flang1/flang1exe/global.h +++ b/tools/flang1/flang1exe/global.h @@ -1,10 +1,20 @@ + /* * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. * See https://llvm.org/LICENSE.txt for license information. * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ - +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * + * Month of Modification: May 2019 : f2008 support + * + * Modified for compiler_options() + * Date of Modification : 21st May 2020 + */ #ifndef GLOBAL_H_ #define GLOBAL_H_ @@ -19,6 +29,17 @@ typedef enum SPTR { SPTR_MAX = 67108864 /* Maximum allowed value */ } SPTR; +// AOCC begin +typedef enum { + STD_UNKNOWN, /* default */ + F2008, + F2003, + F95, + F90, + F77 +} FORTRAN_STD; +// AOCC end + #ifdef __cplusplus // Enable symbol table traversals to work. static inline void operator++(SPTR &s) @@ -140,7 +161,7 @@ typedef struct { #define MAXCPUS 256 /* Max number of dimensions. F'2008 requires 15, Intel is 31. */ -#define MAXRANK 7 +#define MAXRANK 15 /* AOCC */ extern GBL gbl; #define GBL_CURRFUNC gbl.currsub @@ -185,6 +206,7 @@ typedef struct { LOGICAL terse; int dollar; /* defines the char to which '$' is translated */ int x[251]; /* x flags */ + int z[31]; /* AOCC: z flags */ LOGICAL quad; /* quad align "unconstrained objects" if sizeof >= 16 */ int anno; LOGICAL qa; /* TRUE => -qa appeared on command line */ @@ -210,8 +232,26 @@ typedef struct { int tpvalue[TPNVERSION]; /* target processor(s), for unified binary */ int accmp; char *cmdline; /* command line used to invoke the compiler */ + char* source_file; /* get the name of the file being executed */ //AOCC + LOGICAL func_args_alias; /* assume function arguments are aliasing */ // AOCC + // AOCC begin + char *std_string; /* input string arg of -std= */ + FORTRAN_STD std; + LOGICAL disable_loop_vectorize_pragmas; /* Disable Loop vecroizing pragmas */ + LOGICAL x86_64_omptarget; /* IF offloading target is x86-64 */ + LOGICAL amdgcn_target; /* IF offloading target is AMDGPU */ +#ifdef DEBUG + LOGICAL debug_log; /* TRUE enables all debug log statements */ + char *debug_only_strs; /* enables only debug log categories in this string */ +#endif // DEBUG + // AOCC end } FLG; extern FLG flg; +// AOCC begin +extern unsigned get_legal_maxdim(); +extern bool is_legal_numdim(int numdim); +// AOCC end + #endif diff --git a/tools/flang1/flang1exe/hlvect.c b/tools/flang1/flang1exe/hlvect.c index 16b37840fe..38ab45891e 100644 --- a/tools/flang1/flang1exe/hlvect.c +++ b/tools/flang1/flang1exe/hlvect.c @@ -4,6 +4,14 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ /** * \file @@ -144,10 +152,11 @@ VTMP hlv_temps[VT_PHASES][VT_MAX] = { }, /* Phase 1 -- induction temps */ { - {0, 0, 0, "ndi", DT_INT4}, /* induction integers */ - {0, 0, 0, "ndp", DT_CPTR}, /* induction pointers */ - {0, 0, 0, "nds", DT_REAL4}, /* single precision */ - {0, 0, 0, "ndd", DT_REAL8}, /* double precision */ + {0, 0, 0, "ndi", DT_INT4}, /* induction integers */ + {0, 0, 0, "ndp", DT_CPTR}, /* induction pointers */ + {0, 0, 0, "nds", DT_REAL4}, /* single precision */ + {0, 0, 0, "ndd", DT_REAL8}, /* double precision */ + {0, 0, 0, "ndq", DT_QUAD}, /* AOCC: quad precision */ }, }; VTMP hlv_vtemps = { diff --git a/tools/flang1/flang1exe/inliner.c b/tools/flang1/flang1exe/inliner.c index d488438a01..d58a74d3f8 100644 --- a/tools/flang1/flang1exe/inliner.c +++ b/tools/flang1/flang1exe/inliner.c @@ -4,6 +4,12 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified: May 2020 + */ /** * \file @@ -58,7 +64,7 @@ #define INLINER_VERSION 14 #define MAX_INLINE_NAME 42 -#define MAX_FNAME_LEN 256 +#define MAX_FNAME_LEN 4096 #define TOC_HEADER_FMT "Inliner TOC V.%d" #define TOC_ENTRY_FMT "%s %s %s %s" #define MODNAME_FMT "i%d.e" @@ -254,6 +260,20 @@ extractor_possible(void) for (std = STD_NEXT(0); std; std = STD_NEXT(std)) { /* whether to allow loops or conditionals */ switch (A_TYPEG(STD_AST(std))) { + // AOCC Begin + case A_MP_TARGET: + case A_MP_TARGETUPDATE: + case A_MP_TARGETDATA: + case A_MP_TARGETENTERDATA: + case A_MP_TARGETEXITDATA: + ccff_info(MSGNEGINLINER, "INL031", gbl.findex, gbl.funcline, + "%module%separator%function is not HL inlineable: TARGET " + "statements disallowed", + "module=%s", gbl.currmod ? SYMNAME(gbl.currmod) : "", + "separator=%s", gbl.currmod ? "::" : "", "function=%s", + SYMNAME(gbl.currsub), NULL); + return false; + // AOCC End case A_DO: if (!XBIT(13, 0x100)) { ccff_info(MSGNEGINLINER, "INL031", gbl.findex, gbl.funcline, @@ -430,6 +450,7 @@ extractor_end(void) int iStat; FILE *fd; char sTOCFile[MAX_FNAME_LEN]; + char rmCmd[MAX_FNAME_LEN]; LE *ple; if (!sExtDir) @@ -455,8 +476,14 @@ extractor_end(void) fprintf(fd, "\n"); } fclose(fd); + // AOCC Begin + // TBD: restricted to windows now + sprintf(rmCmd,"rm -rf %s", sExtDir); + system(rmCmd); + // AOCC End freearea(PERM_AREA); + } void @@ -546,7 +573,7 @@ inline_stds(int stdStart, int stdLast, int iLevels, int level) static int inline_ast(int std, int ast, int iLevels, int level) { - int astNewl, astNewr, astNew, vastSubs[7], astNewu, astNews, astNewc; + int astNewl, astNewr, astNew, vastSubs[MAXSUBS], astNewu, astNews, astNewc; // AOCC int asd, sptrEntry; int nsubs, sub; int sptrRet; @@ -1043,7 +1070,7 @@ copy_inargs(int sptrEntry, int astCall, int stdstart, int stdlast) int sptrCall, sptrDummy, sptrCopy, sptrBnd; int nargs, arg; int argtNew; - int astArg, astCopy, ast, astl, astu, asts, vastSubs[7], astBnd, astAlloc; + int astArg, astCopy, ast, astl, astu, asts, vastSubs[MAXSUBS], astBnd, astAlloc; // AOCC int shd; int dtyp; int ndims, dim; @@ -1301,7 +1328,7 @@ promote_assumsz_arg(int sptrDummy, int astArg) { int asd; int nsubs, sub; - int astl, astu, vastSubs[7], ast; + int astl, astu, vastSubs[MAXSUBS], ast; // AOCC int dtyp; int dtypeDummy, nsubsDummy, sptr, dtype; @@ -1357,7 +1384,7 @@ allocate_adjarrs(int stdstart, int stdlast) { int sptr; int ndims, dim; - int vastSubs[7], astArr, ast, astAlloc, astl, astu; + int vastSubs[MAXSUBS], astArr, ast, astAlloc, astl, astu; // AOCC int std1 = STD_PREV(stdstart), std2 = stdlast; for (sptr = sptrHigh; sptr < stb.stg_avail; sptr++) @@ -1374,7 +1401,7 @@ allocate_array(int sptr, int stdstart, int stdlast) { ADSC *ad; int sptrBnd; - int vastSubs[7], astArr, ast, astAlloc, astl, astu; + int vastSubs[MAXSUBS], astArr, ast, astAlloc, astl, astu; // AOCC int std1 = STD_PREV(stdstart), std2 = stdlast; int ndims, dim; @@ -1534,7 +1561,7 @@ static int replace_parms(int ast, void *extra_arg) { int iar; - int astLop, astNew, astSS, astSub, vastSubs[7], ast1; + int astLop, astNew, astSS, astSub, vastSubs[MAXSUBS], ast1; // AOCC int sptr, dtypeOld, dtypeNew, memOld, memNew, astMemNew; int asd, asdSS; int ndims, dim; @@ -1627,7 +1654,7 @@ replace_parms(int ast, void *extra_arg) bChanged |= astNew != astLop; ast1 = ast; if (astSS && ASD_NDIM(asdSS) != ndims) { - int nSubs[7], i, j; + int nSubs[MAXSUBS], i, j; // AOCC bChanged = 1; j = 0; ndims = ASD_NDIM(asdSS); @@ -1729,7 +1756,7 @@ rewrite_inlined_args(int astCall, int sptrEntry, int stdstart, int stdlast) int sptrDummy, sptrArg, sptr, dtype; int shd; int ndims, dim; - int vastSubs[7]; + int vastSubs[MAXSUBS]; // AOCC ADSC *adDummy, *adArg, *ad; /* Initialize the argument replacement table. */ @@ -1898,7 +1925,7 @@ replace_arg(int astDummy, int astAct) int rankAct, dimAct, dim, rankDummy; int asdAct, asdDummy; int ast, astl, astu, asts, astSub, ast1; - int vastSubs[7]; + int vastSubs[MAXSUBS]; // AOCC int shd, shdDummy; int dtyp, needsubscripts; ADSC *adDummy; diff --git a/tools/flang1/flang1exe/interf.c b/tools/flang1/flang1exe/interf.c index 8d1c5730a4..0d0139c787 100644 --- a/tools/flang1/flang1exe/interf.c +++ b/tools/flang1/flang1exe/interf.c @@ -5,6 +5,16 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes made to support f2008 support of change in maximum array dimensions + * Date of Modification: 26th June 2019 + * + * Modified to support compiler_options() + * Date of modification: 21st May 2020 + */ /** \file interf.c \brief Routines for importing symbols from .mod files and from IPA. @@ -61,7 +71,7 @@ static int HOST_OLDSCOPE = 0, HOST_NEWSCOPE = 0; static char **modinclist = NULL; static int modinclistsize = 0, modinclistavl = 0; -#define MAX_FNAME_LEN 258 +#define MAX_FNAME_LEN 4096 #define MOD_SUFFIX ".mod" /** \brief 'interface' initialization, called once per compilation @@ -73,7 +83,7 @@ interf_init() #if DEBUG assert(sizeof(SYM) / sizeof(INT) == 44, "bad SYM size", sizeof(SYM) / sizeof(INT), 4); - assert(sizeof(AST) / sizeof(int) == 19, "interf_init:inconsistent AST size", + assert(sizeof(AST) / sizeof(int) == 20, "interf_init:inconsistent AST size", sizeof(AST) / sizeof(int), 2); #endif } @@ -174,7 +184,7 @@ typedef struct {/* info on a shd item read from file */ int lwb; int upb; int stride; - } shp[7]; + } shp[MAXSUBS]; // AOCC } SHDITEM; typedef struct { /* info on argt item read from file */ @@ -188,7 +198,7 @@ typedef struct { /* info on ASD item read from file */ int old; /* old asd index */ LOGICAL installed; /* this entry has been processed */ int ndim; /* number of dimensions */ - int subs[7]; /* subscripts */ + int subs[MAXSUBS]; /* AOCC: subscripts */ } ASDITEM; typedef struct { /* info on astli list read file */ @@ -2081,7 +2091,16 @@ import(lzhandle *fdlz, WantPrivates wantPrivates, int ivsn) if (strcmp(module_name, "iso_c_binding") == 0) { if (strcmp(SYMNAME(sptr), "c_sizeof") == 0) { STYPEP(sptr, ST_PD); - } else { + } + //AOCC Begin + else if(strcmp(SYMNAME(sptr), "compiler_options") == 0){ + STYPEP(sptr, ST_PD); + } + else if(strcmp(SYMNAME(sptr), "compiler_version") == 0){ + STYPEP(sptr, ST_PD); + } + //AOCC End + else { STYPEP(sptr, ST_INTRIN); } } else if (strcmp(module_name, "ieee_arithmetic") == 0) { @@ -5991,6 +6010,11 @@ fill_links_symbol(SYMITEM *ps, WantPrivates wantPrivates) break; case ST_INTRIN: switch (DTY(dtype)) { + // AOCC begin + case TY_QCMPLX: + GQCMPLXP(GNRINTRG(sptr), sptr); + break; + // AOCC end case TY_DCMPLX: GDCMPLXP(GNRINTRG(sptr), sptr); break; diff --git a/tools/flang1/flang1exe/iterat.c b/tools/flang1/flang1exe/iterat.c index 55deb557cd..cc5947bf01 100644 --- a/tools/flang1/flang1exe/iterat.c +++ b/tools/flang1/flang1exe/iterat.c @@ -4,6 +4,12 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified: May 2020 + */ /* comm.c - PGHPF communications module */ @@ -666,7 +672,7 @@ replace_expr(int sub_expr, int isptr, int expr, int indirection) int expr1; int expr2; int sptr; - int subs[7]; + int subs[MAXSUBS]; // AOCC int nargs, argt; if (sub_expr == 0) diff --git a/tools/flang1/flang1exe/kwddf.h b/tools/flang1/flang1exe/kwddf.h index 650269c9ee..5dd09736b1 100644 --- a/tools/flang1/flang1exe/kwddf.h +++ b/tools/flang1/flang1exe/kwddf.h @@ -373,6 +373,7 @@ static KWORD t5[] = { {"from", TK_FROM}, {"grainsize", TK_GRAINSIZE}, {"if", TK_IF}, + {"in_reduction", TK_IN_REDUCTION}, // AOCC {"inbranch", TK_INBRANCH}, {"is_device_ptr", TK_IS_DEVICE_PTR}, {"lastlocal", TK_LASTPRIVATE}, @@ -408,6 +409,8 @@ static KWORD t5[] = { {"uniform", TK_UNIFORM}, {"untied", TK_UNTIED}, {"update", TK_UPDATE}, + {"use_device_addr", TK_USE_DEVICE_ADDR}, // AOCC + {"use_device_ptr", TK_USE_DEVICE_PTR}, // AOCC {"write", TK_WRITE}, }; @@ -441,6 +444,7 @@ static KWORD t6[] = { {"enddo", TK_MP_ENDPDO}, {"enddosimd", TK_MP_ENDDOSIMD}, {"endmaster", TK_MP_ENDMASTER}, + {"endmetadirective", TK_MP_ENDMETADIR}, // AOCC {"endordered", TK_MP_ENDORDERED}, {"endparallel", TK_MP_ENDPARALLEL}, {"endparalleldo", TK_MP_ENDPARDO}, @@ -473,9 +477,11 @@ static KWORD t6[] = { {"endworkshare", TK_MP_ENDWORKSHARE}, {"flush", TK_MP_FLUSH}, {"master", TK_MP_MASTER}, + {"metadirective", TK_MP_METADIR}, // AOCC {"ordered", TK_MP_ORDERED}, {"parallel", TK_MP_PARALLEL}, {"paralleldo", TK_MP_PARDO}, + {"loop", TK_MP_LOOP}, {"paralleldosimd", TK_MP_PARDOSIMD}, {"parallelsections", TK_MP_PARSECTIONS}, {"parallelworkshare", TK_MP_PARWORKSHR}, @@ -512,6 +518,7 @@ static KWORD t6[] = { {"teamsdistributesimd", TK_MP_TEAMSDISTSIMD}, {"threadprivate", TK_MP_THREADPRIVATE}, {"workshare", TK_MP_WORKSHARE}, + {"requires", TK_MP_REQUIRES}, // AOCC }; static KWORD t7[] = { @@ -552,6 +559,13 @@ static KWORD t12[] = { {"", 0}, /* a keyword index must be nonzero */ {"compare", TK_PGICOMPARE}, }; +static KWORD t13[] = { + {"", 0}, /* a keyword index must be nonzero */ + {"condition", TK_CONDITION}, + {"default", TK_DEFAULT}, + {"user", TK_USER}, + {"when", TK_WHEN}, +}; /* **** NOTE -- each of these must appear in a call to init_ktable() in * scan_init(). @@ -567,6 +581,7 @@ static KTABLE pragma_kw = {sizeof(t8) / sizeof(KWORD), &t8[0]}; static KTABLE ppragma_kw = {sizeof(t9) / sizeof(KWORD), &t9[0]}; static KTABLE kernel_kw = {sizeof(t11) / sizeof(KWORD), &t11[0]}; static KTABLE pgi_kw = {sizeof(t12) / sizeof(KWORD), &t12[0]}; +static KTABLE meta_kw = {sizeof(t13) / sizeof(KWORD), &t13[0]}; /* char classification macros */ diff --git a/tools/flang1/flang1exe/lower.c b/tools/flang1/flang1exe/lower.c index e5b6ea825b..9134478a33 100644 --- a/tools/flang1/flang1exe/lower.c +++ b/tools/flang1/flang1exe/lower.c @@ -4,6 +4,14 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ /** \file @@ -756,10 +764,14 @@ trav_struct(int dtype, int off) regclass[regi] = CLASS_SSEQ; return; case TY_QUAD: -#if DEBUG + // AOCC begin + regclass[regi] = CLASS_SSEQ; + return; + // AOCC end +/*#if DEBUG if (sizeof(DT_QUAD) == 16) interr("trav_struct: update handling of long doubles", dtype, 3); -#endif +#endif*/ /* we're treating this like DBLE for now. */ case TY_DBLE: regclass[regi] = CLASS_SSEDP; @@ -775,6 +787,13 @@ trav_struct(int dtype, int off) regclass[0] = CLASS_SSEDP; regclass[1] = CLASS_SSEDP; return; + // AOCC begin + case TY_QCMPLX: + assert(regi == 0, "trav_struct - bad offset for QCMPLX", off, 3); + regclass[0] = CLASS_SSEQP; + regclass[1] = CLASS_SSEQP; + return; + // AOCC end case TY_STRUCT: case TY_DERIVED: /* regclass will be the sum of the members in its eightbyte */ diff --git a/tools/flang1/flang1exe/lower.h b/tools/flang1/flang1exe/lower.h index c5a14566ee..2f8bcaa7c4 100644 --- a/tools/flang1/flang1exe/lower.h +++ b/tools/flang1/flang1exe/lower.h @@ -4,6 +4,10 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ /** \file lower.h \brief definitions for Fortran front-end's lower module @@ -184,7 +188,7 @@ void lower_check_generics(void); struct lower_syms { int license, localmode, ptr0, ptr0c; - int intzero, intone, realzero, dblezero; + int intzero, intone, realzero, dblezero, quadzero; /* pointers for functions: loc, exit, allocate */ int loc, exit, alloc, alloc_chk, ptr_alloc, dealloc, dealloc_mbr, lmalloc, lfree; @@ -243,15 +247,18 @@ typedef struct { int refd_list; /* linked list of pointer/offset/section descriptors in the order they * need to be given addresses */ } lower_symbol_lists; +#ifndef _LOWEREXP_CPP_ +extern +#endif STG_DECLARE(lsymlists, lower_symbol_lists); #define LOWER_MEMBER_PARENT(x) lsymlists.stg_base[x].member_parent #define LOWER_SYMBOL_REPLACE(x) lsymlists.stg_base[x].symbol_replace #define LOWER_POINTER_LIST(x) lsymlists.stg_base[x].pointer_list #define LOWER_REFD_LIST(x) lsymlists.stg_base[x].refd_list -int *lower_argument; -int lower_argument_size; -int lower_line; +extern int *lower_argument; +extern int lower_argument_size; +extern int lower_line; /* only one of thenlabel and elselabel should be nonzero; * the other is the 'fall through' case */ @@ -259,8 +266,8 @@ typedef struct { int thenlabel, elselabel, endlabel; } iflabeltype; -int lower_disable_ptr_chk; -int lower_disable_subscr_chk; +extern int lower_disable_ptr_chk; +extern int lower_disable_subscr_chk; /* types of entries pushed onto the stack */ #define STKDO 1 @@ -357,6 +364,7 @@ int lowersym_pghpf_cmem(int *whichmem); #define CLASS_MEM 13 #define CLASS_FSTK 14 // TODO: UNUSEDS delete #define CLASS_PTR 15 +#define CLASS_SSEQP 16 /* mostly used for small structs passed in regs stuff.*/ /* These values must be kept insync with the values in the BE file exp_rte.c */ diff --git a/tools/flang1/flang1exe/lowerexp.c b/tools/flang1/flang1exe/lowerexp.c index baf0c7bbd7..5646fd10ac 100644 --- a/tools/flang1/flang1exe/lowerexp.c +++ b/tools/flang1/flang1exe/lowerexp.c @@ -5,6 +5,54 @@ * */ +/* + * + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading + * Support for DNORM intrinsic + * + * Date of Modification: 21st February 2019 + * + * Support for parity intrinsic. + * Month of Modification: July 2019 + * + * Support for Bit transformational intrinsic iany, iall, iparity. + * Month of Modification: July 2019 + * + * Complex datatype support for acosh , asinh , atanh + * Modified on 07 January 2020 + * + * Changes to support AMDGPU OpenMP offloading + * Date of modification 12th February 2020 + * Date of modification 04th April 2020 + * + * Added support for quad precision + * Last modified: Feb 2020 + * + * Added code to support SHIFTA intrinsic + * Last modified: April 2020 + * + * Complex datatype support for atan2 under flag f2008 + * Modified on 13th March 2020 + * + * Last modified: May 2020 + * + * Support for real*16 instrinsics + * Date of modification: 18th July 2020 + * + * Implemented rank intrinsic + * Date of modification: 10th Aug 2020 + * + * Added code support for dasinh + * Modified on 31st Aug 2020 + * + * Added code support for cotan + * Modified on Oct 2020 + * + */ + /** \file \brief Routines used by lower.c for lowering to ILMs @@ -27,6 +75,7 @@ #include "rtlRtns.h" #define INSIDE_LOWER +#define _LOWEREXP_CPP_ #include "lower.h" static LOGICAL lower_check_ast(int ast, int *unused); @@ -83,6 +132,12 @@ conv_bint_ilm(int ast, int ilm, int dtype) ilm = plower("oi", "DFIX", ilm); ilm = plower("oi", "ITOSC", ilm); break; + // AOCC begin + case TY_QUAD: + ilm = plower("oi", "QFIX", ilm); + ilm = plower("oi", "ITOSC", ilm); + break; + // AOCC end case TY_CMPLX: ilm = plower("oi", "REAL", ilm); ilm = plower("oi", "FIX", ilm); @@ -93,6 +148,13 @@ conv_bint_ilm(int ast, int ilm, int dtype) ilm = plower("oi", "DFIX", ilm); ilm = plower("oi", "ITOSC", ilm); break; + // AOCC begin + case TY_QCMPLX: + ilm = plower("oi", "QREAL", ilm); + ilm = plower("oi", "QFIX", ilm); + ilm = plower("oi", "ITOSC", ilm); + break; + // AOCC end case TY_WORD: if (ast && A_TYPEG(ast) == A_CNST) { s = lower_getintcon(cngcon(CONVAL2G(A_SPTRG(ast)), DTYG(dtype), DT_INT4)); @@ -176,6 +238,12 @@ conv_sint_ilm(int ast, int ilm, int dtype) ilm = plower("oi", "FIX", ilm); ilm = plower("oi", "ITOS", ilm); break; + // AOCC begin + case TY_QUAD: + ilm = plower("oi", "QFIX", ilm); + ilm = plower("oi", "ITOS", ilm); + break; + // AOCC end case TY_DBLE: ilm = plower("oi", "DFIX", ilm); ilm = plower("oi", "ITOS", ilm); @@ -190,6 +258,13 @@ conv_sint_ilm(int ast, int ilm, int dtype) ilm = plower("oi", "DFIX", ilm); ilm = plower("oi", "ITOS", ilm); break; + // AOCC begin + case TY_QCMPLX: + ilm = plower("oi", "QREAL", ilm); + ilm = plower("oi", "QFIX", ilm); + ilm = plower("oi", "ITOS", ilm); + break; + // AOCC end case TY_WORD: if (ast && A_TYPEG(ast) == A_CNST) { s = lower_getintcon(cngcon(CONVAL2G(A_SPTRG(ast)), DTYG(dtype), DT_INT4)); @@ -280,6 +355,11 @@ conv_int_ilm(int ast, int ilm, int dtype) case TY_DBLE: ilm = plower("oi", "DFIX", ilm); break; + // AOCC begin + case TY_QUAD: + ilm = plower("oi", "QFIX", ilm); + break; + // AOCC end case TY_CMPLX: ilm = plower("oi", "REAL", ilm); ilm = plower("oi", "FIX", ilm); @@ -288,6 +368,12 @@ conv_int_ilm(int ast, int ilm, int dtype) ilm = plower("oi", "DREAL", ilm); ilm = plower("oi", "DFIX", ilm); break; + // AOCC begin + case TY_QCMPLX: + ilm = plower("oi", "QREAL", ilm); + ilm = plower("oi", "QFIX", ilm); + break; + // AOCC end case TY_WORD: if (ast && A_TYPEG(ast) == A_CNST) { s = lower_getintcon(cngcon(CONVAL2G(A_SPTRG(ast)), DTYG(dtype), DT_INT4)); @@ -370,6 +456,11 @@ conv_int8_ilm(int ast, int ilm, int dtype) case TY_DBLE: ilm = plower("oi", "KDFIX", ilm); break; + // AOCC begin + case TY_QUAD: + ilm = plower("oi", "KQFIX", ilm); + break; + // AOCC end case TY_CMPLX: ilm = plower("oi", "REAL", ilm); ilm = plower("oi", "KFIX", ilm); @@ -378,6 +469,12 @@ conv_int8_ilm(int ast, int ilm, int dtype) ilm = plower("oi", "DREAL", ilm); ilm = plower("oi", "KDFIX", ilm); break; + // AOCC begin + case TY_QCMPLX: + ilm = plower("oi", "QREAL", ilm); + ilm = plower("oi", "KQFIX", ilm); + break; + // AOCC end case TY_WORD: if (ast && A_TYPEG(ast) == A_CNST) { s = cngcon(CONVAL2G(A_SPTRG(ast)), DTYG(dtype), DT_INT8); @@ -467,6 +564,11 @@ conv_word_ilm(int ast, int ilm, int dtype) case TY_DBLE: ilm = plower("oi", "DTOUI", ilm); break; + // AOCC begin + case TY_QUAD: + ilm = plower("oi", "QTOUI", ilm); + break; + // AOCC end case TY_CMPLX: ilm = plower("oi", "CTOUDI", ilm); ilm = plower("oi", "UDITOUI", ilm); @@ -475,6 +577,12 @@ conv_word_ilm(int ast, int ilm, int dtype) ilm = plower("oi", "CDTOUDI", ilm); ilm = plower("oi", "UDITOUI", ilm); break; + // AOCC begin + case TY_QCMPLX: + ilm = plower("oi", "CQTOUDI", ilm); + ilm = plower("oi", "UQITOUI", ilm); + break; + // AOCC end case TY_WORD: break; case TY_DWORD: @@ -534,6 +642,11 @@ conv_dword_ilm(int ast, int ilm, int dtype) case TY_DBLE: ilm = plower("oi", "D2K", ilm); break; + // AOCC begin + case TY_QUAD: + ilm = plower("oi", "Q2K", ilm); + break; + // AOCC end case TY_CMPLX: ilm = plower("oi", "CTOUDI", ilm); ilm = plower("oi", "UDITOD", ilm); @@ -544,6 +657,13 @@ conv_dword_ilm(int ast, int ilm, int dtype) ilm = plower("oi", "UDITOD", ilm); ilm = plower("oi", "D2K", ilm); break; + // AOCC begin + case TY_QCMPLX: + ilm = plower("oi", "CQTOUDI", ilm); + ilm = plower("oi", "UQITOD", ilm); + ilm = plower("oi", "Q2K", ilm); + break; + // AOCC end case TY_WORD: ilm = plower("oi", "UI2K", ilm); break; @@ -748,9 +868,11 @@ conv_log_ilm(int ast, int ilm, int dtype) break; case TY_REAL: case TY_DBLE: + case TY_QUAD: // AOCC case TY_LOG8: case TY_INT8: case TY_CMPLX: + case TY_QCMPLX: // AOCC case TY_DCMPLX: ilm = conv_int_ilm(ast, ilm, dtype); break; @@ -825,7 +947,9 @@ conv_log8_ilm(int ast, int ilm, int dtype) case TY_INT8: break; case TY_DBLE: + case TY_QUAD: // AOCC case TY_CMPLX: + case TY_QCMPLX: // AOCC case TY_DCMPLX: ilm = conv_int8_ilm(ast, ilm, dtype); break; @@ -879,6 +1003,11 @@ conv_real_ilm(int ast, int ilm, int dtype) case TY_DBLE: ilm = plower("oi", "SNGL", ilm); break; + // AOCC begin + case TY_QUAD: + ilm = plower("oi", "SNGL", ilm); + break; + // AOCC end case TY_CMPLX: ilm = plower("oi", "REAL", ilm); break; @@ -886,6 +1015,12 @@ conv_real_ilm(int ast, int ilm, int dtype) ilm = plower("oi", "DREAL", ilm); ilm = plower("oi", "SNGL", ilm); break; + // AOCC begin + case TY_QCMPLX: + ilm = plower("oi", "QREAL", ilm); + ilm = plower("oi", "SNGL", ilm); + break; + // AOCC end case TY_WORD: if (ast && A_TYPEG(ast) == A_CNST) { s = lower_getrealcon( @@ -955,6 +1090,11 @@ conv_dble_ilm(int ast, int ilm, int dtype) break; case TY_DBLE: break; + // AOCC begin + case TY_QUAD: + ilm = plower("oi", "DBLE", ilm); + break; + // AOCC end case TY_CMPLX: ilm = plower("oi", "REAL", ilm); ilm = plower("oi", "DBLE", ilm); @@ -962,6 +1102,12 @@ conv_dble_ilm(int ast, int ilm, int dtype) case TY_DCMPLX: ilm = plower("oi", "DREAL", ilm); break; + // AOCC begin + case TY_QCMPLX: + ilm = plower("oi", "QREAL", ilm); + ilm = plower("oi", "DBLE", ilm); + break; + // AOCC end case TY_WORD: /* convert by padding with blanks or truncating */ if (ast && A_TYPEG(ast) == A_CNST) { @@ -996,6 +1142,80 @@ conv_dble_ilm(int ast, int ilm, int dtype) return ilm; } /* conv_dble_ilm */ +// AOCC begin +/* convert whatever type ilm is to QUAD */ +static int +conv_quad_ilm(int ast, int ilm, int dtype) +{ + int s; + switch (DTYG(dtype)) { + case TY_BINT: + case TY_BLOG: + case TY_SINT: + case TY_SLOG: + ilm = conv_int_ilm(ast, ilm, dtype); + case TY_LOG: + case TY_INT: + ilm = plower("oi", "QFLOAT", ilm); + break; + case TY_LOG8: + case TY_INT8: + ilm = plower("oi", "QFLOATK", ilm); + break; + case TY_REAL: + ilm = plower("oi", "QUAD", ilm); + break; + case TY_DBLE: + ilm = plower("oi", "QUAD", ilm); + break; + case TY_QUAD: + break; + case TY_CMPLX: + ilm = plower("oi", "REAL", ilm); + ilm = plower("oi", "QUAD", ilm); + break; + case TY_DCMPLX: + ilm = plower("oi", "DREAL", ilm); + ilm = plower("oi", "QUAD", ilm); + break; + case TY_QCMPLX: + ilm = plower("oi", "QREAL", ilm); + break; + case TY_WORD: + /* convert by padding with blanks or truncating */ + if (ast && A_TYPEG(ast) == A_CNST) { + s = cngcon(CONVAL4G(A_SPTRG(ast)), DTYG(dtype), DT_QUAD); + ilm = plower("oS", "QCON", s); + } else { + ilm = plower("oi", "UITOD", ilm); + } + break; + case TY_DWORD: + /* convert by padding with blanks or truncating */ + if (ast && A_TYPEG(ast) == A_CNST) { + s = cngcon(A_SPTRG(ast), DTYG(dtype), DT_QUAD); + ilm = plower("oS", "QCON", s); + } else { + ilm = plower("oi", "K2Q", ilm); + } + break; + case TY_HOLL: + /* convert by padding with blanks or truncating */ + if (ast && A_TYPEG(ast) == A_CNST) { + s = cngcon(A_SPTRG(ast), DTYG(dtype), DT_QUAD); + ilm = plower("oS", "QCON", s); + } else { + ast_error("unknown hollerith type for conversion to real*16", ast); + } + break; + default: + ast_error("unknown source type for conversion to quad precision", ast); + break; + } + return ilm; +} /* conv_quad_ilm */ +// AOCC end + /* convert whatever type ast is to DBLE */ static int conv_dble(int ast) @@ -1003,6 +1223,15 @@ conv_dble(int ast) return conv_dble_ilm(ast, lower_ilm(ast), A_NDTYPEG(ast)); } /* conv_dble */ +// AOCC begin +/* convert whatever type ast is to QUAD */ +static int +conv_quad(int ast) +{ + return conv_quad_ilm(ast, lower_ilm(ast), A_NDTYPEG(ast)); +} /* conv_quad */ +// AOCC end + /* convert whatever type ilm is to CMPLX */ static int conv_cmplx_ilm(int ast, int ilm, int dtype) @@ -1036,6 +1265,13 @@ conv_cmplx_ilm(int ast, int ilm, int dtype) ilmimag = plower("oS", "RCON", lowersym.realzero); ilm = plower("oii", "CMPLX", ilm, ilmimag); break; + // AOCC begin + case TY_QUAD: + ilm = plower("oi", "SNGL", ilm); + ilmimag = plower("oS", "RCON", lowersym.realzero); + ilm = plower("oii", "CMPLX", ilm, ilmimag); + break; + // AOCC end case TY_CMPLX: break; case TY_DCMPLX: @@ -1045,6 +1281,15 @@ conv_cmplx_ilm(int ast, int ilm, int dtype) ilmreal = plower("oi", "SNGL", ilmreal); ilm = plower("oii", "CMPLX", ilmreal, ilmimag); break; + // AOCC begin + case TY_QCMPLX: + ilmimag = plower("oi", "QIMAG", ilm); + ilmimag = plower("oi", "SNGL", ilmimag); + ilmreal = plower("oi", "QREAL", ilm); + ilmreal = plower("oi", "SNGL", ilmreal); + ilm = plower("oii", "CMPLX", ilmreal, ilmimag); + break; + // AOCC end case TY_WORD: if (ast && A_TYPEG(ast) == A_CNST) { s = lower_getrealcon( @@ -1112,6 +1357,13 @@ conv_dcmplx_ilm(int ast, int ilm, int dtype) ilmimag = plower("oS", "DCON", lowersym.dblezero); ilm = plower("oii", "DCMPLX", ilm, ilmimag); break; + // AOCC begin + case TY_QUAD: + ilm = plower("oi", "DBLE", ilm); + ilmimag = plower("oS", "DCON", lowersym.dblezero); + ilm = plower("oii", "DCMPLX", ilm, ilmimag); + break; + // AOCC end case TY_CMPLX: ilmimag = plower("oi", "IMAG", ilm); ilmimag = plower("oi", "DBLE", ilmimag); @@ -1121,6 +1373,15 @@ conv_dcmplx_ilm(int ast, int ilm, int dtype) break; case TY_DCMPLX: break; + // AOCC begin + case TY_QCMPLX: + ilmimag = plower("oi", "QIMAG", ilm); + ilmimag = plower("oi", "DBLE", ilmimag); + ilmreal = plower("oi", "QREAL", ilm); + ilmreal = plower("oi", "DBLE", ilmreal); + ilm = plower("oii", "DCMPLX", ilmreal, ilmimag); + break; + // AOCC end case TY_WORD: if (ast && A_TYPEG(ast) == A_CNST) { s = cngcon(CONVAL2G(A_SPTRG(ast)), DTYG(dtype), DT_REAL8); @@ -1157,6 +1418,96 @@ conv_dcmplx_ilm(int ast, int ilm, int dtype) return ilm; } /* conv_dcmplx_ilm */ +// AOCC begin +/* convert whatever type ilm is to DCMPLX */ +static int +conv_qcmplx_ilm(int ast, int ilm, int dtype) +{ + int ilmimag, ilmreal, s; + switch (DTYG(dtype)) { + case TY_BINT: + case TY_BLOG: + case TY_SINT: + case TY_SLOG: + ilm = conv_int_ilm(ast, ilm, dtype); + case TY_LOG: + case TY_INT: + ilm = plower("oi", "QFLOAT", ilm); + ilmimag = plower("oS", "QCON", lowersym.quadzero); + ilm = plower("oii", "QCMPLX", ilm, ilmimag); + break; + case TY_LOG8: + case TY_INT8: + ilm = plower("oi", "QFLOATK", ilm); + ilmimag = plower("oS", "QCON", lowersym.quadzero); + ilm = plower("oii", "QCMPLX", ilm, ilmimag); + break; + case TY_REAL: + ilm = plower("oi", "QUAD", ilm); + ilmimag = plower("oS", "QCON", lowersym.quadzero); + ilm = plower("oii", "QCMPLX", ilm, ilmimag); + break; + case TY_DBLE: + ilm = plower("oi", "QUAD", ilm); + ilmimag = plower("oS", "QCON", lowersym.quadzero); + ilm = plower("oii", "QCMPLX", ilm, ilmimag); + break; + case TY_QUAD: + ilmimag = plower("oS", "QCON", lowersym.quadzero); + ilm = plower("oii", "QCMPLX", ilm, ilmimag); + break; + case TY_CMPLX: + ilmimag = plower("oi", "IMAG", ilm); + ilmimag = plower("oi", "QUAD", ilmimag); + ilmreal = plower("oi", "REAL", ilm); + ilmreal = plower("oi", "QUAD", ilmreal); + ilm = plower("oii", "QCMPLX", ilmreal, ilmimag); + break; + case TY_DCMPLX: + ilmimag = plower("oi", "DIMAG", ilm); + ilmimag = plower("oi", "QUAD", ilmimag); + ilmreal = plower("oi", "DREAL", ilm); + ilmreal = plower("oi", "QUAD", ilmreal); + ilm = plower("oii", "QCMPLX", ilmreal, ilmimag); + break; + case TY_QCMPLX: + break; + case TY_WORD: + if (ast && A_TYPEG(ast) == A_CNST) { + s = cngcon(CONVAL2G(A_SPTRG(ast)), DTYG(dtype), DT_REAL8); + ilmreal = plower("oS", "QCON", s); + } else { + ilmreal = plower("oi", "UITOQ", ilm); + } + ilmimag = plower("oS", "QCON", lowersym.quadzero); + ilm = plower("oii", "QCMPLX", ilmreal, ilmimag); + break; + case TY_DWORD: + if (ast && A_TYPEG(ast) == A_CNST) { + s = cngcon(A_SPTRG(ast), DTYG(dtype), DT_REAL8); + ilmreal = plower("oS", "QCON", s); + } else { + ilmreal = plower("oi", "K2Q", ilm); + } + ilmimag = plower("oS", "QCON", lowersym.quadzero); + ilm = plower("oii", "QCMPLX", ilmreal, ilmimag); + break; + case TY_HOLL: + /* convert by padding with blanks or truncating */ + if (ast && A_TYPEG(ast) == A_CNST) { + s = cngcon(A_SPTRG(ast), DTYG(dtype), DT_CMPLX32); + ilm = plower("oS", "CQCON", s); + } else { + ast_error("unknown hollerith type for conversion to complex*32", ast); + } + break; + default: + ast_error("unknown source type for conversion to complex*32", ast); + break; + } + return ilm; +} /* conv_qcmplx_ilm */ +// AOCC end /* convert whatever type ast is to DCMPLX */ static int conv_dcmplx(int ast) @@ -1164,6 +1515,15 @@ conv_dcmplx(int ast) return conv_dcmplx_ilm(ast, lower_ilm(ast), A_NDTYPEG(ast)); } /* conv_dcmplx */ +// AOCC begin +/* convert whatever type ast is to QCMPLX */ +static int +conv_qcmplx(int ast) +{ + return conv_qcmplx_ilm(ast, lower_ilm(ast), A_NDTYPEG(ast)); +} /* conv_qcmplx */ +// AOCC end + int lower_conv_ilm(int ast, int ilm, int fromdtype, int todtype) { @@ -1198,12 +1558,22 @@ lower_conv_ilm(int ast, int ilm, int fromdtype, int todtype) case TY_DBLE: ilm = conv_dble_ilm(ast, ilm, fromdtype); break; + // AOCC begin + case TY_QUAD: + ilm = conv_quad_ilm(ast, ilm, fromdtype); + break; + // AOCC end case TY_CMPLX: ilm = conv_cmplx_ilm(ast, ilm, fromdtype); break; case TY_DCMPLX: ilm = conv_dcmplx_ilm(ast, ilm, fromdtype); break; + // AOCC begin + case TY_QCMPLX: + ilm = conv_qcmplx_ilm(ast, ilm, fromdtype); + break; + // AOCC end case TY_WORD: ilm = conv_word_ilm(ast, ilm, fromdtype); break; @@ -1258,12 +1628,22 @@ lower_conv(int ast, int dtype) case TY_DBLE: ilm = conv_dble(ast); break; + // AOCC begin + case TY_QUAD: + ilm = conv_quad(ast); + break; + // AOCC end case TY_CMPLX: ilm = conv_cmplx(ast); break; case TY_DCMPLX: ilm = conv_dcmplx(ast); break; + // AOCC begin + case TY_QCMPLX: + ilm = conv_qcmplx(ast); + break; + // AOCC end case TY_WORD: ilm = conv_word(ast); break; @@ -1310,12 +1690,22 @@ ltyped(char *opname, int dtype) case TY_DBLE: strcpy(OP, "D"); break; + // AOCC begin + case TY_QUAD: + strcpy(OP, "Q"); + break; + // AOCC end case TY_CMPLX: strcpy(OP, "C"); break; case TY_DCMPLX: strcpy(OP, "CD"); break; + // AOCC begin + case TY_QCMPLX: + strcpy(OP, "CQ"); + break; + // AOCC end case TY_BLOG: case TY_SLOG: case TY_LOG: @@ -1356,12 +1746,22 @@ styped(char *opname, int dtype) case TY_DBLE: strcpy(OP, "D"); break; + // AOCC begin + case TY_QUAD: + strcpy(OP, "Q"); + break; + // AOCC end case TY_CMPLX: strcpy(OP, "C"); break; case TY_DCMPLX: strcpy(OP, "CD"); break; + // AOCC begin + case TY_QCMPLX: + strcpy(OP, "CQ"); + break; + // AOCC end case TY_BLOG: case TY_SLOG: case TY_LOG: @@ -1402,8 +1802,10 @@ lower_bin_arith(int ast, char *opname, int ldtype, int rdtype) case TY_INT8: case TY_REAL: case TY_DBLE: + case TY_QUAD: // AOCC case TY_CMPLX: case TY_DCMPLX: + case TY_QCMPLX: // AOCC case TY_WORD: case TY_DWORD: /* OK */ @@ -1418,8 +1820,6 @@ lower_bin_arith(int ast, char *opname, int ldtype, int rdtype) case TY_NCHAR: ast_error("character result for arithmetic operation", ast); return 0; - case TY_QUAD: - case TY_QCMPLX: default: ast_error("unknown result for arithmetic operation", ast); return 0; @@ -1447,10 +1847,10 @@ lower_un_arith(int ast, char *opname, int ldtype) case TY_INT8: case TY_REAL: case TY_DBLE: - case TY_QUAD: + case TY_QUAD: // AOCC case TY_CMPLX: case TY_DCMPLX: - case TY_QCMPLX: + case TY_QCMPLX: // AOCC case TY_WORD: case TY_DWORD: break; @@ -1503,10 +1903,10 @@ lower_bin_comparison(int ast, char *op) case TY_REAL: case TY_DBLE: - case TY_QUAD: + case TY_QUAD: // AOCC case TY_CMPLX: case TY_DCMPLX: - case TY_QCMPLX: + case TY_QCMPLX: // AOCC ast_error("arithmetic result for comparison operation", ast); return 0; case TY_CHAR: @@ -1530,6 +1930,7 @@ lower_bin_comparison(int ast, char *op) case TY_INT8: case TY_REAL: case TY_DBLE: + case TY_QUAD: // AOCC case TY_CMPLX: case TY_DCMPLX: break; @@ -1551,8 +1952,8 @@ lower_bin_comparison(int ast, char *op) case TY_NCHAR: base = 1; break; - case TY_QUAD: case TY_QCMPLX: + break; default: ast_error("unknown operand type for comparison operation", ast); return 0; @@ -1581,6 +1982,7 @@ add_lnop(int ilm, int ast, int dtype) case OP_LNEQV: case OP_LEQV: case OP_LOR: + case OP_LXOR: case OP_LAND: case OP_SCAND: return ilm; @@ -1946,6 +2348,7 @@ lower_function(int ast) switch (DTYG(dtype)) { case TY_CMPLX: case TY_DCMPLX: + case TY_QCMPLX: // AOCC functmpinc = 1; /* count the function temp as an extra argument */ ++functmpcount; functmp = lower_scalar_temp(dtype); @@ -2399,6 +2802,12 @@ intrin_name(char *name, int ast, int options) prefix = "D"; } break; + case TY_QUAD: + ok = options & allowD; + if (options & prefixD) { + prefix = "Q"; + } + break; case TY_CMPLX: ok = options & allowC; if (options & prefixC) { @@ -2413,6 +2822,18 @@ intrin_name(char *name, int ast, int options) prefix = "D"; } break; + #if 1 + // AOCC begin + case TY_QCMPLX: + ok = options & allowCD; + if (options & prefixCD) { + prefix = "CQ"; + } else if (options & prefixCD) { + prefix = "Q"; + } + break; + // AOCC end + #endif case TY_CHAR: ok = options & allowchar; break; @@ -2478,13 +2899,14 @@ nearest_real_type(int dtype) { switch (DTY(dtype)) { case TY_DWORD: - case TY_QUAD: case TY_INT8: case TY_DBLE: case TY_DCMPLX: - case TY_QCMPLX: case TY_LOG8: return DT_DBLE; + case TY_QCMPLX: + case TY_QUAD: + return DT_QUAD; default: return DT_REAL; } @@ -2554,6 +2976,16 @@ intrinsic_arg_dtype(int intr, int ast, int args, int nargs) case I_COSD: case I_DCOSD: + /* AOCC begin */ + case I_COTAN: + case I_DCOTAN: + case I_QCOTAN: + + case I_COTAND: + case I_DCOTAND: + case I_QCOTAND: + /* AOCC end */ + case I_TAN: case I_DTAN: @@ -2586,6 +3018,7 @@ intrinsic_arg_dtype(int intr, int ast, int args, int nargs) case I_SINH: case I_DSINH: + case I_DASINH: case I_COSH: case I_DCOSH: @@ -2623,6 +3056,7 @@ intrinsic_arg_dtype(int intr, int ast, int args, int nargs) case I_CONJG: case I_DCONJG: + case I_QCONJG: // AOCC case I_IIDIM: case I_JIDIM: @@ -2679,7 +3113,9 @@ intrinsic_arg_dtype(int intr, int ast, int args, int nargs) case I_KISHFTC: case I_LSHIFT: case I_RSHIFT: - + /* AOCC begin */ + case I_SHIFTA: + /* AOCC end */ case I_IAND: case I_IOR: case I_IEOR: @@ -2696,6 +3132,9 @@ intrinsic_arg_dtype(int intr, int ast, int args, int nargs) case I_COMPL: case I_LEADZ: + /* AOCC begin */ + case I_TRAILZ: + /* AOCC end */ case I_POPCNT: case I_POPPAR: return A_NDTYPEG(ast); @@ -2792,12 +3231,27 @@ intrinsic_arg_dtype(int intr, int ast, int args, int nargs) case I_DBLE: return -1; + // AOCC begin + #if 0 + /* type conversion to double */ + case I_QFLOTI: + case I_QFLOAT: + case I_QFLOTJ: + #endif + case I_QREAL: + case I_QUAD: + return -1; + + case I_QIMAG: + // AOCC end case I_DIMAG: case I_AIMAG: case I_IMAG: /* return imaginary part */ if (A_NDTYPEG(ast) == DT_REAL8) return DT_CMPLX16; + if (A_NDTYPEG(ast) == DT_QUAD) + return DT_CMPLX32; return DT_CMPLX8; /* double precision product of reals */ @@ -2806,6 +3260,7 @@ intrinsic_arg_dtype(int intr, int ast, int args, int nargs) case I_CMPLX: case I_DCMPLX: + case I_QCMPLX: // AOCC return -1; /* ichar family */ @@ -2831,6 +3286,14 @@ intrinsic_arg_dtype(int intr, int ast, int args, int nargs) case I_LLT: return -1; + /* AOCC begin */ + case I_BGE: + case I_BGT: + case I_BLE: + case I_BLT: + return -1; + /* AOCC end */ + case I_LOC: case I_C_FUNLOC: case I_C_LOC: @@ -2878,6 +3341,9 @@ intrinsic_arg_dtype(int intr, int ast, int args, int nargs) case I_SET_EXPONENT: case I_VERIFY: case I_RAN: + // AOCC BEGIN + case I_ISNAN: + // AOCC END return -1; case I_ZEXT: @@ -2915,6 +3381,15 @@ intrinsic_arg_dtype(int intr, int ast, int args, int nargs) case I_ALL: case I_ANY: case I_COUNT: +#if 0 + // AOCC Begin + case I_IALL: + case I_IANY: + case I_IPARITY: + case I_PARITY: + case I_NORM2: + // AOCC End +#endif case I_DOT_PRODUCT: case I_NORM2: case I_MATMUL: @@ -2973,6 +3448,7 @@ intrinsic_arg_dtype(int intr, int ast, int args, int nargs) case I_SHIFTR: case I_DSHIFTL: case I_DSHIFTR: + case I_RANK: //AOCC default: return -1; } @@ -3033,6 +3509,9 @@ new_intrin_sym(int ast) int sptr = A_SPTRG(ast); switch (DTY(A_DTYPEG(ast))) { + case TY_QCMPLX: + ast_spec = GQCMPLXG(sptr); + break; case TY_DCMPLX: ast_spec = GDCMPLXG(sptr); break; @@ -3191,15 +3670,17 @@ lower_intrinsic(int ast) case I_HYPOT: ilm = intrin_name("HYPOT", ast, in_r_D); break; + //AOCC Begin case I_ACOSH: - ilm = intrin_name("ACOSH", ast, in_r_D); + ilm = intrin_name("ACOSH", ast, in_r_D_C_CD); break; case I_ASINH: - ilm = intrin_name("ASINH", ast, in_r_D); + ilm = intrin_name("ASINH", ast, in_r_D_C_CD); break; case I_ATANH: - ilm = intrin_name("ATANH", ast, in_r_D); + ilm = intrin_name("ATANH", ast, in_r_D_C_CD); break; + //AOCC End case I_BESSEL_J0: ilm = intrin_name("BESSEL_J0", ast, in_r_D); break; @@ -3230,8 +3711,17 @@ lower_intrinsic(int ast) /* atan2 family */ case I_ATAN2: case I_DATAN2: - ilm = intrin_name("ATAN2", ast, in_r_D); - break; + //AOCC begin + if (flg.std == F2008) { + ilm = intrin_name("ATAN2", ast, in_r_D_C_CD); + break; + } + else + { + ilm = intrin_name("ATAN2", ast, in_r_D); + break; + } + //AOCC end case I_ATAN2D: case I_DATAN2D: ilm = intrin_name("ATAN2D", ast, in_r_D); @@ -3251,6 +3741,7 @@ lower_intrinsic(int ast) /* cmplx */ case I_CMPLX: case I_DCMPLX: + case I_QCMPLX: // AOCC arg1 = ARGT_ARG(args, 0); arg2 = 0; if (nargs >= 2) @@ -3263,6 +3754,11 @@ lower_intrinsic(int ast) case TY_DCMPLX: ilm = lower_conv(arg1, DT_CMPLX16); break; + // AOCC begin + case TY_QCMPLX: + ilm = lower_conv(arg1, DT_CMPLX32); + break; + // AOCC end default: break; } @@ -3280,6 +3776,13 @@ lower_intrinsic(int ast) ilm2 = lower_conv(arg2, DT_REAL8); ilm = plower("oii", "DCMPLX", ilm, ilm2); break; + // AOCC begin + case TY_QCMPLX: + ilm = lower_conv(arg1, DT_QUAD); + ilm2 = lower_conv(arg2, DT_QUAD); + ilm = plower("oii", "QCMPLX", ilm, ilm2); + break; + // AOCC end default: break; } @@ -3292,6 +3795,9 @@ lower_intrinsic(int ast) case I_DCONJG: ilm = intrin_name("CONJG", ast, in_c_cD); break; + case I_QCONJG: //AOCC + ilm = intrin_name("QCONJG", ast, in_c_cD); + break; /* cos family */ case I_COS: @@ -3422,6 +3928,12 @@ lower_intrinsic(int ast) ilm = intrin_name("IMAG", ast, in_r_D); break; + // AOCC begin + case I_QIMAG: + ilm = intrin_name("IMAG", ast, in_r_D); + break; + // AOCC end + /* int family */ case I_IDINT: case I_JIDINT: @@ -3569,6 +4081,8 @@ lower_intrinsic(int ast) dty = DTYG(A_NDTYPEG(ast)); if (DTYG(A_NDTYPEG(ARGT_ARG(args, 0))) == TY_DBLE) { ilm = intrin_name("DNINT", ast, in_I_K); + } else if (DTYG(A_NDTYPEG(ARGT_ARG(args, 0))) == TY_QUAD) { + ilm = intrin_name("QNINT", ast, in_i_K); } else { ilm = intrin_name("NINT", ast, in_i_K); } @@ -3600,6 +4114,7 @@ lower_intrinsic(int ast) ilm = intrin_name("OR", ast, in_i_K); break; + case I_QREAL: // AOCC case I_DREAL: case I_REAL: arg = ARGT_ARG(args, 0); @@ -3614,6 +4129,12 @@ lower_intrinsic(int ast) ilm = plower("oi", "DREAL", ilm); argdtype = DT_REAL8; break; + // AOCC begin + case TY_QCMPLX: + ilm = plower("oi", "QREAL", ilm); + argdtype = DT_QUAD; + break; + // AOCC end default: break; } @@ -3647,6 +4168,12 @@ lower_intrinsic(int ast) ilm = intrin_name("SINH", ast, in_r_D); break; + // AOCC begin + case I_DASINH: + ilm = intrin_name("ASINH", ast, in_r_D); + break; + // AOCC end + /* sqrt family */ case I_SQRT: case I_DSQRT: @@ -3655,7 +4182,21 @@ lower_intrinsic(int ast) ilm = intrin_name("SQRT", ast, in_r_D_C_CD); break; - /* tan family */ + /* AOCC begin */ + case I_COTAN: + case I_DCOTAN: + case I_QCOTAN: + ilm = intrin_name("COTAN", ast, in_r_D); + break; + + case I_COTAND: + case I_DCOTAND: + case I_QCOTAND: + ilm = intrin_name("COTAND", ast, in_r_D); + break; + /* AOCC end */ + + /* tan family */ case I_TAN: case I_DTAN: ilm = intrin_name("TAN", ast, in_r_D); @@ -3697,15 +4238,27 @@ lower_intrinsic(int ast) case I_RSHIFT: ilm = intrin_name("URSHIFT", ast, in_i_K); break; + /* AOCC begin */ + case I_SHIFTA: + ilm = intrin_name("SHIFTA", ast, in_i_K); + break; + /* AOCC end */ /* sign family */ case I_IISIGN: case I_JISIGN: case I_KISIGN: case I_ISIGN: + /* AOCC begin */ + ilm = intrin_name("SIGN", ast, in_I_K_r_D); + break; case I_DSIGN: case I_SIGN: - ilm = intrin_name("SIGN", ast, in_I_K_r_D); + if (XBIT(64, 0x10)) + ilm = intrin_name("SIGNNZ", ast, in_I_K_r_D); + else + ilm = intrin_name("SIGN", ast, in_I_K_r_D); + /* AOCC end */ break; /* xor family */ @@ -3909,24 +4462,28 @@ lower_intrinsic(int ast) case TY_INT8: case TY_FLOAT: case TY_DBLE: + case TY_QUAD: case TY_BLOG: case TY_SLOG: case TY_LOG: case TY_LOG8: - for (i = 0; i < 2; i++) { - arg = ARGT_ARG(args, i); - lower_expression(arg); - intrinsic_args[i] = lower_ilm(arg); + if (!((A_TYPEG(ARGT_ARG(args,2)) == A_INTR + && (A_OPTYPEG(ARGT_ARG(args,2)) == I_PRESENT)))) { + for (i = 0; i < 2; i++) { + arg = ARGT_ARG(args, i); + lower_expression(arg); + intrinsic_args[i] = lower_ilm(arg); + } + intrinsic_args[2] = lower_conv(ARGT_ARG(args, 2), DT_LOG4); + ilm = intrin_name("MERGE", ast, in_Il_K_R_D_C_CD); + nargs = 3; + break; } - intrinsic_args[2] = lower_conv(ARGT_ARG(args, 2), DT_LOG4); - ilm = intrin_name("MERGE", ast, in_Il_K_R_D_C_CD); - nargs = 3; - break; default: /* just treat like a function call */ - if ((DTY(A_DTYPEG(ast)) == TY_CMPLX || DTY(A_DTYPEG(ast)) == TY_DCMPLX) && - (XBIT(70, 0x40000000))) { + if ((DTY(A_DTYPEG(ast)) == TY_CMPLX || DTY(A_DTYPEG(ast)) == TY_DCMPLX + || DTY(A_DTYPEG(ast)) == TY_QCMPLX) && (XBIT(70, 0x40000000))) { for (i = 0; i < 2; i++) { arg = ARGT_ARG(args, i); lower_expression(arg); @@ -3957,6 +4514,16 @@ lower_intrinsic(int ast) A_ILMP(ast, ilm); return ilm; + // AOCC BEGIN + case I_ISNAN: + arg = ARGT_ARG(args,0); + lower_expression(arg); + ilm = plower("oi", styped("ISNAN", A_DTYPEG(arg)), + lower_ilm(arg)); + A_ILMP(ast, ilm); + return ilm; + // AOCC END + case I_NLEN: ilm = intrin_name("NLEN", ast, in_i); break; @@ -4088,6 +4655,9 @@ lower_intrinsic(int ast) case TY_DBLE: rtlRtn = RTE_expondx; break; + case TY_QUAD: + rtlRtn = RTE_exponqx; + break; default: ast_error("unexpected argument type for exponent", ast); break; @@ -4100,6 +4670,9 @@ lower_intrinsic(int ast) case I_FRACTION: if (DTY(DDTG(A_NDTYPEG(ARGT_ARG(args, 0)))) == TY_REAL) { ilm = f90_value_function(mkRteRtnNm(RTE_fracx), DT_REAL4, args, nargs); + } else if (DTY(DDTG(A_NDTYPEG(ast))) == TY_QUAD) { + //AOCC + ilm = f90_value_function(mkRteRtnNm(RTE_fracqx), DT_QUAD, args, nargs); } else { ilm = f90_value_function(mkRteRtnNm(RTE_fracdx), DT_REAL8, args, nargs); } @@ -4109,14 +4682,22 @@ lower_intrinsic(int ast) if (DTY(DDTG(A_NDTYPEG(ast))) == TY_REAL) { ilm = f90_value_function(mkRteRtnNm(RTE_rrspacingx), DT_REAL4, args, nargs); - } else { - ilm = f90_value_function(mkRteRtnNm(RTE_rrspacingdx), DT_REAL8, args, + } else if (DTY(DDTG(A_NDTYPEG(ast))) == TY_QUAD){ + //AOCC + ilm = f90_value_function(mkRteRtnNm(RTE_rrspacingqx), DT_QUAD, args, nargs); + } else { + ilm = + f90_value_function(mkRteRtnNm(RTE_rrspacingdx), DT_REAL8, args, nargs); } break; case I_SPACING: if (DTY(DDTG(A_NDTYPEG(ast))) == TY_REAL) { ilm = f90_value_function(mkRteRtnNm(RTE_spacingx), DT_REAL4, args, nargs); + } else if (DTY(DDTG(A_NDTYPEG(ast))) == TY_QUAD){ + //AOCC + ilm = + f90_value_function(mkRteRtnNm(RTE_spacingqx), DT_QUAD, args, nargs); } else { ilm = f90_value_function(mkRteRtnNm(RTE_spacingdx), DT_REAL8, args, nargs); @@ -4125,15 +4706,21 @@ lower_intrinsic(int ast) case I_NEAREST: if (DTY(DDTG(A_NDTYPEG(ast))) == TY_REAL) { ilm = f90_value_function(mkRteRtnNm(RTE_nearestx), DT_REAL4, args, nargs); + } else if (DTY(DDTG(A_NDTYPEG(ast))) == TY_QUAD) { + //AOCC + ilm = f90_value_function(mkRteRtnNm(RTE_nearestqx), DT_QUAD, args, nargs); } else { - ilm = - f90_value_function(mkRteRtnNm(RTE_nearestdx), DT_REAL8, args, nargs); + ilm = f90_value_function(mkRteRtnNm(RTE_nearestdx), DT_REAL8, args, nargs); } break; case I_SCALE: if (DTY(DDTG(A_NDTYPEG(ast))) == TY_REAL) { ilm = f90_value_function_I2(mkRteRtnNm(RTE_scalex), DT_REAL4, args, nargs); + } else if (DTY(DDTG(A_NDTYPEG(ast))) == TY_QUAD){ + //AOCC + ilm = + f90_value_function_I2(mkRteRtnNm(RTE_scaleqx), DT_QUAD, args, nargs); } else { ilm = f90_value_function_I2(mkRteRtnNm(RTE_scaledx), DT_REAL8, args, nargs); @@ -4143,9 +4730,13 @@ lower_intrinsic(int ast) if (DTY(DDTG(A_NDTYPEG(ast))) == TY_REAL) { ilm = f90_value_function_I2(mkRteRtnNm(RTE_setexpx), DT_REAL4, args, nargs); - } else { - ilm = f90_value_function_I2(mkRteRtnNm(RTE_setexpdx), DT_REAL8, args, + } else if (DTY(DDTG(A_NDTYPEG(ast))) == TY_QUAD) { + //AOCC + ilm = f90_value_function_I2(mkRteRtnNm(RTE_setexpqx), DT_QUAD, args, nargs); + } else { + ilm = + f90_value_function_I2(mkRteRtnNm(RTE_setexpdx), DT_REAL8, args, nargs); } break; case I_VERIFY: @@ -4299,6 +4890,11 @@ lower_intrinsic(int ast) case I_LEADZ: ilm = intrin_name_bsik("LEADZ", ast); break; + /* AOCC begin */ + case I_TRAILZ: + ilm = intrin_name_bsik("TRAILZ", ast); + break; + /* AOCC end */ case I_POPCNT: ilm = intrin_name_bsik("POPCNT", ast); break; @@ -4322,6 +4918,8 @@ lower_intrinsic(int ast) ilm = intrin_name("TANH", ast, in_r_D_C_CD); else if (strcmp(nm, "tan") == 0) ilm = intrin_name("TAN", ast, in_r_D_C_CD); + else if (strcmp(nm, "cotan") == 0) + ilm = intrin_name("COTAN", ast, in_r_D_C_CD); //AOCC else { ast_error("unrecognized NEW INTRINSIC", ast); break; @@ -4337,6 +4935,13 @@ lower_intrinsic(int ast) case I_TIME: case I_MVBITS: + /* AOCC begin */ + case I_BGE: + case I_BGT: + case I_BLE: + case I_BLT: + /* AOCC end */ + case I_SECNDS: case I_DATE_AND_TIME: case I_RANDOM_NUMBER: @@ -4358,6 +4963,13 @@ lower_intrinsic(int ast) case I_ALL: case I_ANY: case I_COUNT: + // AOCC Begin + case I_IALL: + case I_IANY: + case I_IPARITY: + case I_PARITY: + case I_NORM2: + // AOCC End case I_DOT_PRODUCT: case I_MATMUL: case I_MATMUL_TRANSPOSE: @@ -4411,7 +5023,7 @@ lower_intrinsic(int ast) case I_DSHIFTR: case I_C_F_POINTER: case I_C_F_PROCPOINTER: - + case I_RANK: //AOCC default: ast_error("unknown intrinsic function", ast); return 0; @@ -4484,7 +5096,7 @@ lower_intrinsic(int ast) return ilm; } /* lower_intrinsic */ -#if AST_MAX != 165 +#if AST_MAX != 173 // AOCC - 169 + 1 + 1 #error "Need to edit lowerexp.c to add or delete A_... AST types" #endif @@ -4495,7 +5107,7 @@ lower_ast(int ast, int *unused) { int dtype, rdtype, lop, rop, lilm, rilm, ilm = 0, base = 0; int ss, ndim, i, sptr, checksubscr, pointersubscr; - int subscriptilm[10], subscriptilmx[10], lowerboundilm[10], upperboundilm[10]; + int subscriptilm[MAXSUBS], subscriptilmx[MAXSUBS], lowerboundilm[MAXSUBS], upperboundilm[MAXSUBS]; /* AOCC */ LOGICAL norm; dtype = A_DTYPEG(ast); @@ -4536,6 +5148,11 @@ lower_ast(int ast, int *unused) case OP_LOR: ilm = lower_bin_logical(ast, "LOR"); break; + // AOCC begin + case OP_LXOR: + ilm = lower_bin_logical(ast, "XOR"); + break; + // AOCC end case OP_MUL: ilm = lower_bin_arith(ast, "MUL", dtype, dtype); break; @@ -4601,6 +5218,14 @@ lower_ast(int ast, int *unused) case TY_DBLE: ilm = lower_bin_arith(ast, "TOD", dtype, dtype); break; + // AOCC begin + case TY_QCMPLX: + ilm = lower_bin_arith(ast, "TOCQ", dtype, dtype); + break; + case TY_QUAD: + ilm = lower_bin_arith(ast, "TOQ", dtype, dtype); + break; + // AOCC end default: ast_error("unexpected exponent type", ast); break; @@ -4657,6 +5282,11 @@ lower_ast(int ast, int *unused) rilm = lower_conv(A_ROPG(ast), DT_REAL8); ilm = plower("oii", "DCMPLX", lilm, rilm); break; + case TY_QCMPLX: + lilm = lower_conv(A_LOPG(ast), DT_QUAD); + rilm = lower_conv(A_ROPG(ast), DT_QUAD); + ilm = plower("oii", "QCMPLX", lilm, rilm); + break; default: ast_error("unknown operand type for (real,imag)", ast); break; @@ -4695,6 +5325,12 @@ lower_ast(int ast, int *unused) ilm = plower("oS", "DCON", sptr); base = ilm; break; + // AOCC begin + case TY_QUAD: + ilm = plower("oS", "QCON", sptr); + base = ilm; + break; + // AOCC end case TY_CMPLX: ilm = plower("oS", "CCON", sptr); base = ilm; @@ -4703,6 +5339,12 @@ lower_ast(int ast, int *unused) ilm = plower("oS", "CDCON", sptr); base = ilm; break; + // AOCC begin + case TY_QCMPLX: + ilm = plower("oS", "CQCON", sptr); + base = ilm; + break; + // AOCC begin case TY_BLOG: case TY_SLOG: case TY_LOG: @@ -4796,12 +5438,22 @@ lower_ast(int ast, int *unused) case TY_DBLE: ilm = conv_dble(lop); break; + // AOCC begin + case TY_QUAD: + ilm = conv_quad(lop); + break; + // AOCC end case TY_CMPLX: ilm = conv_cmplx(lop); break; case TY_DCMPLX: ilm = conv_dcmplx(lop); break; + // AOCC begin + case TY_QCMPLX: + ilm = conv_qcmplx(lop); + break; + // AOCC end case TY_CHAR: case TY_NCHAR: ilm = lower_ilm(lop); @@ -5450,6 +6102,10 @@ lower_ast(int ast, int *unused) case A_MP_ATOMICWRITE: case A_MP_ATOMICUPDATE: case A_MP_ATOMICCAPTURE: + case A_MP_USE_DEVICE_PTR: + case A_MP_USE_DEVICE_ADDR: // AOCC + case A_MP_IS_DEVICE_PTR: // AOCC + case A_MP_REQUIRESUNIFIEDSHAREDMEMORY: // AOCC default: ast_error("bad ast optype in expression", ast); break; @@ -5612,6 +6268,29 @@ lower_logical(int ast, iflabeltype *iflabp) lower_logical(A_ROPG(ast), iflabp); } break; + // AOCC begin + case OP_LXOR: + if (iflabp->thenlabel == 0) { + /* The incoming fall-through case is 'then'. + * brtrue(left) newlabel + * brfalse(right) elselabel + * newlabel: */ + nlab.thenlabel = lower_lab(); + nlab.elselabel = 0; + lower_logical(A_LOPG(ast), &nlab); + /* second operand can fall through if true, branch around if false */ + lower_logical(A_ROPG(ast), iflabp); + plower("oL", "LABEL", nlab.thenlabel); + lower_reinit(); + } else { + /* The incoming fall-through case is 'else'. + * brtrue(left) thenlabel + * brtrue(right) thenlabel */ + lower_logical(A_LOPG(ast), iflabp); + lower_logical(A_ROPG(ast), iflabp); + } + break; + // AOCC end case OP_LEQV: lower_expression(A_LOPG(ast)); lower_expression(A_ROPG(ast)); @@ -5691,8 +6370,10 @@ lower_logical(int ast, iflabeltype *iflabp) case TY_INT8: case TY_REAL: case TY_DBLE: + case TY_QUAD: // AOCC case TY_CMPLX: case TY_DCMPLX: + case TY_QCMPLX: // AOCC lower_expression(ast); ilm = A_ILMG(ast); ilm2 = plower("oS", "ICON", lowersym.intzero); diff --git a/tools/flang1/flang1exe/lowerilm.c b/tools/flang1/flang1exe/lowerilm.c index 4aed6691a1..bdfbee35a1 100644 --- a/tools/flang1/flang1exe/lowerilm.c +++ b/tools/flang1/flang1exe/lowerilm.c @@ -5,6 +5,29 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading + * Date of modification 20th January 2020 + * Date of modification 24th January 2020 + * Date of modification 04th February 2020 + * Date of modification 12th February 2020 + * Date of modification 04th April 2020 + * Date of modification 28th August 2020 + * + * Added support for quad precision + * Last modified: Feb 2020 + * + * Support for ifort's mm_prefetch intrinsic + * Last modified: Jun 2020 + * + * Added support for openmp schedule clause + * Last modified : March 2021 + * + */ + /** \file \brief Routines used by lower.c for lowering to ILMs. @@ -296,6 +319,8 @@ plower(char *fmt, ...) fprintf(lower_ilm_file, " l%d", d); ++pcount; break; + case 'q': + case 'Q': case 'd': case 'D': if (d < 0) { @@ -1000,7 +1025,7 @@ handle_arguments(int ast, int symfunc, int via_ptr) #endif if (CLASSG(tbp_bind) && VTOFFG(tbp_bind) && - (INVOBJG(tbp_bind) || NOPASSG(tbp_mem))) { /* NOPASS needs fixing */ + (INVOBJG(tbp_bind) /* || NOPASSG(tbp_mem) */)) { /* NOPASS needs fixing */ via_tbp = 1; if (NOPASSG(tbp_mem)) { tbp_nopass_arg = pass_sym_of_ast(A_LOPG(ast)); @@ -1016,6 +1041,9 @@ handle_arguments(int ast, int symfunc, int via_ptr) } else { via_tbp = 0; } + if (A_INVOKING_DESCG(ast) && (SCG(sym_of_ast(A_INVOKING_DESCG(ast))) == SC_PRIVATE)) { + via_tbp = 0; + } count = A_ARGCNTG(ast); NEED(count, lower_argument, int, lower_argument_size, count + 10); @@ -1995,7 +2023,7 @@ lower_do_stmt(int std, int ast, int lineno, int label) int doinitast, doendast, doincast, plast, plastdt; int dotop, dobottom, dotrip, doinc, dovar, dost, p_lb, p_ub; int doinitilm, doendilm, doincilm, dotripilm, lop, lilm, ilm; - int dtype, schedtype; + int dtype, schedtype, modifier; int hack, rilm, dest, src; plast = A_LASTVALG(ast); @@ -2107,6 +2135,20 @@ lower_do_stmt(int std, int ast, int lineno, int label) ilm = lower_ilm(doendast); doendilm = lower_conv_ilm(doendast, ilm, A_NDTYPEG(doendast), dtype); + // AOCC begin + /* fetching the modifier and assigning it to schedtype so + that extra argument to parallel loop is avoided. + Schedule type passed to the parallel loop is or-ed with + modifier which is passed as a new schedule type */ + if (A_SCHED_MODIFIERG(ast) == DI_MOD_NONMONOTONIC) { + schedtype = MP_MOD_NONMONOTONIC; + } else if (A_SCHED_MODIFIERG(ast) == DI_MOD_MONOTONIC) { + schedtype = MP_MOD_MONOTONIC; + } else if (A_SCHED_MODIFIERG(ast) == DI_MOD_SIMD) { + schedtype = MP_MOD_SIMD; + } + // AOCC end + if (A_TYPEG(ast) != A_MP_PDO || A_TASKLOOPG(ast)) { /* sequential DO: * doinc = doincilm @@ -2116,6 +2158,7 @@ lower_do_stmt(int std, int ast, int lineno, int label) * dovar = dovar + doinc * DOEND(lab,lab) */ + if (A_TASKLOOPG(ast)) { /* lower taskloop as a regular loop */ int ub; @@ -2289,6 +2332,7 @@ lower_do_stmt(int std, int ast, int lineno, int label) schedtype = 0x5; else schedtype = 0x1; + if (A_ORDEREDG(ast)) { if ((A_SCHED_TYPEG(ast) == DI_SCH_AUTO) || (A_SCHED_TYPEG(ast) == DI_SCH_RUNTIME)) { @@ -2438,10 +2482,25 @@ lower_do_stmt(int std, int ast, int lineno, int label) */ int ldotrip, ldotripilm, ncpusilm, lcpuilm, labo, dox, dovarilm, chunkast, chunkilm; - schedtype = 0x000; - if (A_SCHED_TYPEG(ast) == MP_SCH_DIST_STATIC) { - schedtype = MP_SCH_DIST_STATIC; + + // AOCC begin + if (A_SCHED_MODIFIERG(ast) != 0) { + schedtype = schedtype | (MP_SCH_ATTR_CHUNKED | MP_SCH_BLK_CYC); + } else { + // AOCC end + schedtype = 0x000 ; + if (flg.amdgcn_target) + schedtype = schedtype | MP_SCH_ATTR_CHUNKED; + if (A_SCHED_TYPEG(ast) == MP_SCH_DIST_STATIC) { + schedtype = MP_SCH_DIST_STATIC; + } + // AOCC Begin + else if (A_SCHED_TYPEG(ast) == MP_SCH_TEAMS_DIST) { + schedtype = MP_SCH_ATTR_DEVICEDIST; + } } + // AOCC End + llvm_omp_sched(std, ast, dtype, dotop, dobottom, dovar, plast, dotrip, doinitilm, doinc, doincilm, doendilm, schedtype, lineno); } else { @@ -2465,7 +2524,14 @@ lower_do_stmt(int std, int ast, int lineno, int label) */ int chunkilm, ncpusilm, lcpuilm, ostep, ostepilm, odovar, doend; int itrip, itop, ibottom, itripilm, iendilm, istepilm, iinitilm, chunkast; - schedtype = (MP_SCH_ATTR_CHUNKED | MP_SCH_BLK_CYC); + + // AOCC begin + if (A_SCHED_MODIFIERG(ast) != 0) { + schedtype = schedtype | (MP_SCH_ATTR_CHUNKED | MP_SCH_BLK_CYC); + } else { + schedtype = (MP_SCH_ATTR_CHUNKED | MP_SCH_BLK_CYC); + } + // AOCC end if (A_SCHED_TYPEG(ast) == MP_SCH_DIST_STATIC) { schedtype = schedtype | MP_SCH_DIST_STATIC; } @@ -3692,7 +3758,10 @@ lower_stmt(int std, int ast, int lineno, int label) } } lower_reinit(); - add_nullify(object); + // AOCC change + if ((A_MEM_ORDERG(A_SRCG(ast)) != A_SRCG(ast)) ) { + add_nullify(object); + } } lower_end_stmt(std); break; @@ -3792,12 +3861,22 @@ lower_stmt(int std, int ast, int lineno, int label) case TY_DBLE: plower("oii", "DST", lilm, rilm); break; + // AOCC begin + case TY_QUAD: + plower("oii", "QPST", lilm, rilm); + break; + // AOCC end case TY_CMPLX: plower("oii", "CST", lilm, rilm); break; case TY_DCMPLX: plower("oii", "CDST", lilm, rilm); break; + // AOCC begin + case TY_QCMPLX: + plower("oii", "CQST", lilm, rilm); + break; + // AOCC end case TY_CHAR: plower("oii", "SST", lilm, rilm); break; @@ -4323,6 +4402,75 @@ lower_stmt(int std, int ast, int lineno, int label) add_nullify(lop); lower_end_stmt(std); return; + + /* AOCC begin */ + case I_MM_PREFETCH: + { + lower_start_stmt(lineno, label, TRUE, std); + args = A_ARGSG(ast); + + lop = ARGT_ARG(args, 0); + rop = ARGT_ARG(args, 1); + + if (A_ARGCNTG(ast) == 1) { + /* if no hint is passed, then we pass default to prefetch_t0 */ + rop = mk_cval(3, DT_INT); + } + + /* + * ifort's documentation on mm_prefetch *doesn't* discourage the usage of + * literal integer values for hint. This is bad for portability! + * FOR_K_PREFETCH_XXX constants should only be encouraged. Due to this, we + * have to solve a mess which are as follows: + * + * In intel compilers: + * hint = 0 lowers to prefetch_t0 + * hint = 1 lowers to prefetch_t1 + * hint = 2 lowers to prefetch_t2 + * hint = 3 lowers to prefetch_nta + * + * while in clang (via __builtin_prefetch, which gets lowered to + * llvm.prefetch intrinsic) and gcc + * hint = 0 lowers to prefetch_nta + * hint = 1 lowers to prefetch_t2 + * hint = 2 lowers to prefetch_t1 + * hint = 3 lowers to prefetch_t0 + * + * We stick to intel's behaviour by rewriting the hint constant values + * since mm_prefetch in Fortran is, AFAIK, an ifort specific intrinsic. + */ + + int hint = CONVAL2G(A_SPTRG(rop)); + switch (hint) { + case 0: + rop = mk_cval(3, DT_INT); + break; + case 1: + rop = mk_cval(2, DT_INT); + break; + case 2: + rop = mk_cval(1, DT_INT); + break; + case 3: + rop = mk_cval(0, DT_INT); + break; + } + + /* + * The first argument is an "address" (lop here). It can be a scalar, + * array access etc. We explicitly emit a LOC() intrinsic here. + */ + lop = ast_intr(I_LOC, DT_PTR, 1, lop); + lower_expression(lop); + lower_expression(rop); + + plower("oii", "MM_PREFETCH", lower_ilm(lop), lower_ilm(rop)); + A_ILMP(ast, ilm); + lower_end_stmt(std); + return; + } + /* AOCC end */ + case I_COPYIN: symfunc = lower_makefunc(mkRteRtnNm(RTE_qopy_in), DT_NONE, FALSE); lower_start_stmt(lineno, label, TRUE, std); @@ -4581,6 +4729,7 @@ lower_stmt(int std, int ast, int lineno, int label) case TY_QUAD: case TY_CMPLX: case TY_DCMPLX: + case TY_QCMPLX: // AOCC case TY_BLOG: case TY_SLOG: case TY_LOG: @@ -4761,12 +4910,14 @@ lower_stmt(int std, int ast, int lineno, int label) flag = flag | 0x04; } - if (A_NPARG(ast) == 0) { + if (A_THRLIMITG(ast) == 0) { lilm = plower("oS", "ICON", lowersym.intzero); } else { - lower_expression(A_NPARG(ast)); - lilm = lower_conv(A_NPARG(ast), DT_LOG4); - flag = flag | 0x02; + lower_expression(A_THRLIMITG(ast)); + lilm = lower_conv(A_THRLIMITG(ast), DT_INT); + if (A_TYPEG(A_THRLIMITG(ast)) == A_ID) + plower("oS", "MP_NUMTHREADS", A_SPTRG(A_THRLIMITG(ast))); + flag = flag | 0x02; } proc_bind = 0; if (A_PROCBINDG(ast)) { @@ -4799,12 +4950,20 @@ lower_stmt(int std, int ast, int lineno, int label) } else { lower_expression(A_NTEAMSG(ast)); ilm = lower_conv(A_NTEAMSG(ast), DT_INT); + // AOCC Begin + if (A_TYPEG(A_NTEAMSG(ast)) == A_ID) + plower("oS", "MP_NUMTEAMS", A_SPTRG(A_NTEAMSG(ast))); + // AOCC End } if (A_THRLIMITG(ast) == 0) { lilm = plower("oS", "ICON", lowersym.intzero); } else { lower_expression(A_THRLIMITG(ast)); lilm = lower_conv(A_THRLIMITG(ast), DT_INT); + // AOCC Begin + if (A_TYPEG(A_THRLIMITG(ast)) == A_ID) + plower("oS", "MP_NUMTHREADS", A_SPTRG(A_THRLIMITG(ast))); + // AOCC End } ilm = plower("oii", "BTEAMSN", ilm, lilm); } else { @@ -4994,6 +5153,14 @@ lower_stmt(int std, int ast, int lineno, int label) lower_end_stmt(std); break; + case A_MP_REQUIRESUNIFIEDSHAREDMEMORY: + lower_start_stmt(lineno, label, TRUE, std); + // requires with clause usm is dumped with value (8) + // for other require clauses, appt values need to be dumped + plower("on", "REQUIRES", OMP_REQ_UNIFIED_SHARED_MEMORY); + lower_end_stmt(std); + break; + case A_MP_TASK: case A_MP_TASKLOOP: lowersym.task_depth++; @@ -5241,15 +5408,83 @@ lower_stmt(int std, int ast, int lineno, int label) ilm = plower("oin", "BTARGET", ilm, flag); lower_end_stmt(std); break; + // AOCC Begin + case A_MP_DEFAULTMAP: + lower_start_stmt(lineno, label, TRUE, std); + flag = A_PRAGMATYPEG(ast); + plower("on", "MP_DEFAULTMAP", flag); + lower_end_stmt(std); + break; + case A_MP_TARGETDECLARE: + lower_start_stmt(lineno, label, TRUE, std); + plower("o", "MP_TARGETDECLARE"); + lower_end_stmt(std); + break; + // AOCC End case A_MP_MAP: lower_start_stmt(lineno, label, TRUE, std); lop = A_LOPG(ast); + rop = A_ROPG(ast); // AOCC lower_expression(lop); - //todo ompaccel need to pass size and base flag = A_PRAGMATYPEG(STD_AST(std)); - plower("oin", "MP_MAP", lower_base(lop), flag); + // AOCC Begin + if (rop) { + lower_expression(rop); + //todo ompaccel need to pass size and base + plower("oini", "MP_MAP_MEM", lower_base(lop), flag, lower_base(rop)); + } else { + // AOCC End + //todo ompaccel need to pass size and base + plower("oin", "MP_MAP", lower_base(lop), flag); + } lower_end_stmt(std); break; + // AOCC Begin + case A_MP_IS_DEVICE_PTR: + lower_start_stmt(lineno, label, TRUE, std); + lop = A_LOPG(ast); + lower_expression(lop); + flag = A_PRAGMATYPEG(STD_AST(std)); + plower("oin", "MP_IS_DEVICE_PTR", lower_base(lop), flag); + lower_end_stmt(std); + break; + // AOCC End + case A_MP_USE_DEVICE_PTR: + lower_start_stmt(lineno, label, TRUE, std); + lop = A_LOPG(ast); + rop = A_ROPG(ast); // AOCC + lower_expression(lop); + flag = A_PRAGMATYPEG(STD_AST(std)); + // AOCC Begin + if (rop) { + lower_expression(rop); + //todo ompaccel need to pass size and base + plower("oini", "MP_USE_DEVICE_PTR", lower_base(lop), flag, lower_base(rop)); + } else { + // AOCC End + //todo ompaccel need to pass size and base + plower("oin", "MP_USE_DEVICE_PTR", lower_base(lop), flag); + } + lower_end_stmt(std); + break; + // AOCC Begin + case A_MP_USE_DEVICE_ADDR: + lower_start_stmt(lineno, label, TRUE, std); + lop = A_LOPG(ast); + rop = A_ROPG(ast); + lower_expression(lop); + flag = A_PRAGMATYPEG(STD_AST(std)); + if (rop) { + lower_expression(rop); + //todo ompaccel need to pass size and base + plower("oini", "MP_USE_DEVICE_ADDR", lower_base(lop), flag, lower_base(rop)); + } else { + //todo ompaccel need to pass size and base + plower("oin", "MP_USE_DEVICE_ADDR", lower_base(lop), flag); + } + lower_end_stmt(std); + break; + // AOCC End case A_MP_BREDUCTION: lower_start_stmt(lineno, label, TRUE, std); ilm = plower("o", "MP_BREDUCTION"); @@ -5288,6 +5523,12 @@ lower_stmt(int std, int ast, int lineno, int label) case A_MP_ENDDISTRIBUTE: break; + case A_MP_LOOP: + break; + + case A_MP_ELOOP: + break; + case A_MP_ETASKLOOP: --lowersym.task_depth; if (lowersym.parallel_depth == 0 && lowersym.task_depth == 0) @@ -5494,6 +5735,10 @@ lower_stmt(int std, int ast, int lineno, int label) case A_WHERE: ast_error("unsupported ast optype in statement", ast); break; + case A_ID: // TODO: + case A_SUBSCR: // TODO: + case A_BINOP: // TODO: + break; default: ast_error("unknown ast optype in statement", ast); break; @@ -5642,7 +5887,7 @@ lower_sptr(int sptr, int pointerval) } } } else { - if (STYPEG(sptr) == ST_MEMBER) { + if (STYPEG(sptr) == ST_MEMBER && pointerval != 0 /*AOCC*/) { /* special case this error: user has referenced an array with the wrong number of array indices */ if (SYMNAME(sptr) && strstr(SYMNAME(sptr), "$sd") != 0) @@ -5865,12 +6110,22 @@ lower_typeload(int dtype, int base) case TY_DBLE: ilm = plower("oi", "DLD", base); break; + // AOCC begin + case TY_QUAD: + ilm = plower("oi", "QPLD", base); + break; + // AOCC end case TY_CMPLX: ilm = plower("oi", "CLD", base); break; case TY_DCMPLX: ilm = plower("oi", "CDLD", base); break; + // AOCC begin + case TY_QCMPLX: + ilm = plower("oi", "CQLD", base); + break; + // AOCC end case TY_PTR: if (!XBIT(49, 0x20000000)) { ilm = plower("oir", "PLD", base, 0); @@ -5929,12 +6184,22 @@ lower_typestore(int dtype, int base, int rhs) case TY_DBLE: ilm = plower("oii", "DST", base, rhs); break; + // AOCC begin + case TY_QUAD: + ilm = plower("oii", "QPST", base, rhs); + break; + // AOCC end case TY_CMPLX: ilm = plower("oii", "CST", base, rhs); break; case TY_DCMPLX: ilm = plower("oii", "CDST", base, rhs); break; + // AOCC begin + case TY_QCMPLX: + ilm = plower("oii", "CQST", base, rhs); + break; + // AOCC end case TY_PTR: if (!XBIT(49, 0x20000000)) { ilm = plower("oii", "PST", base, rhs); @@ -6535,7 +6800,7 @@ lower_data_stmts(void) if (okaddr) { fprintf(lower_ilm_file, "Init Label:%d\n", dinitval); } else { - int dest, src, subs[7], ent, ast; + int dest, src, subs[MAXSUBS], ent, ast; /* AOCC */ if (size_of(DT_PTR) == size_of(DT_INT8)) { int v[4], sptr; v[2] = v[3] = 0; diff --git a/tools/flang1/flang1exe/lowersym.c b/tools/flang1/flang1exe/lowersym.c index 918b47895f..6df5332d59 100644 --- a/tools/flang1/flang1exe/lowersym.c +++ b/tools/flang1/flang1exe/lowersym.c @@ -4,6 +4,14 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Bug fixes. + * Date of Modification: December 2018 + * + */ /** \file @@ -30,6 +38,7 @@ #include "llmputil.h" #define INSIDE_LOWER +#define _LOWERSYM_CPP_ #include "lower.h" #include "dbg_out.h" void scan_for_dwarf_module(); @@ -96,8 +105,8 @@ enum LEN {ASSCHAR = -1, ADJCHAR = -2, DEFERCHAR = -3}; static bool has_opt_args(SPTR sptr) { - int i, psptr, nargs, dpdsc; - + int i, psptr, nargs, dpdsc; + if (STYPEG(sptr) != ST_ENTRY && STYPEG(sptr) != ST_PROC) { return false; } @@ -1256,6 +1265,7 @@ lower_init_sym(void) lowersym.intone = lower_getintcon(1); lowersym.realzero = stb.flt0; lowersym.dblezero = stb.dbl0; + lowersym.quadzero = stb.quad0; lowersym.ptrnull = lower_getnull(); if (XBIT(68, 0x1)) { lowersym.bnd.zero = stb.k0; @@ -2557,7 +2567,7 @@ lower_put_datatype(int dtype, int usage) putwhich("Complex16", "C16"); break; case TY_QCMPLX: - putwhich("Complex16", "C16"); + putwhich("Complex32", "C32"); // AOCC break; case TY_BLOG: @@ -3593,6 +3603,7 @@ lower_symbol(int sptr) case ST_STRUCT: case ST_UNION: case ST_VAR: + putval("lineno", LINENOG(sptr)); putbit("addrtaken", ADDRTKNG(sptr)); putbit("argument", ARGG(sptr)); putbit("assigned", ASSNG(sptr)); @@ -3703,6 +3714,7 @@ lower_symbol(int sptr) if (stype == ST_ARRAY || stype == ST_DESCRIPTOR) { putbit("adjustable", ADJARRG(sptr)); putbit("afterentry", AFTENTG(sptr)); + putbit("assumedrank", ASSUMRANKG(sptr)); putbit("assumedshape", ASSUMSHPG(sptr)); putbit("assumedsize", ASUMSZG(sptr)); putbit("autoarray", @@ -3875,10 +3887,17 @@ lower_symbol(int sptr) puthex(CONVAL2G(sptr)); break; case TY_DCMPLX: + putsym("sym", CONVAL1G(sptr)); + putsym("sym", CONVAL2G(sptr)); + break; + // AOCC begin case TY_QCMPLX: putsym("sym", CONVAL1G(sptr)); putsym("sym", CONVAL2G(sptr)); + putsym("sym", CONVAL3G(sptr)); + putsym("sym", CONVAL4G(sptr)); break; + // AOCC end case TY_QUAD: puthex(CONVAL1G(sptr)); puthex(CONVAL2G(sptr)); @@ -4098,6 +4117,7 @@ lower_symbol(int sptr) retdesc == CLASS_PTR)) { switch (DTY(dtype)) { case TY_CMPLX: + case TY_QCMPLX: // AOCC case TY_DCMPLX: if (!CMPLXFUNC_C && FVALG(sptr)) fvallast = 1; @@ -4334,9 +4354,14 @@ lower_symbol(int sptr) break; case ST_PARAM: + putval("lineno", LINENOG(sptr)); putbit("decl", DCLDG(sptr)); putbit("private", PRIVATEG(sptr)); putbit("ref", REFG(sptr)); + if (STYPEG((SCOPEG(sptr))) == ST_MODULE) + putsym("scope", SCOPEG(sptr)); + else + putsym("scope", 0); if (TY_ISWORD(DTY(dtype))) { putval("val", CONVAL1G(sptr)); } else { diff --git a/tools/flang1/flang1exe/main.c b/tools/flang1/flang1exe/main.c index 453680f579..e699c63d71 100644 --- a/tools/flang1/flang1exe/main.c +++ b/tools/flang1/flang1exe/main.c @@ -1,3 +1,4 @@ + /* * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. * See https://llvm.org/LICENSE.txt for license information. @@ -5,6 +6,25 @@ * */ +/* + * + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading + * Month of modification : May 2019 - Added OMP offload support + * + * Modified for compiler_options() + * Date of modification: 21st May 2020 + * + * Disabling inliner for Offloading compilation + * Date of modification : 01st June 2020 + * + * Adding a new pass to move variable allocations to host code + * Date of modification : 26th Novemeber 2020 + * + */ + /** \file main.c \brief main program and initialization routines for fortran front-end */ @@ -37,6 +57,11 @@ #include "commopt.h" #include "scan.h" #include "hlvect.h" +// AOCC BEGIN +#ifdef DEBUG +#include "debug.h" +#endif // DEBUG +// AOCC END #define IPA_ENABLED 0 #define IPA_NO_ASM 0 @@ -83,6 +108,8 @@ static char *who[] = {"init", "parser", "bblock", "vectorize", "optimize", #define _N_WHO (sizeof(who) / sizeof(char *)) static INT xtimes[_N_WHO]; static LOGICAL postprocessing = TRUE; +char *flang_version_sha = {FLANG_SHA}; +//char *flang_version_sha[] = {FLANG_SHA}; /* Feature names for Fortran front-end */ #if defined(TARGET_LINUX_X8664) @@ -146,11 +173,15 @@ int main(int argc, char *argv[]) { int savescope, savecurrmod = 0; + char *extDirName = NULL; get_rutime(); init(argc, argv); /* initialize */ if (gbl.fn == NULL) gbl.fn = gbl.src_file; + // Disable inlining while offloading, or else it will conflict with + // declare target implementation + if (flg.omptarget) flg.inliner = false; // AOCC #if DEBUG if (debugfunconly > 0) dodebug = 0; @@ -180,6 +211,12 @@ main(int argc, char *argv[]) finish(); } } + if (flg.inliner) { + char template[] = "/tmp/tmpdir.XXXXXX"; + extDirName = mkdtemp(template); + if (extDirName) + extractor_command_info(extDirName,1, NULL); + } do { /* loop once for each user program unit */ #if DEBUG if (debugfunconly > 0) { @@ -206,8 +243,25 @@ main(int argc, char *argv[]) } else { TR(DNAME " PARSER begins\n") parser(); /* parse and do semantic analysis */ + + /* AOCC begin */ +#ifdef OMP_OFFLOAD_LLVM + if (flg.omptarget) { + ompaccel_ast_transform(); + } +#endif + /* AOCC end */ + + /* AOCC begin */ + /* to be used at a later call for checking inherited symbols from parent + * subprogram to child subprogram (if any). This is used by + * warn_uninit_use() */ + if (XBIT(1, 0x100000)) + remember_curr_symcnt(); + /* AOCC end */ set_tag(); } + gbl.func_count++; ccff_open_unit_f90(); if (gbl.internal <= 1) { @@ -407,6 +461,20 @@ main(int argc, char *argv[]) DUMP("convert-forall"); TR1("- after convert_forall"); + /* AOCC begin */ + /* We want to have all forall constructs to be in do-loop form so that + * we can fetch their "dovars" easily */ + if (XBIT(1, 0x100000)) + warn_uninit_use(); + /* AOCC end */ + +#ifdef OMP_OFFLOAD_LLVM + if (flg.omptarget) { + ompaccel_ast_alloc_array(); + ompaccel_ast_alloc_array2(); + } +#endif + TR(DNAME " CONVERT_OUTPUT begins\n"); convert_output(); TR1("- after convert_output"); @@ -522,6 +590,7 @@ main(int argc, char *argv[]) gbl.outerentries = gbl.entries; } stb.curr_scope = savescope; + if (flg.inliner) extractor(); // AOCC ccff_close_unit_f90(); } while (!gbl.eof_flag); finish(); /* finish does not return */ @@ -773,6 +842,11 @@ init(int argc, char *argv[]) /* x flags */ register_xflag_arg(arg_parser, "x", flg.x, (sizeof(flg.x) / sizeof(flg.x[0]))); + /* AOCC: z flags */ + register_xflag_arg(arg_parser, "z", flg.z, + (sizeof(flg.z) / sizeof(flg.z[0]))); + /* FIXME : temporary. Needs to be removed once the driver is updated */ + //set_xflag(68, 1); register_yflag_arg(arg_parser, "y", flg.x); /* Debug flags */ register_qflag_arg(arg_parser, "q", flg.dbg, @@ -800,11 +874,31 @@ init(int argc, char *argv[]) register_boolean_arg(arg_parser, "recursive", (bool *)&(flg.recursive), false); register_string_arg(arg_parser, "cmdline", &(flg.cmdline), NULL); + register_string_arg(arg_parser, "source_file", &(flg.source_file), NULL);//AOCC + register_boolean_arg(arg_parser, "func_args_alias", + (bool *)&(flg.func_args_alias), false); // AOCC + // AOCC begin + register_string_arg(arg_parser, "std", &flg.std_string, "unknown"); + register_boolean_arg(arg_parser, "disable-vectorize-pragmas", + (bool *)&(flg.disable_loop_vectorize_pragmas), false); + + // Debug Logs +#ifdef DEBUG + register_boolean_arg(arg_parser, "debug-log", (bool *)&(flg.debug_log), 0); + register_string_arg(arg_parser, "debug-only", &(flg.debug_only_strs), NULL); +#endif // DEBUG + // AOCC end register_boolean_arg(arg_parser, "es", (bool *)&(flg.es), false); register_boolean_arg(arg_parser, "pp", (bool *)&(flg.p), false); /* Set values form command line arguments */ parse_arguments(arg_parser, argc, argv); + // AOCC BEGIN + flg.source_file = sourcefile; +#ifdef DEBUG + DEBUG_LOG_INIT(flg.debug_log, flg.debug_only_strs); +#endif // DEBUG + // AOCC END /* Direct debug output */ if (was_value_set(arg_parser, &(flg.dbg)) || @@ -819,16 +913,37 @@ init(int argc, char *argv[]) } else if ((flg.dbg[0] & 1) || sourcefile == NULL) { gbl.dbgfil = stderr; } else { - if (ipa_import_mode) { - tempfile = mkfname(sourcefile, file_suffix, ".qdbh"); - } else { - tempfile = mkfname(sourcefile, file_suffix, ".qdbf"); - if ((gbl.dbgfil = fopen(tempfile, "w")) == NULL) - errfatal(5); - } + int index; + for (index = strlen(sourcefile) - 1; index > 0; index--) + if (sourcefile[index] == '.') + break; + if (index == 0) + index = strlen(sourcefile) - 1; /* file name has no suffix */ + tempfile = mkfname(sourcefile, &sourcefile[index], ".qdbf"); + if ((gbl.dbgfil = fopen(tempfile, "w")) == NULL) + errfatal(5); } } + // AOCC begin + /* setting the fortran standard */ + if (strcmp(flg.std_string, "f2008") == 0) { + flg.std = F2008; + } else if (strcmp(flg.std_string, "f2003") == 0) { + flg.std = F2003; + } else if (strcmp(flg.std_string, "f95") == 0) { + flg.std = F95; + } else if (strcmp(flg.std_string, "f90") == 0) { + flg.std = F90; + } else if (strcmp(flg.std_string, "f77") == 0) { + flg.std = F77; + } else if (strcmp(flg.std_string, "unknown") == 0) { + flg.std = STD_UNKNOWN; + } else { + interr("Erroneous -std option", 0, ERR_Fatal); + } + // AOCC end + /* Set preporocessor and Fortran source form * ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ * FIXME this logic needs to be moved to where those values are consumed @@ -877,6 +992,16 @@ init(int argc, char *argv[]) if(omptp != NULL) flg.omptarget = TRUE; #endif + // AOCC Begin + flg.amdgcn_target = FALSE; + flg.x86_64_omptarget = FALSE; + + if (omptp && !strcmp(omptp, "amdgcn-amd-amdhsa")) + flg.amdgcn_target = TRUE; + else if (omptp && strcmp(omptp, "x86_64-pc-linux-gnu") == 0) + flg.x86_64_omptarget = TRUE; + // AOCC End + /* Vectorizer settings */ flg.vect |= vect_val; if (flg.vect & 0x10) @@ -938,7 +1063,9 @@ init(int argc, char *argv[]) if (flg.es && !flg.p) flg.x[123] |= 0x100; - + if (flg.omptarget && flg.debug) + if (!XBIT(123, 0x10000000)) + flg.x[123] |= 0x400; empty_cl: if (sourcefile == NULL) { if (flg.ipa & 0x0a) { @@ -1366,6 +1493,11 @@ finish(void) ipasave_fini(); DUMP("fini"); symtab_fini(); + // AOCC BEGIN +#ifdef DEBUG + DEBUG_LOG_DEINIT(); +#endif // DEBUG + // AOCC END fih_fini(); ast_fini(); direct_fini(); @@ -1452,6 +1584,7 @@ finish(void) ipa_export_close(); } + if (flg.inliner) extractor_end(); // AOCC freearea(8); /* temporary filenames and pathnames space */ free_getitem_p(); /* getitem_p tbl contains area 8 pointers */ destroy_action_map(&phase_dump_map); diff --git a/tools/flang1/flang1exe/module.c b/tools/flang1/flang1exe/module.c index 1ad6e24aa1..f687e5433c 100644 --- a/tools/flang1/flang1exe/module.c +++ b/tools/flang1/flang1exe/module.c @@ -5,6 +5,16 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading + * Date of Modification: 26th Nov 2019 + * Resolving the module scope of aliased symbols + * + */ + /** \file \brief Fortran module support. */ @@ -545,7 +555,8 @@ find_def_in_most_recent_scope(int sptr, int save_sem_scope_level) in private USE or a private module variable */ if (!is_except_in_scope(scope, sptr1) && !is_private_in_scope(scope, sptr1) && - (STYPEG(ng) == ST_USERGENERIC || !PRIVATEG(ng))) { + (STYPEG(ng) == ST_PROC) || // AOCC + (STYPEG(ng) == ST_USERGENERIC || !PRIVATEG(ng)) ) { return sptr1; } } @@ -923,7 +934,7 @@ open_module(SPTR use) if (strcmp(SYMNAME(usedb.base[module_id].module), name) == 0) return; -#define MAX_FNAME_LEN 258 +#define MAX_FNAME_LEN 4096 fullname = getitem(8, MAX_FNAME_LEN + 1); modu_file_name = getitem(8, strlen(name) + strlen(MOD_SUFFIX) + 1); diff --git a/tools/flang1/flang1exe/optimize.h b/tools/flang1/flang1exe/optimize.h index 4150d3dc28..7255dfea06 100644 --- a/tools/flang1/flang1exe/optimize.h +++ b/tools/flang1/flang1exe/optimize.h @@ -4,6 +4,13 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading + * AOCC ChangeLog: + */ /** \file optimize.h \brief arious definitions for the optimizer module @@ -673,7 +680,7 @@ typedef struct { STG_DECLARE(astb, OAST); } OPT; -OPT opt; +extern OPT opt; /***** optimize.c *****/ void optshrd_init(void); @@ -789,6 +796,9 @@ bool pta_stride1(int ptrstdx, int ptrsptr); /* pointsto.c */ void pstride_analysis(void); /* pstride.c */ void fini_pstride_analysis(void); /* pstride.c */ void call_analyze(void); /* rest.c */ +// AOCC Begin +void transform_map_array_section(int ast, int std, int *retval);/* rest.c */ +// AOCC End void convert_output(void); /* outconv.c */ void sectfloat(void); /* outconv.c */ void sectinline(void); /* outconv.c */ diff --git a/tools/flang1/flang1exe/optutil.c b/tools/flang1/flang1exe/optutil.c index 03a2a93ce4..19b4d0c7fa 100644 --- a/tools/flang1/flang1exe/optutil.c +++ b/tools/flang1/flang1exe/optutil.c @@ -5,6 +5,15 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ + /* optutil.c - miscellaneous optimizer utility routines LOGICAL is_optsym(int) @@ -1839,6 +1848,14 @@ cp_loop(int expr) i); i = ast_intr(I_DBLE, DT_DBLE, 1, A_LOPG(i)); break; + // AOCC begin + case TY_QUAD: + if (OPTDBG(9, 65536)) + fprintf(gbl.dbgfil, " cp_loop: def %d - I_QUAD(rhs %d)\n", rdef, + i); + i = ast_intr(I_DBLE, DT_QUAD, 1, A_LOPG(i)); + break; + // AOCC end default: if (OPTDBG(9, 65536)) fprintf(gbl.dbgfil, diff --git a/tools/flang1/flang1exe/outconv.c b/tools/flang1/flang1exe/outconv.c index a5e041d7cb..59fbec2a94 100644 --- a/tools/flang1/flang1exe/outconv.c +++ b/tools/flang1/flang1exe/outconv.c @@ -8,7 +8,12 @@ /** \file * \brief Routines for descriptor optimizatons and forall transformations */ - +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * last modified : May 2020 + */ #include "gbldefs.h" #include "global.h" #include "error.h" @@ -1482,6 +1487,7 @@ _sect(int ast, int i8) if (dims > rank || dims <= 0) return 0; needgsize = 0; + if (XBIT(47, 0x1000000) || SCG(sptroldsd) == SC_CMBLK || gbl.internal == 1 || (gbl.internal > 1 && INTERNALG(sptroldsd)) || ARGG(sptroldsd)) needgsize = 1; @@ -2067,6 +2073,10 @@ _template(int ast, int rank, LOGICAL usevalue, int i8) return 0; flags |= TEMPLATE | SEQSECTION; + if (!sptrnewsd || (STYPEG(sptrnewsd) != ST_ARRDSC && STYPEG(sptrnewsd) != ST_DESCRIPTOR && + DTY(DTYPEG(sptrnewsd)) != TY_ARRAY)) + return 0; + /* set newsd.rank = rank */ insert_assign(get_desc_rank(sptrnewsd), mk_isz_cval(rank, astb.bnd.dtype), beforestd); @@ -3349,7 +3359,7 @@ is_same_mask_in_fused(int std, int *pos) int list1, listp; int isptr; int i; - int reverse[7]; + int reverse[MAXSUBS]; // AOCC int n; CTYPE *ct; int max; @@ -3442,7 +3452,7 @@ conv_forall(int std) int nd; CTYPE *ct; int i; - int revers[7]; + int revers[MAXSUBS]; // AOCC int pos, cnt; LOGICAL samemask; int lhs_sptr, lhs_ast; @@ -3805,7 +3815,7 @@ get_temp_forall2(int forall_ast, int subscr_ast, int alloc_stmt, int dealloc_stmt, int dty, int ast_dty) { int sptr, astd, dstd, asd; - int subscr[MAXSUBS]; + int subscr[MAXSUBS]; // AOCC int par, ndim, lp, std, ast, ast2, i, fg, forloop, fg2, lp2; int save_sc; int dtype = dty ? dty : (DDTG(A_DTYPEG(ast_dty))); @@ -4719,7 +4729,7 @@ position_finder(int forall, int ast) int list1, listp; int isptr; int i; - int reverse[7]; + int reverse[MAXSUBS]; // AOCC int n; int pos; @@ -5464,7 +5474,7 @@ _linearize_func(int ast, int *dummy) continue; } if (needs_linearization(sptr) && use_offset(sptr)) { - int subscr[7]; + int subscr[MAXSUBS]; // AOCC if (param && POINTERG(param)) { subscr[0] = astb.i1; } else if ((STYPEG(sptr) != ST_MEMBER || POINTERG(sptr)) && diff --git a/tools/flang1/flang1exe/parser.c b/tools/flang1/flang1exe/parser.c index 21b1ec0e80..52d74e4cad 100644 --- a/tools/flang1/flang1exe/parser.c +++ b/tools/flang1/flang1exe/parser.c @@ -5,6 +5,15 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ + /** * \file * \brief Fortran parser module @@ -479,12 +488,18 @@ prettytoken(int tkntyp, INT tknval) case TK_DCON: sprintf(symbuf, "doubleprecision constant %s", getprint((int)tknval)); break; + case TK_QCON: // AOCC + sprintf(symbuf, "quadprecision constant %s", getprint((int)tknval)); + break; case TK_CCON: sprintf(symbuf, "complex constant %s", getprint((int)tknval)); break; case TK_DCCON: sprintf(symbuf, "doublecomplex constant %s", getprint((int)tknval)); break; + case TK_QCCON: // AOCC + sprintf(symbuf, "quadcomplex constant %s", getprint((int)tknval)); + break; case TK_HOLLERITH: sprintf(symbuf, "hollerith constant %10.10s", stb.n_base + CONVAL1G(tknval)); @@ -681,6 +696,20 @@ prettytoken(int tkntyp, INT tknval) case TK_MP_PDO: sprintf(symbuf, "DO"); break; + // AOCC Begin + case TK_MP_REQUIRES: + sprintf(symbuf, "%s", "REQUIRES"); + break; + case TK_MP_REQUIRESUNIFIEDSHAREDMEMORY: + sprintf(symbuf, "%s", "REQUIRES UNIFIED_SHARED_MEMORY"); + break; + case TK_MP_METADIR: + sprintf(symbuf, "%s", "METADIRECTIVE"); + break; + case TK_MP_ENDMETADIR: + sprintf(symbuf, "%s", "ENDMETADIRECTIVE"); + break; + // AOCC End case TK_MP_SECTION: sprintf(symbuf, "SECTION"); break; diff --git a/tools/flang1/flang1exe/rest.c b/tools/flang1/flang1exe/rest.c index 9cf2d8978d..b4ef91fb4c 100644 --- a/tools/flang1/flang1exe/rest.c +++ b/tools/flang1/flang1exe/rest.c @@ -4,6 +4,20 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Bug fixes. + * + * Date of Modification: March 2019 + * + * Changes to support AMDGPU OpenMP offloading + * Date of modification 12th February 2020 + * Date of modification 04th April 2020 + * + */ + /** \file rest.c \brief various ast transformations @@ -347,6 +361,14 @@ insert_comm_before(int std, int ast, LOGICAL *rhs_is_dist, LOGICAL is_subscript) case A_MP_EREDUCTION: case A_MP_BREDUCTION: case A_MP_REDUCTIONITEM: + case A_MP_DEFAULTMAP: // AOCC + case A_MP_TARGETDECLARE: // AOCC + case A_MP_USE_DEVICE_PTR: // AOCC + case A_MP_IS_DEVICE_PTR: // AOCC + case A_MP_USE_DEVICE_ADDR: // AOCC + case A_MP_REQUIRESUNIFIEDSHAREDMEMORY: // AOCC + case A_MP_LOOP: // AOCC + case A_MP_ELOOP: // AOCC return a; default: interr("insert_comm_before: unknown expression", std, 2); @@ -844,6 +866,28 @@ find_section_subscript(int ast) return ast; } /* find_section_subscript */ +// AOCC Begin +/* retval will have a array subscript with only lower bound +* For example: arr(3:10) is changed to arr(3) +*/ +void transform_map_array_section(int ast, int std, int *retval) +{ + int sptr, ast2; + LOGICAL continuous; + + if (A_TYPEG(ast) != A_SUBSCR || !A_SHAPEG(ast)) { + return; + } + + sptr = sptr_of_subscript(ast); + ast2 = remove_subscript_expressions(ast, std, sym_of_ast(ast)); + ast2 = convert_subscript(ast2); + continuous = continuous_section(sptr, ast2, 0, 0); + if(continuous) + *retval = first_element_from_section(ast2); +} +// AOCC End + static int transform_section_arg(int ele, int std, int callast, int entry, int *descr, int argnbr) @@ -1656,20 +1700,23 @@ transform_call(int std, int ast) * if the passed object argument (denoted with tbp_inv) is a * derived type component and the declared type is abstract. */ - if (A_TYPEG(ele) == A_SUBSCR || - (i == (tbp_inv-1) && (STYPEG(sptrsdsc) == ST_MEMBER || + if ((A_TYPEG(ele) == A_SUBSCR) || + (i == (tbp_inv-1) && (STYPEG(sptrsdsc) == ST_MEMBER || ABSTRACTG(VTABLEG(entry))))) { /* Create temporary descriptor argument for the * the element. */ - int dest_ast; int dtype = A_DTYPEG(ele); int tmpv = get_tmp_descr(dtype); int src_ast = check_member(ele, mk_id(sptrsdsc)); - + int sptrsdsc1 = sptrsdsc; sptrsdsc = SDSCG(tmpv); dest_ast = mk_id(sptrsdsc); + if (STYPEG(sptrsdsc1) == ST_MEMBER ) { + SCG(sptrsdsc) = SC_PRIVATE; + } + if (i == (tbp_inv-1)) { A_INVOKING_DESCP(ast, dest_ast); } @@ -1696,7 +1743,7 @@ transform_call(int std, int ast) */ check_alloc_ptr_type(sptr, std, 0, unl_poly ? 2 : 1, 0, 0, STYPEG(sptr) == ST_MEMBER ? ele : 0); - sptrsdsc = SDSCG(sptr); + sptrsdsc = DESCRG(sptr); // AOCC } if (sptrsdsc) tmp = mk_id(sptrsdsc); @@ -2218,6 +2265,9 @@ transform_call(int std, int ast) ARGT_ARG(newargt, newj) = descr; } A_ARGSP(ast, newargt); + // AOCC: it is possible that all descriptors are not populated. + // resetting the newnargs count for this case + if (newnargs > newj) newnargs = newj; A_ARGCNTP(ast, newnargs); } /* transform_call Fortran */ @@ -2603,6 +2653,7 @@ handle_seq_section(int entry, int arr, int loc, int std, int *retval, if (DTY(topdtype) == TY_ARRAY) topdtype = DTY(topdtype + 1); +#if 0 if (simplewholearray && !is_pointer && CONTIGATTRG(arraysptr)) { /* Note: The call to first_element() uses the descriptor of the declared * dtype of arr which is fine for simple regular arrays. But it does not @@ -2617,6 +2668,7 @@ handle_seq_section(int entry, int arr, int loc, int std, int *retval, check_member(arrayast, mk_id(DESCRG(arraysptr))) : 0; return; } +#endif /* whole array with no distribution */ if (!is_seq_pointer @@ -4283,6 +4335,14 @@ transform_all_call(int std, int ast) case A_MP_EREDUCTION: case A_MP_BREDUCTION: case A_MP_REDUCTIONITEM: + case A_MP_DEFAULTMAP: // AOCC + case A_MP_TARGETDECLARE: // AOCC + case A_MP_USE_DEVICE_PTR: // AOCC + case A_MP_IS_DEVICE_PTR: // AOCC + case A_MP_USE_DEVICE_ADDR: // AOCC + case A_MP_REQUIRESUNIFIEDSHAREDMEMORY: // AOCC + case A_MP_LOOP: // AOCC + case A_MP_ELOOP: // AOCC return a; case A_PRAGMA: return a; diff --git a/tools/flang1/flang1exe/rte.c b/tools/flang1/flang1exe/rte.c index 95772a37c9..a81d1824f6 100644 --- a/tools/flang1/flang1exe/rte.c +++ b/tools/flang1/flang1exe/rte.c @@ -340,7 +340,11 @@ sym_get_sdescr(int sptr, int rank) DTYPEP(sdsc, dtype); STYPEP(sdsc, ST_DESCRIPTOR); DCLDP(sdsc, 1); - SCP(sdsc, rte_sc); + if (flg.omptarget && rte_sc == SC_LOCAL) { + SCP(sdsc, SC_STATIC); + } else { + SCP(sdsc, rte_sc); + } NODESCP(sdsc, 1); DESCARRAYP(sdsc, 1); /* used in detect.c */ if (DTY(DTYPEG(sptr)) == TY_PTR || IS_PROC_DUMMYG(sptr)) { diff --git a/tools/flang1/flang1exe/scan.c b/tools/flang1/flang1exe/scan.c index 102cffd141..2f617609d4 100644 --- a/tools/flang1/flang1exe/scan.c +++ b/tools/flang1/flang1exe/scan.c @@ -4,6 +4,21 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading + * + * Support type statement for intrinsic types + * Date of Modification: 24 January 2020 + * + * Added support for quad precision + * Last modified: Feb 2020 + * + * Last modified: Jun 2020 + * + */ /** \file scan.c @@ -24,6 +39,7 @@ #include "ccffinfo.h" #include "fih.h" #include "dinit.h" +#include /* functions defined in this file: */ @@ -76,7 +92,9 @@ static void check_continuation(int); static LOGICAL is_next_char(char *, int); static int double_type(char *, int *); void add_headerfile(char *, int, int); - +//AOCC Begin +void check_type_intrinsic(int * , int * , char * , char *); +//AOCC End /* external declarations */ extern void parse_init(void); @@ -226,7 +244,12 @@ static char *stmtb; /* buffer containing current Fortran stmt * terminated by NULL. */ static char *stmtbefore = NULL; /* 'stmtb' before crunch */ static char *stmtbafter = NULL; /* 'stmtb' after crunch */ -static short *last_char = NULL; /* position in stmb of the last char for each +// AOCC Begin +// Changed the type of last_char from short to int. +// when the data set is huge, last_char is supposed to hold value +// bigger than 32767. +// AOCC End +static int *last_char = NULL; /* position in stmb of the last char for each * line */ static int card_count; /* number of cards making up the current stmt */ static int max_card; /* maximum number of cards read in for any @@ -269,6 +292,9 @@ static LOGICAL long_pragma_candidate; /* current statement may be a * long directive/pragma */ static int scmode; /* scan mode - used to interpret alpha tokens * Possible states and values are: */ +static LOGICAL metadir_colon; +static LOGICAL inside_metadir; + #define SCM_FIRST 1 #define SCM_IDENT 2 #define SCM_FORMAT 3 @@ -297,6 +323,7 @@ static int scmode; /* scan mode - used to interpret alpha tokens #define SCM_TYPEIS 25 #define SCM_DEFINED_IO 26 #define SCM_CHEVRON 27 +#define SCM_METADIR 28 static int par_depth; /* current parentheses nesting depth */ static LOGICAL past_equal; /* set if past the equal sign */ @@ -353,7 +380,7 @@ static int (*p_get_token[])(INT *) = {_get_token, _read_token}; #include "kwddf.h" static void init_ktable(KTABLE *); -static int keyword(char *, KTABLE *, int *, LOGICAL); +static int keyword(char *, KTABLE *, int *, int); static int keyword_idx; /* index of KWORD entry found by keyword() */ /* Macro to NULL terminate a substring to error module */ @@ -389,6 +416,7 @@ scan_init(FILE *fd) init_ktable(&ppragma_kw); init_ktable(&kernel_kw); init_ktable(&pgi_kw); + init_ktable(&meta_kw); if (XBIT(49, 0x1040000)) { /* T3D/T3E or C90 Cray targets */ @@ -422,7 +450,7 @@ scan_init(FILE *fd) if (stmtbafter == NULL) error(7, 4, 0, CNULL, CNULL); stmtb = stmtbefore; - last_char = (short *)sccalloc((BIGUINT64)(max_card * sizeof(short))); + last_char = (int *)sccalloc((BIGUINT64)(max_card * sizeof(int))); if (last_char == NULL) error(7, 4, 0, CNULL, CNULL); @@ -537,6 +565,15 @@ _get_token(INT *tknv) static int lparen; tknval = 0; + if (metadir_colon) { + scmode = SCM_PAR; + if (classify_smp() == 0) { + currc = NULL; + goto retry; + } + metadir_colon = FALSE; + goto ret_token; + } retry: if (currc == NULL) { scnerrfg = FALSE; @@ -559,6 +596,8 @@ _get_token(INT *tknv) scn.id.avl = 0; currc = stmtb; scmode = SCM_FIRST; + metadir_colon = FALSE; + inside_metadir = FALSE; integer_only = FALSE; par_depth = 0; past_equal = FALSE; @@ -746,7 +785,7 @@ _get_token(INT *tknv) /* (/.../) can only occur inside () or on RHS */ /* scmode = SCM_OPERATOR; */ } else if (scmode != SCM_FORMAT && scmode != SCM_OPERATOR && - scmode != SCM_PAR) { + scmode != SCM_PAR && scmode != SCM_METADIR) { par_depth++; acb_depth++; currc++; @@ -767,9 +806,18 @@ _get_token(INT *tknv) } lparen = 1; } + if (scmode == SCM_METADIR && tkntyp == TK_DEFAULT) { + metadir_colon = TRUE; + } check_ccon(); break; + case '{': + tkntyp = TK_LBRACE; + break; + case '}': + tkntyp = TK_RBRACE; + break; case '[': tkntyp = TK_ACB; if (classify_ac_type()) { @@ -784,7 +832,8 @@ _get_token(INT *tknv) goto ret_token; case ')': /* return right paren */ - par_depth--; + if (scmode != SCM_METADIR) + par_depth--; if (par_depth == 0) { if (scmode == SCM_IO) scmode = SCM_IDENT; @@ -896,6 +945,9 @@ _get_token(INT *tknv) goto ret_token; } } + if(scmode == SCM_METADIR) { + metadir_colon = TRUE; + } tkntyp = TK_COLON; if (scn.stmtyp == TK_USE) { scmode = SCM_LOOKFOR_OPERATOR; @@ -2581,6 +2633,11 @@ classify_smp(void) scn.stmtyp = tkntyp = TK_MP_ENDDOSIMD; goto end_shared_nowait; } + if (k == 4 && strncmp(cp, "loop", 4) == 0) { + cp += 4; + scn.stmtyp = tkntyp = TK_MP_LOOP; + goto end_shared_nowait; + } if (strncmp(cp, "distribute", 10) == 0) { cp += 10; scn.stmtyp = tkntyp = TK_MP_ENDDISTRIBUTE; @@ -3532,6 +3589,22 @@ classify_smp(void) scmode = SCM_PAR; break; } + + case TK_MP_REQUIRES: { + int savecp = cp; + while (cp && *cp == ' ') cp++; + if (is_ident(cp) && strncmp(cp, "unified_shared_memory", 21) == 0) { + cp += 21; + scn.stmtyp = tkntyp = TK_MP_REQUIRESUNIFIEDSHAREDMEMORY; + scmode = SCM_PAR; + } else { + scn.stmtyp = tkntyp = TK_MP_REQUIRES; + scmode = SCM_PAR; + cp=savecp; + } + break; + } + case TK_MP_TASKLOOP: taskloop: if ((*cp == ' ' && (is_ident(cp + 1)) && @@ -3546,6 +3619,11 @@ classify_smp(void) scmode = SCM_PAR; break; + case TK_MP_LOOP: + scn.stmtyp = tkntyp = TK_MP_LOOP; + scmode = SCM_PAR; + break; + case TK_MP_TARGTEAMS: if ((*cp == ' ' && (is_ident(cp + 1)) && strncmp(cp + 1, "distribute", 10) == 0) || @@ -3605,6 +3683,15 @@ classify_smp(void) } else { scn.stmtyp = tkntyp = TK_MP_TARGTEAMSDIST; } + } else { + if ((*cp == ' ' && (is_ident(cp + 1)) && + strncmp(cp + 1, "loop", 4) == 0) || + (is_ident(cp) && strncmp(cp, "loop", 4) == 0)) { + scn.stmtyp = tkntyp = TK_MP_TARGTEAMSDISTPARDO; + if (*cp == ' ') + ++cp; + cp += 4; + } } scmode = SCM_PAR; break; @@ -3933,6 +4020,13 @@ classify_smp(void) break; } } + } else if ((*cp == ' ' && (is_ident(cp + 1)) && + strncmp(cp + 1, "loop", 4) == 0) || + (is_ident(cp) && strncmp(cp, "loop", 4) == 0)) { + scn.stmtyp = tkntyp = TK_MP_TARGTEAMSDISTPARDO; + if (*cp == ' ') + ++cp; + cp += 4; } } break; @@ -3970,6 +4064,10 @@ classify_smp(void) scmode = SCM_PAR; break; + case TK_MP_METADIR: + scn.stmtyp = tkntyp = TK_MP_METADIR; + scmode = SCM_METADIR; + break; case TKF_TARGETENTER: if (is_freeform && *cp == ' ' && (k = is_ident(cp + 1)) == 4 && @@ -4413,6 +4511,12 @@ alpha(void) * string */ o_idlen = idlen = cp - currc; + if (idlen >= 4 && scmode != SCM_METADIR && inside_metadir && + (!strncmp(id, "when", 4) || !strncmp(id, "default", 7))) { + scmode = SCM_METADIR; + par_depth = 0; + } + /* step 2 - check scan mode to determine further processing */ switch (scmode) { @@ -4879,6 +4983,13 @@ alpha(void) goto return_identifier; } break; + case SCM_METADIR: + tkntyp = keyword(id, &meta_kw, &idlen, sig_blanks); + if (tkntyp == 0) { + goto return_identifier; + } + inside_metadir = TRUE; + goto alpha_exit; default: interr("alpha: bad scan mode", scmode, 4); @@ -5094,6 +5205,11 @@ alpha(void) tkntyp = keyword(id, &normalkw, &idlen, sig_blanks); if (tkntyp == 0) goto return_identifier; + //AOCC Begin + //Support for f2008 feature: type statement for intrinsic types + if(tkntyp == TK_TYPE && flg.std == F2008) + check_type_intrinsic(&tkntyp , &idlen , currc , cp); + //AOCC End bind_state = B_NONE; switch (scn.stmtyp = tkntyp) { case TK_FUNCTION: @@ -6079,7 +6195,7 @@ get_kind_value(int knd) * entry matching the keyword. */ static int -keyword(char *id, KTABLE *ktable, int *keylen, LOGICAL exact) +keyword(char *id, KTABLE *ktable, int *keylen, int flag) { int chi, low, high, p, kl, cond; KWORD *base; @@ -6104,6 +6220,17 @@ keyword(char *id, KTABLE *ktable, int *keylen, LOGICAL exact) if (cond == 0) p = low; } + + //AOCC Begin + /*This condition is solely for Type intrinsic check*/ + if(flag == 2){ + if(strcmp(id,base[p].keytext) != 0) + return 0; + else + return base[p].toktyp; + } + //AOCC End + if (p) { keyword_idx = p; return base[p].toktyp; @@ -6399,7 +6526,7 @@ get_number(int cplxno) char *cp; INT num[4]; int sptr; - LOGICAL d_exp; + LOGICAL d_exp,q_exp; int kind_id_len; int errcode; int nmptr; @@ -6409,6 +6536,7 @@ get_number(int cplxno) chk_octal = TRUE; /* Attempt to recognize Cray's octal extension */ kind_id_len = 0; d_exp = FALSE; + q_exp = FALSE; // AOCC nmptr = 0; c = *(cp = currc); if (c == '-' || c == '+') @@ -6440,13 +6568,13 @@ get_number(int cplxno) goto return_integer; /* digits .eq */ goto state2; /* digits .e */ } - if (isdig(cp[1]) || cp[1] == 'd') + if (isdig(cp[1]) || cp[1] == 'd' || cp[1] == 'q') goto state2; /* digits . digits|d */ if (islower(cp[1])) goto return_integer; /* digits . */ goto state2; /* could still be digits . E|D */ } - if (c == 'e' || c == 'E' || c == 'd' || c == 'D') + if (c == 'e' || c == 'E' || c == 'd' || c == 'D'|| c == 'q' || c == 'Q') goto state3; goto return_integer; state2: /* digits . [ digits ] */ @@ -6454,7 +6582,7 @@ get_number(int cplxno) c = *++cp; } while (isdig(c)); assert(cp > currc + 1, "get_number:single dot", (int)c, 3); - if (c == 'e' || c == 'E' || c == 'd' || c == 'D') + if (c == 'e' || c == 'E' || c == 'd' || c == 'D' || c == 'q' || c == 'Q') goto state3; goto return_real; @@ -6462,6 +6590,10 @@ get_number(int cplxno) if (c == 'd') { d_exp = TRUE; } + // AOCC begin + if (c == 'q' || c == 'Q') + q_exp = TRUE; + // AOCC end c = *++cp; if (isdig(c)) goto state5; @@ -6478,7 +6610,14 @@ get_number(int cplxno) c = *++cp; if (isdig(c)) goto state5; - goto return_real; + // AOCC begin + if (q_exp && c == '_') { + errsev(1063); + return; + } else { + goto return_real; + } + // AOCC end syntax_error: errsev(28); @@ -6536,10 +6675,10 @@ get_number(int cplxno) p++; len--; } - if (len == 0) { - /* Have a cray octal number. Overwrite the 'b' with '"' thus - * terminating the octal constant for get_nondec(). - */ + if (len == 0) { + /* Have a cray octal number. Overwrite the 'b' with '"' thus + * terminating the octal constant for get_nondec(). + */ if (flg.standard) error(170, 2, gbl.lineno, "octal constant composed of octal digits followed by 'b'", CNULL); @@ -6594,9 +6733,8 @@ get_number(int cplxno) error(437, 2, gbl.lineno, "Constant with kind type 16 ", "REAL"); kind = DT_REAL8; } - } else { + } else if (d_exp) { /* constant was not explicitly kinded */ - if (d_exp) { kind = DT_DBLE; if (!XBIT(49, 0x200)) /* not -dp */ @@ -6605,17 +6743,49 @@ get_number(int cplxno) error(437, 2, gbl.lineno, "DOUBLE PRECISION constant", "REAL"); kind = DT_REAL; } - } else { + // AOCC begin + } else if (q_exp) { + kind = DT_QUAD; + if (!XBIT(49, 0x200)) + /* not -qp */ + nmptr = putsname(currc, cp - currc); + if (XBIT(57, 0x10) && DTY(kind) == TY_QUAD) { + error(437, 2, gbl.lineno, "QUAD PRECISION constant", "REAL"); + kind = DT_REAL; + } + } + // AOCC end + else { kind = stb.user.dt_real; nmptr = putsname(currc, cp - currc); } - } if (cplxno) { c = *(cp + kind_id_len); if ((cplxno == 1 && c != ',') || (cplxno == 2 && c != ')')) return; } switch (DTY(kind)) { + // AOCC begin + case TY_QUAD: + tkntyp = TK_QCON; + errcode = atoxq(currc, num, (int)(cp - currc)); + switch (errcode) { + case 0: + break; + case -1: + default: + CERROR(28, 3, gbl.lineno, currc, cp, CNULL); + break; + case -2: + CERROR(112, 1, gbl.lineno, currc, cp, CNULL); + break; + case -3: + CERROR(111, 1, gbl.lineno, currc, cp, CNULL); + break; + } + sptr = tknval = getcon(num, DT_QUAD); + break; + // AOCC end case TY_DBLE: tkntyp = TK_DCON; errcode = atoxd(currc, num, (int)(cp - currc)); @@ -6975,6 +7145,8 @@ check_ccon(void) case SCM_CHEVRON: scmode = SCM_IDENT; goto return_paren; + case SCM_METADIR: + goto return_paren; default: goto return_paren; } @@ -7069,6 +7241,11 @@ check_ccon(void) case TY_DBLE: tkntyp = TK_DCON; break; + // AOCC begin + case TY_QUAD: + tkntyp = TK_QCON; + break; + // AOCC end default: tkntyp = TK_RCON; break; @@ -7080,6 +7257,11 @@ check_ccon(void) case TK_DCON: num[0] = cngcon(val[0], DTYPEG(num[0]), DT_REAL8); break; + // AOCC begin + case TK_QCON: + num[0] = cngcon(val[0], DTYPEG(num[0]), DT_QUAD); + break; + // AOCC end default: interr("check_ccon: unexp.constant", tkntyp, 3); tkntyp = TK_RCON; @@ -7096,6 +7278,12 @@ check_ccon(void) tkntyp = TK_DCCON; tknval = getcon(val, DT_CMPLX16); break; + // AOCC begin + case TK_QCON: + tkntyp = TK_QCCON; + tknval = getcon(val, DT_CMPLX32); + break; + // AOCC end } } else { if (tok1 == TK_DCON) { @@ -7103,6 +7291,13 @@ check_ccon(void) xdble(num[1], val); num[1] = getcon(val, DT_DBLE); } + // AOCC begin + } else if (tok1 == TK_QCON) { + if (tkntyp == TK_RCON) { /* (quad, real) */ + xftoq(num[1], val); + num[1] = getcon(val, DT_QUAD); + } + // AOCC end } else if (tkntyp == TK_RCON) { /* (real, real) */ tkntyp = TK_CCON; tknval = getcon(num, DT_CMPLX); @@ -7110,18 +7305,34 @@ check_ccon(void) NMPTRP(tknval, putsname(save_currc - 1, currc - save_currc + 1)); return; } else { /* (real, double) */ - xdble(num[0], val); - num[0] = getcon(val, DT_DBLE); + if (tkntyp == TK_DCON) { + xdble(num[0], val); + num[0] = getcon(val, DT_DBLE); + } // AOCC begin + else if (tkntyp == TK_QCON) { /* (real, quad) */ + xftoq(num[0], val); + num[0] = getcon(val,DT_QUAD); + } + // AOCC end + } + if (tkntyp == TK_DCON || tok1 == TK_DCON) { + tkntyp = TK_DCCON; + tknval = getcon(num, DT_CMPLX16); + } + // AOCC begin + if (tkntyp == TK_QCON || tok1 == TK_QCON) { + tkntyp = TK_QCCON; + tknval = getcon(num, DT_CMPLX32); } - tkntyp = TK_DCCON; - tknval = getcon(num, DT_CMPLX16); + // AOCC end } return; return_paren: currc = save_currc; tkntyp = TK_LPAREN; /* add as case in _rd_token() */ - par_depth++; + if (scmode != SCM_METADIR) + par_depth++; } /* A dot (.) has been reached. The token is either a keyword @@ -9327,13 +9538,17 @@ _rd_token(INT *tknv) par_depth++; break; case TK_RPAREN: - par_depth--; + if (scmode != SCM_METADIR) + par_depth--; if (bind_state == B_FUNC_FOUND) { bind_state = B_RPAREN_FOUND; } if (par_depth == 0 && scmode == SCM_IF) scmode = SCM_FIRST; break; + case TK_LBRACE: + case TK_RBRACE: + break; default: if (scmode == SCM_FIRST) { scn.stmtyp = tkntyp; @@ -9468,7 +9683,7 @@ realloc_stmtb(void) else stmtb = stmtbafter; last_char = - (short *)sccrelal((char *)last_char, (BIGUINT64)(max_card * sizeof(short))); + (int *)sccrelal((char *)last_char, (BIGUINT64)(max_card * sizeof(int))); if (last_char == NULL) error(7, 4, 0, CNULL, CNULL); } @@ -9560,3 +9775,74 @@ double_type(char *ip, int *p_idlen) } return 0; } +//AOCC Begin +//Checks for type(intrinsic type) +void check_type_intrinsic(int *tkntyp , int *idlen , char *currc , char *cp){ + + char *curr_token; + char look_ahead[MAXIDLEN * 4]; + int intrinsic_type; + int paran_count = 0; + int c , count , index = 0 , space = 0; + char *insert; + curr_token = cp; + count = MAXIDLEN * 4; + insert = look_ahead; + + if(*curr_token == ' '){ + ++curr_token; + index++; + space++; + } + if(*curr_token == '('){ + ++curr_token; + index++; + if(*curr_token == ' '){ + ++curr_token; + index++; + space++; + } + do { + c = *curr_token++; + index++; + if (--count >= 0) + *insert++ = c; + } while (isident(c)); + if (insert != look_ahead) + --insert; + *insert = '\0'; + int temp_idlen = curr_token - cp; + intrinsic_type = keyword(look_ahead, &normalkw, &temp_idlen, 2); + switch(intrinsic_type){ + case TK_INTEGER: + case TK_REAL: + case TK_CHARACTER: + case TK_LOGICAL: + case TK_COMPLEX: + *tkntyp = intrinsic_type; + if(*curr_token == ')'){ + *idlen = index + 5; + } + else if (*(curr_token - 1) == ')'){ + *idlen = index + 4; + } + else if (*(curr_token - 1) == '(' || *curr_token == '('){ + while(index != strlen(cp)){ + if(*curr_token == ')') + paran_count++; + index++; + if(paran_count == 2) + break; + *curr_token++; + } + if(paran_count == 2) + currc[index + 3] = ' '; + *idlen = space+strlen(look_ahead)+5; + } + break; + default: + return; + } + } +} +//AOCC End diff --git a/tools/flang1/flang1exe/semant.c b/tools/flang1/flang1exe/semant.c index 21160d8c67..5b50a10636 100644 --- a/tools/flang1/flang1exe/semant.c +++ b/tools/flang1/flang1exe/semant.c @@ -4,6 +4,30 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Support for AMDGPU OpenMP offloading + * Date of Modification : 9th July 2019 + * + * Suppressed a duplicate diagnostic message: "Redundant specification of array" + * Date of Modification: 16th July 2019 + * + * Fix for allowing atomic read/write construct inside omp critical construct + * Date of Modification: November 2019 + * + * Support for AMDGPU OpenMP offloading + * Date of modification 04th April 2020 + * Date of modification 10th April 2020 + * + * Support for assumed size array as parameter + * Date of modification 9th June 2020 + * + * Fix to assign right kind of dtype for derived types + * Date of modification 06 October 2020 + * + */ /** \file @@ -32,7 +56,7 @@ #include "fih.h" #include "atomic_common.h" - +#include "extern.h" static void gen_dinit(int, SST *); static void pop_subprogram(void); @@ -171,6 +195,7 @@ static int next_enum; static int host_present; static INTERF host_state; static int end_of_host; +extern int has_target; #define ERR310(s1, s2) error(310, 3, gbl.lineno, s1, s2) /* @@ -292,7 +317,7 @@ static struct { ET_B(ET_VALUE) | ET_B(ET_VOLATILE) | ET_B(ET_SHARED) | ET_B(ET_ASYNCHRONOUS) | ET_B(ET_PROTECTED) | ET_B(ET_PINNED) | ET_B(ET_TEXTURE) | ET_B(ET_DEVICE) | ET_B(ET_MANAGED) | - ET_B(ET_IMPL_MANAGED))}, + ET_B(ET_CONTIGUOUS) | ET_B(ET_IMPL_MANAGED))}, {"target", ~(ET_B(ET_ACCESS) | ET_B(ET_ALLOCATABLE) | ET_B(ET_DIMENSION) | ET_B(ET_INTENT) | ET_B(ET_OPTIONAL) | ET_B(ET_SAVE) | ET_B(ET_VALUE) | @@ -312,7 +337,7 @@ static struct { ~(ET_B(ET_ACCESS) | ET_B(ET_DIMENSION) | ET_B(ET_EXTERNAL) | ET_B(ET_INTENT) | ET_B(ET_POINTER) | ET_B(ET_TARGET) | ET_B(ET_STATIC) | ET_B(ET_VOLATILE) | ET_B(ET_ASYNCHRONOUS) | ET_B(ET_PROTECTED) | - ET_B(ET_CONTIGUOUS))}, + ET_B(ET_SAVE) | ET_B(ET_CONTIGUOUS))}, {"value", ~(ET_B(ET_ACCESS) | ET_B(ET_DIMENSION) | ET_B(ET_EXTERNAL) | ET_B(ET_INTENT) | ET_B(ET_PARAMETER) | ET_B(ET_POINTER) | ET_B(ET_SAVE) | @@ -423,6 +448,17 @@ static void _do_iface(int, int); static void fix_iface(int); static void fix_iface0(); +//AOCC begin +// variables used in assumed size expression computation +extern int asz_count; /* number of rhs elements */ +int asz_status = 0; /* lhs is assumed size expression */ +int asz_arrdsc; /* array descriptor of assumed size lhs expression */ +int asz_string = 0; /* indicator to indicate assumed length string */ +int asz_id_elem; /* variable element in assumed size array */ +extern int asz_id_elem_count_tot; /* total number of elements in assumed size + array when variables are its elements */ +//AOCC end + /** \brief Initialize semantic analyzer for new user subprogram unit. */ void @@ -778,6 +814,7 @@ end_subprogram_checks() static int restored = 0; + /** \brief Semantic actions - part 1. \param rednum reduction number \param top top of stack after reduction @@ -785,8 +822,9 @@ static int restored = 0; void semant1(int rednum, SST *top) { - SPTR sptr, sptr1, sptr2, block_sptr, sptr_temp, lab; - int dtype, dtypeset, ss, numss; + + SPTR sptr, sptr1, sptr2, block_sptr, sptr_temp, lab, sptras, asz_sptr; + int dtype, dtypeset, ss, numss, dtypeas; int stype, stype1, i; int begin, end, count; int opc; @@ -799,12 +837,15 @@ semant1(int rednum, SST *top) int doif; int evp; ADSC *ad; + ADSC *adas; char *np, *np2; /* char ptrs to symbol names area */ int name_prefix_char; char *nmptr; VAR *ivl; /* Initializer Variable List */ ACL *ict, *ict1; /* Initializer Constant Tree */ int ast, alias; + int asz_ast; + int res; static int et_type; /* one of ET_...; '::=' passes up */ int et_bitv; LOGICAL no_init; /* init not allowed for entity decl */ @@ -837,6 +878,13 @@ semant1(int rednum, SST *top) int idptemp, newsubidx; int symi; + //AOCC begin + SST *asz_sst; + SST *asz_rhssst; + asz_sst = (SST *)getitem(sem.ssa_area, sizeof(SST)); + asz_rhssst = (SST *)getitem(sem.ssa_area, sizeof(SST)); + //AOCC end + switch (rednum) { /* ------------------------------------------------------------------ */ @@ -872,6 +920,7 @@ semant1(int rednum, SST *top) sem.is_hpf = scn.is_hpf; sem.alloc_std = 0; sem.p_dealloc_delete = NULL; + if (sem.pgphase == PHASE_USE) { switch (scn.stmtyp) { case TK_USE: @@ -1059,7 +1108,7 @@ semant1(int rednum, SST *top) stt = sem.tkntyp; if (stt == TK_NAMED_CONSTRUCT) stt = get_named_stmtyp(); - if (stt != TK_DO) { + if (stt != TK_DO && stt != TK_MP_METADIR) { /* * The collapse value is larger than the number of loops; * this needs to be a fatal error since the DOIF stack @@ -1073,7 +1122,7 @@ semant1(int rednum, SST *top) sem.close_pdo = FALSE; switch (DI_ID(sem.doif_depth)) { case DI_PDO: - if (scn.stmtyp != TK_MP_ENDPDO) { + if (scn.stmtyp != TK_MP_ENDPDO && scn.stmtyp != TK_MP_ENDDOSIMD) { if (A_TYPEG(STD_AST(STD_PREV(0))) != A_MP_BARRIER) (void)add_stmt(mk_stmt(A_MP_BARRIER, 0)); sem.doif_depth--; /* pop DOIF stack */ @@ -1157,6 +1206,12 @@ semant1(int rednum, SST *top) sem.doif_depth--; /* pop DOIF stack */ /* else ENDPARDO pops the stack */ } + if (sem.doif_depth && has_target) { + if (scn.stmtyp != TK_MP_ENDTARGPARDO && scn.stmtyp != TK_MP_ENDTARGET) { + end_target(); + } + has_target = false; + } break; case DI_TASKLOOP: if (scn.stmtyp != TK_MP_ENDTASKLOOP) { @@ -1164,6 +1219,11 @@ semant1(int rednum, SST *top) /* else ENDTASKLOOP pops the stack */ } break; + case DI_TARGET: + if(scn.stmtyp != TK_MP_ENDTARGET && scn.stmtyp != TK_MP_ENDTARGSIMD){ + end_target(); + } + break; default: break; } @@ -1184,8 +1244,14 @@ semant1(int rednum, SST *top) sem.atomic[0] = sem.atomic[1]; sem.atomic[1] = FALSE; } + // AOCC: Allows the omp atomics read/write construct declation inside + // omp critical construct if (sem.mpaccatomic.pending && - sem.mpaccatomic.action_type != ATOMIC_CAPTURE) { + sem.mpaccatomic.action_type != ATOMIC_CAPTURE && + // AOCC begin + (sem.mpaccatomic.action_type != ATOMIC_READ && + sem.mpaccatomic.action_type != ATOMIC_WRITE)) { + // AOCC end error(155, 3, gbl.lineno, "Statement after ATOMIC UPDATE is not an assignment", CNULL); } @@ -1194,8 +1260,10 @@ semant1(int rednum, SST *top) if ((!sem.mpaccatomic.is_acc && use_opt_atomic(sem.doif_depth))) { ; } else { - if (sem.mpaccatomic.is_acc) - sem.mpaccatomic.seen = FALSE; + // AOCC: removing this if condition as sem.mpaccatomic.is_acc is not + // a valid check here + /*if (sem.mpaccatomic.is_acc)*/ + sem.mpaccatomic.seen = FALSE; sem.mpaccatomic.pending = TRUE; } } @@ -1414,8 +1482,19 @@ semant1(int rednum, SST *top) } add_overload(gnr, gbl.currsub); } - if (gbl.currsub) + if (gbl.currsub) { + gbl.entries = gbl.currsub; + if (!sem.which_pass && sem.interface) { + // fix the arguments here.. + int old_p_count = PARAMCTG(gbl.currsub); + fix_class_ptr_args(gbl.currsub); + int new_p_count = PARAMCTG(gbl.currsub); + if (old_p_count != new_p_count) { + PDNUMP(gbl.currsub, new_p_count - old_p_count); + } + } pop_subprogram(); + } break; } @@ -2011,7 +2090,14 @@ semant1(int rednum, SST *top) * ::= */ case ID1: - np = scn.id.name + SST_CVALG(RHS(1)); + np = scn.id.name + SST_CVALG(RHS(1)); + /* AOCC begin + * a variable is the element of an assumed size array + */ + if (asz_status == 1 && sem.in_array_const == true) { + asz_id_elem = 1; + } + //AOCC end sptr = getsymbol(np); if (sem.in_dim && sem.type_mode && !KINDG(sptr) && STYPEG(sptr) != ST_MEMBER) { @@ -2459,7 +2545,7 @@ semant1(int rednum, SST *top) gbl.internal++; host_present = 0x8; symutl.none_implicit = sem.none_implicit &= ~host_present; - SCP(sptr, SC_STATIC); + SCP(sptr, SC_STATIC); } seen_implicit = FALSE; seen_parameter = FALSE; @@ -4798,6 +4884,7 @@ semant1(int rednum, SST *top) sptr = refsym((int)SST_SYMG(RHS(3)), OC_OTHER); type_common: if (STYPEG(sptr) != ST_TYPEDEF) { + np = SYMNAME(sptr); if (STYPEG(sptr) == ST_USERGENERIC && GTYPEG(sptr)) { sptr = GTYPEG(sptr); } else if (STYPEG(sptr) == ST_UNKNOWN && sem.pgphase == PHASE_INIT) { @@ -4855,8 +4942,8 @@ semant1(int rednum, SST *top) sem.gdtype = sem.ogdtype = sem.stag_dtype; } defer_put_kind_type_param(0, 0, NULL, 0, 0, 0); - if (!sem.new_param_dt && has_type_parameter(sem.stag_dtype) && - defer_pt_decl(0, 2)) { + if (!sem.new_param_dt && has_type_parameter(sem.stag_dtype) + /*&& defer_pt_decl(0, 2)*/ /*AOCC*/) { /* In this case we're using just the default type * of a parameterized derived type. We need to make sure we * create another instance of it so we don't pollute the @@ -5191,6 +5278,7 @@ semant1(int rednum, SST *top) */ case TPV2: /* flag that a '*' was seen: id field is 1, sym field is zero. */ + asz_string = 1; SST_IDP(LHS, 1); SST_SYMP(LHS, 0); SST_ASTP(LHS, 0); /* not expression */ @@ -5479,14 +5567,27 @@ semant1(int rednum, SST *top) } set_char_attributes(sptr, &dtype); - if (DTY(DTYPEG(sptr)) == TY_ARRAY) { - DTY(DTYPEG(sptr) + 1) = dtype; - if (DTY(dtype) == TY_DERIVED && DTY(dtype + 3) && + //AOCC Begin + if (sem.new_param_dt) { + dtype = DTYPEG(sptr); + if (DTY(dtype) == TY_ARRAY) { + DTY(dtype + 1) = sem.new_param_dt; + } else { + DTYPEP(sptr, sem.new_param_dt); + } + fix_type_param_members(sptr, sem.new_param_dt); + } + //AOCC End + else { + if (DTY(DTYPEG(sptr)) == TY_ARRAY) { + DTY(DTYPEG(sptr) + 1) = dtype; + if (DTY(dtype) == TY_DERIVED && DTY(dtype + 3) && DISTMEMG(DTY(dtype + 3))) { - error(451, 3, gbl.lineno, SYMNAME(sptr), CNULL); + error(451, 3, gbl.lineno, SYMNAME(sptr), CNULL); + } + } else { + DTYPEP(sptr, dtype); } - } else { - DTYPEP(sptr, dtype); } if (STYPEG(sptr) == ST_ENTRY && FVALG(sptr)) { #if DEBUG @@ -6096,12 +6197,21 @@ semant1(int rednum, SST *top) case DIM_SPEC3: rhstop = 1; SST_IDP(RHS(1), S_STAR); + //AOCC begin + // For Assumed size arrays save the lhs and rhs sst + if (seen_parameter || is_parameter_context()) { + *asz_sst = *top; + *asz_rhssst = *RHS(1); + asz_arrdsc = aux.arrdsc_avl; + asz_status = 1; + } + //AOCC end + dim_spec: - if (sem.arrdim.ndim >= MAXDIMS) { + if (sem.arrdim.ndim >= get_legal_maxdim()) { /* AOCC */ error(47, 3, gbl.lineno, CNULL, CNULL); break; } - /* check upper bound expression */ constarraysize = 1; arraysize = 0; @@ -6164,7 +6274,6 @@ semant1(int rednum, SST *top) } /* check lower bound expression */ - if (rhstop == 1) { /* set default lower bound */ sem.bounds[sem.arrdim.ndim].lowtype = S_CONST; sem.bounds[sem.arrdim.ndim].lowb = 1; @@ -6218,7 +6327,7 @@ semant1(int rednum, SST *top) * ::= : | */ case DIM_SPEC4: - if (sem.arrdim.ndim >= MAXDIMS) { + if (sem.arrdim.ndim >= get_legal_maxdim()) { /* AOCC */ error(47, 3, gbl.lineno, CNULL, CNULL); break; } @@ -6230,7 +6339,7 @@ semant1(int rednum, SST *top) * ::= : | */ case DIM_SPEC5: - if (sem.arrdim.ndim >= MAXDIMS) { + if (sem.arrdim.ndim >= get_legal_maxdim()) { /* AOCC */ error(47, 3, gbl.lineno, CNULL, CNULL); break; } @@ -6622,6 +6731,9 @@ semant1(int rednum, SST *top) * ::= = */ case INIT_BEG1: + /* AOCC begin */ + case INIT_BEG2: + /* AOCC end */ sem.dinit_data = TRUE; sem.equal_initializer = true; break; @@ -8504,8 +8616,69 @@ semant1(int rednum, SST *top) break; SST_SYMP(LHS, sptr); } + + //AOCC begin + //assumed size arrays. modify the saved lhs SST using the rhs sst + if (asz_status) { + sptras = SST_SYMG(top); + dtypeas = DTYPEG(sptras); + adas = AD_DPTR(dtypeas); + if (entity_attr.exist & ET_B(ET_PARAMETER)) { + // check if array is a parameter + if (AD_ASSUMSZ(adas)) { //check if array is an assumed size array + /* the size of the assumed size array when + * its elements are variables + */ + if (asz_count == 0 && asz_id_elem_count_tot != 0) { + asz_count = asz_id_elem_count_tot; + } + sptras = SST_SYMG(asz_sst); + SST_LSYMP(asz_sst, 0); + SST_DTYPEP(asz_sst, DT_INT); + SST_DTYPEP(asz_rhssst, DT_INT); + SST_ACLP(asz_sst, 0); + SST_CVALP(asz_sst, asz_count); + SST_CVALP(asz_rhssst, asz_count); + asz_ast = mk_cval1(SST_CVALG(asz_sst), (int)SST_DTYPEG(asz_sst)); + SST_SHAPEP(asz_sst, 0); + SST_IDP(asz_rhssst, S_CONST); + SST_PARENP(LHS, 0); + SST_ASTP(asz_rhssst, 0); + + arraysize = 0; + if (SST_IDG(asz_rhssst) == S_CONST) { + sem.bounds[sem.arrdim.ndim].uptype = S_CONST; + int uptyp; + uptyp = SST_DTYPEG(asz_rhssst); + if (!DT_ISINT(uptyp)) { + error(170, 2, gbl.lineno, "array upper bound", "is not integer"); + } + // assign the lhs using the size of array computed from the rhs + arraysize = sem.bounds[sem.arrdim.ndim].upb = + chkcon_to_isz(asz_rhssst, FALSE); + asz_ast = sem.bounds[sem.arrdim.ndim].upast = mk_bnd_int(SST_ASTG(asz_rhssst)); + asz_sptr = A_SPTRG(sem.bounds[sem.arrdim.ndim].upast - 1); + CONVAL2P(asz_sptr, arraysize); + SST_ASTP(asz_rhssst, asz_ast); + SST_ASTP(asz_sst, asz_ast); + } + int savedsc_val = aux.arrdsc_avl; + if (asz_status) aux.arrdsc_avl = asz_arrdsc ; + dtypeas = mk_arrdsc(); + // update the lhs array descriptor + SST_DTYPEP(asz_sst, dtypeas); + aux.arrdsc_avl = savedsc_val; + } + } + asz_status = 0; + asz_id_elem_count_tot = 0; + } + //AOCC end + inited = TRUE; sem.dinit_data = FALSE; + asz_string = 0; // AOCC: reset the assumed size computation status + asz_count = 0; goto entity_decl_shared; /* * ::= '=>' ( ) @@ -9193,6 +9366,18 @@ semant1(int rednum, SST *top) goto entity_decl_end; } } + + /* AOCC begin */ + if (flg.std == F2008) { + if (POINTERG(sptr) && !IN_MODULE_SPEC) { + ast = assign_pointer(RHS(1), RHS(3)); + add_stmt(ast); + SST_ASTP(RHS(1), ast); + goto entity_decl_end; + } + } + /* AOCC end */ + construct_acl_for_sst(RHS(3), DTYPEG(SST_SYMG(RHS(1)))); if (!SST_ACLG(RHS(3))) { goto entity_decl_end; @@ -9576,7 +9761,7 @@ semant1(int rednum, SST *top) ndim = AD_NUMDIM(ad1); if (ndim != AD_NUMDIM(ad2)) { error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr)); - break; + break; } for (i = 0; i < ndim; i++) if (AD_LWBD(ad1, i) != AD_LWBD(ad2, i) || @@ -9586,7 +9771,10 @@ semant1(int rednum, SST *top) error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr)); break; } - error(119, 2, gbl.lineno, SYMNAME(sptr), CNULL); + //AOCC begin + // Removing the following line as it produces duplicate warnings + // error(119, 2, gbl.lineno, SYMNAME(sptr), CNULL); + //AOCC end } else if (stype1 != ST_UNKNOWN && stype1 != ST_IDENT && stype1 != ST_VAR) { error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr)); @@ -11279,8 +11467,35 @@ semant1(int rednum, SST *top) case PROC_DCL3: sptr = SST_SYMG(RHS(3)); sem.proc_initializer = true; - goto proc_dcl_init; + // AOCC begin + if (INMODULEG(SST_SYMG(RHS(3)))) { + sptr = SST_SYMG(RHS(1)); + sem.proc_initializer = true; + sptr = decl_procedure_sym(sptr, proc_interf_sptr, entity_attr.exist); + sptr = setup_procedure_sym(sptr, proc_interf_sptr, entity_attr.exist, + entity_attr.access); + if (!TYPDG(sptr)) { + TYPDP(sptr, 1); + if (SCG(sptr) == SC_DUMMY) { + IS_PROC_DUMMYP(sptr, 1); + } + } + sem.dinit_data = FALSE; + inited = TRUE; + SST_IDP(RHS(3), S_IDENT); + get_static_descriptor(sptr); + get_all_descriptors(sptr); + if (POINTERG(sptr) && (!IN_MODULE_SPEC)) { + ast = assign_pointer(RHS(1), RHS(3)); + add_stmt(ast); + SST_ASTP(RHS(1), ast); + goto entity_decl_end; + } + break; + } + // AOCC end + goto proc_dcl_init; /* ------------------------------------------------------------------ */ /* @@ -11381,7 +11596,6 @@ semant1(int rednum, SST *top) sptr = setup_procedure_sym(sptr, proc_interf_sptr, attr, entity_attr.access); } - /* Error while creating proc symbol */ if (sptr == 0) break; @@ -12373,21 +12587,42 @@ semant1(int rednum, SST *top) #endif break; /* - * ::= | + * ::= */ case MP_DECL2: #ifdef OMP_OFFLOAD_LLVM + // AOCC Begin +#ifndef OMP_OFFLOAD_AMD if(flg.omptarget) { error(1200, ERR_Severe, gbl.lineno, "declare target", NULL); } +#endif + if(flg.omptarget) { + int ast = mk_stmt(A_MP_TARGETDECLARE, 0); + (void)add_stmt(ast); + } + // AOCC End #endif break; + + // AOCC Begin /* - * ::= + * ::= ( ) | */ case MP_DECL3: break; + /* + * ::= | + */ + case MP_DECL4: + break; + // AOCC End + /* + * ::= + */ + case MP_DECL5: + break; /* ------------------------------------------------------------------ */ /* @@ -14475,7 +14710,7 @@ _do_iface(int iface_state, int i) } if (proc) { DTYPEP(proc, DTYPEG(iface)); - PARAMCTP(proc, paramct); + PARAMCTP(proc, paramct-PDNUMG(iface)); DPDSCP(proc, dpdsc); FVALP(proc, fval); PUREP(proc, PUREG(iface)); diff --git a/tools/flang1/flang1exe/semant.h b/tools/flang1/flang1exe/semant.h index 4052e038b3..08d0e75353 100644 --- a/tools/flang1/flang1exe/semant.h +++ b/tools/flang1/flang1exe/semant.h @@ -5,6 +5,29 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes made to create single team for omp target parallel block as well + * Date of Modification: 26th June 2019 + * + * Changes to support AMD GPU Offloading + * Added code to avoid allocations for implied do inside target region + * Date of Modification: 24th October 2019 + * Date of Modification: 5th November 2019 + * + * Added code to support reshape with implied dos inside target region + * Date of Modification: 23rd January 2020 + * + * Added code to support SHIFTA intrinsic + * Last modified: April 2020 + * + * Added support for schedule openmp clause + * Last modified : March 2021 + * + */ + /** \file \brief Semantic analyzer data definitions. @@ -282,11 +305,13 @@ typedef struct { // construct (DO, IF, etc.) stack entries int teams; // OpenMP use int distribute; // OpenMP use REDUC *reduc; // reductions for parallel constructs + REDUC *in_reduc; // in_reductions for parallel constructs // AOCC REDUC_SYM *lastprivate; // lastprivate for parallel constructs ITEM *allocated; // list of allocated private variables ITEM *region_vars; // accelerator region copy/local/mirror vars union { struct { // OpenMP - DO + int modifier; // AOCC int sched_type; // one of DI_SCHxxx int chunk; // sptr for chunk size (0 if absent) LOGICAL is_ordered; // loop has the ordered attribute? @@ -332,6 +357,16 @@ typedef struct { // construct (DO, IF, etc.) stack entries #define DI_SCH_AUTO 5 #define DI_SCH_DIST_STATIC 6 #define DI_SCH_DIST_DYNAMIC 7 +#define DI_MOD_NONMONOTONIC 8 +#define DI_MOD_MONOTONIC 9 +#define DI_DEP_MOD_SOURCE 10 +#define DI_DEP_TYPE_SINK 10 +#define DI_DEP_TYPE_IN 11 +#define DI_DEP_TYPE_OUT 12 +#define DI_DEP_TYPE_INOUT 13 +#define DI_DEP_TYPE_MUTEXINOUTSET 14 +#define DI_DEP_TYPE_DEPOBJ 15 +#define DI_MOD_SIMD 16 #define DI_ID(d) sem.doif_base[d].Id #define DI_LINENO(d) sem.doif_base[d].lineno @@ -377,10 +412,12 @@ typedef struct { // construct (DO, IF, etc.) stack entries #define DI_CRITSYM(d) sem.doif_base[d].u.u4.bpar #define DI_BEGINP(d) sem.doif_base[d].u.u4.beginp #define DI_REDUC(d) sem.doif_base[d].u.u4.reduc +#define DI_IN_REDUC(d) sem.doif_base[d].u.u4.in_reduc // AOCC #define DI_LASTPRIVATE(d) sem.doif_base[d].u.u4.lastprivate #define DI_ALLOCATED(d) sem.doif_base[d].u.u4.allocated #define DI_REGIONVARS(d) sem.doif_base[d].u.u4.region_vars #define DI_SCHED_TYPE(d) sem.doif_base[d].u.u4.v.v1.sched_type +#define DI_SCHED_MODIFIER(d) sem.doif_base[d].u.u4.v.v1.modifier //AOCC #define DI_CHUNK(d) sem.doif_base[d].u.u4.v.v1.chunk #define DI_DISTCHUNK(d) sem.doif_base[d].u.u4.v.v1.dist_chunk #define DI_IS_ORDERED(d) sem.doif_base[d].u.u4.v.v1.is_ordered @@ -416,7 +453,7 @@ typedef struct { // construct (DO, IF, etc.) stack entries #define NEED_DOIF(df, typ) \ { \ - df = ++sem.doif_depth; \ + df = ++sem.doif_depth; \ NEED(df + 1, sem.doif_base, DOIF, sem.doif_size, sem.doif_size + 8); \ BZERO(sem.doif_base+df, DOIF, 1); \ DI_LINENO(df) = gbl.lineno; \ @@ -551,6 +588,7 @@ struct _aexpr { #define AC_LNOT 23 #define AC_EXPX 24 #define AC_TRIPLE 25 +#define AC_LXOR 26 // AOCC typedef enum { AC_I_NONE = 0, @@ -609,6 +647,19 @@ typedef enum { AC_I_minloc, AC_I_minval, AC_I_scale, + /* AOCC begin */ + AC_I_transpose, + AC_I_merge_bits, + AC_I_shiftl, + AC_I_shiftr, + AC_I_dshiftl, + AC_I_dshiftr, + AC_I_nearest, + AC_I_shifta, + AC_I_aint, + AC_I_anint, + AC_I_cotan + // AOCC end } AC_INTRINSIC; #define BINOP(p) ((p)->op != AC_NEG && (p)->op != AC_CONV) @@ -862,7 +913,7 @@ void mod_end_subprogram_two(void); /* semantio.c */ int get_nml_array(int); -#define MAXDIMS 7 +#define MAXDIMS MAXSUBS /* AOCC */ typedef struct { struct _sem_bounds { int lowtype; @@ -1094,6 +1145,12 @@ typedef enum { PHASE_END = 9 } PHASE_TYPE; +//AOCC Begin +typedef struct Implied_do_body_std { + int std; + struct Implied_do_body_std *next; +} ido_body_std; +//AOCC END /* declare global semant variables: */ typedef struct { @@ -1383,6 +1440,12 @@ typedef struct { int allocs; int nodes; } stats; + struct { + LOGICAL whencondition; + LOGICAL whenexpanded; + LOGICAL defaultcondition; + LOGICAL whenconditionvalue; + }metadirective; LOGICAL seen_import; /* import stmt in an interface seen */ void *save_aconst; /* saves SST of array constructor */ ITEM *alloc_mem_initialize; /* list of allocatable members to initialize */ @@ -1407,6 +1470,29 @@ typedef struct { bool proc_initializer; /* true if we are initializing a pointer * with a procedure name. */ + //AOCC Begin + struct { + bool replace_temp; /* true if it is in an assignment statement + * and the temporary created for RHS acl + * can be replaced with lhs array + */ + int subsc_assign_std; /* std which assigns to subscript + * of temporary + */ + ido_body_std *body_stds; /* holds the generated std for + * the body of the implied do + */ + } acl_ido; + + struct { + bool is_source_ido; /* true if source is an implied do */ + bool is_shape_ido_const; /* true if shape is an implied do with + * a list of constants */ + int num_dims; /* stores the number of dimensions for + * reshaped array*/ + int const_shape_asts[3]; /* stores the asts of shape constants*/ + } reshape; + //AOCC End } SEM; extern SEM sem; @@ -1510,6 +1596,7 @@ void semfin(void); void ipa_semfin(void); void semfin_free_memory(void); void fix_class_args(int sptr); +void fix_class_ptr_args(int sptr); void llvm_fix_args(int sptr, LOGICAL is_func); void do_equiv(void); void init_derived_type(SPTR, int, int); diff --git a/tools/flang1/flang1exe/semant2.c b/tools/flang1/flang1exe/semant2.c index 179392649a..c73cda5cd6 100644 --- a/tools/flang1/flang1exe/semant2.c +++ b/tools/flang1/flang1exe/semant2.c @@ -5,6 +5,22 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Fixed issues related to type bound procedures with and without nopass clause + * Date of Modification: December 2019 + * + * Support for assumed size array as parameter + * Date of modification 9th June 2020 + * + * Last modified: Jun 2020 + * + * Check for stype of sptr(s) with same names before resusing them. + * Date of modification: 24th October 2020 +*/ + /** \file \brief This file contains part 2 of the compiler's semantic actions @@ -41,7 +57,14 @@ static int reassoc_add(int, int, int); static int get_mem_sptr_by_name(char *name, int dtype); static ITEM *mkitem(SST *stkp); -/** +// AOCC begin +int asz_count; +extern int asz_status; +extern int asz_id_elem; +int asz_id_elem_start; +// AOCC end + +/* \brief semantic actions - part 2. \param rednum reduction number \param top top of stack after reduction @@ -49,7 +72,7 @@ static ITEM *mkitem(SST *stkp); void semant2(int rednum, SST *top) { - int sptr, sptr1, sptr2, dtype; + int sptr, sptr1, sptr2, sptr3, dtype; int acltype, stype, i; int begin, count; int opc; @@ -76,6 +99,7 @@ semant2(int rednum, SST *top) int pfx; int (*p_cmp)(int, int); int set_aclp; + int past = 0, cast = 0; // AOCC switch (rednum) { @@ -249,6 +273,7 @@ semant2(int rednum, SST *top) */ case AC_END1: sem.in_array_const = false; + asz_id_elem = 0; // AOCC : reset that the elements for assumed size array are over break; /* ------------------------------------------------------------------ */ @@ -597,6 +622,13 @@ semant2(int rednum, SST *top) * length or kind expression. */ sptr = refsym((int)SST_SYMG(RHS(1)), OC_OTHER); + //AOCC Begin + sptr3 = (int)SST_SYMG(RHS(1)); + if((SCOPEG(sptr) != SCOPEG(sptr3)) && SCG(sptr) == SC_PRIVATE && + STYPEG(sptr) != STYPEG(sptr3)){ + sptr = sptr3; + } + //AOCC End if (STYPEG(sptr) && sem.type_mode && queue_type_param(sptr, 0, 0, 3)) { sptr = insert_sym(sptr); STYPEP(sptr, ST_IDENT); @@ -663,6 +695,15 @@ semant2(int rednum, SST *top) aclp->dtype = DTYPEG(sptr); SST_ACLP(LHS, aclp); init_named_array_constant(sptr, gbl.currsub); + + // AOCC begin + /* indicating that ast holding the size of variable + * elements in an assumed size array needs to be copied + */ + if (asz_id_elem == 1) { + asz_id_elem_start = 1; + } + // AOCC end ast = mk_id(sptr); } SST_ASTP(LHS, ast); @@ -768,16 +809,21 @@ semant2(int rednum, SST *top) } else { int dty = TBPLNKG(sptr); itemp = ITEM_END; - if (generic_tbp_has_pass_and_nopass(dty, sptr)) { - int parent, sp; - e1 = (SST *)getitem(0, sizeof(SST)); - sp = sym_of_ast(ast); - SST_SYMP(e1, sp); - SST_DTYPEP(e1, DTYPEG(sp)); - mkident(e1); - mkexpr(e1); - itemp = mkitem(e1); - } + // AOCC Begin + // Comment the below code. + // tbp arg will be added to Type bound procedures with nopass clause + // in a common place (func_call2). + //if (generic_tbp_has_pass_and_nopass(dty, sptr)) { + // int parent, sp; + // e1 = (SST *)getitem(0, sizeof(SST)); + // sp = sym_of_ast(ast); + // SST_SYMP(e1, sp); + // SST_DTYPEP(e1, DTYPEG(sp)); + // mkident(e1); + // mkexpr(e1); + // itemp = mkitem(e1); + //} + // AOCC End goto var_ref_common; } } @@ -966,7 +1012,12 @@ semant2(int rednum, SST *top) mem2 = get_specific_member(TBPLNKG(sptr), VTABLEG(mem)); argno = get_tbp_argno(BINDG(mem2), TBPLNKG(sptr)); if (!argno && NOPASSG(mem2)) { - goto var_ref_common; /* assume NOPASS tbp */ + // AOCC Begin + // To add tbp arg, below goto is commented + //goto var_ref_common; /* assume NOPASS tbp */ + // Need to add tbp arg to keep it consistant. + argno = 1; + // AOCC End } } else { argno = get_tbp_argno(sptr, DTYPEG(pass_sym_of_ast(ast))); @@ -1263,6 +1314,26 @@ semant2(int rednum, SST *top) } SST_LSYMP(LHS, sptr); } + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + if(flg.omptarget) + if (sem.target || sem.teams) { + // replace obj%p(i) with ptr(i) to map and access the pointer member + // where, p is a pointer member of obj a structure type variable + // ptr is a compiler created pointer + ast = SST_ASTG(RHS(1)); + if(A_TYPEG(ast) == A_SUBSCR && A_TYPEG(A_LOPG(ast)) == A_MEM ) { + past = get_cc_pointer(A_SPTRG(A_PARENTG(A_LOPG(ast))),sptr1); + if(past) { + A_LOPP(SST_ASTG(RHS(1)), past); + ref_object(A_SPTRG(past)); + cast = add_ptr_assign(past, A_LOPG(SST_ASTG(RHS(1))), 0); + add_stmt_before(cast, STD_NEXT(0)); + } + } + } +#endif + // AOCC End SST_PARENP(LHS, 0); break; /* @@ -1452,7 +1523,8 @@ semant2(int rednum, SST *top) if (strcmp(SYMNAME(sptr1), "re") == 0 || strcmp(SYMNAME(sptr1), "im") == 0) { /* build a phoney member ast that will be rewritten later */ - dtype = DTY(dtype) == TY_CMPLX ? DT_REAL4 : DT_REAL8; + dtype = DTY(dtype) == TY_CMPLX ? DT_REAL4 : DTY(dtype) == TY_DCMPLX ? + DT_REAL8 : DT_QUAD; STYPEP(sptr1, ST_MEMBER); DTYPEP(sptr1, dtype); /* don't count on this, it will change */ SST_ASTP(LHS, mk_member(SST_ASTG(RHS(1)), mk_id(sptr1), dtype)); @@ -1470,6 +1542,12 @@ semant2(int rednum, SST *top) break; } i = NMPTRG(SST_SYMG(RHS(rhstop))); + //AOCC Begin + if (STYPEG(SST_SYMG(RHS(rhstop))) == ST_USERGENERIC || + STYPEG(SST_SYMG(RHS(rhstop))) == ST_PROC || + STYPEG(SST_SYMG(RHS(rhstop))) == ST_ENTRY) + A_ALIASP(ast,SST_SYMG(RHS(rhstop))); + //AOCC End ast = mkmember(dtype, ast, i); if (ast) { sptr1 = A_SPTRG(A_MEMG(ast)); @@ -1835,6 +1913,9 @@ semant2(int rednum, SST *top) /* value set by scan */ ast_conval(top); } + // AOCC: Change the number of array elements for assumed size arrays + if (asz_status == 1) + asz_count += 1; break; /* * ::= | @@ -1846,10 +1927,27 @@ semant2(int rednum, SST *top) SST_DTYPEP(LHS, dtype); if (dtype == DT_INT8) { ast_cnst(top); + } else if (dtype == DT_QUAD) { + // AOCC begin + SST_DTYPEP(LHS, DT_INT8); + SST_CVALP(LHS, CONVAL2G(sptr)); + SST_ACLP(LHS, 0); + int v = SST_CVALG(LHS); + if (v < 0) + val[0] = -1; + else + val[0] = 0; + val[1] = v; + int cnst = getcon(val, DT_INT8); + SST_CVALP(LHS, cnst); + SST_ASTP(LHS, mk_cnst(cnst)); + SST_SHAPEP(LHS, 0); + // AOCC end } else { SST_CVALP(LHS, CONVAL2G(sptr)); ast_conval(top); } + break; /* @@ -1897,7 +1995,7 @@ semant2(int rednum, SST *top) * ::= | */ case CONSTANT9: - SST_DTYPEP(LHS, DT_QCMPLX); + SST_DTYPEP(LHS, DT_CMPLX32); /* value set by scan */ ast_cnst(top); break; @@ -2005,6 +2103,9 @@ semant2(int rednum, SST *top) SST_DTYPEP(LHS, DTYPEG(sptr)); /* value set by scan */ ast_cnst(top); + // AOCC: Change the number of array elements for assumed size arrays + if (asz_status == 1) + asz_count += 1; break; /* * ::= | @@ -2025,7 +2126,7 @@ semant2(int rednum, SST *top) "- KIND parameter has unknown value for quoted string -", SYMNAME(sptr)); } - string_with_kind(top); + string_with_kind(top); break; /* * ::= @@ -2039,7 +2140,7 @@ semant2(int rednum, SST *top) } else if (SST_CVALG(RHS(1)) != 1) error(81, 3, gbl.lineno, "- KIND parameter has unknown value for quoted string", CNULL); - string_with_kind(top); + string_with_kind(top); break; /* ------------------------------------------------------------------ */ @@ -2067,7 +2168,7 @@ semant2(int rednum, SST *top) SST_CVALP(LHS, getcon(val, dtype)); ast_cnst(top); SST_IDP(LHS, S_CONST); - ch_substring(LHS, RHS(3), RHS(5)); + ch_substring(LHS, RHS(3), RHS(5)); break; /* ------------------------------------------------------------------ */ @@ -2812,6 +2913,11 @@ rewrite_cmplxpart_rval(SST *e) case TY_DBLE: intrnm = part == 1 ? "dreal" : "dimag"; break; + // AOCC begin + case TY_QUAD: + intrnm = part == 1 ? "qreal" : "qimag"; + break; + // AOCC end default: interr("rewrite_cmplxpart_rval: unexpected type", DTY(dtype), 3); } @@ -2854,10 +2960,14 @@ form_cmplx_const(SST *res, SST *rp, SST *ip) i = SST_DTYPEG(rp); if (i == DT_DBLE || i == DT_DCMPLX) dtype = DT_DBLE; + else if (i == DT_QUAD || i == DT_QCMPLX) + dtype = DT_QUAD; else { i = SST_DTYPEG(ip); if (i == DT_DBLE || i == DT_DCMPLX) dtype = DT_DBLE; + else if (i == DT_QUAD || i == DT_QCMPLX) + dtype = DT_QUAD; else dtype = DT_REAL; } @@ -2865,7 +2975,8 @@ form_cmplx_const(SST *res, SST *rp, SST *ip) val[0] = SST_CVALG(rp); cngtyp(ip, dtype); val[1] = SST_CVALG(ip); - dtype = (dtype == DT_DBLE) ? DT_DCMPLX : DT_CMPLX; + dtype = (dtype == DT_DBLE) ? DT_DCMPLX : (dtype == DT_QUAD) ? + DT_QCMPLX : DT_CMPLX; } SST_IDP(res, S_CONST); SST_DTYPEP(res, dtype); diff --git a/tools/flang1/flang1exe/semant3.c b/tools/flang1/flang1exe/semant3.c index f6493f0d1e..a4122b7f29 100644 --- a/tools/flang1/flang1exe/semant3.c +++ b/tools/flang1/flang1exe/semant3.c @@ -5,6 +5,20 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last modified: Nov 12, 2019 + * Raise error for non integer nd non character stop codes + * + * Changes to support AMDGPU OpenMP offloading. + * Date of modification 14th October 2019 + * + * Support for Associate Block in OpenMP + * Date of modification : 9th May 2020 + */ + /** \file semant3.c \brief This file contains part 3 of the compiler's semantic actions @@ -31,6 +45,7 @@ #include "lower.h" #include "rtlRtns.h" #include "pd.h" +#include "llmputil.h" static LOGICAL alloc_error = FALSE; static int alloc_source; @@ -58,6 +73,14 @@ static int construct_association(int lhs_sptr, SST *rhs, int stmt_dtype, static void end_association(int sptr); static int get_sst_named_whole_variable(SST *rhs); static int get_derived_type(SST *, LOGICAL); +// AOCC Begin +#ifdef OMP_OFFLOAD_AMD +extern int target_ast; +extern int reduction_kernel; +#endif +void get_subtree(int ast, int* par, int* sib); +int sib, par; +// AOCC End #define IN_OPENMP_ATOMIC (sem.mpaccatomic.ast && !(sem.mpaccatomic.is_acc)) @@ -591,8 +614,31 @@ semant3(int rednum, SST *top) sem.mpaccatomic.seen = FALSE; } - ast = assign(RHS(2), RHS(5)); - *LHS = *RHS(2); +// AOCC Begin +#ifdef OMP_OFFLOAD_AMD + // when assigning to a complex scalar in target region + // but not in a nested parallel + // create a private symbol of that and assign to it + int lhs_sptr = SST_SYMG(RHS(2)); + int lhs_sptr_dtype = DTYPEG(lhs_sptr); + int lhs_ast = SST_ASTG(RHS(2)); + if (sem.target && sem.teams && !sem.parallel + && lhs_sptr > 1 && DTY(lhs_sptr_dtype) == TY_CMPLX + && SCG(lhs_sptr) != SC_PRIVATE) { + int prvt_lhs_sptr = decl_private_sym(lhs_sptr); + SST lhs_sst; + (void)mk_storage(prvt_lhs_sptr, &lhs_sst); + ast = assign(&lhs_sst, RHS(5)); + } else { +#endif +// AOCC End + ast = assign(RHS(2), RHS(5)); + *LHS = *RHS(2); +// AOCC Begin +#ifdef OMP_OFFLOAD_AMD + } +#endif +// AOCC End /* assign() will return 0 if the rhs is an array-valued function * for which the lhs becomes the result argument. */ @@ -1583,6 +1629,24 @@ semant3(int rednum, SST *top) error(1050, ERR_Severe, gbl.lineno, "STOP in", CNULL); // 2018-C1137 ast1 = SST_TMPG(RHS(2)); ast2 = SST_ASTG(RHS(2)); + + // AOCC Begin + // throw error for types other than integer/character type STOP CODE + // + if (DTY(A_DTYPEG(ast1)) == TY_INT || + DTY(A_DTYPEG(ast1)) == TY_SINT || + DTY(A_DTYPEG(ast1)) == TY_INT8 || + DTY(A_DTYPEG(ast1)) == TY_CHAR || + DTY(A_DTYPEG(ast1)) == TY_NCHAR) { + goto stop_common; + } + else { + error(95, ERR_Warning, gbl.lineno, SYMNAME(gbl.currsub), + "-STOP code must be either INTEGER or CHARACTER type-\n"); + } + // AOCC End + +stop_common: if (XBIT(54, 0x10)) { rtlRtn = RTE_stopa; goto pause_shared; @@ -1738,8 +1802,14 @@ semant3(int rednum, SST *top) /* 64-bit hack */ if (DTY(DT_INT) == TY_INT8) i = get_int_cval(i); - snprintf(name, sizeof(name), "%5ld", (long)i); - ast2 = mk_cnst(getstring(name, 5)); + snprintf(name, sizeof(name), "%5ld", (long) i); + // AOCC Begin + if (flg.std == F2008) { + ast2 = mk_cnst(getstring(name, strlen(name))); + } else { + // AOCC End + ast2 = mk_cnst(getstring(name, 5)); + } } } else { if (DTY(SST_DTYPEG(RHS(1))) == TY_CHAR) { @@ -1749,6 +1819,18 @@ semant3(int rednum, SST *top) ast2 = astb.ptr0c; (void)mkarg(RHS(1), &dum); ast1 = SST_ASTG(RHS(1)); + SST_TMPP(LHS, ast1); + get_subtree(ast1, &par, &sib); + // AOCC Begin + if (A_TYPEG(ast1) == A_ID || A_TYPEG(ast1) == A_CNST) { + snprintf(name, sizeof(name), "%s", getprint((int)A_SPTRG(par))); + if (flg.std == F2008) { + ast2 = mk_cnst(getstring(name, strlen(name))); + } else { + // AOCC End + ast2 = mk_cnst(getstring(name, 5)); + } + } } if (flg.standard) { error(170, 2, gbl.lineno, @@ -1801,6 +1883,16 @@ semant3(int rednum, SST *top) construct_name = 0; sem.pgphase = PHASE_EXEC; /* set now, since may have IF (...) stmt */ sem.stats.nodes++; + // AOCC Begin + // if there's an if_construct inside non-reduction kernel fallback to + // tgt_target mode. +#ifdef OMP_OFFLOAD_AMD + if (flg.amdgcn_target && + target_ast && DI_IN_NEST(sem.doif_depth, DI_DISTPARDO) && !reduction_kernel) { + A_COMBINEDTYPEP(target_ast, mode_target); + } +#endif + // AOCC End break; /* * ::= : IF @@ -3738,6 +3830,17 @@ semant3(int rednum, SST *top) int dest_ast = itemp->ast; DTYPE dest_dtype = A_DTYPEG(dest_ast); + // AOCC begin + if (DT_ISREAL(DDTG(dtype)) && DT_ISREAL(DDTG(dest_dtype)) && + DDTG(dtype) != DDTG(dest_dtype)) { + + error(155, 3, gbl.lineno, + "In an ALLOCATE statement the source expression in " + "SOURCE= or MOLD= specifiers must be of the same type " + "and kind type parameters as the object being allocated ", + NULL); + } + // AOCC end if (A_TYPEG(dest_ast) != A_SUBSCR && is_array_dtype(dest_dtype)) { /* An array is being allocated with shape assumed from the * MOLD= or SOURCE= expression. @@ -4667,7 +4770,7 @@ semant3(int rednum, SST *top) itemp = itemp->next) { SST *stkp; - if (sem.arrdim.ndim >= 7) { + if (sem.arrdim.ndim >= get_legal_maxdim()) { /* AOCC */ error(47, 3, gbl.lineno, CNULL, CNULL); alloc_error = TRUE; break; @@ -6250,6 +6353,13 @@ chk_and_rewrite_cmplxpart_assn(SST *lhs, SST *rhs) i_imagnm = "dimag"; i_cmplxnm = "dcmplx"; break; + // AOCC begin + case TY_QUAD: + i_realnm = "qreal"; + i_imagnm = "qimag"; + i_cmplxnm = "qcmplx"; + break; + // AOCC end default: interr("chk_and_rewrite_cmplxpart_assn: unexpected type", DTY(dtype), 3); } @@ -6779,14 +6889,17 @@ construct_association(int lhs_sptr, SST *rhs, int stmt_dtype, LOGICAL is_class) set_descriptor_rank(FALSE /* to reset the hidden API state :-P */); get_all_descriptors(lhs_sptr); if (sem.parallel || sem.target || sem.task) { - if (SDSCG(lhs_sptr)) { + //AOCC Begin + /*if (SDSCG(lhs_sptr)) { SCP(SDSCG(lhs_sptr), SC_PRIVATE); - } + }*/ + SCOPEP(lhs_sptr , SCOPEG(rhs_sptr)); + //AOCC End if (MIDNUMG(lhs_sptr)) { - SCP(MIDNUMG(lhs_sptr), SC_PRIVATE); + SCP(MIDNUMG(lhs_sptr), SC_PRIVATE); } if (PTROFFG(lhs_sptr)) { - SCP(PTROFFG(lhs_sptr), SC_PRIVATE); + SCP(PTROFFG(lhs_sptr), SC_PRIVATE); } } diff --git a/tools/flang1/flang1exe/semantio.c b/tools/flang1/flang1exe/semantio.c index d97271373e..3353e31367 100644 --- a/tools/flang1/flang1exe/semantio.c +++ b/tools/flang1/flang1exe/semantio.c @@ -3,6 +3,20 @@ * See https://llvm.org/LICENSE.txt for license information. * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last modified: Jun 2020 + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified: May 2020 + * + * Support to revert to the old value when newunit has errors. + * Date of Modification: 15th June 2020 */ /** \file @@ -489,7 +503,7 @@ semantio(int rednum, SST *top) int ast1, ast2, ast3; int dim; /* dimension # of the index variable */ int asd; /* array subscript descriptor */ - int subs[7]; + int subs[MAXSUBS]; // AOCC int numdim; int sptr1; int nelems; @@ -718,11 +732,13 @@ semantio(int rednum, SST *top) TYPDP(sptr, 1); INTERNALP(sptr, 0); - ast = mk_func_node(A_FUNC, mk_id(sptr), 0, 0); - ast = mk_assn_stmt(PTV(PT_NEWUNIT), ast, A_DTYPEG(PTV(PT_NEWUNIT))); + ast = begin_io_call(A_FUNC, sptr, 1); //AOCC + (void)add_io_arg(PTARG(PT_UNIT)); //AOCC + ast = mk_assn_stmt(PTV(PT_UNIT), ast, A_DTYPEG(PTV(PT_NEWUNIT))); //AOCC add_stmt_after(ast, io_call.std); - if (A_DTYPEG(PTV(PT_NEWUNIT)) != DT_INT) { - PTV(PT_UNIT) = mk_convert(PTV(PT_NEWUNIT), DT_INT); + + if (A_DTYPEG(PTV(PT_NEWUNIT)) != DT_INT) { + PTV(PT_UNIT) = mk_convert(PTV(PT_UNIT), DT_INT); } } @@ -1168,8 +1184,8 @@ semantio(int rednum, SST *top) (dtype == DT_INT8 || dtype == DT_INT4 || dtype == DT_SINT || dtype == DT_BINT || dtype == DT_LOG8 || dtype == DT_LOG || dtype == DT_SLOG || dtype == DT_BLOG || dtype == DT_REAL4 || - dtype == DT_REAL8 || dtype == DT_CMPLX8 || - dtype == DT_CMPLX16 || + dtype == DT_REAL8 || dtype == DT_QUAD || dtype == DT_CMPLX8 || + dtype == DT_CMPLX16 || dtype == DT_CMPLX32 || (DTY(dtype) == TY_CHAR && fmttyp == FT_LIST_DIRECTED))) { i = sym_mkfunc_nodesc(mkRteRtnNm(getWriteByDtypeRtn(dtype, fmttyp)), @@ -1300,7 +1316,7 @@ semantio(int rednum, SST *top) int shape, forall, triplet_list, n, lb, ub, st, newast; int index_var, triplet, dovar, list, lc, sym, triple; ITEM *arglist, *p; - int subs[7], std; + int subs[MAXSUBS], std; // AOCC int i; if (fmttyp == FT_UNFORMATTED) { argcnt = 4; @@ -2713,6 +2729,7 @@ semantio(int rednum, SST *top) IOERR2(201, PTNAME(PT_DELIM)); PT_CHECK(PT_DECIMAL, astb.ptr0c); PT_CHECK(PT_SIGN, astb.ptr0c); + PT_CHECK(PT_ROUND, astb.ptr0c); sptr = mk_iofunc(rtlRtn, DT_INT, 0); (void)begin_io_call(A_FUNC, sptr, 4); (void)add_io_arg(A_DESTG(ast)); @@ -2895,7 +2912,12 @@ semantio(int rednum, SST *top) CNULL); } if (DTYG(SST_DTYPEG(RHS(1))) == TY_DERIVED && - A_TYPEG(SST_ASTG(RHS(1))) == A_FUNC) { + (A_TYPEG(SST_ASTG(RHS(1))) == A_FUNC || + /* Allocate a temporary ast to store the value of the derived type array + * reference whose subscript is a function reference, otherwise the + * function would be incorrectly called in each component I/O. */ + (A_TYPEG(SST_ASTG(RHS(1))) == A_SUBSCR && + A_CALLFGG(SST_ASTG(RHS(1)))))) { ast = sem_tempify(RHS(1)); (void)add_stmt(ast); SST_IDP(RHS(1), S_IDENT); @@ -4244,7 +4266,7 @@ copy_replic_sect_to_tmp(int array_ast) int asn, std, tmp_ast, tmp_sptr; int dtype; int eldtype; - int subscr[7]; + int subscr[MAXSUBS]; // AOCC /* allocate(tmp(...)) * tmp = array @@ -5041,6 +5063,7 @@ ast_ioret(void) /* ast_type - A_FUNC or A_CALL */ /* count - number of arguments */ /* func - sptr of function to invoke */ +/* return ast to function call */ static int begin_io_call(int ast_type, int func, int count) { @@ -5255,7 +5278,7 @@ static int replace_vector_subscript(int ast, int indexast) { int oldl, newl, oldr, newr, nargs, argt, i, changes, argtnew, sptr; - int asd, nsubs, subs[7], lb; + int asd, nsubs, subs[MAXSUBS], lb; // AOCC int dtype; if (ast == 0) @@ -5400,7 +5423,7 @@ add_iolptrs(int dtype, SST *in_stkptr, int *mndscp) int j, numdim, numdimm; int derived_dtype, dtypem; int mem_id; - int subs[7], rsubs[7]; + int subs[MAXSUBS], rsubs[MAXSUBS]; // AOCC SST *stkptr; ADSC *ad; SST tmpstk; @@ -6138,6 +6161,10 @@ getWriteByDtypeRtn(int dtype, FormatType fmttyp) rtlRtn = (fmttyp == FT_LIST_DIRECTED) ? RTE_f90io_sc_d_ldw : RTE_f90io_sc_d_fmt_write; break; + case DT_QUAD: + rtlRtn = (fmttyp == FT_LIST_DIRECTED) ? RTE_f90io_sc_q_ldw + : RTE_f90io_sc_q_fmt_write; + break; case DT_INT8: rtlRtn = (fmttyp == FT_LIST_DIRECTED) ? RTE_f90io_sc_l_ldw : RTE_f90io_sc_l_fmt_write; @@ -6164,6 +6191,10 @@ getWriteByDtypeRtn(int dtype, FormatType fmttyp) rtlRtn = (fmttyp == FT_LIST_DIRECTED) ? RTE_f90io_sc_cd_ldw : RTE_f90io_sc_cd_fmt_write; break; + case DT_CMPLX32: + rtlRtn = (fmttyp == FT_LIST_DIRECTED) ? RTE_f90io_sc_cq_ldw + : RTE_f90io_sc_cq_fmt_write; + break; default: if (DTY(dtype) == TY_CHAR) { rtlRtn = (fmttyp == FT_LIST_DIRECTED) ? RTE_f90io_sc_ch_ldw diff --git a/tools/flang1/flang1exe/semfin.c b/tools/flang1/flang1exe/semfin.c index 7d9a8b6430..20e6a1cbc1 100644 --- a/tools/flang1/flang1exe/semfin.c +++ b/tools/flang1/flang1exe/semfin.c @@ -275,7 +275,7 @@ add_class_arg_descr_arg(int func_sptr, int arg_sptr, int new_arg_position) int descr_sptr = sym_get_arg_sec(arg_sptr); SDSCP(arg_sptr, descr_sptr); CCSYMP(descr_sptr, TRUE); - } + } } return FALSE; } @@ -1040,6 +1040,24 @@ fix_class_args(int func_sptr) } } +void +fix_class_ptr_args(int func_sptr) +{ + if (!have_class_args_been_fixed_already(func_sptr)) { + /* type descriptors have not yet been added, so now we add them */ + int orig_count = PARAMCTG(func_sptr); + int new_arg_position = orig_count; + int j; + for (j = 0; j < orig_count; ++j) { + int arg_sptr = aux.dpdsc_base[DPDSCG(func_sptr) + j]; + if (POINTERG(arg_sptr) && SDSCG(arg_sptr)) { + inject_arg(func_sptr, SDSCG(arg_sptr), new_arg_position); + ++new_arg_position; + } + } + } +} + static void fix_args(int sptr, LOGICAL is_func) { @@ -3082,7 +3100,10 @@ CheckDecl(int sptr) /* Subroutine reference in a module, could be defined later */ if (sem.mod_cnt > 0 && STYPEG(sptr) == ST_PROC && sem.which_pass == 0) return; - + // AOCC begin + // lower malloc as call + if (!strcmp(SYMNAME(sptr),"malloc")) return; + // AOCC end error(38, !XBIT(124, 0x20000) ? 3 : 2, gbl.lineno, SYMNAME(sptr), CNULL); DCLDP(sptr, 1); } /* CheckDecl */ diff --git a/tools/flang1/flang1exe/semfunc.c b/tools/flang1/flang1exe/semfunc.c index 71df4af5f3..dcd281847a 100644 --- a/tools/flang1/flang1exe/semfunc.c +++ b/tools/flang1/flang1exe/semfunc.c @@ -5,6 +5,81 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Avoiding generation of _mth_aint and _mth_dint lib calls for the aint input; + * instead handling it in flang + * Date of Modification: May 2018 + * + * Support for DNORM intrinsic + * Date of Modification: 21st February 2019 + * + * Support for Bit Sequence Comparsion intrinsic + * Month of Modification: May 2019 + * + * Support for Bit Masking intrinsics. + * Month of Modification: May 2019 + * + * Support for Bit Shifting intrinsics. + * Month of Modification: June 2019 + * + * Support for MERGE_BITS intrinsic. + * Month of Modification: July 2019 + * + * Support for TRAILZ intrinsic. + * Month of Modification: July 2019 + * + * Support for F2008 EXECUTE_COMMAND_LINE intrinsic subroutine. + * Month of Modification: July 2019 + * + * Support for Combined Bit Shifting intrinsic. + * Month of Modification: July 2019 + * + * Support for parity intrinsic. + * Month of Modification: July 2019 + * + * Support for Bit transformational intrinsic iany, iall, iparity. + * Month of Modification: July 2019 + * + * Fixes for CP2K application build + * Month of Modification: November 2019 + * + * Fixed issues related to type bound procedures with and without nopass clause + * Date of Modification: December 2019 + * + * Complex datatype support for acosh , asinh , atanh + * Modified on 08 January 2020 + * + * Added code to support reshape with implied dos inside target region + * Date of Modification: 23rd January 2020 + * + * Added code to support atan with two arguments + * Date of Modification: 27th February 2020 + * + * Added support for quad precision + * Last modified: Feb 2020 + * + * Complex datatype support for atan2 under flag f2008 + * Modified on 13th March 2020 + * + * Modified to omit source file name in compiler_options() + * Date of modification:21st May 2020 + * + * Last modified: Jun 2020 + * + * Support for real*16 intrinsics + * Date of Modification: 18th July 2020 + * + * Implemented rank intrinsic + * Date of modification: 10th Aug 2020 + * + * Added quad support for floor and ceiling intrinsics + * Last modified: August 2020 + * + */ + /** \file \brief Fortran front-end utility routines used by Semantic Analyzer to process functions, subroutines, predeclareds, etc. @@ -108,6 +183,8 @@ static int byval_func_ptr = 0; static int byval_dscptr = 0; static int byval_paramct = 0; +int nearest_status; /* indicating nearest is outside the array */ + #define PASS_BYVAL 1 #define PASS_BYREF 2 #define PASS_BYREF_NO_LEN 3 @@ -460,7 +537,7 @@ get_byval(int func_sptr, int param_sptr) c-_ptr->member */ static int -rewrite_cptr_references(int ast) +rewrite_cptr_references(int ast, bool cassociated) { int past, mast; int new_ast = 0; @@ -481,7 +558,8 @@ rewrite_cptr_references(int ast) default: /* no need to process further all cases of possible nested C_PTR must be in cases above */ - return 0; + if (cassociated) mast=ast; + else return 0; } /* check for type C_PTR, C_FUNC_PTR, and process */ @@ -520,7 +598,7 @@ byvalue_ref_arg(SST *e1, int *dtype, int op, int func_sptr) */ A_DTYPEP(SST_ASTG(e1), DT_PTR); } else { - new_ast = rewrite_cptr_references(SST_ASTG(e1)); + new_ast = rewrite_cptr_references(SST_ASTG(e1),false); if (new_ast) { SST_ASTP(e1, new_ast); SST_IDP(e1, S_EXPR); @@ -654,6 +732,36 @@ is_ptr_arg(SST *sst_actual) return sptr > NOSYM && POINTERG(sptr); } +// AOCC Begin +// Add a tbp arg when there is a call to type bound procedures +static ITEM* +add_tbp_arg (SST *stktop, ITEM *itemp) +{ + ITEM *itemp2; + SST *e1em; + int sp; + int ast = SST_ASTG(stktop); + e1em = (SST *)getitem(0, sizeof(SST)); + sp = sym_of_ast(ast); + SST_SYMP(e1em, sp); + SST_DTYPEP(e1em, DTYPEG(sp)); + mkident(e1em); + mkexpr(e1em); + itemp2 = (ITEM *)getitem(0, sizeof(ITEM)); + itemp2->t.stkp = e1em; + itemp2->next = ITEM_END; + + //tbp arg will be the first argument + if (itemp == ITEM_END) { + itemp = itemp2; + } else { + itemp2->next = itemp; + itemp = itemp2; + } + return itemp; +} // add_tbp_arg +// AOCC End + /* Non-pointer passed to a pointer dummy: geneerate a pointer temp, associate * the temp with the actual arg, and pass the temp. */ @@ -850,6 +958,16 @@ func_call2(SST *stktop, ITEM *list, int flag) dtype = DTY(dtype + 1); if (STYPEG(BINDG(callee)) == ST_USERGENERIC) { int mem; + // AOCC Begin + int imp, mem1; + // For type bound procedures with no "nopass" clause, tbp arg + // has already been added to the list. Need to do the same for type bound + // procedures with "nopass" clause as well. + sptr1 = BINDG(callee); + imp = get_implementation(TBPLNKG(sptr1), sptr1, 0, &mem1); + if (imp && NOPASSG(mem1)) + list = add_tbp_arg(stktop, list); + // AOCC End func_sptr = generic_tbp_func(BINDG(callee), stktop, list); if (func_sptr) { if (get_implementation(dtype, func_sptr, 0, &mem) == 0) { @@ -867,6 +985,14 @@ func_call2(SST *stktop, ITEM *list, int flag) } else { SST_ASTP(stktop, replace_memsym_of_ast(SST_ASTG(stktop), mem)); callee = mem; + // AOCC Begin + // For the type bound procedures with nopass clause, + // tbg arg should be removed before matching the actual arguments. + // First argument is tbp arg. + if (NOPASSG(mem)) { + list = list->next; + } + // AOCC End } } } @@ -1437,6 +1563,20 @@ resolve_fwd_ref(int ref) int func_call(SST *stktop, ITEM *list) { +/* AOCC begin */ +#if defined(OMP_OFFLOAD_LLVM) + + /* Multi-device offloading is not supported at the moment, hence we + * evaluate omp_get_num_devices() call to 1 + */ + const char *func_name = SYMNAME(SST_SYMG(stktop)); + if (flg.x86_64_omptarget && + strcmp(func_name, "omp_get_num_devices") == 0) { + SST_ASTP(stktop, mk_cnst(stb.i1)); + return 1; + } +#endif +/* AOCC end */ int func_sptr; /* Note: If we have a generic tbp (or operator), pass a 0 * flag only if the generic is private. We do this to turn off @@ -2098,8 +2238,13 @@ gen_pointer_result(int array_value, int dscptr, int nactuals, get_all_descriptors(arr_tmp); /* need to have different MIDNUM than arr_value */ /* otherwise multiple declaration */ - pvar = sym_get_ptr(arr_tmp); - MIDNUMP(arr_tmp, pvar); + // AOCC: Issue with CP2k + // the following code is incorrect and it makes + // the pointer to point to invalid locations + // due to wrong offset +// pvar = sym_get_ptr(arr_tmp); +// MIDNUMP(arr_tmp, pvar); + MIDNUMP(arr_tmp, 0); NODESCP(arr_tmp, 0); ddt = DDTG(dt); if ((DTY(dt) == TY_CHAR && dt != DT_DEFERCHAR) || @@ -2578,7 +2723,7 @@ rewrite_subscr(int ast_subscr, int dscptr, int nactuals) int i; int actarr; int asd, numdim; - int subs[7]; /* maximum number of dimensions */ + int subs[MAXSUBS]; /* AOCC: maximum number of dimensions */ int triple; int subscr; @@ -3262,6 +3407,15 @@ subr_call2(SST *stktop, ITEM *list, int flag) } if (stype == ST_USERGENERIC && check_generic) { if (CLASSG(sptr)) { + // AOCC Begin + int imp, mem; + imp = get_implementation(TBPLNKG(sptr), sptr, 0, &mem); + // For type bound procedures with no "nopass" clause, tbp arg + // has already been added to the list. Need to do the same for type bound + // procedures with "nopass" clause as well. + if (imp && NOPASSG(mem)) + list = add_tbp_arg(stktop, list); + // AOCC End sptr = generic_tbp_call(sptr, stktop, list, 0); goto do_call; } @@ -3427,6 +3581,16 @@ subr_call2(SST *stktop, ITEM *list, int flag) sptr1 = 0; break; } + // AOCC Begin + // For the type bound procedures with nopass clause, + // tbg arg should be removed before matching the actual arguments. + // First argument is tbp arg. + if (NOPASSG(mem)) { + list = list->next; + count_actuals(list); + count = carg.nent; + } + // AOCC End ast = replace_memsym_of_ast(ast, mem); SST_ASTP(stktop, ast); sptr = BINDG(mem); @@ -3594,7 +3758,7 @@ subr_call2(SST *stktop, ITEM *list, int flag) do not rewrite iso c_loc */ - ARGT_ARG(argt, ii) = rewrite_cptr_references(SST_ASTG(sp)); + ARGT_ARG(argt, ii) = rewrite_cptr_references(SST_ASTG(sp),false); } else if (get_byval(sptr, param_dummy) && PASSBYVALG(param_dummy) && OPTARGG(param_dummy)) { @@ -3844,14 +4008,7 @@ ptrsubr_call(SST *stktop, ITEM *list) /* sptr is a function */ error(84, 3, gbl.lineno, SYMNAME(sptr), "- attempt to CALL a FUNCTION"); dtype = DTYPEG(sptr); -#if DEBUG - assert(DTY(dtype) == TY_PTR, "ptrsubr_call, expected TY_PTR dtype", sptr, 4); -#endif dtproc = DTY(dtype + 1); -#if DEBUG - assert(DTY(dtproc) == TY_PROC, "ptrsubr_call, expected TY_PROC dtype", sptr, - 4); -#endif dtype = DTY(dtproc + 1); iface = DTY(dtproc + 2); paramct = DTY(dtproc + 3); @@ -3908,7 +4065,7 @@ ptrsubr_call(SST *stktop, ITEM *list) do not rewrite iso c_loc */ - ARGT_ARG(argt, ii) = rewrite_cptr_references(SST_ASTG(sp)); + ARGT_ARG(argt, ii) = rewrite_cptr_references(SST_ASTG(sp),false); ii++; } else if (pass_char_no_len(sptr, param_dummy)) { byvalue_ref_arg(sp, &dum, OP_REF, sptr); @@ -4064,9 +4221,18 @@ gen_newer_intrin(int sptrgenr, int dtype) if (strcmp(intrin_nmptr, "acos") == 0 || strcmp(intrin_nmptr, "asin") == 0 || strcmp(intrin_nmptr, "atan") == 0 || strcmp(intrin_nmptr, "cosh") == 0 || strcmp(intrin_nmptr, "sinh") == 0 || strcmp(intrin_nmptr, "tanh") == 0 || - strcmp(intrin_nmptr, "tan") == 0) { + strcmp(intrin_nmptr, "tan") == 0 || + //AOCC begin + strcmp(intrin_nmptr, "asinh") == 0 || strcmp(intrin_nmptr, "atanh") == 0|| + strcmp(intrin_nmptr, "acosh") == 0 || strcmp(intrin_nmptr, "cotan") == 0 ) { + //AOCC end if (DT_ISCMPLX(dtype)) { switch (DTY(dtype)) { + // AOCC begin + case TY_QCMPLX: + strcat(nmptr, "cq"); + break; + // AOCC end case TY_DCMPLX: strcat(nmptr, "cd"); break; @@ -4094,6 +4260,11 @@ gen_newer_intrin(int sptrgenr, int dtype) INTASTP(sptr, NEW_INTRIN); switch (DTY(dtype)) { + // AOCC begin + case TY_QCMPLX: + GQCMPLXP(sptrgenr, sptr); + break; + // AOCC end case TY_DCMPLX: GDCMPLXP(sptrgenr, sptr); break; @@ -4204,6 +4375,12 @@ ref_intrin(SST *stktop, ITEM *list) * is used as the respective internal respresentation */ switch (intrin) { + // AOCC begin + case I_QUAD: + case I_QCMPLX: + dt_cast_word = DT_QUAD; + break; + // AOCC end case I_DBLE: case I_DCMPLX: dt_cast_word = DT_DBLE; @@ -4468,10 +4645,26 @@ ref_intrin(SST *stktop, ITEM *list) opc = ILMG(sptr); argtyp = ARGTYPG(sptr); paramct = PARAMCTG(sptr); - - if (paramct != 12 && paramct != 11 && count > paramct) { - goto intrinsic_error; + + /* AOCC begin */ + if ((intast == I_ATAN) && (count == 2)) + intast = I_ATAN2; + + else if (paramct != 12 && paramct != 11 && count > paramct) { + if(count > paramct) { + if (intast == I_ATAN) { + e74_cnt(sptre, count, paramct, 2); + return 0; + } + else { + e74_cnt(sptre, count, paramct, paramct); + return 0; + } + } + else + goto intrinsic_error; } + /* AOCC end */ if (paramct == 11) { /* CMPLX/DCMPLX intrinsic */ if (ARG_STK(1)) @@ -4479,7 +4672,8 @@ ref_intrin(SST *stktop, ITEM *list) * real/dble */ - dtype = dtype == DT_CMPLX ? stb.user.dt_real : DT_DBLE; + dtype = dtype == DT_CMPLX ? stb.user.dt_real : dtype == DT_DCMPLX + ? DT_DBLE : DT_QUAD; else /* treat like typical type conversion intrinsic */ paramct = 1; @@ -4605,8 +4799,10 @@ ref_intrin(SST *stktop, ITEM *list) if (DTY(dtype) == TY_REAL) conval = getcon(num1, DT_CMPLX); - else + if (DTY(dtype) == TY_DBLE) conval = getcon(num1, DT_DCMPLX); + else + conval = getcon(num1, DT_QCMPLX); goto const_return; } @@ -4672,6 +4868,7 @@ ref_intrin(SST *stktop, ITEM *list) goto const_return; case IM_IMAG: case IM_DIMAG: + case IM_QIMAG: // AOCC conval = CONVAL2G(con1); goto const_return; case IM_CONJG: @@ -4684,6 +4881,13 @@ ref_intrin(SST *stktop, ITEM *list) con2 = CONVAL2G(con1); res[1] = const_fold(OP_SUB, (INT)stb.dbl0, con2, DT_REAL8); goto const_getcon; + // AOCC begin + case IM_QCONJG: + res[0] = CONVAL1G(con1); + con2 = CONVAL2G(con1); + res[1] = const_fold(OP_SUB, (INT)stb.quad0, con2, DT_QUAD); + goto const_getcon; + // AOCC end #ifdef IM_DPROD case IM_DPROD: con2 = GET_CVAL_ARG(1); @@ -5247,6 +5451,7 @@ ref_intrin(SST *stktop, ITEM *list) */ func_type = A_INTR; + char* rtlFn; switch (intast) { case I_ICHAR: if (count == 2) { @@ -5257,22 +5462,42 @@ ref_intrin(SST *stktop, ITEM *list) case I_MODULO: switch ((int)INTTYPG(sptr)) { case DT_SINT: - rtlRtn = RTE_imodulov; + rtlFn = mkRteRtnNm(RTE_imodulov); +#if defined(OMP_OFFLOAD_LLVM) + if (flg.amdgcn_target) rtlFn ="__f90_imodulov"; +#endif break; case DT_INT4: - rtlRtn = RTE_modulov; + rtlFn = mkRteRtnNm(RTE_modulov); +#if defined(OMP_OFFLOAD_LLVM) + if (flg.amdgcn_target) rtlFn ="__f90_modulov"; +#endif break; case DT_INT8: - rtlRtn = RTE_i8modulov; + rtlFn = mkRteRtnNm(RTE_i8modulov); +#if defined(OMP_OFFLOAD_LLVM) + if (flg.amdgcn_target) rtlFn ="__f90_i8modulov_i8"; +#endif break; case DT_REAL4: - rtlRtn = RTE_amodulov; + rtlFn = mkRteRtnNm(RTE_amodulov); +#if defined(OMP_OFFLOAD_LLVM) + if (flg.amdgcn_target) rtlFn ="__f90_amodulov"; +#endif break; case DT_REAL8: - rtlRtn = RTE_dmodulov; + rtlRtn = mkRteRtnNm(RTE_dmodulov); +#if defined(OMP_OFFLOAD_LLVM) + if (flg.amdgcn_target) rtlFn ="__f90_dmodulov"; +#endif break; + case DT_QUAD: + rtlRtn = mkRteRtnNm(RTE_qmodulov); +#if defined(OMP_OFFLOAD_LLVM) + if (flg.amdgcn_target) rtlFn ="__f90_qmodulov"; +#endif } - fsptr = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), (int)INTTYPG(sptr)); + fsptr = sym_mkfunc_nodesc(rtlFn, (int)INTTYPG(sptr)); EXTSYMP(sptr, fsptr); ELEMENTALP(sptr, 1); func_ast = mk_id(fsptr); @@ -5454,13 +5679,13 @@ _c_associated(SST *stkp, int count) lop = ARG_AST(0); if (!is_iso_cptr(A_DTYPEG(lop))) return 0; - lop = rewrite_cptr_references(lop); + lop = rewrite_cptr_references(lop, true); ARG_AST(0) = lop; if (count == 2) { rop = ARG_AST(1); if (!is_iso_cptr(A_DTYPEG(rop))) return 0; - rop = rewrite_cptr_references(rop); + rop = rewrite_cptr_references(rop, true); ARG_AST(1) = rop; } return 1; @@ -5611,6 +5836,9 @@ ref_pd(SST *stktop, ITEM *list) SPTR pdsym = SST_SYMG(stktop); int pdtype = PDNUMG(pdsym); int is_real2_arg_error = 0; + SST *sp; + int argdtype; + int dt_cast_word; /* any integer type, or hollerith, or, if -x 51 0x20 not set, real/double */ #define TYPELESS(dt) \ @@ -5810,6 +6038,176 @@ ref_pd(SST *stktop, ITEM *list) XFR_ARGAST(1); } break; + + // AOCC Begin + case PD_iparity: + case PD_iall: + case PD_iany: + if (flg.std != F2008) { + char buf[64]; + sprintf(buf, "iall and iany is supported only in f2008, use -std=f2008 to enable\n"); + error(155, 3, gbl.lineno, SYMNAME(pdsym), buf); + } + if (count == 0 || count > 3) { + E74_CNT(pdsym, count, 1, 3); + goto call_e74_cnt; + } + if (evl_kwd_args(list, 3, KWDARGSTR(pdsym))) + goto exit_; + argt_count = 3; + dtype1 = SST_DTYPEG(ARG_STK(0)); + if (!DT_ISNUMERIC_ARR(dtype1)) { + if (pdtype == PD_iany || pdtype == PD_iall || pdtype == PD_iparity) { + if (!(DTY(dtype1) == TY_ARRAY && + (DTYG(dtype1) == TY_CHAR || DTYG(dtype1) == TY_NCHAR))) { + E74_ARG(pdsym, 0, NULL); + goto call_e74_arg; + } + + } else { + E74_ARG(pdsym, 0, NULL); + goto call_e74_arg; + } + } + if (pdtype == PD_iany || pdtype == PD_iall || pdtype == PD_iparity) { + if ((!DT_ISINT_ARR(dtype1) && !DT_ISREAL_ARR(dtype1) && + !(DTY(dtype1) == TY_ARRAY && + (DTYG(dtype1) == TY_CHAR || DTYG(dtype1) == TY_NCHAR))) || + DT_ISLOG_ARR(dtype1)) { + E74_ARG(pdsym, 0, NULL); + goto call_e74_arg; + } + } + dtyper = DTY(dtype1 + 1); + if ((stkp = ARG_STK(2))) { /* mask */ + dtype2 = DDTG(SST_DTYPEG(stkp)); + if (!DT_ISLOG(dtype2)) { + E74_ARG(pdsym, 2, NULL); + goto call_e74_arg; + } + if (!chkshape(stkp, ARG_STK(0), FALSE)) { + E74_ARG(pdsym, 2, NULL); + goto call_e74_arg; + } + XFR_ARGAST(2); + } + if ((stkp = ARG_STK(1))) { /* dim */ + dtype2 = SST_DTYPEG(stkp); + if (!DT_ISINT(dtype2)) { + if (count == 2) { + if (DT_ISLOG(DDTG(dtype2)) && chkshape(stkp, ARG_STK(0), FALSE)) { + XFR_ARGAST(1); + /* shift args over */ + ARG_AST(2) = ARG_AST(1); /* mask */ + ARG_AST(1) = 0; /* dim is 'null' */ + break; + } + } + E74_ARG(pdsym, 1, NULL); + goto call_e74_arg; + } + + if (rank_of_ast(ARG_AST(0)) != 1) { + shaper = reduc_shape((int)A_SHAPEG(ARG_AST(0)), (int)SST_ASTG(stkp), + (int)STD_PREV(0)); + if (shaper) + dtyper = dtype1; + } else + check_dim_error((int)A_SHAPEG(ARG_AST(0)), (int)SST_ASTG(stkp)); + } + break; + case PD_parity: + if (flg.std != F2008) { + char buf[64]; + sprintf(buf, "parity is supported only in f2008, use -std=f2008 to enable\n"); + error(155, 3, gbl.lineno, SYMNAME(pdsym), buf); + } + if (count == 0 || count > 2) { + E74_CNT(pdsym, count, 1, 2); + goto call_e74_cnt; + } + // Evaluate all the arguments, and create them + if (evl_kwd_args(list, count, KWDARGSTR(pdsym))) + goto exit_; + + argt_count = 2; + dtype1 = SST_DTYPEG(ARG_STK(0)); + if (!DT_ISLOG_ARR(dtype1)) { + E74_ARG(pdsym, 0, NULL); + goto call_e74_arg; + } + dtyper = DTY(dtype1 + 1); + if ((stkp = ARG_STK(1))) { /* dim */ + dtype2 = SST_DTYPEG(stkp); + if (!DT_ISINT(dtype2)) { + E74_ARG(pdsym, 1, NULL); + goto call_e74_arg; + } + shaper = reduc_shape((int)A_SHAPEG(ARG_AST(0)), (int)SST_ASTG(stkp), + (int)STD_PREV(0)); + if (shaper) + dtyper = dtype1; + } + break; +#if 0 + // Pre-Defined function norm2() + case PD_norm2: + + if (flg.std != F2008) { + char buf[64]; + sprintf(buf, "norm2 is supported only in f2008, use -std=f2008 to enable\n"); + error(155, 3, gbl.lineno, SYMNAME(pdsym), buf); + } + // Allow only one argument for now + if (count != 1) { + E74_CNT(pdsym, count, 1, 1); + goto call_e74_cnt; + } + // Evaluate all the arguments, and create them + if (evl_kwd_args(list, count, KWDARGSTR(pdsym))) + goto exit_; + + dtype1 = SST_DTYPEG(ARG_STK(0)); + shape1 = SST_SHAPEG(ARG_STK(0)); + int rank = SHD_NDIM(shape1); + // First argument alwys should be array + if ( DTY(dtype1) != TY_ARRAY) { + E74_ARG(pdsym, 0, NULL); + goto call_e74_arg; + } + + // When dim is specified, return vlaue is an array + if (rank > 1 && count > 1) { + dtyper = SST_DTYPEG(ARG_STK(0)); + } + + // Set return type to match the element type of arg1 + if (DTYG(dtype1) == TY_REAL) + dtyper = DT_REAL4; + + if (DTYG(dtype1) == TY_DBLE) + dtyper = DT_REAL8; + + argt_count = count; + break; +#endif + case PD_isnan: + if (count != 1 || get_kwd_args(list, count, KWDARGSTR(pdsym))) + goto bad_args; + dtype1 = SST_DTYPEG(ARG_STK(0)); + if (DTYG(dtype1) != TY_REAL && DTYG(dtype1) != TY_DBLE + && DTYG(dtype1 != TY_QUAD)) + goto bad_args; + (void)mkexpr(ARG_STK(0)); + XFR_ARGAST(0); + dtyper = DT_LOG; + if (DTY(dtype1) == TY_ARRAY) { + shape1 = A_SHAPEG(ARG_AST(0)); + count = SHD_NDIM(shape1); + dtyper = get_array_dtype(count, DT_LOG); + } + break; + // AOCC End case PD_dotproduct: if (!XBIT(49, 0x40)) /* if xbit set, CM fortran intrinsics allowed */ goto bad_args; @@ -6235,8 +6633,8 @@ ref_pd(SST *stktop, ITEM *list) if (sem.dinit_data) { int rank; - int ubound[7]; - int lbound[7]; + int ubound[MAXSUBS]; // AOCC + int lbound[MAXSUBS]; // AOCC SST bndarry; ACL *argacl; ACL **r; @@ -7007,6 +7405,11 @@ ref_pd(SST *stktop, ITEM *list) } else if (dtype1 == DT_DBLE) { (void)mkexpr(ARG_STK(0)); dtyper = DT_DBLE; + // AOCC begin + } else if (dtype1 == DT_QUAD) { + (void)mkexpr(ARG_STK(0)); + dtyper = DT_QUAD; + // AOCC end } else { goto bad_args; } @@ -7063,7 +7466,7 @@ ref_pd(SST *stktop, ITEM *list) stkp = ARG_STK(0); /* source */ shape1 = SST_SHAPEG(stkp); - if (shape1 && SHD_NDIM(shape1) == 7) { + if (shape1 && SHD_NDIM(shape1) == get_legal_maxdim()) { // AOCC E74_ARG(pdsym, 0, NULL); goto call_e74_arg; } @@ -7300,7 +7703,7 @@ ref_pd(SST *stktop, ITEM *list) rtlRtn = RTE_shape4; break; case DT_INT8: - rtlRtn = RTE_shape; + rtlRtn = RTE_shape8; break; default: error(155, 3, gbl.lineno, SYMNAME(gbl.currsub), @@ -7321,6 +7724,11 @@ ref_pd(SST *stktop, ITEM *list) goto expr_val; case PD_reshape: + //AOCC Begin + //reset the vaiables used for expanding reshape + sem.reshape.is_shape_ido_const = false; + sem.reshape.is_source_ido = false; + //AOCC End if (count < 2 || count > 4) { E74_CNT(pdsym, count, 2, 4); goto call_e74_cnt; @@ -7343,10 +7751,27 @@ ref_pd(SST *stktop, ITEM *list) if (shape_acl && shape_acl->is_const) { shape_acl = SST_ACLG(stkp); count = get_int_cval(sym_of_ast(AD_NUMELM(AD_DPTR(dtype1)))); - if (count < 0 || count > 7) { + if (count < 0 || count > MAXSUBS) { // AOCC E74_ARG(pdsym, 1, NULL); goto call_e74_arg; } + //AOCC Begin + //if reshape specifies reshaping to a 2D or a 3D array, + //save the required information for expanding reshape. + if(count == 2 || count == 3) { + sem.reshape.is_shape_ido_const = true; + sem.reshape.num_dims = count; + int i = 0; + ACL *cur_aclp = shape_acl->subc; + SST *stkp; + int ast; + for(; cur_aclp != NULL; cur_aclp = cur_aclp->next) { + stkp = cur_aclp->u1.stkp; + ast = SST_ASTG(stkp); + sem.reshape.const_shape_asts[i++] = ast; + } + } + //AOCC End } else shape_acl = NULL; @@ -7363,6 +7788,17 @@ ref_pd(SST *stktop, ITEM *list) ALLOCDESCP(allo_sptr, TRUE); } } + //AOCC Begin + //mark if source is an implied do. + if (SST_IDG(stkp) == S_ACONST && SST_ACLG(stkp) != 0) { + ACL *aclp; + aclp = SST_ACLG(stkp); + //expand only if source is not a list of constants + if(!aclp->is_const) { + sem.reshape.is_source_ido = true; + } + } + //AOCC End argt_count = 4; stkp = ARG_STK(1); /* shape */ @@ -7391,7 +7827,7 @@ ref_pd(SST *stktop, ITEM *list) goto call_e74_arg; } count = get_int_cval(A_SPTRG(tmp)); - if (count < 0 || count > 7) { + if (count < 0 || count > MAXSUBS) { // AOCC E74_ARG(pdsym, 1, NULL); goto call_e74_arg; } @@ -7411,7 +7847,8 @@ ref_pd(SST *stktop, ITEM *list) XFR_ARGAST(3); dtype2 = SST_DTYPEG(stkp); if (!DT_ISINT(DTY(dtype2 + 1)) || - count != get_int_cval(sym_of_ast(AD_NUMELM(AD_DPTR(dtype2))))) { + ((STYPEG(sym_of_ast(AD_NUMELM(AD_DPTR(dtype2)))) == ST_CONST) && // AOCC + count != get_int_cval(sym_of_ast(AD_NUMELM(AD_DPTR(dtype2)))))) { E74_ARG(pdsym, 3, NULL); goto call_e74_arg; } @@ -7509,12 +7946,12 @@ ref_pd(SST *stktop, ITEM *list) * indices; e.g., lwb : upb : stride. */ int arr; - int subs[7]; + int subs[MAXSUBS]; // AOCC int asd; int dim = 0; int nsubs = 1; int ix; - int shp[7]; + int shp[MAXSUBS]; // AOCC int eldtype; eldtype = DDTG(A_DTYPEG(ast)); @@ -7551,6 +7988,31 @@ ref_pd(SST *stktop, ITEM *list) } break; + //AOCC Begin + case PD_rank: + if (count != 1) { + E74_CNT(pdsym, count, 1, 1); + goto call_e74_cnt; + } + if (evl_kwd_args(list, 1, KWDARGSTR(pdsym))) + goto exit_; + dtyper = stb.user.dt_int; + stkp = ARG_STK(0); + int rank = 0; + if (DTY(SST_DTYPEG(stkp)) == TY_ARRAY) + rank = AD_NUMDIM(AD_DPTR(SST_DTYPEG(stkp))); + ast = mk_cval(rank, dtyper); + EXPSTP(pdsym, 1); + SST_IDP(stktop, S_CONST); + SST_DTYPEP(stktop, dtyper); + SST_SHAPEP(stktop, 0); + SST_ASTP(stktop, ast); + if (DTY(dtyper) != TY_INT8) + SST_CVALP(stktop, rank); + else + SST_CVALP(stktop, A_SPTRG(ast)); + return SST_CVALG(stktop); + //AOCC End case PD_merge: if (count != 3) { E74_CNT(pdsym, count, 3, 3); @@ -7997,21 +8459,22 @@ ref_pd(SST *stktop, ITEM *list) #ifdef PD_ieee_selected_real_kind case PD_ieee_selected_real_kind: #endif - if (count > 2 || count == 0) { - E74_CNT(pdsym, count, 0, 2); + if (count > 3) { + E74_CNT(pdsym, count, 0, 3); goto call_e74_cnt; } - if (evl_kwd_args(list, 2, KWDARGSTR(pdsym))) + if (evl_kwd_args(list, 3, KWDARGSTR(pdsym))) goto exit_; if (sem.dinit_data) { - gen_init_intrin_call(stktop, pdsym, 2, stb.user.dt_int, FALSE); + gen_init_intrin_call(stktop, pdsym, 3, stb.user.dt_int, FALSE); return 0; } stkp = ARG_STK(0); is_constant = TRUE; conval = 4; + int r = 0, p = 0; if (!stkp) { ARG_AST(0) = astb.ptr0; } else { @@ -8032,10 +8495,12 @@ ref_pd(SST *stktop, ITEM *list) conval = 4; else if (con1 <= 15) conval = 8; - else if (con1 <= 31 && !XBIT(57, 4)) + else if (con1 <= 31 && (!XBIT(57, 0x4))) conval = 16; - else + else { conval = -1; + p = -1; + } } } stkp = ARG_STK(1); @@ -8058,35 +8523,87 @@ ref_pd(SST *stktop, ITEM *list) if (XBIT(49, 0x40000)) { /* Cray C90 */ if (con1 <= 37) { - if (conval > 0 && conval < 4) + if (conval > 0 && conval <= 4) conval = 4; } else if (con1 <= 2465) { - if (conval > 0 && conval < 8) + if (conval > 0 && conval <= 8) conval = 8; } else { if (conval > 0) conval = 0; - conval -= 2; + conval = -2; + r = -2; } } else { /* ANSI */ if (con1 <= 37) { - if (conval > 0 && conval < 4) + if (conval > 0 && conval <= 4) conval = 4; } else if (con1 <= 307) { - if (conval > 0 && conval < 8) + if (conval > 0 && conval <= 8) conval = 8; - } else if (con1 <= 4931 && !XBIT(57, 4)) { - if (conval > 0 && conval < 16) + } else if ((con1 <= 4931) && (!XBIT(57, 0x4))) { + if (conval > 0 && conval <= 16) conval = 16; } else { if (conval > 0) conval = 0; - conval -= 2; + conval = -2; + r = -2; + } + } + } + } + // AOCC begin + stkp = ARG_STK(2); + if (!stkp) { + ARG_AST(2) = astb.ptr0; + if (p < 0 && r < 0) + conval = -3; + } else { + dtype1 = SST_DTYPEG(stkp); + if (!DT_ISINT(dtype1)) { + E74_ARG(pdsym, 2, NULL); + goto call_e74_arg; + } + XFR_ARGAST(2); + ast = SST_ASTG(stkp); + if (!A_ALIASG(ast)) { + is_constant = FALSE; + } else { + ast = A_ALIASG(ast); + con1 = A_SPTRG(ast); + con1 = CONVAL2G(con1); + if (XBIT(49, 0x40000)) { + /* Cray C90 */ + if (con1 == 2) { + if (conval > 0 && conval <= 4) + conval = 4; + else if (conval > 0 && conval <= 8) + conval = 8; + else if (p < 0 && r < 0) + conval = -3; + } + else if (con1 != 2) + conval = -5; + } else { + /* ANSI */ + if (con1 == 2) { + if (conval > 0 && conval <= 4) + conval = 4; + else if (conval > 0 && conval <= 8) + conval = 8; + else if (conval > 0 && conval <= 16) + conval = 16; + else if (p < 0 && r < 0) + conval = -3; } + else if (con1 != 2) + conval = -5; } } } + // AOCC end if (is_constant) { goto const_default_int_val; /*return default integer*/ } @@ -8095,7 +8612,7 @@ ref_pd(SST *stktop, ITEM *list) hpf_sym = sym_mkfunc(mkRteRtnNm(RTE_sel_real_kind), stb.user.dt_int); dtyper = stb.user.dt_int; - argt_count = 2; + argt_count = 3; break; case PD_selected_char_kind: @@ -8310,6 +8827,189 @@ ref_pd(SST *stktop, ITEM *list) } goto const_kind_int_val; + /* AOCC begin */ + case PD_bge: + case PD_bgt: + case PD_ble: + case PD_blt: + if (flg.std != F2008) { + error(155, 3, gbl.lineno, SYMNAME(pdsym), + "bit sequence comparison is supported only in f2008, use -std=f2008 to enable\n"); + } + + if (count != 2) { + E74_CNT(pdsym, count, 2, 2); + goto call_e74_cnt; + } + + /* evaluates and makes each args. Sets the ARG_AST(:) as well */ + if (evl_kwd_args(list, count, KWDARGSTR(pdsym))) + goto exit_; + + dtype1 = SST_DTYPEG(ARG_STK(0)); /* first arg */ + dtype2 = SST_DTYPEG(ARG_STK(1)); /* second arg */ + + /* Both arguments should be some kind of INTEGER where kind is at max = 8 */ + switch (DTY(dtype1)) { + case TY_WORD: + case TY_DWORD: + case TY_BINT: + case TY_SINT: + case TY_INT: + case TY_INT8: + break; + default: + E74_ARG(pdsym, 0, NULL); + goto call_e74_arg; + } + + switch (DTY(dtype2)) { + case TY_WORD: + case TY_DWORD: + case TY_BINT: + case TY_SINT: + case TY_INT: + case TY_INT8: + break; + default: + E74_ARG(pdsym, 1, NULL); + goto call_e74_arg; + } + + dtyper = DT_LOG; + argt_count = count; + break; + + case PD_maskl: + case PD_maskr: + if (flg.std != F2008) { + error(155, 3, gbl.lineno, SYMNAME(pdsym), + "bit masking is supported only in f2008, use -std=f2008 to enable\n"); + } + + if (count > 2 || count <= 0) { + E74_CNT(pdsym, count, 1, 2); + goto call_e74_cnt; + } + + /* evaluates and makes each args. Sets the ARG_AST(:) as well */ + if (evl_kwd_args(list, count, KWDARGSTR(pdsym))) + goto exit_; + + /* Both arguments should be some kind of INTEGER where kind is at max = 8 */ + dtype1 = SST_DTYPEG(ARG_STK(0)); /* first arg */ + switch (DTY(dtype1)) { + case TY_WORD: + case TY_DWORD: + case TY_BINT: + case TY_SINT: + case TY_INT: + case TY_INT8: + break; + default: + E74_ARG(pdsym, 0, NULL); + goto call_e74_arg; + } + + if (count == 2) { + dtype2 = SST_DTYPEG(ARG_STK(1)); /* second arg */ + switch (DTY(dtype2)) { + case TY_WORD: + case TY_DWORD: + case TY_BINT: + case TY_SINT: + case TY_INT: + case TY_INT8: + break; + default: + E74_ARG(pdsym, 1, NULL); + goto call_e74_arg; + } + } + + dtyper = DT_INT8; + argt_count = count; + break; + + case PD_merge_bits: { + if (flg.std != F2008) { + error(155, 3, gbl.lineno, SYMNAME(pdsym), + "merge_bits is supported only in f2008, use -std=f2008 to enable\n"); + } + + int dtype3; + + if (count != 3) { + E74_CNT(pdsym, count, 3, 3); + goto call_e74_cnt; + } + + /* evaluates and makes each args. Sets the ARG_AST(:) as well */ + if (evl_kwd_args(list, count, KWDARGSTR(pdsym))) + goto exit_; + + /* All arguments should be some INTGER kind or boz-literal constant. i and j + * can't be both boz-literal constant */ + dtype1 = SST_DTYPEG(ARG_STK(0)); /* first arg (i) */ + switch (DTY(dtype1)) { + case TY_WORD: + case TY_DWORD: + case TY_BINT: + case TY_SINT: + case TY_INT: + case TY_INT8: + break; + default: + E74_ARG(pdsym, 0, NULL); + goto call_e74_arg; + } + + dtype2 = SST_DTYPEG(ARG_STK(1)); /* second arg (j) */ + switch (DTY(dtype2)) { + case TY_WORD: + case TY_DWORD: + case TY_BINT: + case TY_SINT: + case TY_INT: + case TY_INT8: + break; + default: + E74_ARG(pdsym, 1, NULL); + goto call_e74_arg; + } + + dtype3 = SST_DTYPEG(ARG_STK(2)); /* third arg (mask) */ + switch (DTY(dtype3)) { + case TY_WORD: + case TY_DWORD: + case TY_BINT: + case TY_SINT: + case TY_INT: + case TY_INT8: + break; + default: + E74_ARG(pdsym, 2, NULL); + goto call_e74_arg; + } + + /* If i and j are boz-literal constants, then throw error */ + if ((DTY(dtype1) == TY_WORD || DTY(dtype1) == TY_DWORD) && + (DTY(dtype2) == TY_WORD || DTY(dtype2) == TY_DWORD)) { + E74_ARG(pdsym, 0, NULL); + goto call_e74_arg; + } + + /* If kinds mismatch, then throw error */ + if (!(DTY(dtype1) == DTY(dtype2) && DTY(dtype2) == DTY(dtype3))) { + E74_ARG(pdsym, 0, NULL); + goto call_e74_arg; + } + + dtyper = (dtype1 > dtype2) ? dtype1 : dtype2; + argt_count = count; + break; + } + /* AOCC end */ case PD_digits: if (count != 1) { @@ -8377,6 +9077,20 @@ ref_pd(SST *stktop, ITEM *list) } sname = "epsilon(1.0_8)"; goto const_dble_val; + // AOCC begin + case TY_QUAD: + if (XBIT(49, 0x40000)) { /* C90 */ +#define C90_EPSILON "0.50487097934144755546350628178090e-28L" + atoxq(C90_EPSILON, &val[0], strlen(C90_EPSILON)); + } else { + val[0] = 0x3f8f0000; + val[1] = 0; + val[2] = 0; + val[3] = 0; + } + sname = "epsilon(1.0_16)"; + goto const_quad_val; + // AOCC end default: break; } @@ -8441,7 +9155,7 @@ ref_pd(SST *stktop, ITEM *list) default: interr("PD_spacing, pdtype", pdtype, 3); } - } else { /* TY_DBLE */ + } else if (DTY(dtype1) == TY_DBLE) { /* TY_DBLE */ switch (pdtype) { case PD_fraction: rtlRtn = RTE_fracd; @@ -8455,6 +9169,20 @@ ref_pd(SST *stktop, ITEM *list) default: interr("PD_spacingd, pdtype", pdtype, 3); } + } else { + switch (pdtype) { + case PD_fraction: + rtlRtn = RTE_fracq; + break; + case PD_rrspacing: + rtlRtn = RTE_rrspacingq; + break; + case PD_spacing: + rtlRtn = RTE_spacingq; + break; + default: + interr("PD_spacingq, pdtype", pdtype, 3); + } } (void)sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), dtype1); break; @@ -8467,6 +9195,17 @@ ref_pd(SST *stktop, ITEM *list) case PD_acosh: case PD_asinh: case PD_atanh: + if (count != 1) { + E74_CNT(pdsym, count, 1, 1); + goto call_e74_cnt; + } + if (evl_kwd_args(list, 1, KWDARGSTR(pdsym))) + goto exit_; + stkp = ARG_STK(0); + dtyper = SST_DTYPEG(stkp); + shaper = SST_SHAPEG(stkp); + dtype1 = DDTG(dtyper); + break; case PD_bessel_j0: case PD_bessel_j1: case PD_bessel_y0: @@ -8729,13 +9468,14 @@ ref_pd(SST *stktop, ITEM *list) dtyper = dtype1; /* initial result of call is type of argument */ - /* for this case dtype2 is used for conversion; the actual floor/ceiling - * calls we use return real, but the Fortran declaration returns int. + + /* for this case dtype2 is used for conversion; the actual floor/ceiling + * calls we use return real, but the Fortran declaration returns int. * We need to calculate final type for conversion to correct int kind. */ if ((stkp = ARG_STK(1))) { /* kind */ - dtype2 = set_kind_result(stkp, DT_INT, TY_INT); + dtype2 = set_kind_result(stkp, DT_INT, TY_INT); if (!dtype2) { E74_ARG(pdsym, 1, NULL); goto call_e74_arg; @@ -8765,8 +9505,8 @@ ref_pd(SST *stktop, ITEM *list) dtyper = get_array_dtype(1, dtyper); goto gen_call; + // AOCC begin case PD_aint: - case PD_anint: if (count < 1 || count > 2) { E74_CNT(pdsym, count, 1, 2); goto call_e74_cnt; @@ -8781,17 +9521,15 @@ ref_pd(SST *stktop, ITEM *list) E74_ARG(pdsym, 0, NULL); goto call_e74_arg; } - if ((stkp = ARG_STK(1))) { /* kind */ + if ((stkp = ARG_STK(1))) { dtyper = set_kind_result(stkp, DT_REAL, TY_REAL); if (!dtyper) { E74_ARG(pdsym, 1, NULL); goto call_e74_arg; } } else - dtyper = dtype1; /* result is type of argument */ - /* If this is f90, leave the kind argument in. Otherwise issue - * a warning and leave it -- we'll get to it someday - */ + dtyper = dtype1; + (void)mkexpr(ARG_STK(0)); shaper = SST_SHAPEG(ARG_STK(0)); XFR_ARGAST(0); @@ -8803,7 +9541,102 @@ ref_pd(SST *stktop, ITEM *list) } if (shaper) dtyper = get_array_dtype(1, dtyper); + if (dtyper == DT_QUAD) { + ast = ARG_AST(0); + ast = mk_convert(ast, DT_INT); + ast = mk_convert(ast, dtyper); + goto expr_val; + } + + goto gen_call; + + case PD_anint: + if (count < 1 || count > 2) { + E74_CNT(pdsym, count, 1, 2); + goto call_e74_cnt; + } + if (get_kwd_args(list, 2, KWDARGSTR(pdsym))) + goto exit_; + stkp = ARG_STK(0); + if (SST_ISNONDECC(stkp)) + cngtyp(stkp, DT_INT); + dtype1 = DDTG(SST_DTYPEG(stkp)); + if (!DT_ISREAL(dtype1)) { + E74_ARG(pdsym, 0, NULL); + goto call_e74_arg; + } + + if ((stkp = ARG_STK(1))) { /* kind */ + dtyper = set_kind_result(stkp, DT_REAL, TY_REAL); + if (!dtyper) { + E74_ARG(pdsym, 1, NULL); + goto call_e74_arg; + } + } else { + dtyper = dtype1; + } + + if (sem.dinit_data) { + gen_init_intrin_call(stktop, pdsym, count, dtyper, TRUE); + return 0; + } + + stkp = ARG_STK(0); + if (is_sst_const(stkp)) { + con1 = get_sst_cval(stkp); + switch (DTY(dtype1)) { + case TY_REAL: + num1[0] = CONVAL2G(stb.flt0); + if (xfcmp(con1, num1[0]) >= 0) { + INT fv2_23 = 0x4b000000; + if (xfcmp(con1, fv2_23) >= 0) + xfadd(con1, CONVAL2G(stb.flt0), &res[0]); + else + xfadd(con1, CONVAL2G(stb.flthalf), &res[0]); + } else { + INT fvm2_23 = 0xcb000000; + if (xfcmp(con1, fvm2_23) <= 0) + xfsub(con1, CONVAL2G(stb.flt0), &res[0]); + else + xfsub(con1, CONVAL2G(stb.flthalf), &res[0]); + } + break; + case TY_DBLE: + if (const_fold(OP_CMP, con1, stb.dbl0, DT_REAL8) >= 0) { + INT dv2_52[2] = {0x43300000, 0x00000000}; + INT d2_52; + d2_52 = getcon(dv2_52, DT_DBLE); + if (const_fold(OP_CMP, con1, d2_52, DT_REAL8) >= 0) + res[0] = const_fold(OP_ADD, con1, stb.dbl0, DT_REAL8); + else + res[0] = const_fold(OP_ADD, con1, stb.dblhalf, DT_REAL8); + } else { + INT dvm2_52[2] = {0xc3300000, 0x00000000}; + INT dm2_52; + dm2_52 = getcon(dvm2_52, DT_DBLE); + if (const_fold(OP_CMP, con1, dm2_52, DT_REAL8) >= 0) + res[0] = const_fold(OP_SUB, con1, stb.dblhalf, DT_REAL8); + else + res[0] = const_fold(OP_SUB, con1, stb.dbl0, DT_REAL8); + } + break; + } + } + + (void)mkexpr(ARG_STK(0)); + shaper = SST_SHAPEG(ARG_STK(0)); + XFR_ARGAST(0); + argt_count = 1; + if (ARG_STK(1)) { + (void)mkexpr(ARG_STK(1)); + argt_count = 2; + ARG_AST(1) = mk_cval1(target_kind(dtyper), DT_REAL); + } + if (shaper) + dtyper = get_array_dtype(1, dtyper); + goto gen_call; + // AOCC end case PD_int: if (count < 1 || count > 2) { @@ -8967,9 +9800,11 @@ ref_pd(SST *stktop, ITEM *list) stkp1 = ARG_STK(1); stkp2 = ARG_STK(2); + // AOCC : DT_CMPLX32 if (stkp2) { /* kind */ dtyper = set_kind_result(stkp2, DT_CMPLX, TY_CMPLX); - dtype1 = dtyper == DT_CMPLX16 ? DT_REAL8 : DT_REAL4; + dtype1 = dtyper == DT_CMPLX16 ? DT_REAL8 : dtyper == DT_CMPLX32 ? + DT_QUAD : DT_REAL4; if (!dtyper) { E74_ARG(pdsym, 1, NULL); goto call_e74_arg; @@ -9205,7 +10040,12 @@ ref_pd(SST *stktop, ITEM *list) stkp = ARG_STK(0); shaper = SST_SHAPEG(stkp); ast = ARG_AST(0); - if (dtype1 != dtyper) { + + /* + * AOCC: If -fdefault-integer-8, then we need to preserve the shape by + * generating a call, else future semantics will be mislead. + */ + if (dtype1 != dtyper || XBIT(124, 0x10)) { /* AOCC */ argt_count = 1; goto gen_call; } @@ -9235,6 +10075,7 @@ ref_pd(SST *stktop, ITEM *list) conval = pdtype == PD_maxexponent ? 8189 : -8188; else conval = pdtype == PD_maxexponent ? 16384 : -16381; + break; default: E74_ARG(pdsym, 0, NULL); goto call_e74_arg; @@ -9248,40 +10089,88 @@ ref_pd(SST *stktop, ITEM *list) } if (evl_kwd_args(list, 2, KWDARGSTR(pdsym))) goto exit_; - stkp = ARG_STK(0); - shaper = SST_SHAPEG(stkp); - dtype1 = DDTG(SST_DTYPEG(stkp)); - dtype2 = DDTG(SST_DTYPEG(ARG_STK(1))); - if (!DT_ISREAL(dtype1) || !DT_ISREAL(dtype2)) { - E74_ARG(pdsym, 0, NULL); - goto call_e74_arg; - } - shape2 = SST_SHAPEG(ARG_STK(1)); - shaper = set_shape_result(shaper, shape2); - if (shaper < 0) { - E74_ARG(pdsym, 2, NULL); - goto call_e74_arg; - } - ast = ARG_AST(1); - if (shape2) - dtyper = get_array_dtype(1, DT_LOG); - else - dtyper = DT_LOG; - if (DTY(dtype2) == TY_REAL) - ast = mk_binop(OP_GE, ast, mk_cnst(stb.flt0), dtyper); - else - ast = mk_binop(OP_GE, ast, mk_cnst(stb.dbl0), dtyper); - ARG_AST(1) = ast; - if (DTY(dtype1) == TY_REAL) - rtlRtn = RTE_nearest; - else /* TY_DBLE */ - rtlRtn = RTE_nearestd; - (void)sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), dtype1); - dtyper = SST_DTYPEG(stkp); - if (shaper && DTY(dtyper) != TY_ARRAY) - dtyper = get_array_dtype(1, dtyper); - break; + // AOCC begin + sp = ARG_STK(0); + dtype1 = SST_DTYPEG(sp); + shaper = SST_SHAPEG(sp); + sp = ARG_STK(1); + dtype2 = SST_DTYPEG(sp); + + if (sem.in_array_const == 0) { + nearest_status = 1; + stkp = ARG_STK(0); + shaper = SST_SHAPEG(stkp); + dtype1 = DDTG(SST_DTYPEG(stkp)); + dtype2 = DDTG(SST_DTYPEG(ARG_STK(1))); + if (!DT_ISREAL(dtype1) || !DT_ISREAL(dtype2)) { + E74_ARG(pdsym, 0, NULL); + goto call_e74_arg; + } + shape2 = SST_SHAPEG(ARG_STK(1)); + shaper = set_shape_result(shaper, shape2); + if (shaper < 0) { + E74_ARG(pdsym, 2, NULL); + goto call_e74_arg; + } + ast = ARG_AST(1); + if (shape2) + dtyper = get_array_dtype(1, DT_LOG); + else + dtyper = DT_LOG; + if (DTY(dtype2) == TY_REAL) + ast = mk_binop(OP_GE, ast, mk_cnst(stb.flt0), dtyper); + else + ast = mk_binop(OP_GE, ast, mk_cnst(stb.quad0), dtyper); + ARG_AST(1) = ast; + if (DTY(dtype1) == TY_REAL) + rtlRtn = RTE_nearest; + else + rtlRtn = RTE_nearestq; //AOCC + (void)sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), dtype1); + dtyper = SST_DTYPEG(stkp); + if (shaper && DTY(dtyper) != TY_ARRAY) + dtyper = get_array_dtype(1, dtyper); + break; + } + else { + sp = ARG_STK(0); + dtype1 = 0; + for (i = 0; i < count; i++) { + sp = ARG_STK(i); + argdtype = SST_DTYPEG(sp); + if (argdtype == DT_WORD || argdtype == DT_DWORD) { + if (dt_cast_word) { + cngtyp(sp, dt_cast_word); + argdtype = SST_DTYPEG(sp); + } else if (argdtype == DT_WORD) { + } + } + if (!dtype1) { + dtype1 = argdtype; + if (DTY(argdtype) == TY_ARRAY) + break; + } + else { + if (DTY(argdtype) == TY_ARRAY) { + dtype1 = argdtype; + break; + } + } + } + if (DTY(dtype1) == TY_REAL) + rtlRtn = RTE_nearest; + else if(DTY(dtype1) == TY_DBLE) + rtlRtn = RTE_nearestd; + else + rtlRtn = RTE_nearestq; + char* nmptr = mkRteRtnNm(rtlRtn); + (void)sym_mkfunc_nodesc(nmptr, dtype1); + dtyper = SST_DTYPEG(sp); + break; + } + // AOCC end + case PD_precision: if (count != 1) { E74_CNT(pdsym, count, 1, 1); @@ -9331,6 +10220,7 @@ ref_pd(SST *stktop, ITEM *list) case TY_INT8: case TY_REAL: case TY_DBLE: + case TY_QUAD: conval = 2; break; default: @@ -9418,12 +10308,20 @@ ref_pd(SST *stktop, ITEM *list) rtlRtn = RTE_scale; else rtlRtn = RTE_setexp; - } else { /* TY_DBLE */ + } else if (DTY(dtype1) == TY_DBLE){ /* TY_DBLE */ if (pdtype == PD_scale) rtlRtn = RTE_scaled; else rtlRtn = RTE_setexpd; } + //AOCC Begin + else { + if (pdtype == PD_scale) + rtlRtn = RTE_scaleq; + else + rtlRtn = RTE_setexpq; + } + //AOCC End (void)sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), dtype1); break; @@ -9454,6 +10352,22 @@ ref_pd(SST *stktop, ITEM *list) if (XBIT(51, 0x10)) goto const_dword_val; goto const_dble_val; + // AOCC begin + case TY_QUAD: + if (XBIT(49, 0x40000)) { /* C90 */ +#define C90_TINY "0.733441547021938866248564956819e-2465" /* 0200044000000000000000 */ + /* 0000000000000000000000 */ + atoxq(C90_TINY, &val[0], strlen(C90_TINY)); + } else { + /* 3.362103143112093506262677817321752603E-4932 */ + val[0] = 0x00010000; /* was 0x00080000 */ + val[1] = 0x00000000; + val[2] = 0x00000000; + val[3] = 0x00000000; + } + sname = "tiny(1.0_16)"; + goto const_quad_val; + // AOCC end default: break; } @@ -10460,61 +11374,195 @@ ref_pd(SST *stktop, ITEM *list) case PD_shiftl: case PD_shiftr: - if (count != 2) { - E74_CNT(pdsym, count, 2, 2); - goto call_e74_cnt; - } - if (evl_kwd_args(list, 2, KWDARGSTR(pdsym))) - goto exit_; - stkp = ARG_STK(0); /* i */ - shaper = SST_SHAPEG(stkp); - dtype1 = DDTG(SST_DTYPEG(stkp)); - if (!DT_ISINT(dtype1) && !DT_ISREAL(dtype1)) { - E74_ARG(pdsym, 0, NULL); - goto call_e74_arg; - } - stkp = ARG_STK(1); /* j */ - dtype1 = DDTG(SST_DTYPEG(stkp)); - if (!DT_ISINT(dtype1)) { - E74_ARG(pdsym, 0, NULL); - goto call_e74_arg; + /* AOCC begin */ + if (flg.std == F2008) { + if (count != 2) { + E74_CNT(pdsym, count, 2, 2); + goto call_e74_cnt; + } + + /* evaluates and makes each args. Sets the ARG_AST(:) as well */ + if (evl_kwd_args(list, count, KWDARGSTR(pdsym))) + goto exit_; + + dtype1 = SST_DTYPEG(ARG_STK(0)); /* first arg */ + dtype2 = SST_DTYPEG(ARG_STK(1)); /* second arg */ + + switch (DTY(dtype1)) { + case TY_WORD: + case TY_DWORD: + case TY_BINT: + case TY_SINT: + case TY_INT: + case TY_INT8: + break; + default: + E74_ARG(pdsym, 0, NULL); + goto call_e74_arg; + } + + switch (DTY(dtype2)) { + case TY_WORD: + case TY_DWORD: + case TY_BINT: + case TY_SINT: + case TY_INT: + case TY_INT8: + break; + default: + E74_ARG(pdsym, 1, NULL); + goto call_e74_arg; + } + + dtyper = DT_INT; + argt_count = count; + break; + + /* + * The below semantic handling suggests that the shiftl/shiftr it's + * expecting is not the one from the F2008 standard. We default the handling + * to if the standard is not f2008 or above. + */ + + } else { + /* AOCC end */ + if (count != 2) { + E74_CNT(pdsym, count, 2, 2); + goto call_e74_cnt; + } + if (evl_kwd_args(list, 2, KWDARGSTR(pdsym))) + goto exit_; + stkp = ARG_STK(0); /* i */ + shaper = SST_SHAPEG(stkp); + dtype1 = DDTG(SST_DTYPEG(stkp)); + if (!DT_ISINT(dtype1) && !DT_ISREAL(dtype1)) { + E74_ARG(pdsym, 0, NULL); + goto call_e74_arg; + } + stkp = ARG_STK(1); /* j */ + dtype1 = DDTG(SST_DTYPEG(stkp)); + if (!DT_ISINT(dtype1)) { + E74_ARG(pdsym, 0, NULL); + goto call_e74_arg; + } + if (shaper) + dtyper = get_array_dtype(SHD_NDIM(shaper), DT_DWORD); + else + dtyper = DT_DWORD; + break; } - if (shaper) - dtyper = get_array_dtype(SHD_NDIM(shaper), DT_DWORD); - else - dtyper = DT_DWORD; - break; case PD_dshiftl: case PD_dshiftr: - if (count != 3) { - E74_CNT(pdsym, count, 3, 3); - goto call_e74_cnt; - } - if (evl_kwd_args(list, 3, KWDARGSTR(pdsym))) - goto exit_; - shaper = 0; - for (i = 0; i < 3; i++) { - stkp = ARG_STK(i); /* i, j, k */ - dtype1 = DDTG(SST_DTYPEG(stkp)); - if (!DT_ISINT(dtype1)) { - E74_ARG(pdsym, i, NULL); + /* AOCC begin */ + if (flg.std == F2008) { + int dtype3; + + if (count != 3) { + E74_CNT(pdsym, count, 3, 3); + goto call_e74_cnt; + } + + /* evaluates and makes each args. Sets the ARG_AST(:) as well */ + if (evl_kwd_args(list, count, KWDARGSTR(pdsym))) + goto exit_; + + /* All arguments should be some INTGER kind or boz-literal constant. i and j + * can't be both boz-literal constant */ + dtype1 = SST_DTYPEG(ARG_STK(0)); /* first arg (i) */ + switch (DTY(dtype1)) { + case TY_WORD: + case TY_DWORD: + case TY_BINT: + case TY_SINT: + case TY_INT: + case TY_INT8: + break; + default: + E74_ARG(pdsym, 0, NULL); + goto call_e74_arg; + } + + dtype2 = SST_DTYPEG(ARG_STK(1)); /* second arg (j) */ + switch (DTY(dtype2)) { + case TY_WORD: + case TY_DWORD: + case TY_BINT: + case TY_SINT: + case TY_INT: + case TY_INT8: + break; + default: + E74_ARG(pdsym, 1, NULL); + goto call_e74_arg; + } + + dtype3 = SST_DTYPEG(ARG_STK(2)); /* third arg (shift) */ + switch (DTY(dtype3)) { + case TY_WORD: + case TY_DWORD: + case TY_BINT: + case TY_SINT: + case TY_INT: + case TY_INT8: + break; + default: + E74_ARG(pdsym, 2, NULL); + goto call_e74_arg; + } + + /* If i and j are boz-literal constants, then throw error */ + if ((DTY(dtype1) == TY_WORD || DTY(dtype1) == TY_DWORD) && + (DTY(dtype2) == TY_WORD || DTY(dtype2) == TY_DWORD)) { + E74_ARG(pdsym, 0, NULL); goto call_e74_arg; } - if (shaper) { - if ((shape1 = SST_SHAPEG(stkp)) && - SHD_NDIM(shaper) != SHD_NDIM(shape1)) { + + /* If kinds mismatch, then throw error */ + if (DTY(dtype1) != DTY(dtype2)) { + E74_ARG(pdsym, 0, NULL); + goto call_e74_arg; + } + + dtyper = (dtype1 > dtype2) ? dtype1 : dtype2; + argt_count = count; + break; + /* + * The below semantic handling suggests that the dshiftl/dshiftr it's + * expecting is not the one from the F2008 standard. We default the handling + * to if the standard is not f2008 or above. + */ + } else { + /* AOCC end */ + if (count != 3) { + E74_CNT(pdsym, count, 3, 3); + goto call_e74_cnt; + } + if (evl_kwd_args(list, 3, KWDARGSTR(pdsym))) + goto exit_; + shaper = 0; + for (i = 0; i < 3; i++) { + stkp = ARG_STK(i); /* i, j, k */ + dtype1 = DDTG(SST_DTYPEG(stkp)); + if (!DT_ISINT(dtype1)) { E74_ARG(pdsym, i, NULL); goto call_e74_arg; } - } else - shaper = SST_SHAPEG(stkp); + if (shaper) { + if ((shape1 = SST_SHAPEG(stkp)) && + SHD_NDIM(shaper) != SHD_NDIM(shape1)) { + E74_ARG(pdsym, i, NULL); + goto call_e74_arg; + } + } else + shaper = SST_SHAPEG(stkp); + } + if (shaper) + dtyper = get_array_dtype(SHD_NDIM(shaper), DT_INT); + else + dtyper = DT_INT; + break; } - if (shaper) - dtyper = get_array_dtype(SHD_NDIM(shaper), DT_INT); - else - dtyper = DT_INT; - break; case PD_mask: /* Mask is a cray intrinsic */ @@ -10585,6 +11633,15 @@ ref_pd(SST *stktop, ITEM *list) if (get_kwd_args(list, 1, KWDARGSTR(pdsym))) goto exit_; + // AOCC begin + if (STYPEG(SST_SYMG(ARG_STK(0))) == ST_PROC || + is_procedure_ptr(SST_SYMG(ARG_STK(0)))) { + error(4, 3, gbl.lineno, + "Procedure unexpected as argument", NULL); + goto exit_; + } + // AOCC end + (void)mkarg(ARG_STK(0), &dum); XFR_ARGAST(0); ast = ARG_AST(0); @@ -10597,7 +11654,9 @@ ref_pd(SST *stktop, ITEM *list) sptr = A_SPTRG(ast); } if (sptr) { - if (POINTERG(sptr) || ALLOCG(sptr) || CLASSG(sptr) || ASSUMSHPG(sptr) || + // AOCC Begin - Removed pointer restriction + if (ALLOCG(sptr) || CLASSG(sptr) || ASSUMSHPG(sptr) || + // AOCC end ASUMSZG(sptr) || (DTY(DTYPEG(sptr)) == TY_DERIVED && !(CFUNCG(DTY(DTYPEG(sptr) + 3)) || is_iso_cptr(DTYPEG(sptr)) || @@ -10764,6 +11823,9 @@ ref_pd(SST *stktop, ITEM *list) } break; case PD_leadz: + /* AOCC begin */ + case PD_trailz: + /* AOCC end */ case PD_popcnt: case PD_poppar: if (count != 1) { @@ -10804,6 +11866,25 @@ ref_pd(SST *stktop, ITEM *list) ; for (; isspace(*sname); ++sname) ; + //AOCC Begin + sname[strlen(sname)-1] = '\0'; + int i, j ,count; + for(i = 0 ; i < strlen(sname) ; i++) + { + count = 0 , j=0; + while(sname[i] == flg.source_file[j] && sname[i]!='\0') + { + i++, j++ , count++; + } + if(count == strlen(flg.source_file)) + { + for(i; i < strlen(sname) ; i++) + sname[i-count] = sname[i]; + sname[i-count] = '\0'; + break; + } + } + //AOCC End sptr = getstring(sname, strlen(sname)); } else { interr("compiler_options: command line not available", 0, 3); @@ -10847,6 +11928,7 @@ ref_pd(SST *stktop, ITEM *list) else func_ast = mk_id(pdsym); ast = mk_func_node(func_type, func_ast, argt_count + argt_extra, argt); + if (shaper) dtyper = dtype_with_shape(dtyper, shaper); A_DTYPEP(ast, dtyper); @@ -11022,6 +12104,7 @@ ref_pd(SST *stktop, ITEM *list) goto exit_; call_e74_arg: e74_arg(_e74_sym, _e74_pos, _e74_kwd); + exit_: dont_issue_assumedsize_error = 0; EXPSTP(pdsym, 1); /* freeze predeclared */ @@ -11071,6 +12154,11 @@ getMergeSym(int dt, int ikind) case TY_DCMPLX: rtlRtn = RTE_mergedc; break; + // AOCC begin + case TY_QCMPLX: + rtlRtn = RTE_mergeqc; + break; + // AOCC end case TY_BLOG: rtlRtn = RTE_mergel1; break; @@ -11644,6 +12732,50 @@ ref_pd_subr(SST *stktop, ITEM *list) argt_count = 3; break; + /* AOCC begin */ + case PD_mm_prefetch: + if (!count || count > 2) { + E74_CNT(pdsym, count, 1, 2); + goto call_e74_cnt; + } + + if (evl_kwd_args(list, count, KWDARGSTR(pdsym))) + goto exit_; + + dtype1 = SST_DTYPEG(ARG_STK(0)); /* first arg (address) */ + + if (is_sst_const(ARG_STK(0))) { + E74_ARG(pdsym, 0, NULL); + goto call_e74_arg; + } + + if (count == 1) { /* if no hint */ + argt_count = count; + break; + } + + dtype2 = SST_DTYPEG(ARG_STK(1)); /* second arg (hint) */ + + if (!is_sst_const(ARG_STK(1))) { + E74_ARG(pdsym, 1, NULL); + goto call_e74_arg; + } + + switch (DTY(dtype2)) { + case TY_WORD: + case TY_DWORD: + case TY_BINT: + case TY_SINT: + case TY_INT: + break; + default: + E74_ARG(pdsym, 1, NULL); + goto call_e74_arg; + } + argt_count = count; + break; + /* AOCC end */ + case PD_get_environment_variable: if (count < 1 || count > 5) { E74_CNT(pdsym, count, 1, 5); diff --git a/tools/flang1/flang1exe/semfunc2.c b/tools/flang1/flang1exe/semfunc2.c index 67ebf1b56b..b555e6a084 100644 --- a/tools/flang1/flang1exe/semfunc2.c +++ b/tools/flang1/flang1exe/semfunc2.c @@ -4,6 +4,25 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + * Added support for F2008 feature complex type arguments for atan2 + * Date of modification : March 2020 + * + * Fixed flang throws unexpected CE 'Illegal number or type of arguments' for ST_IDENT + * Date of modification : 29th June 2020 + * + * Added code support for dasinh + * Modified on 31st Aug 2020 + * + * Added code support for cotan + * Modified on Oct 2020 + */ /** \file * \brief Utility routines used by semantic analyzer. @@ -856,7 +875,6 @@ intrinsic_as_arg(int intr) int sp2; int cp; FtnRtlEnum rtlRtn; - sp2 = intr; switch (STYPEG(intr)) { case ST_GENERIC: @@ -865,7 +883,12 @@ intrinsic_as_arg(int intr) return 0; case ST_PD: case ST_INTRIN: - cp = PNMPTRG(sp2); + //AOCC begin + if ((strcmp(SYMNAME(intr), "atan2")) == 0) + cp = PNMPTRG(GREALG(intr)); + else + cp = PNMPTRG(sp2); + //AOCC end if (cp == 0 || stb.n_base[cp] == '-') return 0; if (stb.n_base[cp] != '*' || stb.n_base[++cp] != '\0') { @@ -1006,6 +1029,11 @@ intrinsic_as_arg(int intr) case I_COS: sp2 = intast_sym[I_DCOS]; break; + /* AOCC begin */ + case I_COTAN: + sp2 = intast_sym[I_DCOTAN]; + break; + /* AOCC end */ case I_TAN: sp2 = intast_sym[I_DTAN]; break; @@ -1042,6 +1070,11 @@ intrinsic_as_arg(int intr) case I_COSD: sp2 = intast_sym[I_DCOSD]; break; + /* AOCC begin */ + case I_COTAND: + sp2 = intast_sym[I_DCOTAND]; + break; + /* AOCC end */ case I_TAND: sp2 = intast_sym[I_DTAND]; break; @@ -1400,6 +1433,12 @@ select_gsame(int gnr) } else if (XBIT(124, 0x8)) { if (ARGTYPG(spec) == DT_REAL) spec = GDBLEG(gnr); + // AOCC begin + else if (ARGTYPG(spec) == DT_QUAD) + spec = GQUADG(gnr); + else if (ARGTYPG(spec) == DT_QCMPLX) + spec = GQCMPLXG(gnr); + // AOCC end else if (ARGTYPG(spec) == DT_CMPLX) spec = GDCMPLXG(gnr); } @@ -2101,7 +2140,7 @@ compat_arg_lists(int formal, int actual) if (fdscptr == 0 || adscptr == 0 || (flags & DEFER_IFACE_CHK)) { return TRUE; /* No dummy parameter descriptor; can't check. */ } - paramct = PARAMCTG(formal); + paramct = PARAMCTG(formal) - PDNUMG(formal); if (PARAMCTG(actual) != paramct) return FALSE; for (i = 0; i < paramct; i++, fdscptr++, adscptr++) { @@ -2111,7 +2150,8 @@ compat_arg_lists(int formal, int actual) aarg = *(aux.dpdsc_base + adscptr); if (STYPEG(farg) == ST_PROC) { if (STYPEG(aarg) != ST_PROC && STYPEG(aarg) != ST_ENTRY && - STYPEG(aarg) != ST_INTRIN && STYPEG(aarg) != ST_GENERIC) + STYPEG(aarg) != ST_INTRIN && STYPEG(aarg) != ST_GENERIC && + STYPEG(aarg) != ST_IDENT) //AOCC return FALSE; if (!compat_arg_lists(farg, aarg)) return FALSE; @@ -2914,11 +2954,25 @@ iface_intrinsic(int sptr) dtyper = DT_DBLE; argdtype = DT_DBLE; break; + // AOCC begin + case I_DASINH: + paramct = 1; + dtyper = DT_DBLE; + argdtype = DT_DBLE; + break; + // AOCC end case I_DSQRT: /* dsqrt */ paramct = 1; dtyper = DT_DBLE; argdtype = DT_DBLE; break; + /* AOCC begin */ + case I_DCOTAN: /* dcotan */ + paramct = 1; + dtyper = DT_DBLE; + argdtype = DT_DBLE; + break; + /* AOCC end */ case I_DTAN: /* dtan */ paramct = 1; dtyper = DT_DBLE; @@ -2999,6 +3053,13 @@ iface_intrinsic(int sptr) dtyper = DT_REAL; argdtype = DT_REAL; break; + /* AOCC begin */ + case I_COTAN: /* cotan */ + paramct = 1; + dtyper = DT_REAL; + argdtype = DT_REAL; + break; + /* AOCC end */ case I_TANH: /* tanh */ paramct = 1; dtyper = DT_REAL; diff --git a/tools/flang1/flang1exe/semgnr.c b/tools/flang1/flang1exe/semgnr.c index 2d92f8e6b9..254999a44f 100644 --- a/tools/flang1/flang1exe/semgnr.c +++ b/tools/flang1/flang1exe/semgnr.c @@ -4,6 +4,16 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Fixes for CP2K application build + * Month of Modification: November 2019 + * + * Fixed issues related to type bound procedures with and without nopass clause + * Date of Modification: December 2019 + */ /** \file \brief Fortran utility routines used by Semantic Analyzer to process @@ -100,8 +110,9 @@ static struct optabstruct { {0, ""}, /* OP_LOC 26 */ {0, ""}, /* OP_REF 27 */ {0, ""}, /* OP_VAL 28 */ + {0, ".xor."}, /* OP_LXOR 29 */ // AOCC }; -#define OPTABSIZE 29 +#define OPTABSIZE 30 /** \brief Determines if we should (re)generate generic type bound procedure * (tbp) bindings based on scope. This should only be done once per scope. @@ -313,6 +324,10 @@ find_best_generic(int gnr, ITEM *list, int arg_cnt, int try_device, int dscptr; int paramct, curr_paramct; SPTR found_sptrgen, func_sptrgen; + // AOCC Begin + ITEM *list_bkp = list; + int arg_cnt_bkp = arg_cnt; + // AOCC End /* find the generic's max nbr of formal args and use it to compute * the size of the arg distatnce data item. @@ -382,6 +397,11 @@ find_best_generic(int gnr, ITEM *list, int arg_cnt, int try_device, for (gndsc = GNDSCG(sptrgen); gndsc; gndsc = SYMI_NEXT(gndsc)) { func = SYMI_SPTR(gndsc); func_sptrgen = sptrgen; + // AOCC Begin + // Restore the argument list and argument count + list = list_bkp; + arg_cnt = arg_cnt_bkp; + // AOCC End if (IS_TBP(func)) { /* For generic type bound procedures, use the implementation * of the generic bind name for the argument comparison. @@ -399,8 +419,18 @@ find_best_generic(int gnr, ITEM *list, int arg_cnt, int try_device, if (!func) continue; mem = get_generic_member(dty, bind); - if (NOPASSG(mem) && generic_tbp_has_pass_and_nopass(dty, BINDG(mem))) - continue; + // AOCC Begin + // Commented the below code to fix issues with type bound procedures + // with and without nopass clause. + // if (NOPASSG(mem) && generic_tbp_has_pass_and_nopass(dty, BINDG(mem))) + // continue; + if (NOPASSG(mem)) { + // skip the tbp arg which has been added while processing the call + // type bound procedures with nopass clause will not have tbp argument. + list = list->next; + arg_cnt--; + } + // AOCC End if (mem && PRIVATEG(mem) && SCOPEG(stb.curr_scope) != SCOPEG(mem)) continue; } else @@ -410,8 +440,11 @@ find_best_generic(int gnr, ITEM *list, int arg_cnt, int try_device, if (func == 0) continue; } - if (STYPEG(func) == ST_ALIAS) + // AOCC Begin + if (STYPEG(func) == ST_ALIAS) { func = SYMLKG(func); + } + // AOCC End if (chk_elementals && ELEMENTALG(func)) { argdistance = args_match(func, arg_cnt, distance_sz, list, TRUE, try_device == 1); @@ -420,7 +453,8 @@ find_best_generic(int gnr, ITEM *list, int arg_cnt, int try_device, try_device == 1); } if (found && func && found != func && *min_argdistance != INF_DISTANCE && - !is_conflicted_generic(func_sptrgen, found_sptrgen) && + (!PRIVATEG(SCOPEG(func))) && // AOCC + (!is_conflicted_generic(func_sptrgen, found_sptrgen)) && cmp_arg_score(argdistance, min_argdistance, distance_sz) == 0) { int len; char *name, *name_cpy; @@ -1095,6 +1129,8 @@ is_intrinsic_opr(int val, SST *stktop, SST *lop, SST *rop, int tkn_alias) ITEM *list; int rank, dtype; char buf[100]; + int copy , copy_ast; //AOCC + SST *copy_rhs; //AOCC opr = optab[val].opr; if (opr) { diff --git a/tools/flang1/flang1exe/semsmp.c b/tools/flang1/flang1exe/semsmp.c index 0f9e154803..e46ece6677 100644 --- a/tools/flang1/flang1exe/semsmp.c +++ b/tools/flang1/flang1exe/semsmp.c @@ -5,6 +5,21 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading. + * Last Modified: Nov 2020 + * + * Support for x86-64 OpenMP offloading + * Last modified: Mar 2020 + * + * Added support for openmp schedule clause + * Last modified : March 2021 + * + */ + /** \file \brief semantic analyzer routines which process SMP statements. */ @@ -28,6 +43,7 @@ #include "llmputil.h" #include "mp.h" #include "atomic_common.h" +#include "extern.h" /* contents of this file: */ @@ -37,6 +53,7 @@ static void accel_sched_errchk(); static void accel_nosched_errchk(); static void accel_pragmagen(int, int, int); +static int modifier(char *); //AOCC static int sched_type(char *); static void set_iftype(int, char *, char *, char *); static void validate_if(int, char *); @@ -52,6 +69,7 @@ static void do_copyin(void); static void do_copyprivate(void); static int size_of_allocatable(int); static void do_default_clause(int); +static void end_in_reduction(REDUC *, int); // AOCC static void begin_parallel_clause(int); static void end_reduction(REDUC *, int); static void end_lastprivate(int); @@ -82,7 +100,7 @@ static void private_check(); static void deallocate_no_scope_sptr(); static int get_stblk_uplevel_sptr(); static int add_firstprivate_assn(int, int, int); -static void begin_combine_constructs(BIGINT64); +static bool begin_combine_constructs(BIGINT64); static void end_targteams(); static LOGICAL is_last_private(int); static void mp_add_shared_var(int, int); @@ -104,21 +122,46 @@ static LOGICAL is_valid_atomic_update(int, int); static int mk_atomic_update_binop(int, int); static int mk_atomic_update_intr(int, int); static void do_map(); -static LOGICAL use_atomic_for_reduction(int); +// AOCC Begin +static void do_tofrom(); +static void do_usedeviceptr(); +static void do_usedeviceaddr(); // AOCC +static void do_in_reduction(); // AOCC +static void do_isdeviceptr(); +static LOGICAL use_atomic_for_reduction(int, REDUC *, REDUC_SYM *); +// AOCC End + +static LOGICAL is_in_omptarget(int d); #if defined(OMP_OFFLOAD_LLVM) || defined(OMP_OFFLOAD_PGI) static char *map_type; bool isalways = false; static int get_omp_combined_mode(BIGINT64 type); static void mp_handle_map_clause(SST *, int, char *, int, int, bool); +// AOCC Begin +static void mp_handle_motion_clause(SST *, int, int); +static void mp_check_defaultmap_val(const char *maptype); +static int mp_get_map_type_for(const char *map_string); +// AOCC End static void mp_check_maptype(const char *maptype); -static LOGICAL is_in_omptarget(int d); static LOGICAL is_in_omptarget_data(int d); #endif #ifdef OMP_OFFLOAD_LLVM static void gen_reduction_ompaccel(REDUC *reducp, REDUC_SYM *reduc_symp, LOGICAL rmme, LOGICAL in_parallel); +// AOCC Begin +#ifdef OMP_OFFLOAD_AMD +int target_ast = 0; +int reduction_kernel = 0; +#endif +// AOCC End #endif +int teams_ast = 0; // AOCC +int distribute_pdo_ast = 0; /* AOCC */ +int distribute_doif = 0; /* AOCC */ +int tgt_distribute_ast = 0; /* AOCC */ +struct collapse_loop collapse_loop = {0, 0, 0, 0}; +static int map_exit_data = 0; /*-------- define data structures and macros local to this file: --------*/ @@ -239,8 +282,11 @@ static void gen_reduction_ompaccel(REDUC *reducp, REDUC_SYM *reduc_symp, #define CL_ACCATTACH 107 #define CL_ACCDETACH 108 #define CL_ACCCOMPARE 109 -#define CL_PGICOMPARE 110 -#define CL_MAXV 111 /* This must be the last clause */ +#define CL_IN_REDUCTION 110 +#define CL_USE_DEVICE_ADDR 111 +#define CL_PGICOMPARE 112 +#define CL_MP_MODIFIER 113 +#define CL_MAXV 114 /* This must be the last clause */ /* * define bit flag for each statement which may have clauses. Used for * checking for illegal clauses. @@ -286,219 +332,223 @@ static void gen_reduction_ompaccel(REDUC *reducp, REDUC_SYM *reduc_symp, static struct cl_tag { /* clause table */ int present; BIGINT64 val; + BIGINT64 mod; // added a mod field to store the modifier argument void *first; void *last; char *name; BIGINT64 stmt; /* stmts which may use the clause */ } cl[CL_MAXV] = { - {0, 0, NULL, NULL, "DEFAULT", + {0, 0, 0, NULL, NULL, "DEFAULT", BT_PAR | BT_PARDO | BT_PARSECTS | BT_PARWORKS | BT_TASK | BT_TEAMS | BT_TASKLOOP}, - {0, 0, NULL, NULL, "PRIVATE", + {0, 0, 0, NULL, NULL, "PRIVATE", BT_PAR | BT_PDO | BT_PARDO | BT_DOACROSS | BT_SECTS | BT_PARSECTS | BT_SINGLE | BT_PARWORKS | BT_TASK | BT_ACCPARALLEL | BT_ACCKDO | BT_ACCPDO | BT_ACCKLOOP | BT_ACCPLOOP | BT_SIMD | BT_TARGET | BT_TASKLOOP | BT_TEAMS | BT_DISTRIBUTE | BT_ACCSERIAL | BT_ACCSLOOP}, - {0, 0, NULL, NULL, "SHARED", + {0, 0, 0, NULL, NULL, "SHARED", BT_PAR | BT_PARDO | BT_DOACROSS | BT_PARSECTS | BT_PARWORKS | BT_TASK | BT_TASKLOOP | BT_TEAMS}, - {0, 0, NULL, NULL, "FIRSTPRIVATE", + {0, 0, 0, NULL, NULL, "FIRSTPRIVATE", BT_PAR | BT_PDO | BT_PARDO | BT_SECTS | BT_PARSECTS | BT_SINGLE | BT_PARWORKS | BT_TASK | BT_ACCPARALLEL | BT_TARGET | BT_TEAMS | BT_TASKLOOP | BT_DISTRIBUTE | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "LASTPRIVATE", + {0, 0, 0, NULL, NULL, "LASTPRIVATE", BT_PDO | BT_PARDO | BT_DOACROSS | BT_SECTS | BT_PARSECTS | BT_SIMD | BT_TASKLOOP | BT_DISTRIBUTE}, - {0, 0, NULL, NULL, "SCHEDULE", BT_PDO | BT_PARDO}, - {0, 0, NULL, NULL, "ORDERED", BT_PDO | BT_PARDO}, - {0, 0, NULL, NULL, "REDUCTION", + {0, 0, 0, NULL, NULL, "SCHEDULE", BT_PDO | BT_PARDO}, + {0, 0, 0, NULL, NULL, "ORDERED", BT_PDO | BT_PARDO}, + {0, 0, 0, NULL, NULL, "REDUCTION", BT_PAR | BT_PDO | BT_PARDO | BT_DOACROSS | BT_SECTS | BT_PARSECTS | BT_PARWORKS | BT_ACCPARALLEL | BT_ACCKDO | BT_ACCPDO | BT_ACCKLOOP | BT_ACCPLOOP | BT_SIMD | BT_TEAMS | BT_ACCSERIAL | BT_ACCSLOOP}, - {0, 0, NULL, NULL, "IF", + {0, 0, 0, NULL, NULL, "IF", BT_PAR | BT_PARDO | BT_PARSECTS | BT_PARWORKS | BT_TASK | BT_ACCREG | BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCDATAREG | BT_ACCSCALARREG | BT_ACCUPDATE | BT_ACCENTERDATA | BT_ACCEXITDATA | BT_TARGET | BT_TASKLOOP | BT_ACCSERIAL | BT_ACCHOSTDATA}, - {0, 0, NULL, NULL, "COPYIN", + {0, 0, 0, NULL, NULL, "COPYIN", BT_PAR | BT_PARDO | BT_PARSECTS | BT_PARWORKS | BT_ACCREG | BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCDATAREG | BT_ACCSCALARREG | BT_ACCDECL | BT_ACCENTERDATA | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "COPYPRIVATE", BT_SINGLE}, - {0, 0, NULL, NULL, "MP_SCHEDTYPE", BT_DOACROSS}, - {0, 0, NULL, NULL, "CHUNK", BT_DOACROSS}, - {0, 0, NULL, NULL, "NOWAIT", + {0, 0, 0, NULL, NULL, "COPYPRIVATE", BT_SINGLE}, + {0, 0, 0, NULL, NULL, "MP_SCHEDTYPE", BT_DOACROSS}, + {0, 0, 0, NULL, NULL, "CHUNK", BT_DOACROSS}, + {0, 0, 0, NULL, NULL, "NOWAIT", BT_SINGLE | BT_SECTS | BT_PDO | BT_ACCREG | BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCSCALARREG | BT_ACCENDREG | BT_CUFKERNEL | BT_TARGET}, - {0, 0, NULL, NULL, "NUM_THREADS", + {0, 0, 0, NULL, NULL, "NUM_THREADS", BT_PAR | BT_PARDO | BT_PARSECTS | BT_PARWORKS}, - {0, 0, NULL, NULL, "COLLAPSE", + {0, 0, 0, NULL, NULL, "COLLAPSE", BT_PDO | BT_PARDO | BT_ACCKDO | BT_ACCPDO | BT_ACCKLOOP | BT_ACCPLOOP | BT_SIMD | BT_TASKLOOP | BT_DISTRIBUTE | BT_ACCSLOOP}, - {0, 0, NULL, NULL, "UNTIED", BT_TASK | BT_TASKLOOP}, - {0, 0, NULL, NULL, "COPYOUT", + {0, 0, 0, NULL, NULL, "UNTIED", BT_TASK | BT_TASKLOOP}, + {0, 0, 0, NULL, NULL, "COPYOUT", BT_ACCREG | BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCDATAREG | BT_ACCSCALARREG | BT_ACCDECL | BT_ACCEXITDATA | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "LOCAL", + {0, 0, 0, NULL, NULL, "LOCAL", BT_ACCREG | BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCDATAREG | BT_ACCSCALARREG | BT_ACCDECL | BT_ACCENTERDATA | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "CACHE", BT_ACCKDO}, - {0, 0, NULL, NULL, "SHORTLOOP", + {0, 0, 0, NULL, NULL, "CACHE", BT_ACCKDO}, + {0, 0, 0, NULL, NULL, "SHORTLOOP", BT_ACCKDO | BT_ACCKLOOP | BT_ACCPDO | BT_ACCPLOOP | BT_ACCSLOOP}, - {0, 0, NULL, NULL, "VECTOR", + {0, 0, 0, NULL, NULL, "VECTOR", BT_ACCKDO | BT_ACCKLOOP | BT_ACCPDO | BT_ACCPLOOP | BT_ACCSLOOP}, - {0, 0, NULL, NULL, "PARALLEL", + {0, 0, 0, NULL, NULL, "PARALLEL", BT_ACCKDO | BT_ACCKLOOP | BT_ACCPDO | BT_ACCPLOOP}, - {0, 0, NULL, NULL, "SEQ", + {0, 0, 0, NULL, NULL, "SEQ", BT_ACCKDO | BT_ACCKLOOP | BT_ACCPDO | BT_ACCPLOOP | BT_ACCSLOOP}, - {0, 0, NULL, NULL, "HOST", BT_ACCKDO | BT_ACCKLOOP}, - {0, 0, NULL, NULL, "UNROLL", + {0, 0, 0, NULL, NULL, "HOST", BT_ACCKDO | BT_ACCKLOOP}, + {0, 0, 0, NULL, NULL, "UNROLL", BT_ACCKDO | BT_ACCKLOOP | BT_ACCPDO | BT_ACCPLOOP | BT_ACCSLOOP}, - {0, 0, NULL, NULL, "KERNEL", BT_ACCKDO | BT_ACCKLOOP}, - {0, 0, NULL, NULL, "COPY", + {0, 0, 0, NULL, NULL, "KERNEL", BT_ACCKDO | BT_ACCKLOOP}, + {0, 0, 0, NULL, NULL, "COPY", BT_ACCREG | BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCDATAREG | BT_ACCSCALARREG | BT_ACCDECL | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "MIRROR", BT_ACCDATAREG | BT_ACCDECL}, - {0, 0, NULL, NULL, "REFLECTED", BT_ACCDECL}, - {0, 0, NULL, NULL, "UPDATE HOST", + {0, 0, 0, NULL, NULL, "MIRROR", BT_ACCDATAREG | BT_ACCDECL}, + {0, 0, 0, NULL, NULL, "REFLECTED", BT_ACCDECL}, + {0, 0, 0, NULL, NULL, "UPDATE HOST", BT_ACCREG | BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCDATAREG | BT_ACCSCALARREG | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "UPDATE SELF", + {0, 0, 0, NULL, NULL, "UPDATE SELF", BT_ACCREG | BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCDATAREG | BT_ACCSCALARREG | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "UPDATE DEVICE", + {0, 0, 0, NULL, NULL, "UPDATE DEVICE", BT_ACCREG | BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCDATAREG | BT_ACCSCALARREG | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "INDEPENDENT", + {0, 0, 0, NULL, NULL, "INDEPENDENT", BT_ACCKDO | BT_ACCPDO | BT_ACCKLOOP | BT_ACCPLOOP | BT_ACCSLOOP}, - {0, 0, NULL, NULL, "WAIT", + {0, 0, 0, NULL, NULL, "WAIT", BT_ACCREG | BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCSCALARREG | BT_ACCENDREG | BT_CUFKERNEL | BT_ACCDATAREG | BT_ACCUPDATE | BT_ACCENTERDATA | BT_ACCEXITDATA | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "TILE", BT_CUFKERNEL}, - {0, 0, NULL, NULL, "KERNEL_GRID", BT_CUFKERNEL}, - {0, 0, NULL, NULL, "KERNEL_BLOCK", BT_CUFKERNEL}, - {0, 0, NULL, NULL, "UNROLL", /* for sequential loops */ + {0, 0, 0, NULL, NULL, "TILE", BT_CUFKERNEL}, + {0, 0, 0, NULL, NULL, "KERNEL_GRID", BT_CUFKERNEL}, + {0, 0, 0, NULL, NULL, "KERNEL_BLOCK", BT_CUFKERNEL}, + {0, 0, 0, NULL, NULL, "UNROLL", /* for sequential loops */ BT_ACCKDO | BT_ACCKLOOP | BT_ACCPDO | BT_ACCPLOOP | BT_ACCSLOOP}, - {0, 0, NULL, NULL, "UNROLL", /* for parallel loops */ + {0, 0, 0, NULL, NULL, "UNROLL", /* for parallel loops */ BT_ACCKDO | BT_ACCKLOOP | BT_ACCPDO | BT_ACCPLOOP}, - {0, 0, NULL, NULL, "UNROLL", /* for vector loops */ + {0, 0, 0, NULL, NULL, "UNROLL", /* for vector loops */ BT_ACCKDO | BT_ACCKLOOP | BT_ACCPDO | BT_ACCPLOOP | BT_ACCSLOOP}, - {0, 0, NULL, NULL, "CREATE", + {0, 0, 0, NULL, NULL, "CREATE", BT_ACCREG | BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCDATAREG | BT_ACCSCALARREG | BT_ACCDECL | BT_ACCENTERDATA | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "PRESENT", + {0, 0, 0, NULL, NULL, "PRESENT", BT_ACCREG | BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCDATAREG | BT_ACCSCALARREG | BT_ACCDECL | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "PRESENT_OR_COPY", + {0, 0, 0, NULL, NULL, "PRESENT_OR_COPY", BT_ACCREG | BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCDATAREG | BT_ACCSCALARREG | BT_ACCDECL | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "PRESENT_OR_COPYIN", + {0, 0, 0, NULL, NULL, "PRESENT_OR_COPYIN", BT_ACCREG | BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCDATAREG | BT_ACCSCALARREG | BT_ACCDECL | BT_ACCENTERDATA | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "PRESENT_OR_COPYOUT", + {0, 0, 0, NULL, NULL, "PRESENT_OR_COPYOUT", BT_ACCREG | BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCDATAREG | BT_ACCSCALARREG | BT_ACCDECL | BT_ACCEXITDATA | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "PRESENT_OR_CREATE", + {0, 0, 0, NULL, NULL, "PRESENT_OR_CREATE", BT_ACCREG | BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCDATAREG | BT_ACCSCALARREG | BT_ACCDECL | BT_ACCENTERDATA | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "PRESENT_OR_NOT", + {0, 0, 0, NULL, NULL, "PRESENT_OR_NOT", BT_ACCREG | BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCDATAREG | BT_ACCSCALARREG | BT_ACCDECL | BT_ACCENTERDATA | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "ASYNC", + {0, 0, 0, NULL, NULL, "ASYNC", BT_ACCREG | BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCDATAREG | BT_ACCSCALARREG | BT_ACCUPDATE | BT_ACCENTERDATA | BT_ACCEXITDATA | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "STREAM", BT_CUFKERNEL}, - {0, 0, NULL, NULL, "DEVICE", BT_CUFKERNEL}, - {0, 0, NULL, NULL, "WORKER", + {0, 0, 0, NULL, NULL, "STREAM", BT_CUFKERNEL}, + {0, 0, 0, NULL, NULL, "DEVICE", BT_CUFKERNEL}, + {0, 0, 0, NULL, NULL, "WORKER", BT_ACCKDO | BT_ACCKLOOP | BT_ACCPDO | BT_ACCPLOOP | BT_ACCSLOOP}, - {0, 0, NULL, NULL, "GANG", + {0, 0, 0, NULL, NULL, "GANG", BT_ACCKDO | BT_ACCKLOOP | BT_ACCPDO | BT_ACCPLOOP | BT_ACCSLOOP}, - {0, 0, NULL, NULL, "NUM_WORKERS", + {0, 0, 0, NULL, NULL, "NUM_WORKERS", BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "NUM_GANGS", + {0, 0, 0, NULL, NULL, "NUM_GANGS", BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "VECTOR_LENGTH", + {0, 0, 0, NULL, NULL, "VECTOR_LENGTH", BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "USE_DEVICE", BT_ACCHOSTDATA}, - {0, 0, NULL, NULL, "DEVICEPTR", + {0, 0, 0, NULL, NULL, "USE_DEVICE", BT_ACCHOSTDATA}, + {0, 0, 0, NULL, NULL, "DEVICEPTR", BT_ACCREG | BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCDATAREG | BT_ACCSERIAL | BT_ACCDECL}, - {0, 0, NULL, NULL, "DEVICE_RESIDENT", BT_ACCDECL}, - {0, 0, NULL, NULL, "FINAL", BT_TASK | BT_TASKLOOP}, - {0, 0, NULL, NULL, "MERGEABLE", BT_TASK | BT_TASKLOOP}, - {0, 0, NULL, NULL, "DEVICEID", + {0, 0, 0, NULL, NULL, "DEVICE_RESIDENT", BT_ACCDECL}, + {0, 0, 0, NULL, NULL, "FINAL", BT_TASK | BT_TASKLOOP}, + {0, 0, 0, NULL, NULL, "MERGEABLE", BT_TASK | BT_TASKLOOP}, + {0, 0, 0, NULL, NULL, "DEVICEID", BT_ACCREG | BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCDATAREG | BT_ACCSCALARREG | BT_ACCUPDATE | BT_ACCHOSTDATA | BT_ACCENTERDATA | BT_ACCEXITDATA | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "DELETE", BT_ACCEXITDATA}, - {0, 0, NULL, NULL, "PDELETE", BT_ACCEXITDATA}, - {0, 0, NULL, NULL, "LINK", BT_ACCDECL}, - {0, 0, NULL, NULL, "DEVICE_TYPE", + {0, 0, 0, NULL, NULL, "DELETE", BT_ACCEXITDATA}, + {0, 0, 0, NULL, NULL, "PDELETE", BT_ACCEXITDATA}, + {0, 0, 0, NULL, NULL, "LINK", BT_ACCDECL}, + {0, 0, 0, NULL, NULL, "DEVICE_TYPE", BT_ACCKLOOP | BT_ACCPLOOP | BT_ACCKDO | BT_ACCPDO | BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCINITSHUTDOWN | BT_ACCSET | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "AUTO", + {0, 0, 0, NULL, NULL, "AUTO", BT_ACCKLOOP | BT_ACCPLOOP | BT_ACCKDO | BT_ACCPDO | BT_ACCSLOOP}, - {0, 0, NULL, NULL, "TILE", + {0, 0, 0, NULL, NULL, "TILE", BT_ACCKLOOP | BT_ACCPLOOP | BT_ACCKDO | BT_ACCPDO | BT_ACCSLOOP}, - {0, 0, NULL, NULL, "GANG(STATIC:)", + {0, 0, 0, NULL, NULL, "GANG(STATIC:)", BT_ACCKLOOP | BT_ACCPLOOP | BT_ACCKDO | BT_ACCPDO | BT_ACCSLOOP}, - {0, 0, NULL, NULL, "DEFAULT(NONE)", + {0, 0, 0, NULL, NULL, "DEFAULT(NONE)", BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCREG | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "NUM_GANGS(dim:2)", + {0, 0, 0, NULL, NULL, "NUM_GANGS(dim:2)", BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "NUM_GANGS(dim:3)", + {0, 0, 0, NULL, NULL, "NUM_GANGS(dim:3)", BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "GANG(DIM:)", BT_ACCPLOOP | BT_ACCPDO | BT_ACCSLOOP}, - {0, 0, NULL, NULL, "DEFAULT(PRESENT)", + {0, 0, 0, NULL, NULL, "GANG(DIM:)", BT_ACCPLOOP | BT_ACCPDO | BT_ACCSLOOP}, + {0, 0, 0, NULL, NULL, "DEFAULT(PRESENT)", BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCREG | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "COLLAPSE(FORCE)", + {0, 0, 0, NULL, NULL, "COLLAPSE(FORCE)", BT_ACCKLOOP | BT_ACCPLOOP | BT_ACCKDO | BT_ACCPDO | BT_ACCSLOOP}, - {0, 0, NULL, NULL, "FINALIZE", BT_ACCEXITDATA}, - {0, 0, NULL, NULL, "IF_PRESENT", BT_ACCUPDATE | BT_ACCHOSTDATA}, - {0, 0, NULL, NULL, "SAFELEN", BT_SIMD | BT_PDO | BT_PARDO}, - {0, 0, NULL, NULL, "SIMDLEN", BT_SIMD | BT_PDO | BT_PARDO | BT_DECLSIMD}, - {0, 0, NULL, NULL, "LINEAR", BT_SIMD | BT_PDO | BT_PARDO | BT_DECLSIMD}, - {0, 0, NULL, NULL, "ALIGNED", BT_SIMD | BT_PDO | BT_PARDO | BT_DECLSIMD}, - {0, 0, NULL, NULL, "USE_DEVICE_PTR", BT_TARGET}, - {0, 0, NULL, NULL, "DEPEND", BT_TASK | BT_TARGET}, - {0, 0, NULL, NULL, "INBRANCH", BT_DECLSIMD}, - {0, 0, NULL, NULL, "NOTINBRANCH", BT_DECLSIMD}, - {0, 0, NULL, NULL, "UNIFORM", BT_DECLSIMD}, - {0, 0, NULL, NULL, "GRAINSIZE", BT_TASKLOOP}, - {0, 0, NULL, NULL, "NUM_TASKS", BT_TASKLOOP}, - {0, 0, NULL, NULL, "NOGROUP", BT_TASKLOOP}, - {0, 0, NULL, NULL, "OMPDEVICE", BT_TARGET}, - {0, 0, NULL, NULL, "MAP", BT_TARGET}, - {0, 0, NULL, NULL, "DEFAULTMAP", BT_TARGET}, - {0, 0, NULL, NULL, "TO", BT_TARGET}, - {0, 0, NULL, NULL, "LINK", BT_TARGET}, - {0, 0, NULL, NULL, "FROM", BT_TARGET}, - {0, 0, NULL, NULL, "NUM_TEAMS", BT_TEAMS}, - {0, 0, NULL, NULL, "THREAD_LIMIT", BT_TEAMS}, - {0, 0, NULL, NULL, "DIST_SCHEDULE", BT_DISTRIBUTE}, - {0, 0, NULL, NULL, "PRIORITY", BT_TASKLOOP}, - {0, 0, NULL, NULL, "IS_DEVICE_PTR", BT_TARGET}, - {0, 0, NULL, NULL, "SIMD", BT_PDO | BT_PARDO | BT_SIMD}, - {0, 0, NULL, NULL, "THREADS", BT_TARGET}, - {0, 0, NULL, NULL, "DEVICE_NUM", BT_ACCINITSHUTDOWN | BT_ACCSET}, - {0, 0, NULL, NULL, "DEFAULT_ASYNC", BT_ACCSET}, - {0, 0, NULL, NULL, "DECLARE", BT_ACCDECL}, - {0, 0, NULL, NULL, "PROC_BIND", BT_PAR | BT_PARDO}, - {0, 0, NULL, NULL, "NO_CREATE", + {0, 0, 0, NULL, NULL, "FINALIZE", BT_ACCEXITDATA}, + {0, 0, 0, NULL, NULL, "IF_PRESENT", BT_ACCUPDATE | BT_ACCHOSTDATA}, + {0, 0, 0, NULL, NULL, "SAFELEN", BT_SIMD | BT_PDO | BT_PARDO}, + {0, 0, 0, NULL, NULL, "SIMDLEN", BT_SIMD | BT_PDO | BT_PARDO | BT_DECLSIMD}, + {0, 0, 0, NULL, NULL, "LINEAR", BT_SIMD | BT_PDO | BT_PARDO | BT_DECLSIMD}, + {0, 0, 0, NULL, NULL, "ALIGNED", BT_SIMD | BT_PDO | BT_PARDO | BT_DECLSIMD}, + {0, 0, 0, NULL, NULL, "USE_DEVICE_PTR", BT_TARGET}, + {0, 0, 0, NULL, NULL, "DEPEND", BT_TASK | BT_TARGET}, + {0, 0, 0, NULL, NULL, "INBRANCH", BT_DECLSIMD}, + {0, 0, 0, NULL, NULL, "NOTINBRANCH", BT_DECLSIMD}, + {0, 0, 0, NULL, NULL, "UNIFORM", BT_DECLSIMD}, + {0, 0, 0, NULL, NULL, "GRAINSIZE", BT_TASKLOOP}, + {0, 0, 0, NULL, NULL, "NUM_TASKS", BT_TASKLOOP}, + {0, 0, 0, NULL, NULL, "NOGROUP", BT_TASKLOOP}, + {0, 0, 0, NULL, NULL, "OMPDEVICE", BT_TARGET}, + {0, 0, 0, NULL, NULL, "MAP", BT_TARGET}, + {0, 0, 0, NULL, NULL, "DEFAULTMAP", BT_TARGET}, + {0, 0, 0, NULL, NULL, "TO", BT_TARGET}, + {0, 0, 0, NULL, NULL, "LINK", BT_TARGET}, + {0, 0, 0, NULL, NULL, "FROM", BT_TARGET}, + {0, 0, 0, NULL, NULL, "NUM_TEAMS", BT_TEAMS}, + {0, 0, 0, NULL, NULL, "THREAD_LIMIT", BT_TEAMS}, + {0, 0, 0, NULL, NULL, "DIST_SCHEDULE", BT_DISTRIBUTE}, + {0, 0, 0, NULL, NULL, "PRIORITY", BT_TASKLOOP | BT_TASK}, //AOCC + {0, 0, 0, NULL, NULL, "IS_DEVICE_PTR", BT_TARGET}, + {0, 0, 0, NULL, NULL, "SIMD", BT_PDO | BT_PARDO | BT_SIMD}, + {0, 0, 0, NULL, NULL, "THREADS", BT_TARGET}, + {0, 0, 0, NULL, NULL, "DEVICE_NUM", BT_ACCINITSHUTDOWN | BT_ACCSET}, + {0, 0, 0, NULL, NULL, "DEFAULT_ASYNC", BT_ACCSET}, + {0, 0, 0, NULL, NULL, "DECLARE", BT_ACCDECL}, + {0, 0, 0, NULL, NULL, "PROC_BIND", BT_PAR | BT_PARDO}, + {0, 0, 0, NULL, NULL, "NO_CREATE", BT_ACCREG | BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCDATAREG | BT_ACCSCALARREG | BT_ACCDECL | BT_ACCENTERDATA | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "ATTACH", + {0, 0, 0, NULL, NULL, "ATTACH", BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCDATAREG | BT_ACCENTERDATA | BT_ACCSERIAL}, - {0, 0, NULL, NULL, "DETACH", BT_ACCEXITDATA}, - {0, 0, NULL, NULL, "COMPARE", + {0, 0, 0, NULL, NULL, "DETACH", BT_ACCEXITDATA}, + {0, 0, 0, NULL, NULL, "COMPARE", BT_ACCREG | BT_ACCKERNELS | BT_ACCPARALLEL | BT_ACCDATAREG | BT_ACCSCALARREG | BT_ACCSERIAL}, + {0, 0, 0, NULL, NULL, "IN_REDUCTION", BT_TARGET}, // AOCC + {0, 0, 0, NULL, NULL, "USE_DEVICE_ADDR", BT_TARGET}, // AOCC }; #define CL_PRESENT(d) cl[d].present +#define CL_MOD(d) cl[d].mod //AOCC #define CL_VAL(d) cl[d].val #define CL_NAME(d) cl[d].name #define CL_STMT(d) cl[d].stmt @@ -541,6 +591,8 @@ static int distchunk; static int mp_iftype; static ISZ_T kernel_do_nest; static LOGICAL has_team = FALSE; +LOGICAL has_target = FALSE; +LOGICAL is_targsimd = FALSE; static LOGICAL any_pflsr_private = FALSE; @@ -552,6 +604,30 @@ static void add_pragma(int pragmatype, int pragmascope, int pragmaarg); static int kernel_argnum; +/* AOCC begin */ +/* + * Rewrite distribute's sched correctly if under parallel region given that + * they're all enclosed in a target region. + */ +static void rewrite_distr_sched() { +#ifdef OMP_OFFLOAD_AMD + int match_sched; + if (target_ast && distribute_doif) { + if (flg.x86_64_omptarget) { + match_sched = MP_SCH_STATIC; + } else { + match_sched = MP_SCH_TEAMS_DIST; + } + if (DI_SCHED_TYPE(distribute_doif) == match_sched) { + DI_SCHED_TYPE(distribute_doif) = DI_SCH_DIST_STATIC; + A_SCHED_TYPEP(distribute_pdo_ast, DI_SCH_DIST_STATIC); + A_SCHED_TYPEP(tgt_distribute_ast, DI_SCH_DIST_STATIC); + } + } +#endif +} +/* AOCC end */ + /** \brief Semantic analysis for SMP statements. \param rednum reduction number @@ -560,7 +636,7 @@ static int kernel_argnum; void semsmp(int rednum, SST *top) { - int sptr, sptr1, sptr2, ilmptr; + int sptr, sptr1, sptr2; int dtype; ITEM *itemp; /* Pointers to items */ int doif; @@ -631,12 +707,17 @@ semsmp(int rednum, SST *top) case MP_BEGIN1: parstuff_init(); break; + + case LOOP_BEGIN1: + parstuff_init(); + break; /* ------------------------------------------------------------------ */ /* * ::= | */ case MP_STMT1: + rewrite_distr_sched(); /* AOCC */ clause_errchk(BT_PAR, "OMP PARALLEL"); mp_create_bscope(0); DI_BPAR(sem.doif_depth) = emit_bpar(); @@ -798,6 +879,7 @@ semsmp(int rednum, SST *top) * ::= | */ case MP_STMT7: + rewrite_distr_sched(); /* AOCC */ clause_errchk(BT_PDO, "OMP DO"); do_schedule(SST_CVALG(RHS(1))); sem.expect_do = TRUE; @@ -888,6 +970,7 @@ semsmp(int rednum, SST *top) * ::= | */ case MP_STMT14: + rewrite_distr_sched(); /* AOCC */ clause_errchk(BT_PARDO, "OMP PARALLEL DO"); do_schedule(SST_CVALG(RHS(1))); sem.expect_do = TRUE; @@ -1508,10 +1591,23 @@ semsmp(int rednum, SST *top) * ::= | */ case MP_STMT41: + if (sem.metadirective.whencondition) { + if (sem.metadirective.whenexpanded) { break; } + if (!sem.metadirective.defaultcondition && !sem.metadirective.whenconditionvalue) { break; } + sem.metadirective.whenexpanded = true; + } clause_errchk(BT_SIMD, "OMP SIMD"); sem.collapse = 0; if (CL_PRESENT(CL_COLLAPSE)) { sem.collapse = CL_VAL(CL_COLLAPSE); + } else if (CL_PRESENT(CL_SAFELEN) || CL_PRESENT(CL_LINEAR) || + CL_PRESENT(CL_ALIGNED) || CL_PRESENT(CL_PRIVATE) || + CL_PRESENT(CL_LASTPRIVATE) || CL_PRESENT(CL_REDUCTION)){ + errwarn((error_code_t)604); + sem.expect_simd_do = FALSE; + par_push_scope(TRUE); + SST_ASTP(LHS, 0); + break; } sem.expect_simd_do = TRUE; par_push_scope(TRUE); @@ -1550,13 +1646,20 @@ semsmp(int rednum, SST *top) add_stmt(ast); } SST_ASTP(LHS, 0); + do_usedeviceptr(); // AOCC + do_usedeviceaddr(); // AOCC do_map(); break; /* * ::= | */ case MP_STMT44: { - doif = leave_dir(DI_TARGETDATA, TRUE, 0); + // AOCC Begin + if (flg.amdgcn_target) + doif = leave_dir(DI_TARGETDATA, FALSE, 0); + else + // AOCC End + doif = leave_dir(DI_TARGETDATA, TRUE, 0); ast = mk_stmt(A_MP_ENDTARGETDATA, 0); if (CL_PRESENT(CL_IF)) { A_IFEXPRP(ast, CL_VAL(CL_IF)); @@ -1619,7 +1722,9 @@ semsmp(int rednum, SST *top) (void)leave_dir(DI_TARGETEXITDATA, TRUE, 0); } SST_ASTP(LHS, 0); + map_exit_data = 1; do_map(); + map_exit_data = 0; break; /* * ::= | @@ -1645,6 +1750,10 @@ semsmp(int rednum, SST *top) (void)leave_dir(DI_TARGETUPDATE, TRUE, 0); } SST_ASTP(LHS, 0); + // AOCC Begin + if (flg.amdgcn_target || flg.x86_64_omptarget) + do_tofrom(); + // AOCC End break; /* * ::= | @@ -1657,6 +1766,12 @@ semsmp(int rednum, SST *top) if(flg.omptarget) A_COMBINEDTYPEP(DI_BTARGET(sem.doif_depth), get_omp_combined_mode(BT_TARGET)); + // AOCC Begin + // Store the target ast for future use +#ifdef OMP_OFFLOAD_AMD + target_ast = DI_BTARGET(sem.doif_depth); +#endif + // AOCC End #endif par_push_scope(TRUE); begin_parallel_clause(sem.doif_depth); @@ -1670,6 +1785,12 @@ semsmp(int rednum, SST *top) (void)leave_dir(DI_TARGET, TRUE, 0); sem.target--; par_pop_scope(); + // AOCC Begin + // Clear target ast +#ifdef OMP_OFFLOAD_AMD + target_ast = 0; +#endif + // AOCC End ast = emit_etarget(); mp_create_escope(); if (doif) { @@ -1711,6 +1832,15 @@ semsmp(int rednum, SST *top) * ::= | */ case MP_STMT52: + /* AOCC begin */ +#ifdef OMP_OFFLOAD_LLVM + if (target_ast && teams_ast) { + A_COMBINEDTYPEP(target_ast, get_omp_combined_mode( + BT_TARGET | BT_TEAMS | BT_DISTRIBUTE)); + } +#endif + /* AOCC end */ + clause_errchk(BT_DISTRIBUTE, "OMP DISTRIBUTE"); doif = SST_CVALG(RHS(1)); sem.expect_do = TRUE; @@ -1747,7 +1877,26 @@ semsmp(int rednum, SST *top) case MP_STMT56: ast = 0; clause_errchk((BT_DISTRIBUTE | BT_PARDO), "OMP DISTRIBUTE PARALLE DO"); - begin_combine_constructs((BT_DISTRIBUTE | BT_PARDO)); + if (!begin_combine_constructs((BT_DISTRIBUTE | BT_PARDO))) + break; + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + // If we have seen a target pragma already, change the mode to + // + // + // TODO: This code and all other code involving variable target_ast + // is kind of safe hack to enable tgt_target_teams and improve + // execution time. All source around target_ast has to be rewritten + // using correct data structures, mostly a stack would do. Since + // FLANG1 has little to do with target_mode, this can also be safely + // moved to FLANG2 + if (target_ast) { + A_COMBINEDTYPEP(target_ast, get_omp_combined_mode( + BT_TARGET | BT_TEAMS | + BT_DISTRIBUTE | BT_PARDO)); + } +#endif + // AOCC End SST_ASTP(LHS, ast); break; /* @@ -1764,8 +1913,19 @@ semsmp(int rednum, SST *top) ast = 0; clause_errchk((BT_DISTRIBUTE | BT_PARDO | BT_SIMD), "OMP DISTRIBUTE PARALLE DO SIMD"); - begin_combine_constructs((BT_DISTRIBUTE | BT_PARDO | BT_SIMD)); + if (!begin_combine_constructs((BT_DISTRIBUTE | BT_PARDO | BT_SIMD))) break; DI_ISSIMD(sem.doif_depth) = TRUE; + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + // If we have seen a target pragma already, change the mode to + if (target_ast) { + A_COMBINEDTYPEP(target_ast, get_omp_combined_mode( + BT_TARGET | BT_TEAMS | + BT_DISTRIBUTE | BT_PARDO | BT_SIMD)); + } +#endif + // AOCC End + SST_ASTP(LHS, ast); break; /* @@ -1779,6 +1939,7 @@ semsmp(int rednum, SST *top) * ::= | */ case MP_STMT60: + rewrite_distr_sched(); /* AOCC */ clause_errchk((BT_PARDO | BT_SIMD), "OMP PARALLEL DO SIMD"); do_schedule(SST_CVALG(RHS(1))); sem.expect_do = TRUE; @@ -1802,7 +1963,7 @@ semsmp(int rednum, SST *top) case MP_STMT62: ast = 0; clause_errchk((BT_TARGET | BT_PAR), "OMP TARGET PARALLEL"); - begin_combine_constructs((BT_TARGET | BT_PAR)); + if (!begin_combine_constructs((BT_TARGET | BT_PAR))) break; SST_ASTP(LHS, ast); break; /* @@ -1839,7 +2000,7 @@ semsmp(int rednum, SST *top) case MP_STMT64: SST_ASTP(LHS, 0); clause_errchk((BT_TARGET | BT_PARDO), "OMP TARGET PARALLEL DO"); - begin_combine_constructs((BT_TARGET | BT_PARDO)); + if (!begin_combine_constructs((BT_TARGET | BT_PARDO))) break; sem.expect_do = TRUE; break; /* @@ -1881,7 +2042,7 @@ semsmp(int rednum, SST *top) SST_ASTP(LHS, 0); clause_errchk((BT_TARGET | BT_PARDO | BT_SIMD), "OMP TARGET PARALLEL DO SIMD"); - begin_combine_constructs((BT_TARGET | BT_PARDO | BT_SIMD)); + if (!begin_combine_constructs((BT_TARGET | BT_PARDO | BT_SIMD))) break; sem.expect_do = TRUE; DI_ISSIMD(sem.doif_depth) = TRUE; break; @@ -1924,8 +2085,11 @@ semsmp(int rednum, SST *top) sem.collapse = CL_VAL(CL_COLLAPSE); } sem.expect_simd_do = TRUE; + // AOCC Commenting repeated code +#ifndef OMP_OFFLOAD_AMD par_push_scope(TRUE); begin_parallel_clause(sem.doif_depth); +#endif apply_nodepchk(gbl.lineno, 1); SST_ASTP(LHS, 0); @@ -1951,7 +2115,7 @@ semsmp(int rednum, SST *top) */ case MP_STMT72: clause_errchk((BT_TARGET | BT_TEAMS), "OMP TARGET TEAMS"); - begin_combine_constructs((BT_TARGET | BT_TEAMS)); + if (!begin_combine_constructs((BT_TARGET | BT_TEAMS))) break; SST_ASTP(LHS, 0); break; /* @@ -1967,7 +2131,7 @@ semsmp(int rednum, SST *top) case MP_STMT74: SST_ASTP(LHS, 0); clause_errchk((BT_TEAMS | BT_DISTRIBUTE), "OMP TEAMS DISTRIBUTE"); - begin_combine_constructs((BT_TEAMS | BT_DISTRIBUTE)); + if (!begin_combine_constructs((BT_TEAMS | BT_DISTRIBUTE))) break; sem.expect_do = TRUE; break; /* @@ -1985,7 +2149,7 @@ semsmp(int rednum, SST *top) SST_ASTP(LHS, 0); clause_errchk((BT_TEAMS | BT_DISTRIBUTE | BT_SIMD), "OMP TEAMS DISTRIBUTE SIMD"); - begin_combine_constructs((BT_TEAMS | BT_DISTRIBUTE | BT_SIMD)); + if (!begin_combine_constructs((BT_TEAMS | BT_DISTRIBUTE | BT_SIMD))) break; sem.expect_do = TRUE; break; /* @@ -2003,7 +2167,7 @@ semsmp(int rednum, SST *top) SST_ASTP(LHS, 0); clause_errchk((BT_TARGET | BT_TEAMS | BT_DISTRIBUTE), "OMP TARGET TEAMS DISTRIBUTE"); - begin_combine_constructs((BT_TARGET | BT_TEAMS | BT_DISTRIBUTE)); + if (!begin_combine_constructs((BT_TARGET | BT_TEAMS | BT_DISTRIBUTE))) break; sem.expect_do = TRUE; break; /* @@ -2021,7 +2185,7 @@ semsmp(int rednum, SST *top) SST_ASTP(LHS, 0); clause_errchk((BT_TARGET | BT_TEAMS | BT_DISTRIBUTE | BT_SIMD), "OMP TARGET TEAMS DISTRIBUTE SIMD"); - begin_combine_constructs((BT_TARGET | BT_TEAMS | BT_DISTRIBUTE | BT_SIMD)); + if (!begin_combine_constructs((BT_TARGET | BT_TEAMS | BT_DISTRIBUTE | BT_SIMD))) break; sem.expect_do = TRUE; break; /* @@ -2039,7 +2203,18 @@ semsmp(int rednum, SST *top) SST_ASTP(LHS, 0); clause_errchk((BT_TEAMS | BT_DISTRIBUTE | BT_PARDO), "OMP TEAMS DISTRIBUTE PARALLEL Do"); - begin_combine_constructs((BT_TEAMS | BT_DISTRIBUTE | BT_PARDO)); + if (!begin_combine_constructs((BT_TEAMS | BT_DISTRIBUTE | BT_PARDO))) break; + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + // If we have seen a target pragma already, change the mode to + // mode_target_teams_distribute_parallel_for + if (target_ast) { + A_COMBINEDTYPEP(target_ast, get_omp_combined_mode( + BT_TARGET | BT_TEAMS | + BT_DISTRIBUTE | BT_PARDO)); + } +#endif + // AOCC End break; /* * ::= | @@ -2073,7 +2248,18 @@ semsmp(int rednum, SST *top) SST_ASTP(LHS, 0); clause_errchk((BT_TEAMS | BT_DISTRIBUTE | BT_PARDO | BT_SIMD), "OMP TEAMS DISTRIBUTE PARALLEL DO SIMD"); - begin_combine_constructs((BT_TEAMS | BT_DISTRIBUTE | BT_PARDO | BT_SIMD)); + if (!begin_combine_constructs((BT_TEAMS | BT_DISTRIBUTE | BT_PARDO | BT_SIMD))) break; + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + // If we have seen a target pragma already, change the mode to + // mode_target_teams_distribute_parallel_for_simd + if (target_ast) { + A_COMBINEDTYPEP(target_ast, get_omp_combined_mode( + BT_TARGET | BT_TEAMS | + BT_DISTRIBUTE | BT_PARDO | BT_SIMD)); + } +#endif + // AOCC End DI_ISSIMD(sem.doif_depth) = TRUE; break; /* @@ -2091,8 +2277,8 @@ semsmp(int rednum, SST *top) SST_ASTP(LHS, 0); clause_errchk((BT_TARGET | BT_TEAMS | BT_DISTRIBUTE | BT_PARDO | BT_SIMD), "OMP TARGET TEAMS DISTRIBUTE PARDO SIMD"); - begin_combine_constructs( - (BT_TARGET | BT_TEAMS | BT_DISTRIBUTE | BT_PARDO | BT_SIMD)); + if (!begin_combine_constructs( + (BT_TARGET | BT_TEAMS | BT_DISTRIBUTE | BT_PARDO | BT_SIMD))) break; doif = SST_CVALG(RHS(1)); DI_ISSIMD(doif) = TRUE; break; @@ -2141,6 +2327,116 @@ semsmp(int rednum, SST *top) SST_ASTP(LHS, 0); break; + /* AOCC + * ::= + */ + case MP_STMT93: + ast = mk_stmt(A_MP_REQUIRESUNIFIEDSHAREDMEMORY, 0); + SST_ASTP(LHS, ast); + break; + + case MP_STMT94: + break; + + case MP_STMT95: + case MP_STMT96: + ast = mk_stmt(A_MP_LOOP, 0); + SST_ASTP(LHS, ast); + break; + + case MP_METADIR_DEFAULT_STMT1: + sem.metadirective.defaultcondition = true; + break; + case MP_METADIR1: + // TODO: + sem.metadirective.whencondition = false; + sem.metadirective.whenexpanded = false; + sem.metadirective.defaultcondition = false; + // some cleanup stuff: TODO: + SST_ASTP(RHS(0),0); + SST_ASTP(RHS(1),0); + SST_ASTP(RHS(2),0); + SST_ASTP(RHS(3),0); + break; + + /* AOCC + * ::= + */ + case MP_METADIR_CLAUSE1: + // TODO: + sem.metadirective.whencondition = true; + sem.metadirective.whenexpanded = false; + sem.metadirective.defaultcondition = false; + SST_IDP(LHS, 0); + break; + + /* AOCC + * ::= + */ + case MP_METADIR_CLAUSE2: + // TODO: +// fprintf(stderr, " \n"); + break; + + case MP_METADIR_CLAUSE3: + // TODO: +// fprintf(stderr, " \n"); + sem.metadirective.defaultcondition = true; + break; + + case MP_METADIR_DEFAULT_CLAUSE1: + // TODO: +// fprintf(stderr, " \n"); + sem.metadirective.defaultcondition = true; + break; + + case MP_METADIR_CONDITION1: + // TODO: +// fprintf(stderr, " \n"); + break; + + case MP_METADIR_CONDITION2: + // TODO: +// fprintf(stderr, " \n"); + break; + + /* AOCC + * ::= + */ + case MP_METADIR_CONDITION_BASE1: + // TODO: +// fprintf(stderr, " \n"); + break; + + case MP_METADIR_WHEN_CLAUSE1: + // TODO: +// fprintf(stderr, " \n"); + break; + + case MP_METADIR_CONDITION_BASE2: + // TODO: +// fprintf(stderr, " , \n"); + break; + + case MP_METADIR_CONDITION_BASE_USER1: + // TODO: +// fprintf(stderr, " , %d\n", rhstop); + sem.metadirective.whenconditionvalue = SST_CVALG(RHS(6)); + break; + + /* AOCC + * ::= IMPLEMENTATION = { VENDOR ( ) } + */ + case MP_METADIR_CONDITION_BASE_IMPL1: + // TODO: +// fprintf(stderr, " , \n"); + break; + + case MP_METADIR_CONDITION_BASE_DEVICE1: + // TODO: +// fprintf(stderr, " , \n"); + break; + /* ------------------------------------------------------------------ */ /* * ::= | @@ -2460,16 +2756,64 @@ semsmp(int rednum, SST *top) error(547, ERR_Warning, gbl.lineno, "DEPEND", CNULL); break; /* - * ::= IS_DEVICE_PTR ( ) | + * ::= IS_DEVICE_PTR ( ) | */ - case PAR_ATTR28: - error(547, ERR_Warning, gbl.lineno, "IS_DEVICE_PTR", CNULL); - break; + case PAR_ATTR28: { + // AOCC Begin + ITEM *itemp, *itembeg, *itemend; + int type = OMP_TGT_MAPTYPE_TARGET_PARAM | + OMP_TGT_MAPTYPE_LITERAL; + int clause = CL_IS_DEVICE_PTR; + + itembeg = SST_BEGG(RHS(3)); + itemend = SST_ENDG(RHS(3)); + if (itembeg == ITEM_END) + return; + for (itemp = itembeg; itemp != ITEM_END; itemp = itemp->next) { + int sptr = A_SPTRG(itemp->ast); + if (SCG(sptr) != SC_DUMMY && !PASSBYVALG(sptr)) { + error(155, 3, gbl.lineno, + "A non DUMMY object is used in IS_DEVICE_PTR clause", NULL); + } else if (ALLOCG(sptr)) { + error(155, 3, gbl.lineno, + "Object with allocatable attribute is used in IS_DEVICE_PTR clause", + NULL); + } else if (POINTERG(sptr)) { + error(155, 3, gbl.lineno, + "Object with pointer attribute is used in IS_DEVICE_PTR clause", + NULL); + } else if (PASSBYVALG(sptr)) { + error(155, 3, gbl.lineno, + "Object with value attribute is used in IS_DEVICE_PTR clause", + NULL); + } + itemp->t.cltype = type; + } + add_clause(clause, FALSE); + if (CL_FIRST(clause) == NULL) + CL_FIRST(clause) = itembeg; + else + ((ITEM *)CL_FIRST(clause))->next = itembeg; + CL_LAST(clause) = itemend; + // AOCC End + } + break; /* * ::= DEFAULTMAP ( : ) | */ case PAR_ATTR29: - error(547, ERR_Warning, gbl.lineno, "DEFAULTMAP", CNULL); + // AOCC Begin +#if defined(OMP_OFFLOAD_LLVM) || defined(OMP_OFFLOAD_PGI) + if (flg.omptarget) { + mp_check_maptype(scn.id.name + SST_CVALG(RHS(3))); + mp_check_defaultmap_val(scn.id.name + SST_CVALG(RHS(5))); + const char *map_type = scn.id.name + SST_CVALG(RHS(3)); + int maptype = mp_get_map_type_for(map_type); + add_clause(CL_DEFAULTMAP, TRUE); + CL_VAL(CL_DEFAULTMAP) = maptype; + } +#endif + // AOCC End break; /* * ::= | @@ -2554,7 +2898,74 @@ semsmp(int rednum, SST *top) case PAR_ATTR37: add_clause(CL_NOGROUP, TRUE); break; - /* ------------------------------------------------------------------ */ + // AOCC BEGIN + /* + * ::= NOWAIT + */ + case PAR_ATTR38: + add_clause(CL_NOWAIT, TRUE); + break; + /* + * ::= USE_DEVICE_PTR ( ) + */ + case PAR_ATTR39: { + ITEM *itemp, *itembeg, *itemend; + int type = OMP_TGT_MAPTYPE_TARGET_PARAM | + OMP_TGT_MAPTYPE_RETURN_PARAM; + int clause = CL_USE_DEVICE_PTR; + + itembeg = SST_BEGG(RHS(3)); + itemend = SST_ENDG(RHS(3)); + if (itembeg == ITEM_END) + return; + for (itemp = itembeg; itemp != ITEM_END; itemp = itemp->next) { + itemp->t.cltype = type; + } + add_clause(clause, FALSE); + if (CL_FIRST(clause) == NULL) + CL_FIRST(clause) = itembeg; + else + ((ITEM *)CL_LAST(clause))->next = itembeg; + CL_LAST(clause) = itemend; + break; + } + /* + * ::= IN_REUDCTION ( ) + */ + case PAR_ATTR40: + break; + /* + * ::= USE_DEVICE_ADDR ( ) + */ + case PAR_ATTR41: { + ITEM *itemp, *itembeg, *itemend; + int type = OMP_TGT_MAPTYPE_RETURN_PARAM; + + int clause = CL_USE_DEVICE_ADDR; + + itembeg = SST_BEGG(RHS(3)); + itemend = SST_ENDG(RHS(3)); + if (itembeg == ITEM_END) + return; + for (itemp = itembeg; itemp != ITEM_END; itemp = itemp->next) { + itemp->t.cltype = type; + } + add_clause(clause, FALSE); + if (CL_FIRST(clause) == NULL) + CL_FIRST(clause) = itembeg; + else + ((ITEM *)CL_LAST(clause))->next = itembeg; + CL_LAST(clause) = itemend; + break; + } + /* + * ::= BIND ( PARALLEL/TEAMS ) + */ + case PAR_ATTR42: + // TODO: + break; + // AOCC END + /* ------------------------------------------------------------------ */ /* * ::= | */ @@ -2762,28 +3173,55 @@ semsmp(int rednum, SST *top) /* ------------------------------------------------------------------ */ /* - * ::= SCHEDULE | + * ::= SCHEDULE ( ) | */ case SCHEDULE1: add_clause(CL_SCHEDULE, TRUE); CL_VAL(CL_SCHEDULE) = SST_IDG(RHS(2)); break; /* - * ::= MP_SCHEDTYPE = | + * storing the modifier passes in clause table + * + * ::= SCHEDULE ( ) | */ + // AOCC begin case SCHEDULE2: + add_clause(CL_SCHEDULE, TRUE); + CL_MOD(CL_SCHEDULE) = SST_IDG(RHS(2)); + CL_MOD(CL_SCHEDULE) = modifier(scn.id.name); + break; + // AOCC end + /* + * ::= MP_SCHEDTYPE = | + */ + case SCHEDULE3: add_clause(CL_MP_SCHEDTYPE, TRUE); CL_VAL(CL_SCHEDULE) = sched_type(scn.id.name + SST_CVALG(RHS(3))); break; /* * ::= CHUNK = */ - case SCHEDULE3: + case SCHEDULE4: add_clause(CL_CHUNK, TRUE); chk_scalartyp(RHS(3), DT_INT, FALSE); chunk = SST_ASTG(RHS(3)); break; +/* ------------------------------------------------------------------ */ + /* + * ::= | + */ + case MODIFIER1: + SST_IDP(LHS, DI_MOD_NONMONOTONIC); + break; + /* + * ::= + */ + case MODIFIER2: + SST_IDP(LHS, modifier(scn.id.name)); + break; + + /* ------------------------------------------------------------------ */ /* * ::= | @@ -2792,11 +3230,19 @@ semsmp(int rednum, SST *top) SST_IDP(LHS, DI_SCH_STATIC); break; /* - * ::= ( ) + * ::= ( ) */ case SCHED_TYPE2: SST_IDP(LHS, sched_type(scn.id.name + SST_CVALG(RHS(2)))); break; + /* + * ::= : ) + */ + // AOCC begin + case SCHED_MOD_TYPE1: + SST_IDP(LHS, sched_type(scn.id.name + SST_CVALG(RHS(2)))); + break; + // AOCC end /* ------------------------------------------------------------------ */ /* @@ -2865,6 +3311,27 @@ semsmp(int rednum, SST *top) reducp->opr = OP_ADD; rhstop = 1; reduction_shared: + /* AOCC begin */ + if (flg.x86_64_omptarget) { + /* This is a temporary workaround for dynamic array reduction where we + * serialize the kernel. + */ + bool skip_reduction = false; + for (itemp = SST_BEGG(RHS(rhstop)); itemp != ITEM_END; + itemp = itemp->next) { + if (ALLOCG(itemp->t.sptr)) { + if (teams_ast) { + A_THRLIMITP(teams_ast, mk_cnst(stb.i1)); + A_NTEAMSP(teams_ast, mk_cnst(stb.i1)); + } + skip_reduction = true; + } + } + if (skip_reduction) + break; + } + /* AOCC end */ + if (CL_FIRST(CL_REDUCTION) == NULL) CL_FIRST(CL_REDUCTION) = reducp; else @@ -2920,6 +3387,137 @@ semsmp(int rednum, SST *top) } /* skip past the fake REDUC_SYM item */ reducp->list = reducp->list->next; + //AOCC Begin +#ifdef OMP_OFFLOAD_AMD + if (target_ast) { + reduction_kernel = 1; + } +#endif + // AOCC End + break; + /* ------------------------------------------------------------------ */ + /* + * ::= : + */ + case IN_REDUCTION1: + if (SST_IDG(RHS(1)) == 1 && SST_SYMG(RHS(1)) == 0) + /* error occurred, so just ignore it */ + break; + add_clause(CL_IN_REDUCTION, FALSE); + /* + * Need to keep the REDUC items around until the end of the + * parallel do, so allocate them in area 1. + */ + reducp = (REDUC *)getitem(1, sizeof(REDUC)); + reducp->next = NULL; + if (SST_IDG(RHS(1)) == 0) { + reducp->opr = SST_OPTYPEG(RHS(1)); + if (reducp->opr == OP_LOG) + reducp->intrin = SST_OPCG(RHS(1)); + } else { + reducp->opr = 0; + reducp->intrin = SST_SYMG(RHS(1)); + } + rhstop = 3; + goto in_reduction_shared; + break; + /* + * ::= + */ + case IN_REDUCTION2: + add_clause(CL_IN_REDUCTION, FALSE); + /* + * Need to keep the REDUC items around until the end of the + * parallel do, so allocate them in area 1. + */ + reducp = (REDUC *)getitem(1, sizeof(REDUC)); + reducp->next = NULL; + reducp->opr = OP_ADD; + rhstop = 1; + in_reduction_shared: + /* AOCC begin */ + if (flg.x86_64_omptarget) { + /* This is a temporary workaround for dynamic array reduction where we + * serialize the kernel. + */ + bool skip_reduction = false; + for (itemp = SST_BEGG(RHS(rhstop)); itemp != ITEM_END; + itemp = itemp->next) { + if (ALLOCG(itemp->t.sptr)) { + if (teams_ast) { + A_THRLIMITP(teams_ast, mk_cnst(stb.i1)); + A_NTEAMSP(teams_ast, mk_cnst(stb.i1)); + } + skip_reduction = true; + } + } + if (skip_reduction) + break; + } + /* AOCC end */ + + if (CL_FIRST(CL_IN_REDUCTION) == NULL) + CL_FIRST(CL_IN_REDUCTION) = reducp; + else + ((REDUC *)CL_LAST(CL_IN_REDUCTION))->next = reducp; + CL_LAST(CL_IN_REDUCTION) = reducp; + /* + * create a fake REDUC_SYM item (from area 0 freed during the end of + * statement processing. + */ + reducp->list = reduc_symp_last = (REDUC_SYM *)getitem(0, sizeof(REDUC_SYM)); + reducp->list->next = NULL; + for (itemp = SST_BEGG(RHS(rhstop)); itemp != ITEM_END; + itemp = itemp->next) { + /* + * Need to keep the REDUC_SYM items around until the end of the + * parallel do, so allocate them in area 1. + */ + reduc_symp = (REDUC_SYM *)getitem(1, sizeof(REDUC_SYM)); + reduc_symp->Private = 0; + reduc_symp->shared = itemp->t.sptr; + reduc_symp->next = NULL; + for (reduc_symp_curr = reducp->list->next; reduc_symp_curr; + reduc_symp_curr = reduc_symp_curr->next) { + if (reduc_symp_curr->shared == reduc_symp->shared) { + error(155, 2, gbl.lineno, "Duplicate name in in_reduction clause -", + SYMNAME(reduc_symp->shared)); + break; + } + } + + reduc_symp_last->next = reduc_symp; + reduc_symp_last = reduc_symp; + if (STYPEG(reduc_symp->shared) != ST_VAR && + STYPEG(reduc_symp->shared) != ST_ARRAY) { + error(155, 3, gbl.lineno, + "Reduction variable must be a scalar or array variable -", + SYMNAME(reduc_symp->shared)); + /* + * pass up 0 so that do_reduction() & end_reduction() + * will ignore this item. + */ + reduc_symp->shared = 0; + } else { + dtype = DTYPEG(reduc_symp->shared); + dtype = DDTG(dtype); + if (!DT_ISBASIC(dtype)) { + error(155, 3, gbl.lineno, + "Reduction variable must be of intrinsic type -", + SYMNAME(reduc_symp->shared)); + reduc_symp->shared = 0; + } + } + } + /* skip past the fake REDUC_SYM item */ + reducp->list = reducp->list->next; + //AOCC Begin +#ifdef OMP_OFFLOAD_AMD + if (target_ast) { + reduction_kernel = 1; + } +#endif + // AOCC End break; /* ------------------------------------------------------------------ */ @@ -3183,12 +3781,32 @@ semsmp(int rednum, SST *top) /* * ::= TO ( ) | */ - case MOTION_CLAUSE1: + // AOCC Begin + /* + * CHANGED MOTION_CLAUSE1 and MOTION_CLAUSE2 + * In the grammer we have changed list type from to + * . This is because doesn't populate + * ast properly. Changing that behaviour may break something else as + * it is used in many places. + * + */ + // AOCC End + case MOTION_CLAUSE1: + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + mp_handle_motion_clause(top, CL_TO, 3); +#endif + // AOCC End break; /* * ::= FROM ( ) */ case MOTION_CLAUSE2: + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + mp_handle_motion_clause(top, CL_FROM, 3); +#endif + // AOCC End break; /* ------------------------------------------------------------------ */ @@ -3359,6 +3977,12 @@ semsmp(int rednum, SST *top) * ::= */ case SIMD_BEGIN1: + // KVF point + if (sem.metadirective.whencondition) { + if (sem.metadirective.whenexpanded) { break; } + if (!sem.metadirective.defaultcondition && !sem.metadirective.whenconditionvalue) { break; } + sem.metadirective.whenexpanded = true; + } parstuff_init(); doif = enter_dir(DI_SIMD, FALSE, 0, DI_B(DI_ATOMIC_CAPTURE)); SST_CVALP(LHS, sem.doif_depth); /* always pass up do's DOIF index */ @@ -3374,8 +3998,14 @@ semsmp(int rednum, SST *top) doif = enter_dir(DI_TARGETDATA, TRUE, 0, DI_B(DI_ATOMIC_CAPTURE) | DI_B(DI_TARGET) | DI_B(DI_TARGETENTERDATA) | DI_B(DI_TARGETEXITDATA) | - DI_B(DI_TARGETUPDATE) | DI_B(DI_TARGETDATA)); - SST_CVALP(LHS, doif); + DI_B(DI_TARGETUPDATE)); + // AOCC Begin + if (flg.amdgcn_target) + SST_CVALP(LHS, sem.doif_depth); + else + // AOCC End + SST_CVALP(LHS, doif); + break; /* ------------------------------------------------------------------ */ @@ -3525,6 +4155,7 @@ semsmp(int rednum, SST *top) * ::= */ case TARGSIMD_BEGIN1: + is_targsimd = TRUE; parstuff_init(); doif = enter_dir(DI_TARGET, TRUE, 0, DI_B(DI_ATOMIC_CAPTURE)); SST_CVALP(LHS, doif); @@ -4818,14 +5449,46 @@ semsmp(int rednum, SST *top) */ case ACCEL_DATA1: #if defined(OMP_OFFLOAD_LLVM) || defined(OMP_OFFLOAD_PGI) - if(is_in_omptarget(sem.doif_depth) || is_in_omptarget_data(sem.doif_depth)) { + if(is_in_omptarget(sem.doif_depth) || flg.amdgcn_target || flg.x86_64_omptarget) { //todo support array section in the map clause for openmp if (SST_IDG(RHS(1)) == S_IDENT || SST_IDG(RHS(1)) == S_DERIVED) { sptr = SST_SYMG(RHS(1)); } else { sptr = SST_LSYMG(RHS(1)); } - error(1206, ERR_Warning, gbl.lineno, sptr ? SYMNAME(sptr) : CNULL, CNULL); + if(!(int)ASUMSZG(sptr)) // AOCC + error(1206, ERR_Warning, gbl.lineno, sptr ? SYMNAME(sptr) : CNULL, CNULL); + + // AOCC Begin + // create subscript with lower and upper bound for the array in RHS(1) + itemp = SST_BEGG(RHS(3)); + if(DTY(DTYPEG(sptr)) == TY_ARRAY && (int)ASUMSZG(sptr)){ + ITEM *itemp1; + int triple_flag, curr_dim; + for(triple_flag = curr_dim = 0,itemp1 = itemp; + (itemp1 && itemp1 != ITEM_END); itemp1 = itemp1->next){ + SST *e1 = itemp1->t.stkp; + if(SST_IDG(e1) == S_TRIPLE){ + int mask = 0; + if(SST_IDG(SST_E1G(e1)) == S_NULL){ + mask |= lboundMask; + } + if(SST_IDG(SST_E2G(e1)) == S_NULL){ + mask |= uboundMask; + } + if(SST_IDG(SST_E3G(e1)) == S_NULL){ + mask |= strideMask; + } + mask <<= 3 * curr_dim; + triple_flag |= mask; + ++curr_dim; + } + } + SST_DIMFLAGP(LHS, triple_flag); + (void)mkvarref(RHS(1), itemp); // creates triple and subscript + SST_PARENP(LHS, 0); + } + // AOCC End goto accel_data2; break; } @@ -5962,6 +6625,24 @@ accel_pragmagen(int pragma, int pragma1, int pragma2) { } +// AOCC begin +static int +modifier(char *nm) +{ + if (sem_strcmp(nm, "nonmonotonic") == 0) + return DI_MOD_NONMONOTONIC; + + if (sem_strcmp(nm, "monotonic") == 0) + return DI_MOD_MONOTONIC; + + if (sem_strcmp(nm, "simd") == 0) + return DI_MOD_SIMD; + + error(34, 3, gbl.lineno, nm, CNULL); + return DI_MOD_NONMONOTONIC; +} +//AOCC end + static int sched_type(char *nm) { @@ -6196,6 +6877,13 @@ emit_btarget(int atype) int ast, shast; int sptr, stblk; + if (sem.metadirective.whencondition) { +// if (sem.metadirective.whenexpanded) { --sem.doif_depth; return 0; } +// if (!sem.metadirective.defaultcondition && !sem.metadirective.whenconditionvalue) { --sem.doif_depth; return 0; } + if (sem.metadirective.whenexpanded) { return 0; } + if (!sem.metadirective.defaultcondition && !sem.metadirective.whenconditionvalue) { return 0; } + sem.metadirective.whenexpanded = true; + } ast = mk_stmt(atype, 0); sem.target++; if (CL_PRESENT(CL_IF)) { @@ -6211,6 +6899,14 @@ emit_btarget(int atype) } if (CL_PRESENT(CL_NOWAIT)) { } + // AOCC Begin + if (CL_PRESENT(CL_DEFAULTMAP)) { + int new_ast = mk_stmt(A_MP_DEFAULTMAP, 0); + int maptype = CL_VAL(CL_DEFAULTMAP); + (void)add_stmt(new_ast); + A_PRAGMATYPEP(new_ast, maptype); + } + // AOCC End (void)add_stmt(ast); return ast; } @@ -6245,6 +6941,11 @@ emit_bpar(void) A_ENDLABP(ast, 0); if (CL_PRESENT(CL_IF)) { if (mp_iftype != OMP_DEFAULT && (mp_iftype & OMP_PARALLEL) != OMP_PARALLEL) +#ifdef OMP_OFFLOAD_AMD + if (flg.omptarget && !CL_PRESENT(CL_DIST_SCHEDULE) && mp_iftype & OMP_TARGET) + ; + else +#endif error(155, 3, gbl.lineno, "IF (parallel:) or IF is expected in PARALLEL " "or combined PARALLEL construct ", @@ -6253,7 +6954,7 @@ emit_bpar(void) A_IFPARP(ast, CL_VAL(CL_IF)); } if (CL_PRESENT(CL_NUM_THREADS)) - A_NPARP(ast, CL_VAL(CL_NUM_THREADS)); + A_THRLIMITP(ast, CL_VAL(CL_NUM_THREADS)); /* PROC_BIND ast should be constant value */ if (CL_PRESENT(CL_PROC_BIND)) { @@ -6311,6 +7012,7 @@ do_schedule(int doif) DI_DISTCHUNK(doif) = 0; if (CL_PRESENT(CL_SCHEDULE) || CL_PRESENT(CL_MP_SCHEDTYPE)) { DI_SCHED_TYPE(doif) = CL_VAL(CL_SCHEDULE); + DI_SCHED_MODIFIER(doif) = CL_MOD(CL_SCHEDULE); if (chunk) { if (DI_SCHED_TYPE(doif) == DI_SCH_RUNTIME || DI_SCHED_TYPE(doif) == DI_SCH_AUTO) { @@ -6377,6 +7079,22 @@ do_dist_schedule(int doif, LOGICAL chk_collapse) DI_DISTCHUNK(doif) = 0; } DI_CHUNK(doif) = DI_DISTCHUNK(doif); + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + if (flg.omptarget && !CL_PRESENT(CL_DIST_SCHEDULE) && target_ast && + A_COMBINEDTYPEG(target_ast) == mode_target_teams_distribute) { + if (flg.amdgcn_target) { + DI_SCHED_TYPE(doif) = MP_SCH_TEAMS_DIST; + } else if (flg.x86_64_omptarget) { + // Force static scheduling if this is a target teams-distribute without a + // parallel do. + DI_SCHED_TYPE(doif) = MP_SCH_STATIC; + } else { + DI_SCHED_TYPE(doif) = DI_SCH_DIST_STATIC; + } + } else +#endif + // AOCC End DI_SCHED_TYPE(doif) = DI_SCH_DIST_STATIC; DI_IS_ORDERED(doif) = CL_PRESENT(CL_ORDERED); DI_ISSIMD(doif) = 0; @@ -6481,6 +7199,8 @@ do_distbegin(DOINFO *doinfo, int do_label, int construct_name) DI_NAME(doif) = construct_name; direct_loop_enter(); (void)add_stmt(dast); + if (CL_PRESENT(CL_COLLAPSE)) + collapse_loop.distributed_loop = A_STDG(dast); /* simulate enter_dir(DI_PARDO...) */ { @@ -6599,7 +7319,13 @@ mk_firstprivate(int sptr1, int taskdupstd) std = 0; if (!POINTERG(sptr)) { - if (!XBIT(54, 0x1) && ALLOCATTRG(sptr)) { + // AOCC + // If the construct is target based, copy the + // original value of the firstprivate variable + // before the BMSCOPE AST node or else the code + // will end up in kernel. + if ((!XBIT(54, 0x1) && ALLOCATTRG(sptr)) || + (is_in_omptarget(sem.doif_depth))) { // AOCC std = sem.scope_stack[sem.scope_level].end_prologue; if (std == 0) { std = STD_PREV(0); @@ -7252,6 +7978,19 @@ do_reduction(void) /* error - illegal reduction variable */ continue; reduc_symp->Private = decl_private_sym(reduc_symp->shared); + // AOCC Begin + // FIXME: Remove when we support reduction of real*4, int, int*8 in GPUs + if (DTYPEG(reduc_symp->Private) == DT_REAL && flg.amdgcn_target) { + DTYPEP(reduc_symp->Private, DT_DBLE); + } + if (DTYPEG(reduc_symp->Private) == DT_INT && flg.amdgcn_target) { + DTYPEP(reduc_symp->Private, DT_DBLE); + } + if (DTYPEG(reduc_symp->Private) == DT_INT8 && flg.amdgcn_target) { + DTYPEP(reduc_symp->Private, DT_DBLE); + } + + // AOCC End set_parref_flag(reduc_symp->shared, reduc_symp->shared, BLK_UPLEVEL_SPTR(sem.scope_level)); (void)mk_storage(reduc_symp->Private, &lhs); @@ -7598,6 +8337,266 @@ do_copyprivate() } } +// AOCC Begin +static void +do_tofrom() +{ + if (!flg.omptarget) + return; + + ITEM *item; + int ast; + if (CL_PRESENT(CL_TO)) { + for (item = (ITEM *)CL_FIRST(CL_TO); item != ITEM_END; item = item->next) { + ast = mk_stmt(A_MP_MAP, 0); + (void)add_stmt(ast); + A_LOPP(ast, item->ast); + A_PRAGMATYPEP(ast, item->t.cltype); + // AOCC Begin + if (A_TYPEG(item->ast) == A_MEM) + A_ROPP(ast, A_PARENTG(item->ast)); + // AOCC End + } + } + if (CL_PRESENT(CL_FROM)) { + for (item = (ITEM *)CL_FIRST(CL_FROM); item != ITEM_END; + item = item->next) { + ast = mk_stmt(A_MP_MAP, 0); + (void)add_stmt(ast); + A_LOPP(ast, item->ast); + A_PRAGMATYPEP(ast, item->t.cltype); + // AOCC Begin + if (A_TYPEG(item->ast) == A_MEM) + A_ROPP(ast, A_PARENTG(item->ast)); + // AOCC End + } + } + ast = mk_stmt(A_MP_EMAP, 0); + (void)add_stmt(ast); +} + +static void +do_usedeviceptr() +{ + if (!flg.omptarget) + return; + + ITEM *item; + int ast; + if (CL_PRESENT(CL_USE_DEVICE_PTR)) { + for (item = (ITEM *)CL_FIRST(CL_USE_DEVICE_PTR); item != ITEM_END; + item = item->next) { + ast = mk_stmt(A_MP_USE_DEVICE_PTR, 0); // AOCC + (void)add_stmt(ast); + A_LOPP(ast, item->ast); + A_PRAGMATYPEP(ast, item->t.cltype); + } + } +} + +// AOCC Begin +static void +do_usedeviceaddr() +{ + if (!flg.omptarget) + return; + + ITEM *item; + int ast; + if (CL_PRESENT(CL_USE_DEVICE_ADDR)) { + for (item = (ITEM *)CL_FIRST(CL_USE_DEVICE_ADDR); item != ITEM_END; + item = item->next) { + ast = mk_stmt(A_MP_USE_DEVICE_ADDR, 0); + (void)add_stmt(ast); + A_LOPP(ast, item->ast); + A_PRAGMATYPEP(ast, item->t.cltype); + } + } +} +// AOCC End + +static void +do_in_reduction() +{ + REDUC *in_reducp; + REDUC_SYM *in_reduc_symp; + + if(CL_PRESENT(CL_IN_REDUCTION)) { + for (in_reducp = CL_FIRST(CL_IN_REDUCTION); in_reducp; + in_reducp = in_reducp->next) { + for (in_reduc_symp = in_reducp->list; in_reduc_symp; + in_reduc_symp = in_reduc_symp->next) { + int dtype, ast; + INT val[4]; + INT conval; + SST cnst; + SST lhs; + char *nm; + + if (in_reduc_symp->shared == 0) + /* error illegal reduction variable */ + continue; + in_reduc_symp->Private = decl_private_sym(in_reduc_symp->shared); + + if (DTYPEG(in_reduc_symp->Private) == DT_REAL && flg.amdgcn_target) { + DTYPEP(in_reduc_symp->Private, DT_DBLE); + } + if (DTYPEG(in_reduc_symp->Private) == DT_CMPLX && flg.amdgcn_target) { + DTYPEP(in_reduc_symp->Private, DT_DCMPLX); + } + + set_parref_flag(in_reduc_symp->shared, in_reduc_symp->shared, + BLK_UPLEVEL_SPTR(sem.scope_level)); + (void)mk_storage(in_reduc_symp->Private, &lhs); + + // initialization of the private copy + dtype = DT_INT; + switch (in_reducp->opr) { + case 0: + nm = SYMNAME(in_reducp->intrin); + if (strcmp(nm, "max") == 0) { + dtype = DTYPEG(in_reduc_symp->shared); + dtype = DDTG(dtype); + if (DT_ISINT(dtype)) { + if (size_of(dtype) <= 4) { + conval = 0x80000000; + dtype = DT_INT; + } else { + val[0] = 0x80000000; + val[1] = 0x00000000; + conval = getcon(val, dtype); + } + } else if (dtype == DT_REAL) + /* -3.402823466E+38 */ + conval = 0xff7fffff; + else if (dtype == DT_QUAD) { + val[0] = 0xffffffff; + val[1] = 0xffffffff; + val[2] = 0xffefffff; + val[3] = 0xffffffff; + conval = getcon(val, DT_QUAD); + + } else { + /* -1.79769313486231571E+308 */ + val[0] = 0xffefffff; + val[1] = 0xffffffff; + conval = getcon(val, DT_DBLE); + } + break; + } + if (strcmp(nm, "min") == 0) { + dtype = DTYPEG(in_reduc_symp->shared); + dtype = DDTG(dtype); + if (DT_ISINT(dtype)) { + if (size_of(dtype) <= 4) { + conval = 0x7fffffff; + dtype = DT_INT; + } else { + val[0] = 0x7fffffff; + val[1] = 0xffffffff; + conval = getcon(val, dtype); + } + } else if (dtype == DT_REAL) { + /* 3.402823466E+38 */ + conval = 0x7f7fffff; + } else if (dtype == DT_QUAD) { + val[0] = 0xffffffff; + val[1] = 0xffffffff; + val[2] = 0x7fefffff; + val[3] = 0xffffffff; + conval = getcon(val, DT_QUAD); + } else { + /* 1.79769313486231571E+308 */ + val[0] = 0x7fefffff; + val[1] = 0xffffffff; + conval = getcon(val, DT_DBLE); + } + break; + } + if (strcmp(nm, "iand") == 0) { + dtype = DTYPEG(in_reduc_symp->shared); + dtype = DDTG(dtype); + if (size_of(dtype) <= 4) { + conval = 0xffffffff; + dtype = DT_INT; + } else { + val[0] = 0xffffffff; + val[1] = 0xffffffff; + conval = getcon(val, dtype); + } + break; + } + if (strcmp(nm, "ior") == 0) { + conval = 0; + break; + } + if (strcmp(nm, "ieor") == 0) { + conval = 0; + break; + } + interr("do_in_reduction - illegal intrinsic", in_reducp->intrin, 0); + break; + case OP_ADD: + case OP_SUB: + conval = 0; + break; + case OP_MUL: + conval = 1; + break; + case OP_LOG: + dtype = DT_LOG; + switch (in_reducp->intrin) { + case OP_LAND: + case OP_LEQV: + conval = SCFTN_TRUE; + break; + case OP_LOR: + case OP_LNEQV: + conval = SCFTN_FALSE; + break; + default: + interr("do_in_reduction - illegal log operator", + in_reducp->intrin, 0); + } + break; + default: + interr("do_in_reduction - illegal log operator", + in_reducp->opr, 0); + break; + } + SST_IDP(&cnst, S_CONST); + SST_DTYPEP(&cnst, dtype); + SST_CVALP(&cnst, conval); + ast = mk_cval1(conval, dtype); + SST_ASTP(&cnst, ast); + (void)add_stmt(assign(&lhs, &cnst)); + } + } + DI_IN_REDUC(sem.doif_depth) = CL_FIRST(CL_IN_REDUCTION); + } +} + +static void +do_isdeviceptr() +{ + if (!flg.omptarget) + return; + + ITEM *item; + int ast; + + if (CL_PRESENT(CL_IS_DEVICE_PTR)) { + for (item = (ITEM *)CL_FIRST(CL_IS_DEVICE_PTR); item != ITEM_END; + item = item->next) { + ast = mk_stmt(A_MP_IS_DEVICE_PTR, 0); + (void)add_stmt(ast); + A_LOPP(ast, item->ast); + A_PRAGMATYPEP(ast, item->t.cltype); + } + } +} +// AOCC End + static void do_map() { @@ -7606,12 +8605,53 @@ do_map() ITEM *item; int ast; + int past = 0, cast = 0; // AOCC + if (CL_PRESENT(CL_MAP)) { for (item = (ITEM *)CL_FIRST(CL_MAP); item != ITEM_END; item = item->next) { + // AOCC Begin + SPTR blk = A_SPTRG(item->ast); + if (blk && STYPEG(blk) == ST_CMBLK) { + for (SPTR sptr = CMEMFG(blk); sptr > NOSYM; + sptr = (SPTR) SYMLKG(sptr)) { + int sptr_ast = mk_id(sptr); + ast = mk_stmt(A_MP_MAP, 0); + (void)add_stmt(ast); + A_LOPP(ast, sptr_ast); + A_PRAGMATYPEP(ast, item->t.cltype); + } + continue; + } + // replace obj%p(i) with ptr(i) to map and access the pointer member + // where, p is a pointer member of obj a structure type variable + // ptr is a compiler created pointer + // + // This is used when obj%p is mapped using map clause + if(!map_exit_data && A_TYPEG(item->ast) == A_MEM && + POINTERG(A_SPTRG(A_MEMG(item->ast))) && + SCG(A_SPTRG(A_MEMG(item->ast))) == SC_BASED) { + past = get_cc_pointer(A_SPTRG(A_PARENTG(item->ast)), + A_SPTRG(A_MEMG(item->ast))); + if(past){ + cast = add_ptr_assign(past, item->ast, 0); + add_stmt_after(cast, sem.last_std); + } + } + // AOCC End ast = mk_stmt(A_MP_MAP, 0); (void)add_stmt(ast); - A_LOPP(ast, item->ast); + // AOCC Begin + if(cast) + A_LOPP(ast, past); + else + // AOCC End + A_LOPP(ast, item->ast); A_PRAGMATYPEP(ast, item->t.cltype); + // AOCC Begin + if (A_TYPEG(item->ast) == A_MEM) { + A_ROPP(ast, A_PARENTG(item->ast)); + } + // AOCC End // TODO ompaccel do later lower/upper bounds } } @@ -7867,6 +8907,8 @@ begin_parallel_clause(int doif) switch (DI_ID(doif)) { case DI_TARGET: + do_in_reduction(); // AOCC + do_isdeviceptr(); // AOCC do_map(); break; default: @@ -7970,6 +9012,15 @@ end_parallel_clause(int doif) break; } } + // AOCC Begin + switch (DI_ID(doif)) { + case DI_TARGET: + end_in_reduction(DI_IN_REDUC(doif), doif); + break; + default: + break; + } + // AOCC End } static ATOMIC_RMW_OP @@ -8029,7 +9080,7 @@ gen_reduction(REDUC *reducp, REDUC_SYM *reduc_symp, LOGICAL rmme, return; } } - if (use_atomic_for_reduction(sem.doif_depth)) + if (use_atomic_for_reduction(sem.doif_depth, reducp, reduc_symp)) // AOCC add_stmt(mk_stmt(A_MP_ATOMIC, 0)); (void)mk_storage(reduc_symp->shared, &lhs); @@ -8050,7 +9101,7 @@ gen_reduction(REDUC *reducp, REDUC_SYM *reduc_symp, LOGICAL rmme, * shared <-- intrin(shared, private) */ (void)ref_intrin(&intrin, arg1); - if (use_atomic_for_reduction(sem.doif_depth) && + if (use_atomic_for_reduction(sem.doif_depth, reducp, reduc_symp) && // AOCC sem.mpaccatomic.rmw_op != AOP_UNDEF) { MEMORY_ORDER save_mem_order = sem.mpaccatomic.mem_order; sem.mpaccatomic.mem_order = MO_SEQ_CST; @@ -8097,7 +9148,8 @@ gen_reduction(REDUC *reducp, REDUC_SYM *reduc_symp, LOGICAL rmme, SST_ASTP(&op1, ast); SST_SHAPEP(&op1, A_SHAPEG(ast)); - if (use_atomic_for_reduction(sem.doif_depth)&& get_atomic_rmw_op(opc) != AOP_UNDEF) { + if (use_atomic_for_reduction(sem.doif_depth, reducp, reduc_symp) // AOCC + && get_atomic_rmw_op(opc) != AOP_UNDEF) { MEMORY_ORDER save_mem_order = sem.mpaccatomic.mem_order; sem.mpaccatomic.rmw_op = get_atomic_rmw_op(opc); @@ -8142,6 +9194,9 @@ end_reduction(REDUC *red, int doif) int ast_crit, ast_endcrit, ast_red; int save_par, save_target, save_teams; LOGICAL done = FALSE; + // AOCC Begin + LOGICAL bredcution_created = FALSE; + // AOCC End LOGICAL in_parallel = FALSE; if (red == NULL) @@ -8168,7 +9223,8 @@ end_reduction(REDUC *red, int doif) if (reduc_symp->shared == 0) /* error - illegal reduction variable */ continue; - if (!use_atomic_for_reduction(sem.doif_depth) && !done) { + if (!use_atomic_for_reduction(sem.doif_depth, red, reduc_symp) // AOCC + && !done) { ast_crit = emit_bcs_ecs(A_MP_CRITICAL); done = TRUE; } @@ -8182,14 +9238,18 @@ end_reduction(REDUC *red, int doif) if (reduc_symp->shared == 0) /* error - illegal reduction variable or set by loop above */ continue; - if (!use_atomic_for_reduction(sem.doif_depth) && !done) { + if (!use_atomic_for_reduction(sem.doif_depth, red, reduc_symp) // AOCC + && !done) { #ifdef OMP_OFFLOAD_LLVM ast_red = mk_stmt(A_MP_BREDUCTION, 0); + // AOCC Begin + bredcution_created = TRUE; + // AOCC End (void) add_stmt(ast_red); #endif ast_crit = emit_bcs_ecs(A_MP_CRITICAL); #ifdef OMP_OFFLOAD_LLVM - if (!use_atomic_for_reduction(sem.doif_depth)) { + if (!use_atomic_for_reduction(sem.doif_depth, red, reduc_symp)) { // AOCC A_ISOMPREDUCTIONP(ast_crit, 1); gen_reduction_ompaccel(reducp, reduc_symp, FALSE, in_parallel); } @@ -8204,20 +9264,58 @@ end_reduction(REDUC *red, int doif) sem.parallel = save_par; sem.target = save_target; sem.teams = save_teams; - if (!use_atomic_for_reduction(sem.doif_depth)) { + if (!use_atomic_for_reduction(sem.doif_depth, red, reduc_symp)) { // AOCC ast_endcrit = emit_bcs_ecs(A_MP_ENDCRITICAL); A_LOPP(ast_crit, ast_endcrit); A_LOPP(ast_endcrit, ast_crit); #ifdef OMP_OFFLOAD_LLVM A_ISOMPREDUCTIONP(ast_endcrit, 1); #endif + // AOCC Begin + // Emitting ereduction ilm only bredution is emitted #ifdef OMP_OFFLOAD_LLVM - ast_red = mk_stmt(A_MP_EREDUCTION, 0); - (void)add_stmt(ast_red); + if (bredcution_created) { + ast_red = mk_stmt(A_MP_EREDUCTION, 0); + (void)add_stmt(ast_red); + } #endif + // AOCC End } } +// AOCC Begin +static void +end_in_reduction(REDUC *in_red, int doif) +{ + REDUC *in_reducp; + REDUC_SYM *in_reduc_symp; + int save_par, save_target, save_teams; + LOGICAL in_parallel = FALSE; + + if(!in_red) + return; + + save_par = sem.parallel; + sem.parallel = 0; + save_target = sem.target; + sem.target = 0; + save_teams = sem.teams; + sem.teams = 0; + in_parallel = (save_par || save_target || save_teams); + + if (DI_ID(doif) == DI_TARGET) { + for (in_reducp = in_red; in_reducp; in_reducp = in_reducp->next) { + for (in_reduc_symp = in_reducp->list; in_reduc_symp; + in_reduc_symp = in_reduc_symp->next) { + if(use_atomic_for_reduction(sem.doif_depth, in_red, in_reduc_symp)) { + gen_reduction(in_reducp, in_reduc_symp, FALSE, in_parallel); + } + } + } + } +} +// AOCC End + static void end_lastprivate(int doif) { @@ -8379,6 +9477,14 @@ do_btarget(int doif) mp_create_bscope(0); DI_BTARGET(doif) = emit_btarget(A_MP_TARGET); par_push_scope(TRUE); + // AOCC Begin + if (CL_PRESENT(CL_DEFAULTMAP)) { + int new_ast = mk_stmt(A_MP_DEFAULTMAP, 0); + int maptype = CL_VAL(CL_DEFAULTMAP); + (void)add_stmt(new_ast); + A_PRAGMATYPEP(new_ast, maptype); + } + // AOCC End begin_parallel_clause(doif); } @@ -8398,10 +9504,14 @@ do_bteams(int doif) } if (CL_PRESENT(CL_THREAD_LIMIT)) { thread_limit = CL_VAL(CL_THREAD_LIMIT); + } else if (CL_PRESENT(CL_NUM_THREADS)) { + thread_limit = CL_VAL(CL_NUM_THREADS); } + A_NTEAMSP(ast, num_teams); A_THRLIMITP(ast, thread_limit); add_stmt(ast); + teams_ast = ast; sem.teams++; par_push_scope(FALSE); @@ -8415,6 +9525,7 @@ do_bdistribute(int doif, LOGICAL chk_collapse) do_dist_schedule(doif, chk_collapse); ast = mk_stmt(A_MP_DISTRIBUTE, 0); + distribute_doif = doif; /* AOCC */ DI_BDISTRIBUTE(doif) = ast; add_stmt(ast); @@ -8532,6 +9643,11 @@ restore_clauses(void) CL_VAL(CL_THREAD_LIMIT) = mk_id(sptr); set_parref_flag(sptr, sptr, BLK_UPLEVEL_SPTR(sem.scope_level)); } + if (CL_PRESENT(CL_NUM_THREADS)) { + sptr = CL_VAL(CL_NUM_THREADS); + CL_VAL(CL_NUM_THREADS) = mk_id(sptr); + set_parref_flag(sptr, sptr, BLK_UPLEVEL_SPTR(sem.scope_level)); + } break; case DI_PARDO: case DI_TARGPARDO: @@ -8586,7 +9702,7 @@ restore_clauses(void) /* handle begin combine constructs for target/teams/distribute/parallel/do */ -static void +static bool begin_combine_constructs(BIGINT64 construct) { int doif = sem.doif_depth; @@ -8594,13 +9710,27 @@ begin_combine_constructs(BIGINT64 construct) LOGICAL do_enter = FALSE; has_team = FALSE; + has_target = FALSE; #if defined(OMP_OFFLOAD_LLVM) || defined(OMP_OFFLOAD_PGI) combinedMode = get_omp_combined_mode(construct); if (flg.omptarget) { + if (sem.metadirective.whencondition) { + if (sem.metadirective.whenexpanded || + (!sem.metadirective.defaultcondition && !sem.metadirective.whenconditionvalue)) { + --sem.doif_depth; + return false; + } + } if (!CL_PRESENT(CL_SCHEDULE)) { if (combinedMode == mode_target_teams_distribute_parallel_for_simd || combinedMode == mode_target_teams_distribute_parallel_for) + // AOCC + // Modification: Commenting this, as it will generate wrong schedule + // type for inner mp loop, causing overlapping iteration + // space. +#ifndef OMP_OFFLOAD_AMD add_clause(CL_SCHEDULE, TRUE); +#endif CL_VAL(CL_SCHEDULE) = DI_SCH_STATIC; chunk = 3; } @@ -8618,19 +9748,33 @@ begin_combine_constructs(BIGINT64 construct) #ifdef OMP_OFFLOAD_LLVM if (flg.omptarget) { if (combinedMode == mode_target_teams_distribute_parallel_for_simd) { - errwarn(1203); combinedMode = mode_target_teams_distribute_parallel_for; } else if (combinedMode == mode_target_parallel_for_simd) { - errwarn(1203); combinedMode = mode_target_parallel_for; } else if (combinedMode == mode_target_teams_distribute) { + // AOCC Begin + // Commenting this as generated code is correct +#ifndef OMP_OFFLOAD_AMD error(1202, ERR_Severe, gbl.lineno, "target teams distribute", "parallel do"); +#endif + // AOCC End } else if (combinedMode == mode_target_teams) { + // AOCC Begin + // Commenting this as generated code is correct +#ifndef OMP_OFFLOAD_AMD error(1202, ERR_Severe, gbl.lineno, "target teams", "distribute parallel do"); +#endif + // AOCC End } A_COMBINEDTYPEP(ast, combinedMode); + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + // Store the target ast for future use + target_ast = DI_BTARGET(sem.doif_depth); +#endif + // AOCC End } #endif do_enter = TRUE; @@ -8676,7 +9820,7 @@ begin_combine_constructs(BIGINT64 construct) if ((BT_PARDO & construct)) { par_push_scope(TRUE); } - return; + return true; } if ((BT_PARDO & construct)) { if (do_enter) { @@ -8690,6 +9834,9 @@ begin_combine_constructs(BIGINT64 construct) DI_BPAR(doif) = emit_bpar(); par_push_scope(FALSE); begin_parallel_clause(sem.doif_depth); + if (BT_TARGET & construct && !has_team) { + has_target = TRUE; + } } if (BT_PAR & construct) { if (do_enter) { @@ -8701,8 +9848,9 @@ begin_combine_constructs(BIGINT64 construct) DI_BPAR(doif) = emit_bpar(); par_push_scope(FALSE); begin_parallel_clause(sem.doif_depth); - return; + return true; } + return true; } void @@ -8720,6 +9868,7 @@ end_teams() A_LOPP(ast, DI_BTEAMS(doif)); mp_create_escope(); } + teams_ast = 0; } void @@ -8736,6 +9885,12 @@ end_target() A_LOPP(DI_BTARGET(doif), ast); A_LOPP(ast, DI_BTARGET(doif)); } + // AOCC Begin + // Clear target ast +#ifdef OMP_OFFLOAD_AMD + target_ast = 0; +#endif + // AOCC End } void @@ -8890,7 +10045,7 @@ void add_assign_firstprivate(int dstsym, int srcsym) { SST srcsst, dstsst; - int where, savepar, savetask, savetarget, ast; + int where, savepar, savetask, savetarget, ast, saveteams; int dupwhere; dupwhere = where = sem.scope_stack[sem.scope_level].end_prologue; @@ -8911,7 +10066,9 @@ add_assign_firstprivate(int dstsym, int srcsym) savepar = sem.parallel; savetask = sem.task; savetarget = sem.target; + saveteams = sem.teams; sem.parallel = 0; + sem.teams = 0; if (sem.task && TASKG(dstsym)) { ast = mk_stmt(A_MP_TASKFIRSTPRIV, 0); int src_ast = mk_id(srcsym); @@ -8932,6 +10089,7 @@ add_assign_firstprivate(int dstsym, int srcsym) sem.parallel = savepar; sem.task = savetask; sem.target = savetarget; + sem.teams = saveteams; sem.scope_stack[sem.scope_level].end_prologue = where; if (sem.task && TASKG(dstsym)) { ast = mk_stmt(A_MP_TASKDUP, 0); @@ -9041,7 +10199,7 @@ enter_dir(int typ, /* begin what structured directive */ return cur; } -static int +int leave_dir(int typ, /* end of which structured directive */ LOGICAL ignore_nested, /* ignore directive if nested within itself */ LOGICAL ignore_sev /* error severity if nested directive ignored */ @@ -9346,13 +10504,19 @@ check_targetdata(int type, char *nm) error(533, 3, gbl.lineno, CL_NAME(i), nm); break; case CL_NOWAIT: - if (type != OMP_TARGETENTERDATA && type != OMP_TARGETEXITDATA) + if (type != OMP_TARGETENTERDATA && type != OMP_TARGETEXITDATA && type != OMP_TARGETUPDATE) error(533, 3, gbl.lineno, CL_NAME(i), nm); break; case CL_USE_DEVICE_PTR: if (type != OMP_TARGETDATA) error(533, 3, gbl.lineno, CL_NAME(i), nm); break; + // AOCC Begin + case CL_USE_DEVICE_ADDR: + if (type != OMP_TARGETDATA) + error(533, 3, gbl.lineno, CL_NAME(i), nm); + break; + // AOCC End default: error(533, 3, gbl.lineno, CL_NAME(i), nm); } @@ -9770,9 +10934,9 @@ set_parref_flag(int sptr, int psptr, int stblk) return; if (STYPEG(sptr) == ST_MEMBER) return; + if (!flg.omptarget && (SCG(sptr) == SC_CMBLK || SCG(sptr) == SC_STATIC)) /* For OpenMP target offload, we put every symbols into the uplevel struct. * Because every symbols must be sent to the target device, and are loaded from the uplevel struct.*/ - if (!flg.omptarget && (SCG(sptr) == SC_CMBLK || SCG(sptr) == SC_STATIC)) return; if (SCG(sptr) == SC_EXTERN && ST_ISVAR(sptr)) /* No global vars in uplevel */ return; @@ -9780,8 +10944,10 @@ set_parref_flag(int sptr, int psptr, int stblk) if (SCG(sptr) != SC_LOCAL) { if (SCG(sptr) == SC_BASED) { int sym = MIDNUMG(sptr); - if (SCG(sym) != SC_LOCAL) + // AOCC Modification : Allowing global variables to be mapped. + if (!(flg.omptarget && SCG(sym) == SC_CMBLK) && SCG(sym) != SC_LOCAL) { return; + } } } } @@ -10117,7 +11283,7 @@ gen_reduction_ompaccel(REDUC *reducp, REDUC_SYM *reduc_symp, LOGICAL rmme, ast_reditem = mk_stmt(A_MP_REDUCTIONITEM, 0); A_SHSYMP(ast_reditem, current_redsym->shared); A_PRVSYMP(ast_reditem, current_redsym->Private); - if (current_red->opr == 0) + if (current_red->opr == 0 || current_red-> opr == OP_LOG) A_REDOPRP(ast_reditem, current_red->intrin); else A_REDOPRP(ast_reditem, current_red->opr); @@ -10131,6 +11297,68 @@ gen_reduction_ompaccel(REDUC *reducp, REDUC_SYM *reduc_symp, LOGICAL rmme, #endif /* OMP_OFFLOAD_LLVM */ #if defined(OMP_OFFLOAD_LLVM) || defined(OMP_OFFLOAD_PGI) +// AOCC Bgin +static void +mp_handle_motion_clause(SST *top, int clause, int op) +{ + ITEM *itemp, *itembeg, *itemend; + int type = 0; + type |= OMP_TGT_MAPTYPE_TARGET_PARAM; + + if (clause == CL_TO) { + type |= OMP_TGT_MAPTYPE_TO; + } else if (clause == CL_FROM) { + type |= OMP_TGT_MAPTYPE_FROM; + } else { + assert(0, "Illegal motion cluase", clause, 3); + } + + itembeg = SST_BEGG(RHS(op)); + itemend = SST_ENDG(RHS(op)); + if (itembeg == ITEM_END) + return; + + int it = 0;; + for (itemp = itembeg; itemp != ITEM_END; itemp = itemp->next) { + it++; + itemp->t.cltype = type; + } + + add_clause(clause, FALSE); + if (CL_FIRST(clause) == NULL) + CL_FIRST(clause) = itembeg; + else + ((ITEM *)CL_LAST(clause))->next = itembeg; + CL_LAST(clause) = itemend; +} + +static void +mp_check_defaultmap_val(const char *value) { + if (strcmp(value, "scalar")) + error(1219, ERR_Severe, gbl.lineno, value, 0); +} + +static int +mp_get_map_type_for(const char *map_string) { + int map_type = 0; + if (!strcmp(map_string, "tofrom")) + map_type |= OMP_TGT_MAPTYPE_FROM | OMP_TGT_MAPTYPE_TO; + else if (!strcmp(map_string, "from")) + map_type |= OMP_TGT_MAPTYPE_FROM; + else if (!strcmp(map_string, "to")) + map_type |= OMP_TGT_MAPTYPE_TO; + else if (!strcmp(map_string, "alloc")) + map_type |= OMP_TGT_MAPTYPE_NONE; // todo opmaccel dunno what to pass + else if (!strcmp(map_string, "delete")) + map_type |= OMP_TGT_MAPTYPE_DELETE; + else if (!strcmp(map_string, "release")) + map_type |= OMP_TGT_MAPTYPE_NONE; // todo opmaccel dunno what to pass + else + error(1205, ERR_Severe, gbl.lineno, map_string, 0); + return map_type; +} +// AOCC End + static void mp_check_maptype(const char *maptype) { @@ -10200,6 +11428,13 @@ get_omp_combined_mode(BIGINT64 type) combined_type = BT_TARGET | BT_TEAMS | BT_DISTRIBUTE | BT_PARDO; if ((type & combined_type) == combined_type) return mode_target_teams_distribute_parallel_for; + // AOCC Begin + // TODO : Do we need an explicit mode_type for this case? + // This is reduction kernel case. We need to emit __tgt_target_teams + combined_type = BT_TARGET | BT_DISTRIBUTE | BT_PARDO; + if ((type & combined_type) == combined_type) + return mode_target_teams_distribute_parallel_for; + // AOCC End combined_type = BT_TARGET | BT_TEAMS | BT_DISTRIBUTE; if ((type & combined_type) == combined_type) return mode_target_teams_distribute; @@ -10234,6 +11469,12 @@ static void check_valid_data_sharing(int sptr) { int count = 0; + + //AOCC Begin + /* Is sptr a constant? */ + if (PARAMG(sptr)) + error(155, ERR_Severe, gbl.lineno, SYMNAME(sptr),"is not a variable"); + //AOCC End /* In shared list? */ if (is_in_list(CL_SHARED, sptr)) @@ -10303,6 +11544,7 @@ static LOGICAL is_in_omptarget_data(int d) } static LOGICAL is_in_omptarget(int d) { +#if defined(OMP_OFFLOAD_LLVM) || defined(OMP_OFFLOAD_PGI) if(flg.omptarget && (DI_IN_NEST(d, DI_TARGET) || DI_IN_NEST(d, DI_TARGTEAMSDISTPARDO) || DI_IN_NEST(d, DI_TARGPARDO) || @@ -10310,6 +11552,7 @@ static LOGICAL is_in_omptarget(int d) DI_IN_NEST(d, DI_TARGTEAMSDIST) || DI_IN_NEST(d, DI_TARGETENTERDATA))) return TRUE; +#endif return FALSE; } /** @@ -10327,10 +11570,26 @@ LOGICAL use_opt_atomic(int d) \brief Decide whether to use llvm atomic for reduction or not. Atomic is used only for teams reduction. */ -static LOGICAL use_atomic_for_reduction(int d) +static LOGICAL use_atomic_for_reduction(int d, REDUC *reducp, + REDUC_SYM *red_sym) // AOCC { #ifdef OMP_OFFLOAD_LLVM if(flg.omptarget && DI_IN_NEST(d, DI_TARGET) ) { + // AOCC begin + if (DI_IN_NEST(d, DI_PARDO) && teams_ast) { + for (REDUC_SYM *reduc_symp = reducp->list; reduc_symp; + reduc_symp = reduc_symp->next) { + int ty = DTY(DTYPEG(reduc_symp->shared)); + if (ty == TY_CMPLX || ty == TY_DCMPLX) { + return TRUE; + } + } + } + + if (DI_IN_NEST(d, DI_PARDO) && !teams_ast) { + return TRUE; + } + // AOCC End if(DI_IN_NEST(d, DI_PARDO) || DI_IN_NEST(d, DI_TARGTEAMSDISTPARDO)) return OPT_OMP_ATOMIC; diff --git a/tools/flang1/flang1exe/semsym.c b/tools/flang1/flang1exe/semsym.c index ef1503d286..ff115203eb 100644 --- a/tools/flang1/flang1exe/semsym.c +++ b/tools/flang1/flang1exe/semsym.c @@ -4,6 +4,16 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support character arrays as subroutine internal variables. + * Date of Modification: December 2018 + * + * Check stype of sptr(s) with same names before reusing them + * Date of Modification: October 2020 + */ /** \file \brief Fortran Semantic action routines to resolve symbol references as to @@ -122,6 +132,7 @@ sym_in_scope(int first, OVCLASS overloadclass, int *paliassym, int *plevel, bestsptr = bestsptrloop = 0; bestuse = bestuse2 = bestusecount = bestuse2count = 0; bestsl = -1; + for (sptrloop = first_hash(first); sptrloop; sptrloop = HASHLKG(sptrloop)) { int want_scope, usecount, sptrlink; SCOPESTACK *scope; @@ -255,7 +266,10 @@ sym_in_scope(int first, OVCLASS overloadclass, int *paliassym, int *plevel, !CONSTRUCTSYMG(sptrlink))) { int sl = get_scope_level(scope); if (sl > bestsl && - (scope->kind != SCOPE_BLOCK || sptr >= scope->symavl)) { + (scope->kind != SCOPE_BLOCK || sptr >= scope->symavl) + // AOCC BEGIN + || (STYPEG(sptr) == ST_TYPEDEF && sl == bestsl && STYPEG(first) == ST_PROC)) { + // AOCC END if (scope->kind == SCOPE_USE && STYPEG(sptrlink) != ST_USERGENERIC && STYPEG(sptrlink) != ST_ENTRY && !VTOFFG(sptrlink) && @@ -275,6 +289,7 @@ sym_in_scope(int first, OVCLASS overloadclass, int *paliassym, int *plevel, } else if (bestuse && scope->kind == SCOPE_USE && /* for submodule, use-association overwrites host-association*/ STYPEG(scope->sptr) == ST_MODULE && + bestuse2 && // AOCC ANCESTORG(gbl.currmod) != scope->sptr && scope->sptr != bestuse && STYPEG(sptrlink) != ST_USERGENERIC && @@ -566,6 +581,8 @@ set_internref_flag(int sptr) { INTERNREFP(sptr, 1); if (DTY(DTYPEG(sptr)) == TY_ARRAY || POINTERG(sptr) || ALLOCATTRG(sptr) || + // AOCC: changes to support character arrays as subroutine internal variables + (DTY(DTYPEG(sptr)) == TY_CHAR || DTY(DTYPEG(sptr)) == TY_NCHAR) || IS_PROC_DUMMYG(sptr) || ADJLENG(sptr)) { int descr, sdsc, midnum, devcopy; int cvlen = 0; @@ -588,7 +605,14 @@ set_internref_flag(int sptr) if (devcopy) INTERNREFP(devcopy, 1); } - if (DTY(DTYPEG(sptr)) == TY_ARRAY) { + // AOCC: changes to support character arrays as subroutine internal variables + if (DTY(DTYPEG(sptr)) == TY_CHAR || DTY(DTYPEG(sptr)) == TY_NCHAR ) { + if (ADJLENG(sptr)) { + int cvlen = CVLENG(sptr); + if (cvlen) INTERNREFP(cvlen, 1); + } + } + if (DTY(DTYPEG(sptr)) == TY_ARRAY ) { ADSC *ad; ad = AD_DPTR(DTYPEG(sptr)); if (AD_ADJARR(ad) || ALLOCATTRG(sptr) || ASSUMSHPG(sptr)) { @@ -841,6 +865,40 @@ declsym(int first, SYMTYPE stype, LOGICAL errflg) sptr = sptralias; goto return1; } + // AOCC BEGIN + if (stype == ST_PROC && st == ST_TYPEDEF) { + /* the existing symbol is typedef and creating a type bound procedure. + * in the same name is acceptable. Hide the type bound procedure symbol. + */ + oldsptr = sptr; + /* create new one for type bound procedure */ + sptr = insert_sym(first); + IGNOREP(sptr, 1); /* hide the procedure symbol */ + goto return1; + } + if (stype == ST_TYPEDEF && st == ST_PROC && VTOFFG(sptr)) { + /* the existing symbol is the type bound procedure and a new typedef + * in the same name is acceptable. Hide the type bound procedure symbol. + */ + IGNOREP(sptr, 1); /* hide the procedure symbol */ + oldsptr = sptr; + /* create new one for typedef */ + sptr = insert_sym(first); + /* make sure this is the first symbol on the hash list */ + pop_sym(sptr); + push_sym(sptr); + goto return1; + } + if (stype == ST_VAR && st == ST_PROC) { + /* the existing symbol is module procedure and declare the new symbol for + for procedure pointer refering to subroutine*/ + IGNOREP(sptr, 1); /* hide the procedure symbol */ + oldsptr = sptr; + sptr = insert_sym(first); + sptr = replace_variable(sptr, stype); + goto return1; + } + // AOCC END if (stype == ST_ENTRY && sptralias == sptr && sem.mod_sym && st == ST_PROC && ENCLFUNCG(sptr) == sem.mod_sym) { /* the existing symbol is the interface (ST_PROC) for @@ -1625,6 +1683,11 @@ decl_private_sym(int sptr) name = SYMNAME(sptr); sptr1 = getsymbol(name); sptr = refsym(sptr1, stb.ovclass[STYPEG(sptr)]); + //AOCC Begin + if((SCOPEG(sptr) != SCOPEG(sptr1)) && SCG(sptr) == SC_PRIVATE && + STYPEG(sptr) != STYPEG(sptr1)) + sptr = sptr1; + //AOCC End if (SCOPEG(sptr) == sem.scope_stack[sem.scope_level].sptr) return sptr; /* a variable can appear in more than 1 clause */ if (checking_scope && sem.scope_stack[sem.scope_level].kind == SCOPE_PAR) { diff --git a/tools/flang1/flang1exe/semutil.c b/tools/flang1/flang1exe/semutil.c index 96d124f6b1..45368ceab7 100644 --- a/tools/flang1/flang1exe/semutil.c +++ b/tools/flang1/flang1exe/semutil.c @@ -5,6 +5,40 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * + * Bug fixes. + * Date of Modification: December 2018 + * + * Changes to support AMD GPU Offloading + * Last modified : July 2020 + * + * Changes to emit proper error message when pointer is associated with + * a constant + * Date of Modification: 17th December 2019 + * + * Added code to support reshape with implied dos inside target region + * Date of Modification: 23rd January 2020 + * + * Added support for quad precision + * last modified: feb 2020 + * + * Last modified: Jun 2020 + * + * Added support to identify generic functions in derived classes + * Last modified: Dec 2020 + * + * Support to access tbp through pointers. + * Last modified: Jan 2021 + * + * Added support for openmp schedule clause + * Date of modification: Jan 2021 + */ + + /** \file \brief Utility routines used by Semantic Analyzer. */ @@ -22,6 +56,8 @@ #include "semstk.h" #include "machar.h" #include "ast.h" +#include "extern.h" + #define RTE_C #include "rte.h" #include "pd.h" @@ -59,7 +95,84 @@ static int find_pointer_variable_assign(int, int); static int inline_contig_check(int src, SPTR src_sptr, SPTR sdsc, int std); static bool is_selector(SPTR sptr); +//AOCC Begin +static void replace_acl_temp_with_lhs(SST *sst_rhstemp, SST *sst_lhs); +static bool expand_reshape(SST *sst_rhs, SST *sst_lhs); +extern void rewrite_asts_collapse_loop(struct collapse_loop); +extern int distribute_doif; +extern int distribute_pdo_ast; +extern int tgt_distribute_ast; +extern LOGICAL is_targsimd; +//AOCC End + +struct key_value +{ + int key; + int value; +}; + +struct key_value *cc_ptr_for_pmembers = NULL; + +/** \brief To map a pointer member of a structure to target, a suitable + * compiler created pointer is returned + * + * \param base_sptr symbol table pointer of the structure variable + * \param mem_sptr symbole table pointer of the member of structure + * from structure definition + * \param ast + * + * \returns ast of a pointer that can to assigned to member + * of the structure + */ +int get_cc_pointer(int base_sptr, int mem_sptr) +{ + int psym, dtype, past; + int oldndim, oldndefer; + static i = 0, N = 2; + + if(!cc_ptr_for_pmembers) { + cc_ptr_for_pmembers = (struct key_value*)malloc(sizeof(struct key_value) * N); + } + + // check for non pointer member + if(SCG(mem_sptr) != SC_BASED || + STYPEG(mem_sptr) != ST_MEMBER) + return 0; + + for(int j=0; j 0; --i) { if (DI_ID(i) == DI_ASSOC) { - for (itemp = DI_ASSOCIATIONS(doif); itemp != NULL; + for (itemp = DI_ASSOCIATIONS(i); itemp != NULL; itemp = itemp->next) { if (itemp->t.sptr == sptr) { return true; @@ -3171,6 +3434,9 @@ fix_term(SST *stktop, int sptr) break; case TY_DBLE: break; + // AOCC + case TY_QUAD: + break; case TY_INT8: break; default: @@ -3338,6 +3604,29 @@ assign(SST *newtop, SST *stktop) } } + //AOCC Begin + // if rhs is an acl, we may have to replace the temporary used with + // lhs + sem.acl_ido.body_stds = NULL; + sem.acl_ido.replace_temp = false; + ACL * aclp; + // check if it is an 1D-array assignment statement and rhs is an array constructor + if (flg.omptarget && (SST_IDG(newtop) == S_LVALUE || SST_IDG(newtop) == S_IDENT)) { + if (DTY(dtype) == TY_ARRAY && ADD_NUMDIM(dtype) == 1) { + if (SST_IDG(stktop) == S_ACONST && SST_ACLG(stktop) != 0) { + SPTR lhs_sptr; + lhs_sptr = SST_SYMG(newtop); + if(!ALLOCATTRG(lhs_sptr) && !POINTERG(lhs_sptr)) { + aclp = SST_ACLG(stktop); + // if the temporary created is considered to have deferred shape + if(AD_DEFER(AD_DPTR( aclp->dtype)) ) + sem.acl_ido.replace_temp = true; + } + } + } + } + //AOCC End + mkexpr1(stktop); cngshape(stktop, newtop); @@ -3346,6 +3635,22 @@ assign(SST *newtop, SST *stktop) check_derived_type_array_section(SST_ASTG(newtop)); + //AOCC Begin + //if it is a direct assignment of an instrinsic call: reshape, + //try expanding reshape if it is inside target region. + if(flg.omptarget) { + if(A_TYPEG(SST_ASTG(stktop)) == A_INTR) { + if(A_OPTYPEG(SST_ASTG(stktop)) == I_RESHAPE) { + if(expand_reshape(stktop, newtop)) + return 0; + } + } + } + if(sem.acl_ido.replace_temp && (sem.acl_ido.body_stds != NULL)) { + replace_acl_temp_with_lhs(stktop, newtop); + return 0; + } + //AOCC End { int lhs; int rhs; @@ -3376,6 +3681,19 @@ assign(SST *newtop, SST *stktop) ITEM *p, *t; p = NULL; + // AOCC Begin + for (t = sem.etmp_list; t != NULL; t = t->next) { + if (t->ast == rhs) { + ast_to_comment(STD_AST(sem.arrfn.alloc_std)); + if (p == NULL) + sem.etmp_list = t->next; + else + p->next = t->next; + break; + } + p = t; + } + // AOCC End for (t = sem.p_dealloc; t != NULL; t = t->next) { if (t->ast == rhs) { ast_to_comment(STD_AST(sem.arrfn.alloc_std)); @@ -3404,10 +3722,320 @@ assign(SST *newtop, SST *stktop) direct_loop_end(gbl.lineno, gbl.lineno); } } - return ast; } +//AOCC Begin +/*expands reshape based on the following conditions: + * - if reshape has only two arguments : source and shape + * - if source is an implied do + * - if shape is an implied do and specifies a 2D/3D array + * - if LHS is not of derived type + * - if number of dimensions of LHS and the result are same + *and returns + * - 1, if expanded + * - 0, if not expanded. + * example + * arr(:,:,:) = reshape(source,/(4,3,2/)) + * will be expanded to + * do i=1,4 + * do j=1,3 + * do k=1,2 + * arr(i,j,k) = source(i+(j-1)*4+(k-1)*(3*4)) + * end do + * end do + * end do + */ +static bool expand_reshape(SST *sst_rhs, SST *sst_lhs) { + + int args; + int dims; + int source_ast; + int shape_ast; + int index1, index2, index3; + int expr1, expr2, expr3, expr4, expr5, expr6; + int source_index; + ADSC * ad_source; + int dtype_source; + int ast; + int lhs_ast; + int lb_source; + DOINFO *doinfo1; + DOINFO *doinfo2; + DOINFO *doinfo3; + int cnt; + ACL *aclp; + int dest1, dest2, dest3; + int src, dest; + int doif1, doif2, doif3; + int expr; + + args = A_ARGSG(SST_ASTG(sst_rhs)); + + //check whether reshape has only two arguments + //pad and order must not be present. + if(ARGT_ARG(args, 2) || ARGT_ARG(args, 3)) + return false; + + //check whether source and shape are implied dos + if(!sem.reshape.is_source_ido || !sem.reshape.is_shape_ido_const) + return false; + + //check whether shape specifies a 2D or 3Darray + cnt = sem.reshape.num_dims; + if(cnt != 2 && cnt != 3) + return false; + + dims = sem.reshape.num_dims; + source_ast = ARGT_ARG(args,0); + shape_ast = ARGT_ARG(args,1); + + ad_source = AD_DPTR(A_DTYPEG(SST_ASTG(sst_lhs))); + dims = AD_NUMDIM(ad_source); + + //check if number of dimensions of LHS is equal to that + //of reshaped array + if(cnt != dims) { + return false; + } + + lhs_ast = SST_ASTG(sst_lhs); + if(A_TYPEG(lhs_ast) == A_SUBSCR) { + lhs_ast = A_LOPG(lhs_ast); + } + + //avoid reshaping if LHS is not of derived type. + int parent = A_PARENTG(lhs_ast); + if(parent > 0 && parent < astb.stg_avail) { + int dtype_parent = A_DTYPEG(parent); + dtype_parent = DTY(dtype_parent + 1); + if(DTY(dtype_parent) == TY_DERIVED) { + return false; + } + } + + //emit code to expand 2d-reshape. + //create variables for indices of do loops + index1 = get_temp(DT_INT); + index2 = get_temp(DT_INT); + index3 = get_temp(DT_INT); + //create variables for expressions for indexing + expr1 = get_temp(DT_INT); + expr2 = get_temp(DT_INT); + expr3 = get_temp(DT_INT); + expr4 = get_temp(DT_INT); + expr5 = get_temp(DT_INT); + expr6 = get_temp(DT_INT); + //create variable for indexing the source array + source_index = get_temp(DT_INT); + + //create new asts + mk_id(index1); + mk_id(index2); + mk_id(index3); + + //create the first do loop header + doinfo1 = get_doinfo(1); + doinfo1->init_expr = astb.i1; + dest1 = sem.reshape.const_shape_asts[0]; + doinfo1->limit_expr = dest1; + doinfo1->step_expr = astb.i1; + doinfo1->index_var = index1; + doif1 = 1; + NEED_DOIF(doif1, DI_DO); + ast = do_begin(doinfo1); + (void)add_stmt(ast); + + //create the second do loop header + doinfo2 = get_doinfo(1); + doinfo2->init_expr = astb.i1; + dest2 = sem.reshape.const_shape_asts[1]; + doif2 = 2; + doinfo2->limit_expr = dest2; + doinfo2->step_expr = astb.i1; + doinfo2->index_var = index2; + ast = do_begin(doinfo2); + (void)add_stmt(ast); + NEED_DOIF(doif2, DI_DO); + + if(cnt == 3) { + //create the third do loop header + doinfo3 = get_doinfo(1); + doinfo3->init_expr = astb.i1; + dest3 = sem.reshape.const_shape_asts[2]; + doif3 = 3; + doinfo3->limit_expr = dest3; + doinfo3->step_expr = astb.i1; + doinfo3->index_var = index3; + ast = do_begin(doinfo3); + (void)add_stmt(ast); + NEED_DOIF(doif3, DI_DO); + } + + //create the do loop body + //source_index = (index2-1)*shape(1)+index1 + //lhs(index1, index2) = source(index) + expr = mk_binop(OP_SUB, mk_id(index2), astb.i1, DT_INT); + ast = mk_assn_stmt(mk_id(expr1), expr,DT_INT); + (void)add_stmt(ast); + expr = mk_binop(OP_MUL, mk_id(expr1), dest1, DT_INT); + ast = mk_assn_stmt(mk_id(expr2), expr,DT_INT); + (void)add_stmt(ast); + expr = mk_binop(OP_ADD, mk_id(expr2), mk_id(index1), DT_INT); + //if it is a reshape to 3D array, add additional expressions + if(cnt == 3) { + ast = mk_assn_stmt(mk_id(expr3), expr,DT_INT); + (void)add_stmt(ast); + expr = mk_binop(OP_SUB, mk_id(index3), astb.i1, DT_INT); + ast = mk_assn_stmt(mk_id(expr4), expr,DT_INT); + (void)add_stmt(ast); + expr = mk_binop(OP_MUL, mk_id(expr4), dest2, DT_INT); + ast = mk_assn_stmt(mk_id(expr5), expr,DT_INT); + (void)add_stmt(ast); + expr = mk_binop(OP_MUL, mk_id(expr5), dest1, DT_INT); + ast = mk_assn_stmt(mk_id(expr6), expr,DT_INT); + (void)add_stmt(ast); + expr = mk_binop(OP_ADD, mk_id(expr6), mk_id(expr3), DT_INT); + } + ast = mk_assn_stmt(mk_id(source_index), expr,DT_INT); + (void)add_stmt(ast); + dest = add_subscript(source_ast, mk_id(source_index), DT_INT); + if(cnt == 2) { + src = add_subscript_2d(lhs_ast, mk_id(index1), mk_id(index2), DT_INT); + } else { + src = add_subscript_3d(lhs_ast, mk_id(index1), mk_id(index2), mk_id(index3), DT_INT); + } + + ast = mk_assn_stmt(src, dest, array_element_dtype(A_DTYPEG(source_ast))); + (void)add_stmt(ast); + + if(cnt == 3) { + do_end(doinfo3); + } + do_end(doinfo2); + do_end(doinfo1); + + return true; +} + +/* + * If LHS is an one dimensional array and RHS is an implied-do, + * if a temporary was allocated for storing the result of implied-do, + * replace the use of temporary array with LHS. + */ + static void replace_acl_temp_with_lhs(SST *sst_rhstemp, SST *sst_lhs){ + SPTR acl_lhs; + int rhs_ast; + int temp_array_ast; + int lhs_ast; + int lhs_array_ast; + SPTR arr_tmp; + int ast; + int dtype_lhs; + int dtype_rhs; + int lb_lhs; + int lb_tmp; + ADSC * ad_lhs; + ADSC * ad_tmp; + + // assign lowerbound of lhs to subscript used for temporary + // array in the body of the implied do. Before replacement, + // subscript points to lower bound of temporary array. + dtype_lhs = SST_DTYPEG(sst_lhs); + dtype_rhs = SST_DTYPEG(sst_rhstemp); + ad_lhs = AD_DPTR(dtype_lhs); + ad_tmp = AD_DPTR(dtype_rhs); + lb_lhs = AD_LWAST(ad_lhs, 0); + lb_tmp = AD_LWAST(ad_tmp, 0); + ast = STD_AST(sem.acl_ido.subsc_assign_std); + ast_visit(1, 1); + ast_replace(lb_tmp,lb_lhs); + ast = ast_rewrite(ast); + STD_AST(sem.acl_ido.subsc_assign_std) = ast; + ast_unvisit(); + + acl_lhs = SST_SYMG(sst_lhs); + rhs_ast = SST_ASTG(sst_rhstemp); + lhs_ast = SST_ASTG(sst_lhs); + arr_tmp = A_SPTRG(rhs_ast); + + temp_array_ast = rhs_ast; + lhs_array_ast = lhs_ast; + //the assignment can be to an array or an array section + //If to an array section, it has the type SUBSCRIPT + if(A_TYPEG(lhs_ast) == A_SUBSCR) { + lhs_array_ast = A_LOPG(lhs_ast); + } + + //stds which contain the assignment to temporary is + //read and all references to temporary are replaced with LHS + ido_body_std *temp; + temp = sem.acl_ido.body_stds; + int idostd; + while (temp != NULL) { + int std_to_replace = temp->std; + ast = STD_AST(std_to_replace); + ast_visit(1, 1); + ast_replace(temp_array_ast,lhs_array_ast); + ast = ast_rewrite(ast); + ast_unvisit(); + ast_visit(1, 1); + ast_replace(lb_tmp,lb_lhs); + ast = ast_rewrite(ast); + STD_AST(std_to_replace) = ast; + ast_unvisit(); + idostd = std_to_replace; + temp = temp ->next; + } + + int findast = temp_array_ast; + int allocstd = 0; + int std; + + //the allocation statements for temporary are removed + for (std = STD_PREV(idostd); std; std = STD_PREV(std)) { + ast = STD_AST(std); + if (A_TYPEG(ast) == A_ALLOC && A_TKNG(ast) == TK_ALLOCATE) { + if (contains_ast(ast, findast)) { + allocstd = std; + break; + } + } + } + if(allocstd) + delete_stmt(allocstd); + + //deallocation entries are removed + ITEM *p, *t; + p = NULL; + for (t = sem.p_dealloc; t != NULL; t = t->next) { + if (t->ast == temp_array_ast) { + if (p == NULL) + sem.p_dealloc = t->next; + else + p->next = t->next; + break; + } + p = t; + } + for (t = sem.p_dealloc_delete; t != NULL; t = t->next) { + if (t->ast == temp_array_ast) { + delete_stmt(t->t.ilm); + } + } + //reset replace temporar + sem.acl_ido.replace_temp = false; + ido_body_std *temp_next; + temp = sem.acl_ido.body_stds; + while (temp != NULL) { + temp_next = temp ->next; + free(temp); + temp = temp_next; + } + sem.acl_ido.body_stds = NULL; + } +//AOCC End + /* * Can the result temp by substituted with the LHS? * The LHS cannot: @@ -4142,6 +4770,14 @@ add_ptr_assign(int dest, int src, int std) gen_contig_check(dest, dest, 0, gbl.lineno, false, std); ast = mk_stmt(A_CONTINUE, 0); /* return a continue statement */ } + //AOCC Begin + if(A_TYPEG(src) == A_ID && A_TYPEG(dest) == A_ID && + STYPEG(A_SPTRG(src)) == ST_VAR && SCG(A_SPTRG(src)) == SC_BASED && + STYPEG(A_SPTRG(dest)) == ST_VAR && SCG(A_SPTRG(dest)) == SC_BASED && + TBPLNKG(A_SPTRG(src)) && A_DTYPEG(src) == A_DTYPEG(dest) && + !is_deferlenchar_ast(dest)) + gen_alloc_dealloc(TK_ALLOCATE, dest, NULL); + //AOCC End return ast; } @@ -4667,6 +5303,14 @@ chkopnds(SST *lop, SST *operator, SST *rop) cngtyp(lop, DT_CMPLX16); } + // AOCC begin + if ((TY_OF(lop) == TY_QUAD && TY_OF(rop) == TY_CMPLX) || + (TY_OF(lop) == TY_CMPLX && TY_OF(rop) == TY_QUAD)) { + cngtyp(rop, DT_CMPLX32); + cngtyp(lop, DT_CMPLX32); + } + // AOCC end + if (opc == OP_CMP) { /* Rules for relational expressions: nondecimal constants result * in a typeless comparison. Size of the larger operand is used. @@ -4802,7 +5446,7 @@ chkopnds(SST *lop, SST *operator, SST *rop) } else if (!XBIT(124, 0x40000) && SST_IDG(rop) == S_CONST) { int pw, is_int; INT conval; - INT num[2]; + INT num[4]; switch (TY_OF(rop)) { case TY_CMPLX: conval = SST_CVALG(rop); @@ -4844,6 +5488,31 @@ chkopnds(SST *lop, SST *operator, SST *rop) return; } break; + // AOCC begin + case TY_QCMPLX: + conval = SST_CVALG(rop); + if (!is_quad0(CONVAL2G(conval))) + break; + conval = CONVAL1G(conval); + goto ck_quad_pw; + case TY_QUAD: + conval = SST_CVALG(rop); + ck_quad_pw: + num[0] = CONVAL1G(conval); + num[1] = CONVAL2G(conval); + num[2] = CONVAL3G(conval); + num[3] = CONVAL4G(conval); + is_int = xqisint(num, &pw); + if ((!flg.ieee || pw == 1 || pw == 2) && is_int) { + if (TY_OF(lop) < TY_OF(rop)) + cngtyp(lop, (int)SST_DTYPEG(rop)); /* Normal rule */ + SST_CVALP(rop, pw); + SST_DTYPEP(rop, DT_INT4); + SST_ASTP(rop, mk_cval1(pw, DT_INT4)); + return; + } + break; + // AOCC end default: break; } @@ -5458,10 +6127,21 @@ mod_type(int dtype, int ty, int kind, int len, int propagated, int sptr) return DT_REAL8; if (len == 4) return (DT_REAL4); + // AOCC begin + if (len == 16) + return (DT_QUAD); + // AOCC end } error(31, 2, gbl.lineno, (sptr) ? SYMNAME(sptr) : (ty == TY_HALF ? "real2" : "real"), CNULL); break; + // AOCC begin + case TY_QCMPLX: + if (sem.ogdtype == DT_CMPLX32 && kind != 0) { + error(32, 2, gbl.lineno, (sptr) ? SYMNAME(sptr) : "quadcomplex", CNULL); + break; + } + // AOCC end case TY_DCMPLX: if (sem.ogdtype == DT_CMPLX16 && kind != 0) { error(32, 2, gbl.lineno, (sptr) ? SYMNAME(sptr) : "doublecomplex", CNULL); @@ -5481,6 +6161,10 @@ mod_type(int dtype, int ty, int kind, int len, int propagated, int sptr) return DT_QCMPLX; } } + // AOCC begin + if (len == 32) + return DT_CMPLX32; + // AOCC end if (len == 16) return DT_CMPLX16; if (len == 8) @@ -5731,6 +6415,15 @@ do_parbegin(DOINFO *doinfo) DOVARP(iv, 1); ast = mk_stmt(A_MP_PDO, 0 /* SST_ASTG(RHS(1)) BLOCKDO */); + /* AOCC begin */ + if(DI_ID(sem.doif_depth) == DI_DISTRIBUTE) { + distribute_pdo_ast = ast; + } + if(DI_ID(sem.doif_depth) == DI_TARGTEAMSDIST) { + tgt_distribute_ast = ast; + } + /* AOCC end */ + dovar = mk_id(iv); A_DOVARP(ast, dovar); A_M1P(ast, doinfo->init_expr); @@ -5752,11 +6445,13 @@ do_parbegin(DOINFO *doinfo) A_CHUNKP(ast, DI_CHUNK(sem.doif_depth)); A_DISTCHUNKP(ast, DI_DISTCHUNK(sem.doif_depth)); /* currently unused */ A_SCHED_TYPEP(ast, DI_SCHED_TYPE(sem.doif_depth)); + A_SCHED_MODIFIERP(ast, DI_SCHED_MODIFIER(sem.doif_depth)); // AOCC A_ORDEREDP(ast, DI_IS_ORDERED(sem.doif_depth)); } else { A_CHUNKP(ast, 0); A_DISTCHUNKP(ast, 0); A_SCHED_TYPEP(ast, 0); + A_SCHED_MODIFIERP(ast, 0); A_ORDEREDP(ast, 0); } if (doinfo->lastval_var) { @@ -5944,6 +6639,11 @@ collapse_begin(DOINFO *doinfo) * Same with the init expr. */ doinfo->init_expr = collapse_expr(doinfo->init_expr, dtype, "Xa"); + if (A_TYPEG(doinfo->init_expr+1) == A_ASN && + A_TYPEG(A_DESTG(doinfo->init_expr+1)) == A_ID && + A_DESTG(doinfo->init_expr+1) == doinfo->init_expr) + collapse_loop.instruction_range_start = A_STDG(doinfo->init_expr + 1); + /* * lp_cnt <-- (e2 - e1 + e3) / e3 */ @@ -6051,6 +6751,7 @@ collapse_add(DOINFO *doinfo) ast = mk_binop(OP_MUL, dest_ast, ast, coll_st.dtype); ast = mk_assn_stmt(dest_ast, ast, coll_st.dtype); (void)add_stmt(ast); + collapse_loop.instruction_range_end = A_STDG(ast); if (doinfo->collapse == 1) { DOINFO *dinf; @@ -6083,6 +6784,14 @@ collapse_add(DOINFO *doinfo) else ast = do_parbegin(dinf); std = add_stmt(ast); + collapse_loop.parallel_loop = A_STDG(ast); + // Apply the collapse loop transformation + rewrite_asts_collapse_loop(collapse_loop); + collapse_loop.distributed_loop = 0; + collapse_loop.instruction_range_start = 0; + collapse_loop.instruction_range_end = 0; + collapse_loop.parallel_loop = 0; + sem.doif_depth = sv; if (DI_ID(sv) == DI_DOCONCURRENT) STD_BLKSYM(std) = DI_CONC_BLOCK_SYM(sv); @@ -6328,6 +7037,9 @@ do_end(DOINFO *doinfo) sem.close_pdo = TRUE; par_pop_scope(); ast = mk_stmt(A_MP_ENDDISTRIBUTE, 0); + distribute_doif = 0; /* AOCC */ + distribute_pdo_ast = 0; /* AOCC */ + tgt_distribute_ast = 0; /* AOCC */ A_LOPP(DI_BDISTRIBUTE(par_doif), ast); A_LOPP(ast, DI_BDISTRIBUTE(par_doif)); (void)add_stmt(ast); @@ -6351,6 +7063,8 @@ do_end(DOINFO *doinfo) par_pop_scope(); par_pop_scope(); ast = mk_stmt(A_MP_ENDDISTRIBUTE, 0); + distribute_doif = 0; /* AOCC */ + distribute_pdo_ast = 0; /* AOCC */ A_LOPP(DI_BDISTRIBUTE(par_doif), ast); A_LOPP(ast, DI_BDISTRIBUTE(par_doif)); (void)add_stmt(ast); @@ -6417,6 +7131,11 @@ do_end(DOINFO *doinfo) switch (DI_ID(orig_doif)) { case DI_DO: (void)add_stmt(mk_stmt(A_ENDDO, 0)); + if(is_targsimd && DI_ID(par_doif) == DI_TARGET){ + sem.close_pdo = TRUE; + sem.collapse = 0; + is_targsimd = FALSE; + } break; case DI_DOCONCURRENT: std = add_stmt(mk_stmt(A_ENDDO, 0)); @@ -6491,9 +7210,23 @@ mkmember(int structd, int base, int nmx) if (flg.xref) xrefput(sptr, 'r'); member = mk_id(sptr); + A_ALIASP(base,0); ast = mk_member(base, mk_id(sptr), dtype); return ast; - } else if (PARENTG(sptr)) { /* type extension */ + //AOCC Begin + } else if ((STYPEG(BINDG(sptr)) == ST_USERGENERIC) && + (STYPEG(A_ALIASG(base)) == ST_USERGENERIC || + STYPEG(A_ALIASG(base)) == ST_PROC || + STYPEG(A_ALIASG(base)) == ST_ENTRY)){ + char* var = SYMNAME(A_ALIASG(base)); + if(!strncmp(SYMNAME(sptr),var,strlen(var))){ + A_ALIASP(base,0); + int ast = mk_member(base, mk_id(BINDG(sptr)), dtype); + return ast; + } + } + //AOCC End + else if (PARENTG(sptr)) { /* type extension */ int ast = mkmember(DTYPEG(sptr), base, nmx); if (ast) return ast; @@ -6673,6 +7406,22 @@ _xtok(INT conval1, BIGINT64 count, int dtype) conval = getcon(dresult, DT_REAL8); break; + // AOCC begin + case TY_QUAD: + num1[0] = CONVAL1G(conval1); + num1[1] = CONVAL2G(conval1); + num1[2] = CONVAL3G(conval1); + num1[3] = CONVAL4G(conval1); + qresult[0] = CONVAL1G(stb.quad1); + qresult[1] = CONVAL2G(stb.quad1); + qresult[2] = CONVAL3G(stb.quad1); + qresult[3] = CONVAL4G(stb.quad1); + while (count--) + xqmul(num1, qresult, qresult); + conval = getcon(qresult, DT_QUAD); + break; + // AOCC end + case TY_CMPLX: real1 = CONVAL1G(conval1); imag1 = CONVAL2G(conval1); @@ -6718,6 +7467,47 @@ _xtok(INT conval1, BIGINT64 count, int dtype) conval = getcon(num1, DT_CMPLX16); break; + // AOCC begin + case TY_QCMPLX: + qreal1[0] = CONVAL1G(CONVAL1G(conval1)); + qreal1[1] = CONVAL2G(CONVAL1G(conval1)); + qreal1[2] = CONVAL3G(CONVAL1G(conval1)); + qreal1[3] = CONVAL4G(CONVAL1G(conval1)); + + qimag1[0] = CONVAL1G(CONVAL2G(conval1)); + qimag1[1] = CONVAL2G(CONVAL2G(conval1)); + qimag1[2] = CONVAL3G(CONVAL2G(conval1)); + qimag1[3] = CONVAL4G(CONVAL2G(conval1)); + + qrealrs[0] = CONVAL1G(CONVAL1G(one)); + qrealrs[1] = CONVAL2G(CONVAL1G(one)); + qrealrs[2] = CONVAL3G(CONVAL1G(one)); + qrealrs[3] = CONVAL4G(CONVAL1G(one)); + + qimagrs[0] = CONVAL1G(CONVAL2G(one)); + qimagrs[1] = CONVAL2G(CONVAL2G(one)); + qimagrs[2] = CONVAL3G(CONVAL2G(one)); + qimagrs[3] = CONVAL4G(CONVAL2G(one)); + while (count--) { + /* (a + bi) * (c + di) ==> (ac-bd) + (ad+cb)i */ + qrealpv[0] = qrealrs[0]; + qrealpv[1] = qrealrs[1]; + qrealpv[2] = qrealrs[2]; + qrealpv[3] = qrealrs[3]; + + xqmul(qreal1, qrealrs, qtemp1); + xqmul(qimag1, qimagrs, qtemp); + xqsub(qtemp1, qtemp, qrealrs); + xqmul(qreal1, qimagrs, qtemp1); + xqmul(qrealpv, qimag1, qtemp); + xqadd(qtemp1, qtemp, qimagrs); + } + num1[0] = getcon(drealrs, DT_QUAD); + num1[1] = getcon(dimagrs, DT_QUAD); + conval = getcon(num1, DT_CMPLX32); + break; + // AOCC end + case TY_BLOG: case TY_SLOG: case TY_LOG: @@ -6743,4 +7533,3 @@ error83(int ty) else errsev(83); } - diff --git a/tools/flang1/flang1exe/semutil2.c b/tools/flang1/flang1exe/semutil2.c index 454509d330..226f4c88cd 100644 --- a/tools/flang1/flang1exe/semutil2.c +++ b/tools/flang1/flang1exe/semutil2.c @@ -5,6 +5,37 @@ * */ +/* +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Support for transpose intrinsic during initialization + * Date of Modification: 1st March 2019 + * + * Changes to support AMD GPU Offloading + * Added code to avoid allocations for implied do inside target region + * Date of Modification: 24th October 2019 + * Date of Modification: 5th November 2019 + * + * Added code to support reshape with implied dos inside target region + * Date of Modification: 23rd January 2020 + * + * Added support for quad precision + * Last modified: Feb 2020 + * + * Support for nearest intrinsic + * Last modified: 01 March 2020 + * + * Added code to support SHIFTA intrinsic + * Last modified : April 2020 + * + * Last modified: Jun 2020 + * + * Added code support for COTAN intrinsic + * Last modified : Oct 2020 + */ + /** \file \brief Utility routines used by Fortran Semantic Analyzer. */ @@ -79,6 +110,8 @@ static int init_intrin_type_desc(int ast, SPTR sptr, int std); * semant-created temporaries which are re-used across statements. */ +extern int nearest_status; + static int temps_ctr[3]; #define TEMPS_CTR(n) (temps_ctr[n]++) #define TEMPS_STK(n) ((sem.doif_depth << 10) + temps_ctr[n]++) @@ -796,6 +829,7 @@ add_etmp(int sptr) x->next = sem.etmp_list; sem.etmp_list = x; x->t.sptr = sptr; + if (sptr) x->ast = mk_id(sptr); } void @@ -888,6 +922,9 @@ select_kind(DTYPE dtype, int ty, INT kind_val) if (!XBIT(57, 0x2)) out_dtype = DT_INT8; break; + case 16: + out_dtype = DT_QUAD; + break; case 4: out_dtype = DT_INT4; break; @@ -901,14 +938,14 @@ select_kind(DTYPE dtype, int ty, INT kind_val) break; case TY_CMPLX: case TY_DCMPLX: + case TY_QCMPLX: switch (kind_val) { case 16: - if (!XBIT(57, 0x8)) - out_dtype = DT_QCMPLX; - if (XBIT(57, 0x10)) { + out_dtype = DT_CMPLX32; + /*if (XBIT(57, 0x10)) { error(437, 2, gbl.lineno, "COMPLEX(16)", "COMPLEX(8)"); out_dtype = DT_CMPLX16; - } + }*/ break; case 8: out_dtype = DT_CMPLX16; @@ -920,14 +957,10 @@ select_kind(DTYPE dtype, int ty, INT kind_val) break; case TY_REAL: case TY_DBLE: + case TY_QUAD: switch (kind_val) { case 16: - if (!XBIT(57, 0x4)) - out_dtype = DT_QUAD; - if (XBIT(57, 0x10)) { - error(437, 2, gbl.lineno, "REAL(16)", "REAL(8)"); - out_dtype = DT_REAL8; - } + out_dtype = DT_QUAD; // AOCC break; case 8: out_dtype = DT_REAL8; @@ -1399,7 +1432,7 @@ size_of_array(DTYPE dtype) if (DTY(dtype + 2) != 0) { ad = AD_DPTR(dtype); numdim = AD_NUMDIM(ad); - if (numdim < 1 || numdim > 7) { + if (!is_legal_numdim(numdim)) { /* AOCC */ interr("extent_of: bad numdim", 0, 1); numdim = 0; } @@ -2205,7 +2238,7 @@ init_constructf90() { int i; - for (i = 0; i < 7; i++) { + for (i = 0; i < MAXDIMS; i++) { // AOCC acs.element_cnt[i] = 0; /* # of individual constructor items */ acs.indx[i] = astb.bnd.one; /* subscript of first element */ acs.indx_tmpid[i] = 0; /* no subscripting temporary yet */ @@ -2215,7 +2248,10 @@ init_constructf90() sub_i = 7; } -static int +//AOCC Begin +//static int +int +//AOCC End add_subscript(int base_id, int indexast, DTYPE dtype) { int dest; @@ -2226,6 +2262,34 @@ add_subscript(int base_id, int indexast, DTYPE dtype) return dest; } +//AOCC Begin +int +add_subscript_2d(int base_id, int indexast1, int indexast2, DTYPE dtype) +{ + int dest; + + acs.subs[sub_i++] = indexast1; + acs.subs[sub_i] = indexast2; + + /* generate subscripts as they are seen */ + dest = mk_subscr(base_id, &acs.subs[sub_i-1], 2, dtype); + return dest; +} +int +add_subscript_3d(int base_id, int indexast1, int indexast2, int indexast3, DTYPE dtype) +{ + int dest; + + acs.subs[sub_i++] = indexast1; + acs.subs[sub_i++] = indexast2; + acs.subs[sub_i] = indexast3; + + /* generate subscripts as they are seen */ + dest = mk_subscr(base_id, &acs.subs[sub_i-2], 3, dtype); + return dest; +} +//AOCC End + static int apply_shape_subscripts(int base_id, int shp, DTYPE dtype) { @@ -2282,7 +2346,9 @@ get_subscripting_tmp(int indexast) tmpids[sub_i] = mk_id(get_temp(astb.bnd.dtype)); if (indexast != tmpids[sub_i]) { ast = mk_assn_stmt(tmpids[sub_i], indexast, astb.bnd.dtype); - add_stmt(ast); + //AOCC Begin + sem.acl_ido.subsc_assign_std = add_stmt(ast); + //AOCC End } return (tmpids[sub_i]); } @@ -3014,7 +3080,29 @@ _constructf90(int base_id, int in_indexast, bool in_array, ACL *aclp) ast = mk_assn_stmt(dest, src, dtype); } ast = ast_rewrite_indices(ast); - (void)add_stmt(ast); + //AOCC Begin + int ast_std = add_stmt(ast); + if(sem.acl_ido.replace_temp && (sem.acl_ido.body_stds == NULL)) { + ido_body_std * newstd; + newstd = (ido_body_std *)malloc(sizeof(ido_body_std)); + newstd->std = ast_std; + newstd->next = NULL; + sem.acl_ido.body_stds = newstd; + } else { + if(sem.acl_ido.replace_temp && (sem.acl_ido.body_stds != NULL)) { + //if it is a nested ido, insert std to the tail + ido_body_std *temp = sem.acl_ido.body_stds; + while(temp->next != NULL) { + temp = temp->next; + } + ido_body_std * newstd; + newstd = (ido_body_std *)malloc(sizeof(ido_body_std)); + newstd->std = ast_std; + newstd->next = NULL; + temp->next = newstd; + } + } + //AOCC End if (in_array) { indexast = mk_binop(OP_ADD, indexast, astb.bnd.one, astb.bnd.dtype); incr_element_cnt(); @@ -3279,6 +3367,27 @@ mk_ulbound_intrin(AC_INTRINSIC intrin, int ast) return expracl; } +// AOCC begin +static ACL * +mk_transpose_intrin(int ast) +{ + ACL *expracl = mk_init_intrinsic(AC_I_transpose); + expracl->dtype = A_DTYPEG(ast); + + AEXPR *aexpr; + aexpr = expracl->u1.expr; + + int argt = A_ARGSG(ast); + int srcast = ARGT_ARG(argt, 0); + aexpr->rop = construct_acl_from_ast(srcast, A_DTYPEG(srcast), 0); + if (!aexpr->rop) { + return 0; + } + + return expracl; +} +// AOCC end + static ACL * mk_reshape_intrin(int ast) { @@ -3588,7 +3697,7 @@ construct_arg_list(int ast) ACL *argroot = NULL; ACL **curarg = &argroot; int i; - + for (i = 0; i < A_ARGCNTG(ast); i++) { int argast = ARGT_ARG(argt, i); /* argast is 0 for optional args */ @@ -3621,33 +3730,65 @@ static ACL * mk_elem_init_intrinsic(AC_INTRINSIC init_intr, int ast, DTYPE dtype, int parent_acltype) { - ACL *arg1acl; - ACL *a; - DTYPE arg1dtype; - DTYPE dtypebase = DDTG(dtype); - ACL *expracl = mk_init_intrinsic(init_intr); - ACL *arglist = construct_arg_list(ast); - - if (!arglist) { - sem.dinit_error = TRUE; - return 0; + // AOCC begin + if (nearest_status == 1) { + ACL *expracl = mk_init_intrinsic(init_intr); + int argt = A_ARGSG(ast); + ACL *argroot = NULL; + ACL **curarg = &argroot; + int argast = ARGT_ARG(argt, 0); + if (argast) { + *curarg = construct_acl_from_ast(argast, A_DTYPEG(argast), 0); + if (!*curarg) { + return 0; + } + curarg = &(*curarg)->next; + } + argast = ARGT_ARG(argt, 1); + if (argast) { + *curarg = construct_acl_from_ast(argast-2, A_DTYPEG(argast), 0); + if (!*curarg) { + return 0; + } + curarg = &(*curarg)->next; + } + if (sem.dinit_error) { + return 0; + } + expracl->dtype = dtype; + expracl->u1.expr->rop = argroot; + return expracl; } + else { + ACL *arg1acl; + ACL *a; + DTYPE arg1dtype; + DTYPE dtypebase = DDTG(dtype); + ACL *expracl = mk_init_intrinsic(init_intr); + ACL *arglist = construct_arg_list(ast); + + if (!arglist) { + sem.dinit_error = TRUE; + return 0; + } + arg1acl = arglist; + arg1dtype = arg1acl->dtype; + expracl->dtype = dtypebase; + expracl->u1.expr->rop = arglist; - arg1acl = arglist; - arg1dtype = arg1acl->dtype; - expracl->dtype = dtypebase; - expracl->u1.expr->rop = arglist; - - if (DTY(dtype) == TY_ARRAY) { - if (DTY(arg1dtype) != TY_ARRAY && parent_acltype != AC_ACONST) - expracl->repeatc = ADD_NUMELM(dtype); - a = GET_ACL(15); - a->id = AC_ACONST; - a->dtype = dtype; - a->subc = expracl; - expracl = a; + if (DTY(dtype) == TY_ARRAY) { + if (DTY(arg1dtype) != TY_ARRAY && parent_acltype != AC_ACONST) + expracl->repeatc = ADD_NUMELM(dtype); + a = GET_ACL(15); + a->id = AC_ACONST; + a->dtype = dtype; + a->subc = expracl; + expracl = a; + } + return expracl; } - return expracl; + nearest_status = 0; + // AOCC end } static AC_INTRINSIC @@ -3686,6 +3827,10 @@ map_I_to_AC(int intrin) return AC_I_lshift; case I_RSHIFT: return AC_I_rshift; + /* AOCC begin */ + case I_SHIFTA: + return AC_I_shifta; + /* AOCC end */ case I_IMIN0: case I_MIN0: case I_AMIN1: @@ -3747,6 +3892,11 @@ map_I_to_AC(int intrin) case I_COS: case I_DCOS: return AC_I_cos; + /* AOCC begin */ + case I_COTAN: + case I_DCOTAN: + return AC_I_cotan; + /* AOCC end */ case I_TAN: case I_DTAN: return AC_I_tan; @@ -3780,6 +3930,8 @@ map_I_to_AC(int intrin) return AC_I_minloc; case I_MINVAL: return AC_I_minval; + case I_NEAREST: + return AC_I_nearest; //AOCC default: return AC_I_NONE; } @@ -3817,6 +3969,12 @@ map_PD_to_AC(int pdnum) return AC_I_ichar; case PD_int: return AC_I_int; + // AOCC begin + case PD_anint: + return AC_I_anint; + case PD_aint: + return AC_I_aint; + // AOCC end case PD_nint: return AC_I_nint; case PD_char: @@ -3845,6 +4003,20 @@ map_PD_to_AC(int pdnum) return AC_I_ceiling; case PD_transfer: return AC_I_transfer; + // AOCC begin + case PD_transpose: + return AC_I_transpose; + case PD_merge_bits: + return AC_I_merge_bits; + case PD_shiftl: + return AC_I_lshift; + case PD_shiftr: + return AC_I_rshift; + case PD_dshiftl: + return AC_I_dshiftl; + case PD_dshiftr: + return AC_I_dshiftr; + // AOCC end case PD_scale: return AC_I_scale; case PD_maxloc: @@ -3855,6 +4027,8 @@ map_PD_to_AC(int pdnum) return AC_I_minloc; case PD_minval: return AC_I_minval; + case PD_nearest: + return AC_I_nearest; //AOCC default: return AC_I_NONE; } @@ -3900,6 +4074,13 @@ construct_intrinsic_acl(int ast, DTYPE dtype, int parent_acltype) case AC_I_ieor: case AC_I_merge: case AC_I_scale: + /* AOCC begin */ + case AC_I_merge_bits: + case AC_I_dshiftl: + case AC_I_dshiftr: + case AC_I_aint: + case AC_I_anint: + /* AOCC end */ return mk_elem_init_intrinsic(intrin, ast, dtype, parent_acltype); case AC_I_maxloc: case AC_I_maxval: @@ -3918,6 +4099,16 @@ construct_intrinsic_acl(int ast, DTYPE dtype, int parent_acltype) int new_ast = ast_intr(I_ISHFT, A_DTYPEG(ast), 2, val, new_shift); return mk_elem_init_intrinsic(AC_I_ishft, new_ast, dtype, parent_acltype); } + /* AOCC begin */ + case AC_I_shifta: { + int argt = A_ARGSG(ast); + int val = ARGT_ARG(argt, 0); + int shift = ARGT_ARG(argt, 1); + int new_shift = mk_unop(OP_SUB, shift, A_DTYPEG(shift)); + int new_ast = ast_intr(I_ISHFT, A_DTYPEG(ast), 2, val, new_shift); + return mk_elem_init_intrinsic(AC_I_ishft, new_ast, dtype, parent_acltype); + } + /* AOCC end */ case AC_I_len: case AC_I_lbound: case AC_I_ubound: @@ -3929,8 +4120,16 @@ construct_intrinsic_acl(int ast, DTYPE dtype, int parent_acltype) case AC_I_selected_real_kind: case AC_I_selected_char_kind: return mk_nonelem_init_intrinsic(intrin, ast, A_DTYPEG(ast)); + //AOCC Begin + case AC_I_nearest: + return mk_elem_init_intrinsic(AC_I_nearest, ast, dtype, parent_acltype); + //AOCC End case AC_I_size: return mk_size_intrin(ast); + // AOCC begin + case AC_I_transpose: + return mk_transpose_intrin(ast); + // AOCC end case AC_I_reshape: return mk_reshape_intrin(ast); case AC_I_shape: @@ -3979,6 +4178,11 @@ get_ast_op(int op) case AC_LOR: ast_op = OP_LOR; break; + // AOCC begin + case AC_LXOR: + ast_op = OP_LXOR; + break; + // AOCC end case AC_LAND: ast_op = OP_LAND; break; @@ -4047,6 +4251,11 @@ get_ac_op(int ast) case OP_LOR: ac_op = AC_LOR; break; + // AOCC begin + case OP_LXOR: + ac_op = AC_LXOR; + break; + // AOCC end case OP_LAND: ac_op = AC_LAND; break; @@ -4078,6 +4287,7 @@ get_ac_op(int ast) break; case DT_REAL4: case DT_REAL8: + case DT_QUAD: //AOCC ac_op = AC_EXPX; break; default: @@ -6491,7 +6701,7 @@ dinit_getval1(int ast, DTYPE dtype) if (dtype == 0) dtype = A_DTYPEG(ast); aval = const_eval(ast); - ast = mk_cval1(aval, A_DTYPEG(ast)); + ast = mk_cval(aval, A_DTYPEG(ast)); // AOCC } if (dtype == 0) return ast; @@ -6767,7 +6977,7 @@ build_array_list(ASTLIST *list, int ast, DTYPE dtype, int sptr) break; asd = A_ASDG(ast); ndim = ASD_NDIM(asd); - assert(ndim <= 7, "build_array_list, >7 dimensions", ndim, 3); + assert(ndim <= get_legal_maxdim(), "build_array_list, > allowed dimensions", ndim, 3); /* AOCC */ assert(A_SHAPEG(A_LOPG(ast)), "build_array_list, shapeless array", 0, 3); for (i = 0; i < ndim; ++i) { int ss; @@ -8060,6 +8270,11 @@ add_to_list(ACL *val, ACL **root) { ACL *tail; if (*root) { + // AOCC Begin + // check if val is already in the list + for (tail = *root; tail; tail = tail->next) + if (tail == val ) return; + // AOCC End for (tail = *root; tail->next; tail = tail->next) ; tail->next = val; @@ -8268,6 +8483,150 @@ INTINTRIN2("iand", eval_iand, &) INTINTRIN2("ior", eval_ior, |) INTINTRIN2("ieor", eval_ieor, ^) +/* AOCC begin */ +static ACL * +eval_merge_bits(ACL *arg, DTYPE dtype) { + ACL *arg_i = eval_init_expr_item(arg); + ACL *arg_j = eval_init_expr_item(arg->next); + ACL *arg_mask = eval_init_expr_item(arg->next->next); + + ACL *arg_notmask = clone_init_const(arg_mask, true); + + /* 32-bit values get stored in the conval field, while larger values need to + * be looked up in the symbol table. + */ + if (size_of(arg_mask->dtype) > 4) { + INT ival[2]; + ISZ_T mask_val, notmask_val; + + ival[0] = CONVAL1G(arg_mask->conval); + ival[1] = CONVAL2G(arg_mask->conval); + + INT64_2_ISZ(ival, mask_val); + notmask_val = ~mask_val; + ISZ_2_INT64(notmask_val, ival); /* Now ival will represent notmask_val */ + + arg_notmask->conval = getcon(ival, arg_mask->dtype); + } else { + arg_notmask->conval = ~(arg_mask->conval); + } + + ACL *arg_i_and_mask = clone_init_const(arg_i, true); + arg_i_and_mask->next = arg_mask; + + ACL *arg_j_and_notmask = clone_init_const(arg_j, true); + arg_j_and_notmask->next = arg_notmask; + + ACL *iand_i = eval_iand(arg_i_and_mask, dtype); + ACL *iand_j = eval_iand(arg_j_and_notmask, dtype); + + iand_i->next = iand_j; + + return eval_ior(iand_i, dtype); +} + +static ACL * +eval_dshift(ACL *arg, DTYPE dtype, bool is_left) +{ + ACL *arg_i = eval_init_expr_item(arg); + ACL *arg_j = eval_init_expr_item(arg->next); + ACL *arg_shift = eval_init_expr_item(arg->next->next); + + short bit_size_i = bits_in(arg_i->dtype); + short bit_size_j = bits_in(arg_j->dtype); + + if (is_left) { + /* Evaluating IOR(SHIFTL(I, SHIFT), SHIFTR(J, BIT_SIZE(J) - SHIFT)). */ + + /* evaluating lhs of IOR */ + ACL *arg_i_and_shift = clone_init_const(arg_i, true); + arg_i_and_shift->next = arg_shift; + ACL * arg_shiftl_i = eval_ishft(arg_i_and_shift, arg_i->dtype); + + /* evaluating rhs of IOR */ + ACL *arg_j_and_bs_j = clone_init_const(arg_j, true); + arg_j_and_bs_j->next = clone_init_const(arg_shift, true); + /* The negation below is to force ishft to do a right shift */ + arg_j_and_bs_j->next->conval = -(bit_size_j - arg_shift->conval); + ACL *arg_shiftr_bs_j = eval_ishft(arg_j_and_bs_j, arg_j->dtype); + + /* Setting up args for the final ior */ + arg_shiftl_i->next = arg_shiftr_bs_j; + return eval_ior(arg_shiftl_i, arg_i->dtype); + + } else { + /* Evaluating IOR(SHIFTL(I, BIT_SIZE(I) - SHIFT), SHIFTR(J, SHIFT)) */ + + /* evaluating lhs of IOR */ + ACL *arg_i_and_bs_i = clone_init_const(arg_i, true); + arg_i_and_bs_i->next = clone_init_const(arg_shift, true); + arg_i_and_bs_i->next->conval = bit_size_i - arg_shift->conval; + ACL *arg_shiftl_bs_i = eval_ishft(arg_i_and_bs_i, arg_i->dtype); + + /* evaluating rhs of IOR */ + ACL *arg_j_and_shift = clone_init_const(arg_j, true); + arg_j_and_shift->next = clone_init_const(arg_shift, true); + arg_j_and_shift->next->conval = -(arg_j_and_shift->next->conval); + ACL * arg_shiftr_j = eval_ishft(arg_j_and_shift, arg_j->dtype); + + /* Setting up args for the final ior */ + arg_shiftl_bs_i->next = arg_shiftr_j; + return eval_ior(arg_shiftl_bs_i, arg_i->dtype); + } +} +/* AOCC end */ +//AOCC Begin +static ACL * +eval_nearest(ACL *arg, DTYPE dtype) +{ + ACL *rslt = arg; + ACL *arg1, *arg2; + INT conval; + arg1 = eval_init_expr_item(arg); + arg2 = eval_init_expr_item(arg->next); + rslt = clone_init_const(arg1, TRUE); + arg1 = (rslt->id == AC_ACONST ? rslt->subc : rslt); + arg2 = (arg2->id == AC_ACONST ? arg2->subc : arg2); + + for (; arg1; arg1 = arg1->next, arg2 = arg2->next) { + INT num1[4], num2[4]; + INT res[4]; + INT con1, con2; + con1 = arg1->conval; + con2 = arg2->conval; + switch (DTY(arg1->dtype)) { + case TY_REAL: + xfnearest(con1, con2, &res[0]); + conval = res[0]; + break; + case TY_DBLE: + num1[0] = CONVAL1G(con1); + num1[1] = CONVAL2G(con1); + num2[0] = CONVAL1G(con2); + num2[1] = CONVAL2G(con2); + xdnearest(num1, num2, res); + conval = getcon(res, DT_DBLE); + break; + case TY_CMPLX: + case TY_DCMPLX: + error(155, 3, gbl.lineno, + "Intrinsic not supported in initialization:", "nearest"); + break; + case TY_HALF: + /* fallthrough to error */ + default: + error(155, 3, gbl.lineno, + "Intrinsic not supported in initialization:", "nearest"); + break; + } + conval = cngcon(conval, arg1->dtype, dtype); + arg1->conval = conval; + arg1->dtype = dtype; + } + return rslt; +} +//AOCC End + static ACL * eval_ichar(ACL *arg, DTYPE dtype) { @@ -8415,6 +8774,14 @@ eval_abs(ACL *arg, DTYPE dtype) xdabsv(num1, res); con1 = getcon(res, dtype); break; + // AOCC begin + case TY_QUAD: + con1 = wrkarg->conval; + GET_QUAD(num1, con1); + xqabsv(num1, res); + con1 = getcon(res, dtype); + break; + // AOCC end case TY_CMPLX: con1 = wrkarg->conval; f1 = CONVAL1G(con1); @@ -8430,6 +8797,12 @@ eval_abs(ACL *arg, DTYPE dtype) con1 = wrkarg->conval; rsltdtype = DT_REAL; break; + // AOCC begin + case TY_QCMPLX: + con1 = wrkarg->conval; + rsltdtype = DT_REAL; + break; + // AOCC end default: con1 = wrkarg->conval; break; @@ -8552,6 +8925,7 @@ cmp_acl(DTYPE dtype, ACL *x, ACL *y, bool want_max, bool back) break; case TY_INT8: case TY_DBLE: + case TY_QUAD: // AOCC cmp = const_fold(OP_CMP, x->conval, y->conval, dtype); break; default: @@ -9032,6 +9406,13 @@ eval_floor(ACL *arg, DTYPE dtype) adjust = 1; } break; + case TY_QUAD: + conval = cngcon(con1, DT_QUAD, dtype); + if (const_fold(OP_CMP, con1, stb.quad0, DT_QUAD) < 0) { + con1 = cngcon(conval, dtype, DT_QUAD); + if (const_fold(OP_CMP, con1, wrkarg->conval, DT_QUAD) != 0) + adjust = 1; + } } if (adjust) { if (DT_ISWORD(dtype)) @@ -9185,7 +9566,14 @@ transfer_store(INT conval, DTYPE dtype, char *destination) dest[0] = CONVAL2G(conval); dest[1] = CONVAL1G(conval); break; - + // AOCC begin + case TY_QUAD: + dest[0] = CONVAL4G(conval); + dest[1] = CONVAL3G(conval); + dest[2] = CONVAL2G(conval); + dest[3] = CONVAL1G(conval); + break; + // AOCC end case TY_CMPLX: dest[0] = CONVAL1G(conval); dest[1] = CONVAL2G(conval); @@ -9200,6 +9588,21 @@ transfer_store(INT conval, DTYPE dtype, char *destination) dest[3] = CONVAL1G(imag); break; + // AOCC begin + case TY_QCMPLX: + real = CONVAL1G(conval); + imag = CONVAL2G(conval); + dest[0] = CONVAL4G(real); + dest[1] = CONVAL3G(real); + dest[2] = CONVAL2G(real); + dest[3] = CONVAL1G(real); + dest[0] = CONVAL4G(imag); + dest[1] = CONVAL3G(imag); + dest[2] = CONVAL2G(imag); + dest[3] = CONVAL1G(imag); + break; + // AOCC end + case TY_CHAR: memcpy(dest, stb.n_base + CONVAL1G(conval), size_of(dtype)); break; @@ -9214,7 +9617,7 @@ static INT transfer_load(DTYPE dtype, char *source) { int *src = (int *)source; - INT num[2], real[2], imag[2]; + INT num[4], real[4], imag[4]; if (DT_ISWORD(dtype)) return src[0]; @@ -9242,6 +9645,27 @@ transfer_load(DTYPE dtype, char *source) num[1] = getcon(imag, DT_REAL8); break; + // AOCC begin + case TY_QUAD: + num[3] = src[0]; + num[2] = src[1]; + num[1] = src[2]; + num[0] = src[3]; + break; + case TY_QCMPLX: + real[3] = src[0]; + real[2] = src[1]; + real[1] = src[2]; + real[0] = src[3]; + imag[3] = src[0]; + imag[2] = src[1]; + imag[1] = src[2]; + imag[0] = src[3]; + num[0] = getcon(real, DT_QUAD); + num[1] = getcon(imag, DT_QUAD); + break; + // AOCC end + case TY_CHAR: return getstring(source, size_of(dtype)); @@ -9378,10 +9802,13 @@ eval_selected_real_kind(ACL *arg) { ACL *rslt; ACL *wrkarg; - int r; + int r, pre, range; INT con; r = 4; + // AOCC + pre = 0; + range = 0; wrkarg = arg = eval_init_expr(arg); con = get_int_from_init_conval(wrkarg); @@ -9389,25 +9816,52 @@ eval_selected_real_kind(ACL *arg) r = 4; else if (con <= 15) r = 8; - else + else if (con <= 33 && (!XBIT(57, 0x4))) + r = 16; + else { r = -1; + pre = -1; + } if (arg->next) { wrkarg = arg->next; con = get_int_from_init_conval(wrkarg); if (con <= 37) { - if (r > 0 && r < 4) + if (r > 0 && r <= 4) r = 4; } else if (con <= 307) { - if (r > 0 && r < 8) + if (r > 0 && r <= 8) r = 8; + } else if ((con <= 4931) && (!XBIT(57, 0x4))) { + if (r > 0 && r <= 16) + r = 16; } else { if (r > 0) r = 0; - r -= 2; + range = -2; + r = -2; } } + // AOCC begin + if (arg->next->next) { + wrkarg = arg->next->next; + con = get_int_from_init_conval(wrkarg); + if (con == 2 || con == 0) { + if (r > 0 && r <= 4) + r = 4; + else if (r > 0 && r <= 8) + r = 8; + else if (r > 0 && r <= 16) + r = 16; + else if (pre < 0 && range < 0) + r = -3; + } + else if (con != 2) + r = -5; + } + // AOCC end + rslt = GET_ACL(15); rslt->id = AC_CONVAL; rslt->dtype = stb.user.dt_int; @@ -9860,7 +10314,7 @@ copy_initconst_to_array(ACL **arr, ACL *c, int count) } static ACL * -eval_reshape(ACL *arg, DTYPE dtype) +eval_reshape(ACL *arg, DTYPE dtype, LOGICAL transpose) // AOCC { ACL *srclist; ACL *tacl; @@ -9883,7 +10337,7 @@ eval_reshape(ACL *arg, DTYPE dtype) arg = eval_init_expr(arg); srclist = clone_init_const(arg, TRUE); - if (arg->next->next) { + if (arg->next && arg->next->next) { // AOCC pad = arg->next->next; if (pad->id == AC_ACONST) { pad = eval_init_expr_item(pad); @@ -9905,11 +10359,18 @@ eval_reshape(ACL *arg, DTYPE dtype) } if (orderarg == NULL) { - if (src_sz == dest_sz) { - return srclist; - } - for (i = 0; i < rank; i++) { - order[i] = i; + // AOCC begin + if (transpose) { + order[0] = 1; + order[1] = 0; + } else { + if (src_sz == dest_sz) { + return srclist; + } + for (i = 0; i < rank; i++) { + order[i] = i; + } + // AOCC end } } else { LOGICAL out_of_order; @@ -10113,8 +10574,19 @@ eval_sqrt(ACL *arg, DTYPE dtype) xdsqrt(num1, res); conval = getcon(res, DT_DBLE); break; + // AOCC begin + case TY_QUAD: + num1[0] = CONVAL1G(con1); + num1[1] = CONVAL2G(con1); + num1[2] = CONVAL3G(con1); + num1[3] = CONVAL4G(con1); + xqsqrt(num1, res); + conval = getcon(res, DT_QUAD); + break; + // AOCC end case TY_CMPLX: case TY_DCMPLX: + case TY_QCMPLX: // AOCC /* a = sqrt(real**2 + imag**2); "hypot(real,imag) if (a == 0) { @@ -10152,7 +10624,8 @@ eval_sqrt(ACL *arg, DTYPE dtype) /*---------------------------------------------------------------------*/ -#define FPINTRIN1(iname, ent, fscutil, dscutil) \ +// AOCC parameter: qscutil +#define FPINTRIN1(iname, ent, fscutil, dscutil, qscutil) \ static ACL *ent(ACL *arg, DTYPE dtype) \ { \ ACL *rslt; \ @@ -10176,8 +10649,19 @@ eval_sqrt(ACL *arg, DTYPE dtype) dscutil(num1, res); \ conval = getcon(res, DT_DBLE); \ break; \ + /* AOCC begin */ \ + case TY_QUAD: \ + num1[0] = CONVAL1G(con1); \ + num1[1] = CONVAL2G(con1); \ + num1[2] = CONVAL3G(con1); \ + num1[3] = CONVAL4G(con1); \ + qscutil(num1, res); \ + conval = getcon(res, DT_QUAD); \ + break; \ + /* AOCC end */ \ case TY_CMPLX: \ case TY_DCMPLX: \ + case TY_QCMPLX: \ error(155, 3, gbl.lineno, \ "Intrinsic not supported in initialization:", iname); \ break; \ @@ -10195,25 +10679,28 @@ eval_sqrt(ACL *arg, DTYPE dtype) return rslt; \ } -FPINTRIN1("exp", eval_exp, xfexp, xdexp) +FPINTRIN1("exp", eval_exp, xfexp, xdexp, xqexp) + +FPINTRIN1("log", eval_log, xflog, xdlog, xqlog) -FPINTRIN1("log", eval_log, xflog, xdlog) +FPINTRIN1("log10", eval_log10, xflog10, xdlog10, xqlog10) -FPINTRIN1("log10", eval_log10, xflog10, xdlog10) +FPINTRIN1("sin", eval_sin, xfsin, xdsin, xqsin) -FPINTRIN1("sin", eval_sin, xfsin, xdsin) +FPINTRIN1("cos", eval_cos, xfcos, xdcos, xqcos) -FPINTRIN1("cos", eval_cos, xfcos, xdcos) +FPINTRIN1("tan", eval_tan, xftan, xdtan, xqtan) -FPINTRIN1("tan", eval_tan, xftan, xdtan) +FPINTRIN1("asin", eval_asin, xfasin, xdasin, xqasin) -FPINTRIN1("asin", eval_asin, xfasin, xdasin) +FPINTRIN1("acos", eval_acos, xfacos, xdacos, xdacos) -FPINTRIN1("acos", eval_acos, xfacos, xdacos) +FPINTRIN1("atan", eval_atan, xfatan, xdatan, xqatan) -FPINTRIN1("atan", eval_atan, xfatan, xdatan) +FPINTRIN1("cotan", eval_cotan, xfcotan, xdcotan, xqcotan) -#define FPINTRIN2(iname, ent, fscutil, dscutil) \ +// AOCC parameter: qscutil +#define FPINTRIN2(iname, ent, fscutil, dscutil, qscutil) \ static ACL *ent(ACL *arg, DTYPE dtype) \ { \ ACL *rslt = arg; \ @@ -10243,8 +10730,23 @@ FPINTRIN1("atan", eval_atan, xfatan, xdatan) dscutil(num1, num2, res); \ conval = getcon(res, DT_DBLE); \ break; \ + /* AOCC begin */ \ + case TY_QUAD: \ + num1[0] = CONVAL1G(con1); \ + num1[1] = CONVAL2G(con1); \ + num1[2] = CONVAL3G(con1); \ + num1[3] = CONVAL4G(con1); \ + num2[0] = CONVAL1G(con2); \ + num2[1] = CONVAL2G(con2); \ + num2[2] = CONVAL3G(con2); \ + num2[3] = CONVAL4G(con2); \ + qscutil(num1, num2, res); \ + conval = getcon(res, DT_QUAD); \ + break; \ + /* AOCC end */ \ case TY_CMPLX: \ case TY_DCMPLX: \ + case TY_QCMPLX: \ error(155, 3, gbl.lineno, \ "Intrinsic not supported in initialization:", iname); \ break; \ @@ -10262,7 +10764,7 @@ FPINTRIN1("atan", eval_atan, xfatan, xdatan) return rslt; \ } -FPINTRIN2("atan2", eval_atan2, xfatan2, xdatan2) +FPINTRIN2("atan2", eval_atan2, xfatan2, xdatan2, xqatan2) static INT get_const_from_ast(int ast) @@ -10540,7 +11042,7 @@ eval_const_array_triple_section(ACL *curr_e) sb.sub[ndims].stride = get_ival(v->dtype, v->conval); - if (++ndims >= 7) { + if (++ndims >= get_legal_maxdim()) { /* AOCC */ interr("initialization expression: too many dimensions\n", 0, 3); return 0; } @@ -10596,6 +11098,11 @@ mk_cmp(ACL *c, int op, INT l_conval, INT r_conval, int rdtype, int dt) case OP_LOR: c->conval = l_conval | r_conval; break; + // AOCC begin + case OP_LXOR: + c->conval = l_conval ^ r_conval; + break; + // AOCC end case OP_LAND: c->conval = l_conval & r_conval; break; @@ -10760,6 +11267,14 @@ eval_init_op(int op, ACL *lop, DTYPE ldtype, ACL *rop, DTYPE rdtype, SPTR sptr, case AC_I_nint: root = eval_nint(rop, dtype); break; + // AOCC begin + case AC_I_anint: + root = eval_nint(rop, dtype); + break; + case AC_I_aint: + root = eval_nint(rop, dtype); + break; + // AOCC end case AC_I_null: root = eval_null(sptr); break; @@ -10772,8 +11287,22 @@ eval_init_op(int op, ACL *lop, DTYPE ldtype, ACL *rop, DTYPE rdtype, SPTR sptr, case AC_I_transfer: root = eval_transfer(rop, dtype); break; + // AOCC begin + case AC_I_transpose: + root = eval_reshape(rop, dtype, /*transpose*/ TRUE); + break; + case AC_I_merge_bits: + root = eval_merge_bits(rop, dtype); + break; + case AC_I_dshiftl: + root = eval_dshift(rop, dtype, /*is_left*/ TRUE); + break; + case AC_I_dshiftr: + root = eval_dshift(rop, dtype, /*is_left*/ FALSE); + break; + // AOCC end case AC_I_reshape: - root = eval_reshape(rop, dtype); + root = eval_reshape(rop, dtype, /*transpose*/ FALSE); // AOCC break; case AC_I_selected_int_kind: root = eval_selected_int_kind(rop); @@ -10784,6 +11313,11 @@ eval_init_op(int op, ACL *lop, DTYPE ldtype, ACL *rop, DTYPE rdtype, SPTR sptr, case AC_I_selected_char_kind: root = eval_selected_char_kind(rop); break; + //AOCC Begin + case AC_I_nearest: + root = eval_nearest(rop, dtype); + break; + //AOCC End case AC_I_scan: root = eval_scan(rop); break; @@ -11038,6 +11572,11 @@ eval_init_op(int op, ACL *lop, DTYPE ldtype, ACL *rop, DTYPE rdtype, SPTR sptr, case OP_LOR: root->conval = lop->conval | rop->conval; break; + // AOCC begin + case OP_LXOR: + root->conval = lop->conval ^ rop->conval; + break; + // AOCC end case OP_LAND: root->conval = lop->conval & rop->conval; break; diff --git a/tools/flang1/flang1exe/symacc.c b/tools/flang1/flang1exe/symacc.c index 5429ac8ac5..c65d9e125d 100644 --- a/tools/flang1/flang1exe/symacc.c +++ b/tools/flang1/flang1exe/symacc.c @@ -5,6 +5,15 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * Last modified: Jun 2020 + */ + /******************************************************** FIXME: get rid of this "important notice" and proliferating copies. @@ -46,7 +55,7 @@ sym_init_first(void) STG_ALLOC(stb, 1000); assert(stb.stg_base, "sym_init: no room for symtab", stb.stg_size, ERR_Fatal); - stb.n_size = 5024; + stb.n_size = 5024 + 512; NEW(stb.n_base, char, stb.n_size); assert(stb.n_base, "sym_init: no room for namtab", stb.n_size, ERR_Fatal); stb.n_base[0] = 0; @@ -72,6 +81,7 @@ sym_init_first(void) DT_LOG = DT_LOG4; DT_DBLE = DT_REAL8; DT_DCMPLX = DT_CMPLX16; + DT_QCMPLX = DT_CMPLX32; DT_PTR = DT_INT4; } @@ -377,6 +387,17 @@ add_fp_constants(void) atoxd("0.5", &tmp[0], 3); stb.dblhalf = getcon(tmp, DT_REAL8); + // AOCC begin + atoxq("0.0", &tmp[0], 4); + stb.quad0 = getcon(tmp, DT_QUAD); + atoxq("1.0", &tmp[0], 4); + stb.quad1 = getcon(tmp, DT_QUAD); + atoxq("2.0", &tmp[0], 4); + stb.quad2 = getcon(tmp, DT_QUAD); + atoxq("0.5", &tmp[0], 4); + stb.quadhalf = getcon(tmp, DT_QUAD); + // AOCC end + #ifdef LONG_DOUBLE_FLOAT128 atoxq("0.0", &tmp[0], 4); stb.float128_0 = getcon(tmp, DT_FLOAT128); diff --git a/tools/flang1/flang1exe/symacc.h b/tools/flang1/flang1exe/symacc.h index ce15c2b632..9997a7e15f 100644 --- a/tools/flang1/flang1exe/symacc.h +++ b/tools/flang1/flang1exe/symacc.h @@ -4,6 +4,15 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * Last Modified: Jun 2020 + * + */ #ifndef SYMACC_H_ #define SYMACC_H_ @@ -212,6 +221,10 @@ typedef struct { DTYPE dt_cmplx; /* default cmplx - DT_CMPLX */ DTYPE dt_log; /* default logical - DT_LOG */ DTYPE dt_dble; /* default double precision - DT_DBLE */ + // AOCC begin + DTYPE dt_quad; /* default quad precision - DT_QUAD */ + DTYPE dt_qcmplx; /* default quad cmplx - DT_QCMPLX */ + // AOCC begin DTYPE dt_dcmplx; /* default double cmplx - DT_DCMPLX */ DTYPE dt_ptr; /* default pointer integer - DT_PTR */ /* The following members are the default integer, real, complex, and @@ -236,9 +249,21 @@ inline SPTR SymConval1(SPTR sptr) { inline SPTR SymConval2(SPTR sptr) { return static_cast(CONVAL2G(sptr)); } +// AOCC begin +inline SPTR SymConval3(SPTR sptr) { + return static_cast(CONVAL3G(sptr)); +} +inline SPTR SymConval4(SPTR sptr) { + return static_cast(CONVAL4G(sptr)); +} +// AOCC end #else #define SymConval1 CONVAL1G #define SymConval2 CONVAL2G +// AOC begin +#define SymConval3 CONVAL3G +#define SymConval4 CONVAL4G +// AOCC end #endif /** mode parameter for installsym_ex. */ diff --git a/tools/flang1/flang1exe/symtab.c b/tools/flang1/flang1exe/symtab.c index 5975bd60c8..ad7cb62500 100644 --- a/tools/flang1/flang1exe/symtab.c +++ b/tools/flang1/flang1exe/symtab.c @@ -4,6 +4,17 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading + * + * Added support for quad precision + * Last modified: Feb 2020 + * Last modified: Jun 2020 + * + */ /** * \file @@ -48,7 +59,7 @@ typedef struct { typedef struct { SPTR dec_sptr; - SPTR def_sptr; + SPTR def_sptr; } DEC_DEF_MAP; static DTIMPL dtimplicit; @@ -72,7 +83,7 @@ void sym_init(void) { int i; - INT tmp[2], res[2]; + INT tmp[2], res[2], res1[4], tmp1[4]; int dtype; static char *npname = "hpf_np$"; int sptr; @@ -94,8 +105,10 @@ sym_init(void) DT_DBLE = DT_REAL8; DT_DCMPLX = DT_CMPLX16; } else { - DT_DBLE = DT_QUAD; - DT_DCMPLX = DT_QCMPLX; + // AOCC begin + //DT_REAL = DT_QUAD; + DT_QCMPLX = DT_CMPLX32; + // AOCC end } } if (XBIT(49, 0x80000000)) { @@ -165,11 +178,11 @@ sym_init(void) if (INTTYPG(i) == DT_QUAD) INTTYPP(i, DT_REAL8); else if (INTTYPG(i) == DT_QCMPLX) - INTTYPP(i, DT_CMPLX16); + INTTYPP(i, DT_CMPLX32); if (ARGTYPG(i) == DT_QUAD) ARGTYPP(i, DT_REAL8); else if (ARGTYPG(i) == DT_QCMPLX) - ARGTYPP(i, DT_CMPLX16); + ARGTYPP(i, DT_CMPLX32); } /* @@ -184,6 +197,7 @@ sym_init(void) /* int 0, 1 */ tmp[0] = tmp[1] = (INT)0; + tmp1[0] = tmp1[1] = tmp1[2] = tmp1[3] = (INT)0; // AOCC stb.i0 = getcon(tmp, DT_INT); if (DT_INT == DT_INT8) stb.k0 = stb.i0; @@ -282,6 +296,14 @@ sym_init(void) tmp[1] = CONVAL2G(stb.dbl0); xdneg(tmp, res); stb.dblm0 = getcon(res, DT_DBLE); +// AOCC begin + tmp1[0] = CONVAL1G(stb.quad0); + tmp1[1] = CONVAL2G(stb.quad0); + tmp1[2] = CONVAL3G(stb.quad0); + tmp1[3] = CONVAL4G(stb.quad0); + xqneg(tmp1, res1); + stb.quadm0 = getcon(res1, DT_QUAD); +// AOCC end #define NXTRA 2 aux.curr_entry = &onlyentry; @@ -1018,12 +1040,13 @@ getprint(int sptr) num[1] = CONVAL2G(sptr); cprintf(b, "%24.17le", num); break; + case TY_QUAD: num[0] = CONVAL1G(sptr); num[1] = CONVAL2G(sptr); num[2] = CONVAL3G(sptr); num[3] = CONVAL4G(sptr); - cprintf(b, "%44.37qd", num); + cprintf(b, "%44.37Lf", num); break; case TY_CMPLX: @@ -1046,6 +1069,23 @@ getprint(int sptr) cprintf(&b[26], "%24.17le", num); break; + // AOCC begin + case TY_QCMPLX: + num[0] = CONVAL1G(CONVAL1G(sptr)); + num[1] = CONVAL2G(CONVAL1G(sptr)); + num[2] = CONVAL3G(CONVAL1G(sptr)); + num[3] = CONVAL4G(CONVAL1G(sptr)); + cprintf(b, "%44.37Lf", num); + b[44] = ','; + b[45] = ' '; + num[0] = CONVAL1G(CONVAL2G(sptr)); + num[1] = CONVAL2G(CONVAL2G(sptr)); + num[2] = CONVAL3G(CONVAL2G(sptr)); + num[3] = CONVAL4G(CONVAL2G(sptr)); + cprintf(&b[46], "%44.37Lf", num); + break; + // AOCC end + case TY_NCHAR: sptr = CONVAL1G(sptr); /* sptr to char string constant */ dtype = DTYPEG(sptr); @@ -2719,6 +2759,7 @@ cmp_interfaces_strict(SPTR sym1, SPTR sym2, cmp_interface_flags flag) } } paramct -= j; + if (PDNUMG(sym1)) paramct-=PDNUMG(sym1); for (j = i = 0; i < paramct2; ++i) { psptr2 = aux.dpdsc_base[dpdsc2 + i]; @@ -2727,8 +2768,10 @@ cmp_interfaces_strict(SPTR sym1, SPTR sym2, cmp_interface_flags flag) } } paramct2 -= j; + if (PDNUMG(sym2)) paramct2-=PDNUMG(sym2); - if (PUREG(sym1) != PUREG(sym2) || IMPUREG(sym1) != IMPUREG(sym2)) { + if (flg.std != F2008 && // AOCC. For f2008, pure attrbute is not considered + PUREG(sym1) != PUREG(sym2) || IMPUREG(sym1) != IMPUREG(sym2)) { if (flag & CMP_SUBMOD_IFACE) error(1060, ERR_Severe, gbl.lineno, "PURE function prefix",SYMNAME(sym1)); @@ -2951,6 +2994,10 @@ instantiate_interface(SPTR iface) SCOPEP(arg, proc); if (DTY(DTYPEG(arg)) == TY_ARRAY && ASSUMSHPG(arg)) { DTYPE elem_dt = array_element_dtype(DTYPEG(arg)); + // AOCC Begin + ADSC *ad = AD_DPTR(DTYPEG(dec_def_map[j].dec_sptr)); + sem.arrdim.ndim = sem.arrdim.ndefer = AD_NUMDIM(ad); + // AOCC End int arr_dsc = mk_arrdsc(); DTY(arr_dsc + 1) = elem_dt; DTYPEP(arg, arr_dsc); diff --git a/tools/flang1/flang1exe/transfrm.c b/tools/flang1/flang1exe/transfrm.c index 3273919fff..de09376fab 100644 --- a/tools/flang1/flang1exe/transfrm.c +++ b/tools/flang1/flang1exe/transfrm.c @@ -4,6 +4,18 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading + * Support for parity intrinsic. + * Month of Modification: July 2019 + * + * Support for Bit transformational intrinsic iany, iall, iparity. + * Month of Modification: July 2019 + * Last modified: Jun 2020 + */ /** \brief Fortran transformation module */ @@ -66,6 +78,7 @@ static int get_sdsc_ast(SPTR sptrsrc, int astsrc); static int build_poly_func_node(int dest, int src, int intrin_type); static int mk_poly_test(int dest, int src, int optype, int intrin_type); static int count_allocatable_members(int ast); +void rewrite_asts_collapse_loop(struct collapse_loop); FINFO_TBL finfot; static int init_idx[MAXSUBS + MAXSUBS]; @@ -75,6 +88,308 @@ struct pure_gbl pure_gbl; extern int pghpf_type_sptr; int pghpf_local_mode_sptr = 0; +#ifdef OMP_OFFLOAD_LLVM +// AOCC BEGIN +/* maximum number of AST statement clones */ +#define MAX_CLONES 1000 + +static void rewrite_omp_targetdata_construct() { + + int std = 0; + int ast = 0, ifast = 0, new_if = 0, new_end = 0, ast_type = 0; + int begin_std = 0, target_ast = 0; + + ast_visit(1,1); + for (std = STD_NEXT(0); std > 0; std = STD_NEXT(std)) { + ast = STD_AST(std); + + // Search for targetdata. + if (A_TYPEG(ast) != A_MP_TARGETDATA) { + continue; + } + begin_std = std; + + ast = STD_AST(std); + target_ast = ast; + + ifast = A_IFPARG(target_ast); + if (!ifast) + continue; + + // Create new if-then-endif structure. + new_if = mk_stmt(A_IFTHEN, 0); + new_end = mk_stmt(A_ENDIF, 0); + // Copy the condition from the TARGETDATA statement. + A_IFEXPRP(new_if, ifast); + // Place if-then before the targetdata + add_stmt_before(new_if, begin_std); + A_IFPARP(ast, 0); + + // Next statements should be list of A_MP_MAP and one A_MP_EMAP + std = STD_NEXT(std); + assert(std > 0, "", ast, 4); + ast = STD_AST(std); + + while (A_TYPEG(ast) != A_MP_EMAP) { + assert(A_TYPEG(ast) == A_MP_MAP, "", ast, 4); + std = STD_NEXT(std); + assert(std > 0, "", ast, 4); + ast = STD_AST(std); + } + + assert(A_TYPEG(ast) == A_MP_EMAP, "", ast, 4); + // Insert else-then {cloned nodes} statements after + // A_MP_EMAP + add_stmt_after(new_end, std); + + std = STD_NEXT(std); + assert(std > 0, "", ast, 4); + ast = STD_AST(std); + + // Search for endtargetdata node and insert the + // same if-then-endif condition around it as well. + while (A_TYPEG(ast) != A_MP_ENDTARGETDATA) { + std = STD_NEXT(std); + assert(std > 0, "", ast, 4); + ast = STD_AST(std); + } + + assert(A_TYPEG(ast) == A_MP_ENDTARGETDATA, "", ast, 4); + // Clone the if and end statements. + new_if = ast_rewrite(new_if); + new_end = ast_rewrite(new_end); + + add_stmt_before(new_if, std); + add_stmt_after(new_end, std); + } + ast_unvisit(); + + // Handle targetenterdata and targetexitdata. + ast_visit(1,1); + for (std = STD_NEXT(0); std > 0; std = STD_NEXT(std)) { + ast = STD_AST(std); + + // Search for targetdata. + ast_type = A_TYPEG(ast); + if (ast_type != A_MP_TARGETENTERDATA && ast_type != A_MP_TARGETEXITDATA) { + continue; + } + begin_std = std; + + ast = STD_AST(std); + target_ast = ast; + + ifast = A_IFPARG(target_ast); + if (!ifast) + continue; + + // Create new if-then-endif structure. + new_if = mk_stmt(A_IFTHEN, 0); + new_end = mk_stmt(A_ENDIF, 0); + // Copy the condition from the TARGET(ENTER|EXIT)DATA statement. + A_IFEXPRP(new_if, ifast); + // Place if-then before the targetdata + add_stmt_before(new_if, begin_std); + A_IFPARP(ast, 0); + + // Next statements should be list of A_MP_MAP and one A_MP_EMAP + std = STD_NEXT(std); + assert(std > 0, "", ast, 4); + ast = STD_AST(std); + + while (A_TYPEG(ast) != A_MP_EMAP) { + assert(A_TYPEG(ast) == A_MP_MAP, "", ast, 4); + std = STD_NEXT(std); + assert(std > 0, "", ast, 4); + ast = STD_AST(std); + } + + assert(A_TYPEG(ast) == A_MP_EMAP, "", ast, 4); + // Insert else-then {cloned nodes} statements after + // A_MP_EMAP + add_stmt_after(new_end, std); + } + + ast_unvisit(); +} + +static void rewrite_omp_target_construct() { + + int std = 0; + int ast = 0, ifast = 0, new_if = 0, new_end = 0, new_else = 0; + int cloned_stmts[MAX_CLONES]; + int begin_std = 0, target_ast = 0; + int curr = 0; + int new_stmt = 0; + int found_inner_scope = 0; + + ast_visit(1,1); + for (std = STD_NEXT(0); std > 0; std = STD_NEXT(std)) { + ast = STD_AST(std); + + // Search for BMPSCOPE. + if (A_TYPEG(ast) != A_MP_BMPSCOPE) { + continue; + } + begin_std = std; + + // Next AST Statement should be Target + std = STD_NEXT(std); + assert(std > 0, "", ast, 4); + ast = STD_AST(std); + if (A_TYPEG(ast) != A_MP_TARGET) { + continue; + } + target_ast = ast; + + ifast = A_IFPARG(target_ast); + if (!ifast) { + continue; + } + + // Create new if-then-else structure. + new_if = mk_stmt(A_IFTHEN, 0); + new_else = mk_stmt(A_ELSE, 0); + new_end = mk_stmt(A_ENDIF, 0); + // Copy the condition from the TARGET statement. + A_IFEXPRP(new_if, ifast); + // Place if-then before the A_MP_BMPSCOPE. + add_stmt_before(new_if, begin_std); + A_IFPARP(ast, 0); + + // Next statement could be an assignment to a private variable + // when in_reduction is used + // or local variable when in_reduction is used + std = STD_NEXT(std); + assert(std > 0, "", ast, 4); + ast = STD_AST(std); + + while (A_TYPEG(ast) == A_ASN) { + assert(SCG(A_SPTRG(A_DESTG(ast))) == SC_PRIVATE || + SCG(A_SPTRG(A_DESTG(ast))) == SC_LOCAL , "", ast, 4); + std = STD_NEXT(std); + assert(std > 0, "", ast, 4); + ast = STD_AST(std); + } + + // Next statements should be list of A_MP_MAP and one A_MP_EMAP + while (A_TYPEG(ast) != A_MP_EMAP) { + assert(A_TYPEG(ast) == A_MP_MAP, "", ast, 4); + std = STD_NEXT(std); + assert(std > 0, "", ast, 4); + ast = STD_AST(std); + } + + assert(A_TYPEG(ast) == A_MP_EMAP, "", ast, 4); + std = STD_NEXT(std); + ast = STD_AST(std); + + int outer_scope = 1; + int team_scope = 0; + + while (std > 0) { + ast = STD_AST(std); + if (A_TYPEG(ast) == A_MP_ENDTARGET) break; + if (A_TYPEG(ast) == A_MP_TEAMS) team_scope = 1; + if (A_TYPEG(ast) == A_MP_BMPSCOPE) { + if (outer_scope || !team_scope) { + new_stmt = STD_AST(clone_bmpscope_std(begin_std)); + } else { + new_stmt = STD_AST(clone_bmpscope_std(std)); + } + int stblk_ast = A_STBLKG(new_stmt); + int uplevel_sptr = PARUPLEVELG(A_SPTRG(stblk_ast)); + int uplevel_sptr2 = PARUPLEVELG(A_STBLKG(ast)); + if (!outer_scope) { + llmp_uplevel_set_parent(uplevel_sptr, uplevel_sptr-2); + } + outer_scope = 0; + } else { + new_stmt = ast_rewrite(ast); + } + A_DESTP(new_stmt, A_DESTG(ast)); + A_SRCP(new_stmt, A_SRCG(ast)); + assert(curr < MAX_CLONES, + "rewrite_omp_target_construct: Too many AST " + "statements to clone",ast,4); + cloned_stmts[curr++] = new_stmt; + std = STD_NEXT(std); + } + + assert(A_TYPEG(ast) == A_MP_ENDTARGET, "", ast, 4); + + // Match for A_EMPSCOPE. + std = STD_NEXT(std); + assert(std > 0, "", ast, 4); + ast = STD_AST(std); + assert(A_TYPEG(ast) == A_MP_EMPSCOPE, "", ast, 4); + + // Insert else-then {cloned nodes} statements after + // A_MP_EMPSCOPE. + add_stmt_after(new_end, std); + // Insert the cloned statements in the + // else part. + while (curr > 0) { + int cloned_ast = cloned_stmts[--curr]; + add_stmt_after(cloned_ast,std); + } + add_stmt_after(new_else, std); + + // Move to next node. + std = STD_NEXT(std); + } + + ast_unvisit(); +} + +void rewrite_omp_map_array_section() { + int std = 0, bmpstd; + int ast = 0, lop; + int ast2 = 0, shape, src; + int tmp, newast, asn; + + ast_visit(1,1); + + for(std = STD_NEXT(0); std > 0; std = STD_NEXT(std)) { + ast = STD_AST(std); + + if(ast == 0) + continue; + + if(A_TYPEG(ast) == A_MP_BMPSCOPE) + bmpstd = std; + if(A_TYPEG(ast) != A_MP_MAP) + continue; + + lop = A_LOPG(ast); + + if(A_TYPEG(lop) != A_SUBSCR || !A_SHAPEG(lop)) + continue; + + transform_map_array_section(lop, bmpstd, &ast2); + + shape = A_SHAPEG(lop); + + // compute the size of the array + if(SHD_UPB(shape, 0)){ + src = mk_binop(OP_ADD, mk_binop(OP_SUB, SHD_UPB(shape,0), + SHD_LWB(shape,0), astb.bnd.dtype), + SHD_STRIDE(shape,0), astb.bnd.dtype); + tmp = getcctmp('z', src, ST_VAR, DT_INT8); + newast = mk_id(tmp); + asn = mk_assn_stmt(newast, src, DT_INT8); + add_stmt_before(asn, bmpstd); + A_ROPP(ast, newast); + } + if(ast2) + A_LOPP(ast, ast2); + } + + ast_unvisit(); +} +#endif +// AOCC END + void transform(void) { @@ -86,6 +401,33 @@ transform(void) /* create descriptors */ trans_get_descrs(); +// AOCC BEGIN +#ifdef OMP_OFFLOAD_LLVM + if (flg.omptarget) { + /* Handle if-clause in OpenMP statements. + */ + rewrite_omp_target_construct(); + rewrite_omp_targetdata_construct(); +#if DEBUG + if (DBGBIT(50, 4)) { + fprintf(gbl.dbgfil, "After rewrite_omp_target_construct\n"); + dstda(); + } +#endif + /* Handle sections for assumed array in map clause + */ + rewrite_omp_map_array_section(); + +#if DEBUG + if(DBGBIT(50, 4)) { + fprintf(gbl.dbgfil, "After rewrite_omp_map_array_section\n"); + dstda(); + } +#endif + } +#endif +// AOCC END + /* turn block wheres into single wheres */ #if DEBUG if (DBGBIT(50, 4)) { @@ -578,6 +920,55 @@ in_wheresymlist(ITEM *list, int sptr) return FALSE; } +/* move few STD nodes ahead of distributed do loop. + * update the upper bound of distributed loop as that of parallel loop. + */ +void +rewrite_asts_collapse_loop(struct collapse_loop collapse_loop) +{ + if ((collapse_loop.distributed_loop != 0) && + (collapse_loop.instruction_range_start != 0) && + (collapse_loop.instruction_range_end != 0) && + (collapse_loop.parallel_loop != 0)) { + + // move range of STD nodes ahead of distributed do loop + move_range_before(collapse_loop.instruction_range_start, + collapse_loop.instruction_range_end, + collapse_loop.distributed_loop); + + /* add an assignment statement to assign a new value to the upper bound of + * distributed loop which is same as that of parallel loop. + * add this newly created assignment statement just before the distributed + * loop. + */ + int collapse_assn_ast = + mk_assn_stmt(A_M2G(STD_AST(collapse_loop.distributed_loop)), + A_DESTG(STD_AST(collapse_loop.instruction_range_end)), DT_INT); + (void)add_stmt_before(collapse_assn_ast, collapse_loop.distributed_loop); + + /* set the lower bound of both distributed and parallel loop to 1 and + * add this assignement statement just before distributed loop. + */ + collapse_assn_ast = + mk_assn_stmt(A_M1G(STD_AST(collapse_loop.distributed_loop)), + astb.i1, DT_INT); + (void)add_stmt_before(collapse_assn_ast, collapse_loop.distributed_loop); + + /* update the lower bound, upper bound and stride of parallel loop as that + * of distributed loop. This makes it possible to pass the proper bounds to + * the second runtime kmpc call corresponding to the parallel loop. + * Here the bounds returned as reference by the first kmpc call + * corresponding to distributed loop are used during second kmpc call. + */ + A_M1P(STD_AST(collapse_loop.parallel_loop), + A_M1G(STD_AST(collapse_loop.distributed_loop))); + A_M2P(STD_AST(collapse_loop.parallel_loop), + A_M2G(STD_AST(collapse_loop.distributed_loop))); + A_M3P(STD_AST(collapse_loop.parallel_loop), + A_M3G(STD_AST(collapse_loop.distributed_loop))); + } +} + /* * Transform block WHERE statements to single-statement wheres */ @@ -1027,7 +1418,8 @@ rewrite_block_forall(void) continue; } if (A_TYPEG(ast) == A_ALLOC || A_TYPEG(ast) == A_CONTINUE || - A_TYPEG(ast) == A_COMMENT || A_TYPEG(ast) == A_COMSTR) + A_TYPEG(ast) == A_COMMENT || A_TYPEG(ast) == A_COMSTR || + A_TYPEG(ast) == A_DO || A_TYPEG(ast) == A_ENDDO) //AOCC continue; /* or it may be like, z_b_0 = 1 */ if (A_TYPEG(ast) == A_ASN && A_TYPEG(A_DESTG(ast)) == A_ID) @@ -1808,6 +2200,11 @@ collapse_assignment(int asn, int std) FtnRtlEnum rtlRtn; int rhs_isptr, lhs_isptr; + // AOCC Begin + // for device offload do not transform array assignments to runtime library + if (flg.omptarget) return 0; + // AOCC End + if (flg.opt < 2) return 0; @@ -1953,6 +2350,12 @@ collapse_assignment(int asn, int std) if (CONVAL1G(cnst) == stb.dbl0 && CONVAL2G(cnst) == stb.dbl0) is_zero = 1; break; + // AOCC begin + case DT_CMPLX32: + if (CONVAL1G(cnst) == stb.quad0 && CONVAL2G(cnst) == stb.quad0) + is_zero = 1; + break; + // AOCC end case DT_BINT: case DT_SINT: case DT_INT4: @@ -1968,7 +2371,7 @@ collapse_assignment(int asn, int std) break; default: if (cnst == stb.i0 || cnst == stb.k0 || cnst == stb.flt0 || - cnst == stb.dbl0) + cnst == stb.dbl0 || cnst == stb.quad0) is_zero = 1; break; } @@ -2022,6 +2425,9 @@ collapse_assignment(int asn, int std) case 16: rtlRtn = RTE_mzeroz16; break; + case 32: + rtlRtn = RTE_mzeroz32; + break; } } else { switch (size_of(dtype)) { @@ -2037,6 +2443,9 @@ collapse_assignment(int asn, int std) case 8: rtlRtn = RTE_mzero8; break; + case 16: + rtlRtn = RTE_mzeroz8; + break; } } nm = mkRteRtnNm(rtlRtn); @@ -2057,6 +2466,9 @@ collapse_assignment(int asn, int std) case 16: rtlRtn = RTE_mcopyz16; break; + case 32: + rtlRtn = RTE_mcopyz32; + break; } } else { switch (size_of(dtype)) { @@ -2072,6 +2484,9 @@ collapse_assignment(int asn, int std) case 8: rtlRtn = RTE_mcopy8; break; + case 16: + rtlRtn = RTE_mcopyz8; + break; } } nm = mkRteRtnNm(rtlRtn); @@ -2093,6 +2508,9 @@ collapse_assignment(int asn, int std) case 16: rtlRtn = RTE_msetz16; break; + case 32: + rtlRtn = RTE_msetz32; + break; } } else { switch (size_of(dtype)) { @@ -2108,6 +2526,9 @@ collapse_assignment(int asn, int std) case 8: rtlRtn = RTE_mset8; break; + case 16: + rtlRtn = RTE_msetz8; + break; } } nm = mkRteRtnNm(rtlRtn); @@ -2283,6 +2704,10 @@ inline_spread_shifts(int asgn_ast, int forall_ast, int inlist) case I_PRODUCT: case I_MAXVAL: case I_MINVAL: + case I_PARITY: // AOCC + case I_IPARITY: // AOCC + case I_IALL: // AOCC + case I_IANY: // AOCC case I_ALL: case I_ANY: case I_COUNT: @@ -3365,7 +3790,7 @@ mk_deallocate(int ast) /* is_assign_lhs is set when this is for the LHS of an assignment */ void -rewrite_deallocate(int ast, bool is_assign_lhs, int std) +rewrite_deallocate(int ast, bool is_assign_lhs, int std, bool can_reorder) { int i; int sptrmem; @@ -3391,7 +3816,25 @@ rewrite_deallocate(int ast, bool is_assign_lhs, int std) astparent = mk_subscr_copy(ast, asd, DTY(dtype + 1)); } } - + // AOCC Begin + bool reorder_nullify=false; + for (sptrmem = DTY(DDTG(dtype) + 1); sptrmem > NOSYM; + sptrmem = SYMLKG(sptrmem)) { + if (is_tbp_or_final(sptrmem)) { + continue; /* skip tbp */ + } + if (!ALLOCATTRG(sptrmem)) { + continue; + } + if (can_reorder && has_finalized_component(sptrmem)) { + reorder_nullify=true; + } + } + if (reorder_nullify) { + add_stmt_after(add_nullify_ast(ast), std); + A_MEM_ORDERP(ast,ast); + } + // AOCC End for (sptrmem = DTY(DDTG(dtype) + 1); sptrmem > NOSYM; sptrmem = SYMLKG(sptrmem)) { int astdealloc; @@ -3402,16 +3845,19 @@ rewrite_deallocate(int ast, bool is_assign_lhs, int std) astmem = mk_id(sptrmem); astmem = mk_member(astparent, astmem, A_DTYPEG(astmem)); if (!POINTERG(sptrmem) && allocatable_member(sptrmem)) { - rewrite_deallocate(astmem, false, std); + rewrite_deallocate(astmem, false, std, false); } if (!ALLOCATTRG(sptrmem)) { continue; } astdealloc = mk_deallocate(astmem); A_DALLOCMEMP(astdealloc, 1); - add_stmt_before(astdealloc, std); + if (reorder_nullify) { // AOCC + add_stmt_after(astdealloc, std); + } else { + add_stmt_before(astdealloc, std); + } } - gen_do_ends(docnt, std); if (need_endif) { int astendif = mk_stmt(A_ENDIF, 0); @@ -3672,7 +4118,7 @@ gen_dealloc_mbr(int ast, int std) int std_dealloc = add_stmt_before(astfunc, std); A_DALLOCMEMP(astfunc, 1); if (allocatable_member(memsym_of_ast(ast))) { - rewrite_deallocate(ast, true, std_dealloc); + rewrite_deallocate(ast, true, std_dealloc, true); } } diff --git a/tools/flang1/flang1exe/transfrm.h b/tools/flang1/flang1exe/transfrm.h index 9d6636336b..ce6afd0426 100644 --- a/tools/flang1/flang1exe/transfrm.h +++ b/tools/flang1/flang1exe/transfrm.h @@ -36,7 +36,7 @@ LOGICAL is_array_type(int sptr); int mk_conformable_test(int dest, int src, int optype); int mk_allocate(int ast); int mk_deallocate(int ast); -void rewrite_deallocate(int ast, bool is_assign_lhs, int std); +void rewrite_deallocate(int ast, bool is_assign_lhs, int std, bool can_reorder); void gen_dealloc_if_allocated(int ast, int std); #endif /* FE_TRANSFRM_H */ diff --git a/tools/flang1/flang1exe/vsub.c b/tools/flang1/flang1exe/vsub.c index 1a3c18432e..f82d496117 100644 --- a/tools/flang1/flang1exe/vsub.c +++ b/tools/flang1/flang1exe/vsub.c @@ -96,6 +96,7 @@ rewrite_forall(void) set_descriptor_sc(SC_PRIVATE); break; case A_MP_ENDTASK: + case A_MP_ETASKLOOP: --task_depth; if (parallel_depth == 0 && task_depth == 0) { set_descriptor_sc(SC_LOCAL); diff --git a/tools/flang1/utils/ast/ast.in.h b/tools/flang1/utils/ast/ast.in.h index 10a098e03b..8cc6757fd9 100644 --- a/tools/flang1/utils/ast/ast.in.h +++ b/tools/flang1/utils/ast/ast.in.h @@ -4,6 +4,15 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified: May 2020 + * + * Added support for openmp schedule clause + * Date of modification: Jan 2021 + */ /** * \file @@ -25,6 +34,8 @@ #define A_TKNP(s,v) A_hw21P(s,v) #define A_NTRIPLEG(s) A_hw21G(s) #define A_NTRIPLEP(s,v) A_hw21P(s,v) +#define A_SCHED_MODIFIERG(s) A_hw23G(s) // AOCC +#define A_SCHED_MODIFIERP(s,v) A_hw23P(s,v) // AOCC #define A_SCHED_TYPEG(s) A_hw21G(s) #define A_SCHED_TYPEP(s,v) A_hw21P(s,v) #define A_CANCELKINDG(s) A_hw21G(s) @@ -75,7 +86,7 @@ #define OP_ARRAY 31 #define OP_DERIVED 32 #define OP_BYVAL 33 - +#define OP_LXOR 34 // AOCC /* AST attributes: for fast AST checking -- astb.attr is a table indexed * by A_ */ @@ -252,6 +263,7 @@ typedef struct { /* AST typedef declarations: */ typedef struct { + uint16_t hw23; // added to store modifier argument so that it can be accessed in flang2 int16_t type; uint8_t f1:1, f2:1, f3:1, f4:1, f5:1, f6:1, f7:1, f8:1; uint8_t hw1:8; @@ -293,14 +305,14 @@ typedef struct { int ptr0c; /* 'predefined' ast for non-present character I/O spec*/ struct { STG_MEMBERS(int); - int hash[7]; /* max # of dimensions */ + int hash[MAXSUBS]; /* AOCC: max # of dimensions */ } asd; STG_DECLARE(std, STD); STG_DECLARE(astli, ASTLI); STG_DECLARE(argt, int); struct { STG_MEMBERS(SHD); - int hash[7]; /* max # of dimensions */ + int hash[MAXSUBS]; /* AOCC: max # of dimensions */ } shd; STG_DECLARE(comstr, char); UINT16 implicit[55]; /* implicit dtypes: diff --git a/tools/flang1/utils/ast/ast.n b/tools/flang1/utils/ast/ast.n index 6435fe40eb..4ac34dd2a3 100644 --- a/tools/flang1/utils/ast/ast.n +++ b/tools/flang1/utils/ast/ast.n @@ -4,6 +4,15 @@ .\" * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception .\" * .\" */ +.\"/* +.\" * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +.\" * Notified per clause 4(b) of the license. +.\" * +.\" * Added support for openmp schedule clause +.\" * Date of modification: Jan 2021 +.\" * +.\" * Last Modified: May 2020 +.\" */ .NS 30 "Abstract Syntax Tree" .de SF \"shared field .ie '\\$1'B' .nr ii \\$2u @@ -230,6 +239,14 @@ that its value does not exceed 65335. Always an unsigned halfword. Used where it's known (or there's a practical limit) that its value does not exceed 65335. +.SF hw23 w11:h3 +Always an unsigned halfword. +Used where it's known (or there's a practical limit) +that its value does not exceed 65335. +.SF hw24 w11:h4 +Always an unsigned halfword. +Used where it's known (or there's a practical limit) +that its value does not exceed 65335. .SF OPT1 w13 Optimizer-/vectorizer-/communication optimizer- dependent field. .SF OPT2 w14 @@ -2784,6 +2801,8 @@ If set, it is distribute loop If set, it is distribute parallel loop .FL TASKLOOP f3 If set, it is taskloop +.FL LOOP f3 +If set, it is loop .FL CALLFG May be referenced .lp @@ -2808,6 +2827,8 @@ AST pointer to the last value variable. Schedule type (see DI_SCH macros in semant.h) .OV ORDERED hw22 If nonzero, loop has the ORDERED attribute. +.OV SCHED_MODIFIER hw23 +Schedule modifier (see DI_SCH macros in semant.h) .SE DISTCHUNK w9 AST pointer to the disribute chunk size; this field is zero if the chunk clause is not present. @@ -3117,6 +3138,12 @@ AST pointer to the corresponding \f(CWA_MP_ENDTASK\fP. .SM MP_TASKLOOP .SI "taskloop" .lp +.SM MP_LOOP +.SI "loop" +.lp +.SM MP_REQUIRESUNIFIEDSHAREDMEMORY +.SI "requiresunifiedsharedmemory" +.lp OpenMP taskloop directive. .lp .ul @@ -3261,6 +3288,18 @@ Flags Other Fields .OV STD HSHLK .lp +.SM MP_ELOOP +.SI "endloop" +.lp +OpenMP endloop directive. +.lp +.ul +Flags +.lp +.ul +Other Fields +.OV STD HSHLK +.lp .SM MP_TASKWAIT .SI "taskwait" .lp @@ -3611,6 +3650,33 @@ Other Fields .SE LOP AST pointer to the corresponding \f(CWA_MP_TEAMS\fP. .lp +.\" AOCC Begin +.SM MP_DEFAULTMAP +.SI "defaultmap" +.lp +OpenMP Default map +.lp +.SM MP_TARGETDECLARE +.SI "targetdeclare" +.lp +OpenMP target declare +.lp +.SM MP_USE_DEVICE_PTR +.SI "use_device_ptr" +.lp +OpenMP use device ptr +.lp +.SM MP_USE_DEVICE_ADDR +.SI "use_device_addr" +.lp +OpenMP use device addr +.lp +.SM MP_IS_DEVICE_PTR +.SI "is_device_ptr" +.lp +OpenMP is device ptr +.lp +.\" AOCC End .SM MP_MAP .SI "map" .lp diff --git a/tools/flang1/utils/machar/machar.n b/tools/flang1/utils/machar/machar.n index 7cfd266c26..3bdc5c218f 100644 --- a/tools/flang1/utils/machar/machar.n +++ b/tools/flang1/utils/machar/machar.n @@ -4,6 +4,12 @@ .\" * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception .\" * .\" */ +.\"/* +.\" * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +.\" * Notified per clause 4(b) of the license. +.\" * +.\" * Last Modified: April 2020 +.\" */ .NS 24 "Target Machine" "Appendix III - " .de DN .nf @@ -63,8 +69,10 @@ lw(1n) lfCW | l | c. %TM_IDIV2%divide by power of 2 instruction%no %TM_FDIV%single precision divide instruction%no %TM_DDIV%double precision divide instruction%no +%TM_QDIV%quad precision divide instruction%no %TM_FRCP%single precision Newton's reciprocal%no %TM_DRCP%double precision Newton's reciprocal%no +%TM_QRCP%quad precision Newton's reciprocal%no %TM_UICMP%unsigned integer compare instruction%yes %TM_SQRT%square root instruction%no %TM_FIELD_INST%bit field support instructions%no @@ -78,8 +86,10 @@ lw(1n) lfCW | l | c. %TM_AUTOINC_FP%auto increment when addressing single/double%yes %TM_FCMPZ%single precision compare with zero%yes %TM_DCMPZ%double precision compare with zero%yes +%TM_QCMPZ%quad precision compare with zero%yes %TM_FCJMPZ%single precision compare with zero and jump%yes %TM_DCJMPZ%double precision compare with zero and jump%yes +%TM_QCJMPZ%quad precision compare with zero and jump%yes %TM_REAL8%default real size is 8%no .TE .lp @@ -113,6 +123,11 @@ signed quantity. .DA "( (x) << ((y)&31) )" .DN RSHIFT(x,y) .DA "( (x) >> ((y)&31) )" +.DN SHIFTA(x,y) +.DA "( ((y)&31) == 0 ? (x) :" +.DA "( (x) & 0x80000000 ?" +.DA "( (unsigned int)(x) >> ((y)&31) ) | ( ((unsigned int)-1) << (32-((y)&31)) ) :" +.DA "(x) >> ((y)&31) ) )" .np Constant fold shift per target machine; operand which is shifted is an unsigned quantity. @@ -175,7 +190,7 @@ lw(1n) lfCW | l | l | l | l | l | l | l | l. %TY_HCMPLX%4%1%32%0%reg2%Half Complex%half complex%2% %TY_CMPLX%8%3%64%0%reg2%Complex%complex%4% %TY_DCMPLX%16%7%128%0%reg3%Double Precision Complex%double complex%8% -%TY_QCMPLX%16%7%128%0%reg3%Quad Precision Complex%complex*32%16% +%TY_QCMPLX%32%15%256%0%reg3%Quad Precision Complex%complex*32%16% *\ AOCC \* %TY_BLOG%1%0%8%0%reg0%Byte Logical%logical*1%1% %TY_SLOG%2%1%16%0%reg0%Short Logical%logical*2%2% %TY_LOG%4%3%32%0%reg0%Logical%logical%4% @@ -257,11 +272,11 @@ lw(1n) lfCW | l | l | l | l | l | l | l | l. %TY_HALF%2%1%16%0%reg1%Floating Point Half%real%2% %TY_REAL%8%7%64%0%reg1%Floating Point Real%real%8% %TY_DBLE%8%7%64%0%reg2%Double Precision Real%real%8% -%TY_QUAD%16%15%128%0%reg2%Quad Precision Real%double precision%16% +%TY_QUAD%16%15%128%0%reg2%Quad Precision Real%Quad precision%16% %TY_HCMPLX%4%1%32%0%reg2%Half Complex%half complex%2% %TY_CMPLX%16%7%64%0%reg3%Complex%complex%8% %TY_DCMPLX%16%7%128%0%reg3%Double Precision Complex%complex%8% -%TY_QCMPLX%32%15%256%0%reg3%Quad Precision Complex%double complex%16% +%TY_QCMPLX%32%15%256%0%reg3%Quad Precision Complex%quad complex%16% %TY_BLOG%8%7%64%0%reg0%Byte Logical%logical%1% %TY_SLOG%8%7%64%0%reg0%Short Logical%logical%2% %TY_LOG%8%7%64%0%reg0%Logical%logical%4% @@ -302,7 +317,7 @@ lw(1n) lfCW | l | l | l | l | l | l | l | l. %TY_HCMPLX%4%1%32%0%reg2%Half Complex%half complex%2% %TY_CMPLX%8%3%64%0%reg2%Complex%complex%4% %TY_DCMPLX%16%7%128%0%reg3%Double Precision Complex%complex(8)%8% -%TY_QCMPLX%16%7%128%0%reg3%Quad Precision Complex%complex(16)%16% +%TY_QCMPLX%16%7%256%0%reg3%Quad Precision Complex%complex(16)%16% %TY_BLOG%1%0%8%0%reg0%Byte Logical%logical(1)%1% %TY_SLOG%2%1%16%0%reg0%Short Logical%logical(2)%2% %TY_LOG%4%3%32%0%reg0%Logical%logical%4% diff --git a/tools/flang1/utils/n2rst/CMakeLists.txt b/tools/flang1/utils/n2rst/CMakeLists.txt index 2b5513e7dd..8041114264 100644 --- a/tools/flang1/utils/n2rst/CMakeLists.txt +++ b/tools/flang1/utils/n2rst/CMakeLists.txt @@ -3,6 +3,12 @@ # See https://llvm.org/LICENSE.txt for license information. # SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception # +# +# Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +# Notified per clause 4(b) of the license. +# +# Last Modified: May 2020 +# add_executable(fen2rst ${UTILS_SHARED_DIR}/n2rst.cpp @@ -32,7 +38,7 @@ add_custom_command( ${FLANG1_DOC_BIN_DIR}/scanner.rst ${FLANG1_DOC_BIN_DIR}/semant.rst ${FLANG1_DOC_BIN_DIR}/transform.rst - COMMAND ${CMAKE_BINARY_DIR}/bin/fen2rst -v ${FLANG1_DOC_SRC_DIR}/ast.n + COMMAND ${CMAKE_BINARY_DIR}/bin/fen2rst -v ${UTILS_AST_DIR}/ast.n ${FLANG1_DOC_SRC_DIR}/comms.n ${FLANG1_DOC_SRC_DIR}/controller.n ${FLANG1_DOC_SRC_DIR}/dinit.n @@ -46,7 +52,7 @@ add_custom_command( ${FLANG1_DOC_SRC_DIR}/semant.n ${FLANG1_DOC_SRC_DIR}/transform.n WORKING_DIRECTORY ${FLANG1_DOC_BIN_DIR} - DEPENDS fen2rst ${FLANG1_DOC_SRC_DIR}/ast.n + DEPENDS fen2rst ${UTILS_AST_DIR}/ast.n ${FLANG1_DOC_SRC_DIR}/comms.n ${FLANG1_DOC_SRC_DIR}/controller.n ${FLANG1_DOC_SRC_DIR}/dinit.n diff --git a/tools/flang1/utils/prstab/gram.tki b/tools/flang1/utils/prstab/gram.tki index 1c98a64185..8335a4f93b 100644 --- a/tools/flang1/utils/prstab/gram.tki +++ b/tools/flang1/utils/prstab/gram.tki @@ -3,6 +3,12 @@ # See https://llvm.org/LICENSE.txt for license information. # SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception # +# +# Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +# Notified per clause 4(b) of the license. +# +# Last Modified: May 2020 +# END TK_EOL TK_ENDSTMT @@ -39,6 +45,8 @@ END TK_EOL '/)' TK_ACE ( TK_LPAREN ) TK_RPAREN +{ TK_LBRACE +} TK_RBRACE + TK_PLUS - TK_MINUS * TK_STAR @@ -128,6 +136,7 @@ ALIAS TK_ALIAS ALIGN TK_ALIGN ALLOCATE TK_ALLOCATE ALLOCATABLE TK_ALLOCATABLE +ARCH TK_ARCH ASSIGN TK_ASSIGN ASSIGNMENT TK_ASSIGNMENT ASSOCIATE TK_ASSOCIATE @@ -158,6 +167,7 @@ CONSTANT TK_CONSTANT CONTAINS TK_CONTAINS TCONTAINS TK_TCONTAINS CONCURRENT TK_CONCURRENT +CONDITION TK_CONDITION CONTIGUOUS TK_CONTIGUOUS CONTINUE TK_CONTINUE CONVERT TK_CONVERT @@ -235,6 +245,7 @@ GOTOX TK_GOTOX ID TK_ID IF TK_IF IGNORE_TKR TK_IGNORE_TKR +IMPLEMENTATION TK_IMPLEMENTATION IMPLICIT TK_IMPLICIT IMPORT TK_IMPORT IMPURE TK_IMPURE @@ -340,9 +351,12 @@ UNIT TK_UNIT UNROLL TK_UNROLL UPDATE TK_UPDATE USE TK_USE +USER TK_USER VALUE TK_VALUE +VENDOR TK_VENDOR VOLATILE TK_VOLATILE WAIT TK_WAIT +WHEN TK_WHEN WHERE TK_WHERE WHILE TK_WHILE WRITE TK_WRITE @@ -491,6 +505,8 @@ COPY TK_COPY TK_MP_TARGTEAMSDISTPARDOSIMD TK_MP_TARGTEAMSDISTSIMD TK_MP_TASK + TK_MP_REQUIRES + TK_MP_REQUIRESUNIFIEDSHAREDMEMORY TK_MP_TASKGROUP TK_MP_TASKLOOP TK_MP_TASKLOOPSIMD @@ -504,6 +520,8 @@ COPY TK_COPY TK_MP_THREADPRIVATE TK_MP_WORKSHARE TK_MP_ENDWORKSHARE + TK_MP_ENDMETADIR + TK_MP_LOOP TK_RED_TYPE ACCWAIT TK_ACCWAIT ALIGNED TK_ALIGNED @@ -579,3 +597,7 @@ DEVICE_NUM TK_DEVICE_NUM DEFAULT_ASYNC TK_DEFAULT_ASYNC LAUNCHBOUNDS TK_LAUNCH_BOUNDS MP_MAP TK_MP_MAP +METADIRECTIVE TK_MP_METADIR +USE_DEVICE_PTR TK_USE_DEVICE_PTR +IN_REDUCTION TK_IN_REDUCTION +USE_DEVICE_ADDR TK_USE_DEVICE_ADDR diff --git a/tools/flang1/utils/prstab/gram.txt b/tools/flang1/utils/prstab/gram.txt index 2b9276aeeb..29d030100e 100644 --- a/tools/flang1/utils/prstab/gram.txt +++ b/tools/flang1/utils/prstab/gram.txt @@ -3,6 +3,29 @@ # See https://llvm.org/LICENSE.txt for license information. # SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception # +# +# Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +# Notified per clause 4(b) of the license. +# +# Changes to support AMDGPU OpenMP Offloading +# Changed motion cluase variable list type from to +# . +# More details in case MOTION_CLAUSE1 and MOTION_CLAUSE2 of semsmp() +# Date of modification 23rd September 2019 +# +# Removed from and added individual definitions +# for same. +# Date of modification 10th April 2020 +# +# Including common block names in declare target list +# Date of modification 21st April 2020 +# +# Adding grammer for use_device_ptr +# Date of modification 29th April 2020 +# +# Added grammar for openmp schedule clause +# Date of modification: Jan 2021 +# ::= @@ -384,7 +407,8 @@ ::= , | - ::= = + ::= = | + '=>' ::= , = | = @@ -877,7 +901,9 @@ ::= ::= | - | + | + ( ) | + | ::= @@ -1766,9 +1792,39 @@ | | | - | - | - + | + | + | + | + | + | + + + ::= METADIRECTIVE + + ::= | + | + + + ::= WHEN ( : ) + + ::= ( ) + ::= DEFAULT + + ::= | + | + , + + ::= | + | + + + ::= USER = { CONDITION ( ) } + + ::= IMPLEMENTATION = { VENDOR ( ) } + + ::= DEVICE = { ARCH ( ) } + ::= | ( ) @@ -1837,7 +1893,7 @@ DEVICE ( ) | | | - IS_DEVICE_PTR ( ) | + IS_DEVICE_PTR ( ) | DEFAULTMAP ( : ) | | DIST_SCHEDULE ( ) | @@ -1846,7 +1902,12 @@ PRIORITY ( ) | NUM_TEAMS ( ) | THREAD_LIMIT ( ) | - NOGROUP + NOGROUP | + NOWAIT | + USE_DEVICE_PTR ( ) | + IN_REDUCTION ( ) | + USE_DEVICE_ADDR ( ) | + BIND ( ) ::= | ( ) @@ -1871,11 +1932,17 @@ ::= LASTPRIVATE ( ) ::= SCHEDULE | - MP_SCHEDTYPE = | + SCHEDULE ( | + MP_SCHEDTYPE = | CHUNK = + ::= | + + + ::= : ) + ::= | - ( ) + ( ) ::= | , @@ -1886,6 +1953,10 @@ ::= : | + ::= : | + + + ::= | * | .AND. | @@ -1932,8 +2003,8 @@ ::= | : - ::= TO ( ) | - FROM ( ) + ::= TO ( ) | + FROM ( ) ::= | @@ -1944,6 +2015,8 @@ ::= + ::= + ::= ::= diff --git a/tools/flang1/utils/prstab/prodstr.c b/tools/flang1/utils/prstab/prodstr.c index 2473e61366..a971511ed5 100644 --- a/tools/flang1/utils/prstab/prodstr.c +++ b/tools/flang1/utils/prstab/prodstr.c @@ -118,7 +118,12 @@ readln() char *status; strncpy(savelin, linbuf, 121); - savelin[strlen(savelin) - 1] = '\0'; + + if(strlen(savelin)!=0) + savelin[strlen(savelin) - 1] = '\0'; + else + savelin[0] = '\0'; + status = fgets(linbuf, 121, infile); lineno++; curchr = 0; diff --git a/tools/flang1/utils/prstab/prstab.h b/tools/flang1/utils/prstab/prstab.h index 98d2193fff..c788dd5fd0 100644 --- a/tools/flang1/utils/prstab/prstab.h +++ b/tools/flang1/utils/prstab/prstab.h @@ -4,6 +4,10 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ /** \file * \brief LR header files * @@ -34,6 +38,13 @@ #define SNPRINTF snprintf #endif +#ifndef _PRSTAB_GLOBAL_ +#define EXTERN extern +#else +#define EXTERN +#endif + + #define MAXSHD 2000 #define MAXSHDP1 2001 #define MAXSHD2P1 4001 @@ -50,7 +61,7 @@ /* Global Declarations */ -struct { +EXTERN struct { FILE *infile; FILE *gramin; FILE *tokin; @@ -61,32 +72,32 @@ struct { FILE *semfil; } files; -INT *scrtch; -INT *hashpt; -CHAR *linech; -char *filnambuf; +EXTERN INT *scrtch; +EXTERN INT *hashpt; +EXTERN CHAR *linech; +EXTERN char *filnambuf; -struct { +EXTERN struct { INT *item; INT *nextt; } s4; -struct { +EXTERN struct { INT *sstore; INT *sthead; } s1_1; -struct { +EXTERN struct { INT garbag; INT lstptr; } lstcom; -struct { +EXTERN struct { INT qhead; INT qtail; } qcom; -struct { +EXTERN struct { LOGICAL listsw; LOGICAL runosw; LOGICAL xrefsw; @@ -102,11 +113,11 @@ struct { LOGICAL dbgesw; } switches; -struct { +EXTERN struct { INT adequt; } adqcom; -struct { +EXTERN struct { INT *lftuse; INT *rgtuse; INT *frsprd; @@ -120,7 +131,7 @@ struct { INT nterms; } g_1; -struct { +EXTERN struct { INT nstate; INT nxttrn; INT nxtred; @@ -137,19 +148,19 @@ struct { INT *red; } s_1; -struct { +EXTERN struct { INT sstptr; INT shdptr; } string_1; -struct { +EXTERN struct { INT linbuf[81]; INT curchr; INT lineno; INT fstchr; } readcm; -struct { +EXTERN struct { INT pnum; INT brkflg; INT semnum; diff --git a/tools/flang1/utils/prstab/prstab1.c b/tools/flang1/utils/prstab/prstab1.c index 2b2770ae79..8a3a94e7de 100644 --- a/tools/flang1/utils/prstab/prstab1.c +++ b/tools/flang1/utils/prstab/prstab1.c @@ -4,12 +4,17 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + */ /** \file * \brief LR parser (part 1) * */ #include "lrutils.h" +#define _PRSTAB_GLOBAL_ #include "prstab.h" INT xargc; diff --git a/tools/flang1/utils/symtab/symini.cpp b/tools/flang1/utils/symtab/symini.cpp index dae5911574..5d5d943732 100644 --- a/tools/flang1/utils/symtab/symini.cpp +++ b/tools/flang1/utils/symtab/symini.cpp @@ -5,6 +5,37 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Support for DNORM intrinsic + * Date of Modification: 21st February 2019 + * + * Support for Bit Sequence Comparsion intrinsic + * Month of Modification: May 2019 + * + * Support for Bit Masking intrinsics. + * Month of Modification: May 2019 + * + * Support for Bit Shifting intrinsics. + * Month of Modification: June 2019 + * + * Support for MERGE_BITS intrinsic. + * Month of Modification: July 2019 + * + * Support for parity intrinsic. + * Month of Modification: July 2019 + * + * Support for Bit transformational intrinsic iany, iall, iparity. + * Month of Modification: July 2019 + * + * Added support for quad precision + * Last modified: Feb 2020 + * Last modified: Jun 2020 + * + */ + /** * \file * \brief Symbol initialization for Fortran @@ -43,7 +74,7 @@ * out5 - output file which will contain ILMs (ilmtp.h) *---------------------------------------------------------------------*/ -STB stb; +extern STB stb; /** * .IN name pcnt atyp dtype ILM pname arrayf @@ -147,7 +178,7 @@ class SyminiFE90 : public UtilityApplication argtype["L8"] = DT_LOG8; argtype["K"] = DT_NCHAR; argtype["Q"] = DT_QUAD; - argtype["CQ"] = DT_QCMPLX; + argtype["CQ"] = DT_CMPLX32; argtype["BI"] = DT_BINT; argtype["AD"] = DT_ADDR; elt[".IN"] = LT_IN; @@ -655,6 +686,8 @@ class SyminiFE90 : public UtilityApplication INTASTP(sptr1, intast_sym.size() - 1); } } + + // AOCC begin /* cqname */ tok = makeLower(getToken()); if (tok.empty() || tok[0] == '-') @@ -668,6 +701,8 @@ class SyminiFE90 : public UtilityApplication INTASTP(sptr1, intast_sym.size() - 1); } } + // AOCC end + /* gsame */ SPTR sptr1 = find_symbol(std::string(".") + SYMNAME(sptr)); if (sptr1 != 0 && STYPEG(sptr1) == ST_INTRIN) { @@ -1146,6 +1181,7 @@ const char *SyminiFE90::init_names0[] = { ".cdsqrt", "cdsqrt", ".cqsqrt", + "cqsqrt", ".alog", "alog", ".dlog", @@ -1156,6 +1192,7 @@ const char *SyminiFE90::init_names0[] = { ".cdlog", "cdlog", ".cqlog", + "cqlog", ".alog10", "alog10", ".dlog10", @@ -1201,6 +1238,16 @@ const char *SyminiFE90::init_names0[] = { ".dcosd", "dcosd", ".qcosd", + "..cotan", + ".cotan", + ".dcotan", + "dcotan", + ".qcotan", + "..cotand", + ".cotand", + ".dcotand", + "dcotand", + ".qcotand", "..tan", ".tan", ".dtan", @@ -1281,16 +1328,19 @@ const char *SyminiFE90::init_names0[] = { ".cdabs", "cdabs", ".cqabs", + "cqabs", "..aimag", ".aimag", ".dimag", "dimag", ".qimag", + "qimag", "..conjg", ".conjg", ".dconjg", "dconjg", ".qconjg", + "qconjg", "dprod", "imax0", ".max0", @@ -1448,6 +1498,12 @@ const char *SyminiFE90::init_names0[] = { ".2d", ".2c", ".2cd", +// AOCC begin + "qreal", + ".2q", + ".2c", + ".2cq", +// AOCC end "dint", "dnint", "..inint", @@ -1488,6 +1544,8 @@ const char *SyminiFE90::init_names0[] = { "sind", "cos", "cosd", + "cotan", + "cotand", "tan", "tand", "asin", @@ -1531,6 +1589,23 @@ const char *SyminiFE90::init_names0[] = { "any", "compl", "count", + // AOCC Begin + "bge", + "bgt", + "ble", + "blt", + "maskl", + "maskr", + "merge_bits", + "norm2", + "isnan", + "parity" + "iparity" + "iall", + "iany", + "quad", + "qcmplx", + // AOCC End "dot_product", "eqv", "matmul", @@ -1644,6 +1719,7 @@ const char *SyminiFE90::init_names0[] = { "dshiftl", "dshiftr", "mask", + "rank", }; /** @@ -1661,6 +1737,7 @@ const char *SyminiFE90::init_names1[] = { ".cdsqrt", "cdsqrt", ".cqsqrt", + "cqsqrt", ".alog", "alog", ".dlog", @@ -1671,6 +1748,7 @@ const char *SyminiFE90::init_names1[] = { ".cdlog", "cdlog", ".cqlog", + "cqlog", ".alog10", "alog10", ".dlog10", @@ -1716,6 +1794,16 @@ const char *SyminiFE90::init_names1[] = { ".dcosd", "dcosd", ".qcosd", + "..cotan", + ".cotan", + ".dcotan", + "dcotan", + ".qcotan", + "..cotand", + ".cotand", + ".dcotand", + "dcotand", + ".qcotand", "..tan", ".tan", ".dtan", @@ -1765,7 +1853,6 @@ const char *SyminiFE90::init_names1[] = { ".atan2d", ".datan2d", "datan2d", - ".qatan2d", "..sinh", ".sinh", ".dsinh", @@ -1796,16 +1883,19 @@ const char *SyminiFE90::init_names1[] = { ".cdabs", "cdabs", ".cqabs", + "cqabs", "..aimag", ".aimag", ".dimag", "dimag", ".qimag", + "qimag", "..conjg", ".conjg", ".dconjg", "dconjg", ".qconjg", + "qconjg", "dprod", "imax0", ".max0", @@ -1966,6 +2056,12 @@ const char *SyminiFE90::init_names1[] = { ".2d", ".2c", ".2cd", +// AOCC begin + "qreal", + ".2q", + ".2c", + ".2cq", +// AOCC end "dint", "dnint", "..inint", @@ -2006,6 +2102,8 @@ const char *SyminiFE90::init_names1[] = { "sind", "cos", "cosd", + "cotan", + "cotand", "tan", "tand", "asin", @@ -2049,6 +2147,23 @@ const char *SyminiFE90::init_names1[] = { "any", "compl", "count", + // AOCC Begin + "bge", + "bgt", + "ble", + "blt", + "quad", + "maskl", + "maskr", + "merge_bits", + "norm2", + "isnan", + "parity", + "iparity" + "iall", + "iany", + "qcmplx", + // AOCC End "dot_product", "eqv", "matmul", @@ -2163,6 +2278,7 @@ const char *SyminiFE90::init_names1[] = { "dshiftl", "dshiftr", "mask", + "rank", }; /** @@ -2180,6 +2296,7 @@ const char *SyminiFE90::init_names2[] = { ".cdsqrt", "cdsqrt", ".cqsqrt", + "cqsqrt", ".alog", "alog", ".dlog", @@ -2190,6 +2307,7 @@ const char *SyminiFE90::init_names2[] = { ".cdlog", "cdlog", ".cqlog", + "cqlog", ".alog10", "alog10", ".dlog10", @@ -2235,6 +2353,16 @@ const char *SyminiFE90::init_names2[] = { ".dcosd", "dcosd", ".qcosd", + "..cotan", + ".cotan", + ".dcotan", + "dcotan", + ".qcotan", + "..cotand", + ".cotand", + ".dcotand", + "dcotand", + ".qcotand", "..tan", ".tan", ".dtan", @@ -2284,7 +2412,6 @@ const char *SyminiFE90::init_names2[] = { ".atan2d", ".datan2d", "datan2d", - ".qatan2d", "..sinh", ".sinh", ".dsinh", @@ -2315,16 +2442,19 @@ const char *SyminiFE90::init_names2[] = { ".cdabs", "cdabs", ".cqabs", + "cqabs", "..aimag", ".aimag", ".dimag", "dimag", ".qimag", + "qimag", "..conjg", ".conjg", ".dconjg", "dconjg", ".qconjg", + "qconjg", "dprod", "imax0", ".max0", @@ -2485,6 +2615,12 @@ const char *SyminiFE90::init_names2[] = { ".2d", ".2c", ".2cd", +// AOCC begin + "qreal", + ".2q", + ".2c", + ".2cq", +// AOCC end "dint", "dnint", "..inint", @@ -2525,6 +2661,8 @@ const char *SyminiFE90::init_names2[] = { "sind", "cos", "cosd", + "cotan", + "cotand", "tan", "tand", "asin", @@ -2568,6 +2706,23 @@ const char *SyminiFE90::init_names2[] = { "any", "compl", "count", + // AOCC Begin + "bge", + "bgt", + "ble", + "blt", + "quad", + "maskl", + "maskr", + "merge_bits", + "norm2", + "isnan", + "parity", + "iparity" + "iall", + "iany", + "qcmplx", + // AOCC End "dot_product", "eqv", "matmul", @@ -2735,6 +2890,7 @@ const char *SyminiFE90::init_names2[] = { "ieee_set_flag", "ieee_set_halting_mode", "ieee_set_status", + "rank", }; /** @@ -2752,6 +2908,7 @@ const char *SyminiFE90::init_names3[] = { ".cdsqrt", "cdsqrt", ".cqsqrt", + "cqsqrt", ".alog", "alog", ".dlog", @@ -2762,6 +2919,7 @@ const char *SyminiFE90::init_names3[] = { ".cdlog", "cdlog", ".cqlog", + "cqlog", ".alog10", "alog10", ".dlog10", @@ -2807,6 +2965,16 @@ const char *SyminiFE90::init_names3[] = { ".dcosd", "dcosd", ".qcosd", + "..cotan", + ".cotan", + ".dcotan", + "dcotan", + ".qcotan", + "..cotand", + ".cotand", + ".dcotand", + "dcotand", + ".qcotand", "..tan", ".tan", ".dtan", @@ -2856,7 +3024,6 @@ const char *SyminiFE90::init_names3[] = { ".atan2d", ".datan2d", "datan2d", - ".qatan2d", "..sinh", ".sinh", ".dsinh", @@ -2887,16 +3054,19 @@ const char *SyminiFE90::init_names3[] = { ".cdabs", "cdabs", ".cqabs", + "cqabs", "..aimag", ".aimag", ".dimag", "dimag", ".qimag", + "qimag", "..conjg", ".conjg", ".dconjg", "dconjg", ".qconjg", + "qconjg", "dprod", "imax0", ".max0", @@ -3057,6 +3227,12 @@ const char *SyminiFE90::init_names3[] = { ".2d", ".2c", ".2cd", +// AOCC begin + "qreal", + ".2q", + ".2c", + ".2cq", +// AOCC end "dint", "dnint", "..inint", @@ -3097,6 +3273,8 @@ const char *SyminiFE90::init_names3[] = { "sind", "cos", "cosd", + "cotan", + "cotand", "tan", "tand", "asin", @@ -3140,6 +3318,23 @@ const char *SyminiFE90::init_names3[] = { "any", "compl", "count", + // AOCC Begin + "bge", + "bgt", + "ble", + "blt", + "quad", + "maskl", + "maskr", + "merge_bits", + "norm2", + "isnan", + "parity", + "iparity" + "iall", + "iany", + "qcmplx", + // AOCC End "dot_product", "eqv", "matmul", @@ -3308,8 +3503,12 @@ const char *SyminiFE90::init_names3[] = { "ieee_set_halting_mode", "ieee_set_status", "leadz", + // AOCC begin + "trailz", + // AOCC end "popcnt", "poppar", + "rank", }; const size_t SyminiFE90::init_names0_size = diff --git a/tools/flang1/utils/symtab/symini_ftn.n b/tools/flang1/utils/symtab/symini_ftn.n index 86a3a2e760..da8063dcc6 100644 --- a/tools/flang1/utils/symtab/symini_ftn.n +++ b/tools/flang1/utils/symtab/symini_ftn.n @@ -4,6 +4,38 @@ .\" * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception .\" * .\" */ +.\"/* +.\" * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +.\" * Notified per clause 4(b) of the license. +.\" * +.\" * Support for DNORM intrinsic +.\" * Date of Modification: 21st February 2019 +.\" * +.\" * Support for EXECUTE_COMMAND_LINE intrinsic +.\" * Date of Modification: July 2019 +.\" * +.\" * Support for parity intrinsic. +.\" * Month of Modification: July 2019 +.\" * +.\" * Support for Bit transformational intrinsic iany, iall, iparity. +.\" * Month of Modification: July 2019 +.\" * +.\" * Added code to support SHIFTA intrinsic +.\" * Last modified: April 2020 +.\" * +.\" * Complex datatype support for atan2 under flag f2008 +.\" * Modified on 13th March 2020 +.\" +.\" * Implemented rank intrinsic +.\" * Date of modification: 10th Aug 2020 +.\" +.\" * Added code support for dasinh +.\" * Modified on 31st Aug 2020 +.\" +.\" * Added code support for cotan +.\" * Modified on Oct 2020 +.\" +.\" */ .NS 28 "Intrinsics & Generics" "Appendix VII - " .de IN .sp @@ -313,6 +345,32 @@ sptr name pcnt atyp dtype ILM pname arrayf native? .IN .QCOSD 1 Q Q none * V .AT elemental x +.IN ..COTAN 1 R R none * V +.AT elemental x +.IN .COTAN 1 R R none * V +.AT elemental x +.IN .DCOTAN 1 D D none * V +.AT elemental x +.IN DCOTAN 1 D D none * V +.AT elemental x +.IN .QCOTAN 1 Q Q none * V +.AT elemental x +.IN QCOTAN 1 Q Q none * V +.AT elemental x + +.IN ..COTAND 1 R R none * V +.AT elemental x +.IN .COTAND 1 R R none * V +.AT elemental x +.IN .DCOTAND 1 D D none * V +.AT elemental x +.IN DCOTAND 1 D D none * V +.AT elemental x +.IN .QCOTAND 1 Q Q none * V +.AT elemental x +.IN QCOTAND 1 Q Q none * V +.AT elemental x + .IN ..TAN 1 R R none * V .AT elemental x .IN .TAN 1 R R none * V @@ -431,6 +489,10 @@ sptr name pcnt atyp dtype ILM pname arrayf native? .AT elemental x .IN DSINH 1 D D none * V .AT elemental x +.IN .DASINH 1 D D none * V +.AT elemental x +.IN DASINH 1 D D none * V +.AT elemental x .IN .QSINH 1 Q Q none * V .AT elemental x @@ -498,6 +560,8 @@ sptr name pcnt atyp dtype ILM pname arrayf native? .AT elemental z .IN .QIMAG 1 CQ Q QIMAG * V .AT elemental x +.IN QIMAG 1 CQ Q QIMAG * V +.AT elemental z .IN ..CONJG 1 C C CONJG * V .AT elemental z @@ -509,6 +573,8 @@ sptr name pcnt atyp dtype ILM pname arrayf native? .AT elemental z .IN .QCONJG 1 CQ CQ QCONJG * V .AT elemental x +.IN QCONJG 1 CQ CQ QCONJG * V +.AT elemental z .IN DPROD 2 R D DPROD * V .AT elemental x y @@ -648,6 +714,8 @@ sptr name pcnt atyp dtype ILM pname arrayf native? .AT elemental a p .IN .DMODULO 2 D D none -pgf90_dmodulo V .AT elemental a p +.IN ..QMODULO 2 Q Q none -pgf90_qmodulo V +.AT elemental a p .IN .QMODULO 2 Q Q none -pgf90_qmodulo V .AT elemental a p @@ -777,6 +845,13 @@ sptr name pcnt atyp dtype ILM pname arrayf native? .IN .KRSHIFT 2 I8 I8 none - .AT elemental i shift +.IN .ISHIFTA 2 SI SI none - +.AT elemental i shift +.IN .JSHIFTA 2 I I none - +.AT elemental i shift +.IN .KSHIFTA 2 I8 I8 none - +.AT elemental i shift + .IN .2SCH 1 SI H CHAR - .AT elemental i .IN .CHAR 1 I H CHAR - @@ -870,6 +945,11 @@ Extension to Fortran-77. .IN DREAL 1 CD D tc .AT elemental a Converts complex*16 to double. +.\" AOCC begin +.IN QREAL 1 CQ Q tc +Converts complex*32 to quad. +.AT elemental a +.\" AOCC end .IN .2D 1 N D tc Convert any numeric data type to double precision. .AT elemental a @@ -879,6 +959,14 @@ Convert any numeric data type to complex. .IN .2CD 11 N CD tc Convert any numeric data type to double complex. .AT elemental a +.\" AOCC begin +.IN .2Q 1 N Q tc +Convert any numeric data type to quad precision. +.AT elemental a +.IN .2CQ 11 N CQ tc +Convert any numeric data type to quad complex. +.AT elemental a +.\" AOCC end .IN DINT 1 D D none * V .AT elemental a @@ -937,11 +1025,17 @@ sptr name siname iname rname dname cname cdname i8name .AT elemental a .GN DCMPLX .2CD .2CD .2CD .2CD .2CD .2CD .2CD .2CD .2CD .AT elemental x *y -.GN IMAG - - - - .AIMAG DIMAG - - .QIMAG +./" AOCC begin +.GN QUAD QFLOTI QFLOAT .2Q .2Q .2Q QREAL .2Q .2Q .2Q +.AT elemental a +.GN QCMPLX .2CQ .2CQ .2CQ .2CQ .2CQ .2CQ .2CQ .2CQ .2CQ +.AT elemental x *y +./" AOCC end +.GN IMAG - - - - .AIMAG DIMAG - QIMAG QIMAG .AT elemental z -.GN AIMAG - - - - .AIMAG DIMAG - - .QIMAG +.GN AIMAG - - - - .AIMAG DIMAG - QIMAG QIMAG .AT elemental z -.GN CONJG - - - - .CONJG DCONJG - - .QCONJG +.GN CONJG - - - - .CONJG DCONJG - QCONJG QCONJG .AT elemental z .GN ININT - - .ININT IIDNNT - - - - - .AT elemental a @@ -967,14 +1061,18 @@ sptr name siname iname rname dname cname cdname i8name .AT elemental x .GN LOG10 - - ALOG10 DLOG10 - - - .QLOG10 - .AT elemental x -.GN SIN - - .SIN DSIN CSIN CDSIN - .QSIN .CQSIN +.GN SIN - - .SIN DSIN CSIN CDSIN - .QSIN .CQSIN CQSIN .AT elemental x -.GN SIND - - .SIND DSIND - - - .QSIN .CQSIN +.GN SIND - - .SIND DSIND - - - .QSIND .CQSIND .AT elemental x .GN COS - - .COS DCOS CCOS CDCOS - .QCOS .CQCOS .AT elemental x .GN COSD - - .COSD DCOSD - - - .QCOSD - .AT elemental x +.GN COTAN - - .COTAN DCOTAN - - - .QCOTAN - +.AT elemental x +.GN COTAND - - .COTAND DCOTAND - - - .QCOTAND - +.AT elemental x .GN TAN - - .TAN DTAN - - - .QTAN - .AT elemental x .GN TAND - - .TAND DTAND - - - .QTAND - @@ -1015,6 +1113,8 @@ sptr name siname iname rname dname cname cdname i8name .AT elemental i shift .GN RSHIFT .IRSHIFT .JRSHIFT - - - - .KRSHIFT - - .AT elemental i shift +.GN SHIFTA .ISHIFTA .JSHIFTA - - - - .KSHIFTA - - +.AT elemental i shift .GN MODULO .IMODULO .MODULO .AMODULO .DMODULO - - .KMODULO .QMODULO - .AT elemental a p .bp @@ -1080,6 +1180,32 @@ Translates to a call to either \*(cfftn_imvbits\*(rf or .\" --------------------- .\" Predeclared Functions .\" --------------------- +.PD BGE - - +.AT elemental i j +.PD BGT - - +.AT elemental i j +.PD BLE - - +.AT elemental i j +.PD BLT - - +.AT elemental i j + +.PD MASKL - - +.AT elemental i *kind +.PD MASKR - - +.AT elemental i *kind + +.PD SHIFTL - - +.AT elemental i j +.PD SHIFTR - - +.AT elemental i j + +.PD DSHIFTL - - +.AT elemental i j shift +.PD DSHIFTR - - +.AT elemental i j shift + +.PD MERGE_BITS - - +.AT elemental i j mask .PD REAL - - .AT elemental a *kind .PD CMPLX - - @@ -1114,10 +1240,26 @@ The JZEXT intrinsic; result is integer*4, arg is any logical or integer. .AT elemental -- .PD ANY - - .AT transformational mask *dim +.PD PARITY - - +.AT transformational mask *dim +.PD IALL - - +.AT transformational array *dim *mask +.PD IANY - - +.AT transformational array *dim *mask +.PD IPARITY - - +.AT transformational array *dim *mask .PD COMPL - - .AT elemental -- .PD COUNT - - .AT transformational mask *dim +.PD NORM2 - - +.AT transformational array *dim +.PD ISNAN - - +.AT elemental x +.PD EXECUTE_COMMAND_LINE - - +.AT subroutine command *wait *exitstat *cmdstat *cmdmsg +.PD MM_PREFETCH - - +.AT subroutine address *hint .PD DOT_PRODUCT - - .AT transformational vector_a vector_b .PD EQV - - @@ -1129,11 +1271,11 @@ The JZEXT intrinsic; result is integer*4, arg is any logical or integer. .PD MAXLOC - - .AT transformational array *dim *mask *kind *back .PD MAXVAL - - -.AT transformational array *dim *mask +.AT transformational array *dim *mask .PD MINLOC - - .AT transformational array *dim *mask *kind *back .PD MINVAL - - -.AT transformational array *dim *mask +.AT transformational array *dim *mask .PD MERGE - - .AT elemental tsource fsource mask .PD NEQV - - @@ -1178,6 +1320,8 @@ of its single-precision (double-precision) argument. .AT transformational source shape *pad *order .PD SHAPE - - .AT transformational source *kind +.PD RANK - - +.AT transformational source *kind .PD SIZE - - .AT inquiry array *dim *kind .PD ALLOCATED - - @@ -1198,8 +1342,8 @@ of its single-precision (double-precision) argument. .AT inquiry x .PD SELECTED_INT_KIND - - .AT transformational r -.PD SELECTED_REAL_KIND - - -.AT transformational *p *r +.PD SELECTED_REAL_KIND - - - +.AT transformational *p *r *radix .PD .DLBOUND - - CM Fortran's version of LBOUND. .AT inquiry array *dim @@ -1209,6 +1353,9 @@ CM Fortran UBOUND intrinsic. .PD .DSHAPE - - CM Fortran SHAPE intrinsic. .AT transformational source +.PD .DRANK - - +CM Fortran SHAPE intrinsic. +.AT transformational source .PD .DSIZE - - CM Fortran SIZE intrinsic. .AT inquiry array *dim @@ -1538,6 +1685,8 @@ Internal subroutine to perform a copy out of an ordinary argument. .AT transformational array *dim *mask *segment *exclusive .H1 LEADZ - - .AT elemental i +.H1 TRAILZ - - +.AT elemental i .H1 MAXVAL_PREFIX - - .AT transformational array *dim *mask *segment *exclusive .H1 MAXVAL_SCATTER - - @@ -1698,14 +1847,6 @@ Internal subroutine to perform a copy out of an ordinary argument. .AT elemental x .H4 DCOT * - .AT elemental x -.H4 SHIFTL - - -.AT elemental i j -.H4 SHIFTR - - -.AT elemental i j -.H4 DSHIFTL - - -.AT elemental i j k -.H4 DSHIFTR - - -.AT elemental i j k .H4 MASK - - .AT elemental i .bp @@ -1779,7 +1920,7 @@ sptr name pcnt atyp dtype ILM pname arrayf native? .H5 IEEE_VALUE - - .AT elemental x class .H5 IEEE_SELECTED_REAL_KIND - - -.AT transformational *p *r +.AT transformational *p *r *radix .H5 IEEE_GET_ROUNDING_MODE - - .AT subroutine round value .H5 IEEE_GET_UNDERFLOW_MODE - - @@ -1822,16 +1963,8 @@ sptr name pcnt atyp dtype ILM pname arrayf native? .AT elemental i .H7 POPPAR - - .AT elemental i -.H7 .TRAILZ - - +.H7 TRAILZ - - .AT elemental i -.H7 .BGE - - -.AT elemental i j -.H7 .BGT - - -.AT elemental i j -.H7 .BLE - - -.AT elemental i j -.H7 .BLT - - -.AT elemental i j .H7 .MASKL - - .AT elemental i *kind .H7 .MASKR - - @@ -1842,12 +1975,6 @@ sptr name pcnt atyp dtype ILM pname arrayf native? .AT elemental i shift .H7 .SHIFTR - - .AT elemental i shift -.H7 .DSHIFTL - - -.AT elemental i j shift -.H7 .DSHIFTR - - -.AT elemental i j shift -.H7 .MERGE_BITS - - -.AT elemental i j mask .H7 .IALL - - .AT transformational array *dim *mask .H7 .IANY - - @@ -1861,7 +1988,7 @@ sptr name pcnt atyp dtype ILM pname arrayf native? .H7 ASINH - - .AT elemental x .H7 ATANH - - -.AT elemental x +.AT elemental x y .H7 BESSEL_J0 - - .AT elemental x .H7 BESSEL_J1 - - diff --git a/tools/flang1/utils/symtab/symtab.in.h b/tools/flang1/utils/symtab/symtab.in.h index 29c3d06015..c11f4ca4c1 100644 --- a/tools/flang1/utils/symtab/symtab.in.h +++ b/tools/flang1/utils/symtab/symtab.in.h @@ -4,6 +4,12 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified : Jun 2020 + */ #ifndef SYMTAB_H_ #define SYMTAB_H_ @@ -43,6 +49,7 @@ #define DT_LOG stb.dt_log #define DT_DBLE stb.dt_dble #define DT_DCMPLX stb.dt_dcmplx +#define DT_QCMPLX stb.dt_qcmplx // AOCC #define DT_PTR stb.dt_ptr #define DT_FLOAT DT_REAL4 diff --git a/tools/flang1/utils/symtab/symtab.n b/tools/flang1/utils/symtab/symtab.n index 37251e7844..bd61214882 100644 --- a/tools/flang1/utils/symtab/symtab.n +++ b/tools/flang1/utils/symtab/symtab.n @@ -2,7 +2,13 @@ .\" * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. .\" * See https://llvm.org/LICENSE.txt for license information. .\" * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -.\" * +.\" * +.\" * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +.\" * Notified per clause 4(b) of the license. +.\" * +.\" * Added support for quad precision +.\" * Last modified: Feb 2020 +.\" * .\" */ .NS 27 "Symbol Table" .de OC \"overloading class @@ -1851,6 +1857,10 @@ undefined. .ip \f(CWTY_DBLE\fP First 32-bit word of d.p. constant in SC format. +.\" AOCC begin +.ip \f(CWTY_QUAD\fP +First 32-bit word of quad precision constant. +.\" AOCC end .ip \f(CWTY_FLOAT128\fP First 32-bit word of quad constant. .ip \f(CWTY_CMPLX\fP @@ -1893,6 +1903,10 @@ Second constant value: 32-bit floating point value. .ip \f(CWTY_DBLE\fP Second 32-bit word of double precision constant. +.\" AOCC begin +.ip \f(CWTY_QUAD\fP +Second 32-bit word of quad precision constant. +.\" AOCC end .ip \f(CWTY_FLOAT128\fP Second 32-bit word of quad constant. .ip \f(CWTY_CMPLX\fP @@ -2110,8 +2124,11 @@ means the arguments can be either .cw DT_INT , .cw DT_REAL , .cw DT_DBLE , +.\" AOCC +.cw DT_QUAD , .cw DT_CMPLX , or +.cw DT_QCMPLX . .cw DT_DCMPLX . .cw DT_WORD means the argument must be one of the 32-bit data types, @@ -2862,6 +2879,7 @@ means the arguments can be either .cw DT_DBLE , .cw DT_CMPLX , or +.cw DT_QCMPLX . .cw DT_DCMPLX . .cw DT_WORD means the argument must be one of the 32-bit data types, @@ -3219,7 +3237,8 @@ on context. Internal to the Fortran compiler. .PD DT_CMPLX4 "half complex" TY_HCMPLX .PD DT_CMPLX8 complex TY_CMPLX .PD DT_CMPLX16 "double complex" TY_DCMPLX -.PD DT_QCMPLX "complex*32" TY_QCMPLX +.PD DT_CMPLX32 "quad complex" TY_QCMPLX +./" .PD DT_QCMPLX "complex*32" TY_QCMPLX .PD DT_BLOG "logical*1" TY_BLOG .PD DT_SLOG "logical*2" TY_SLOG .PD DT_LOG4 "logical" TY_LOG @@ -3242,10 +3261,14 @@ Integer array (1:1); this predeclared data type is filled in by ast_init(). .PD DT_128F "__m128" TY_128 .PD DT_128D "__m128d" TY_128 +.\" AOCC +.PD DT_128Q "__m128q" TY_128 .PD DT_128I "__m128i" TY_128 .PD DT_256 "256-bit" TY_256 .PD DT_256F "__m256" TY_256 +.\" AOCC .PD DT_256D "__m256d" TY_256 +.PD DT_256Q "__m256q" TY_256 .PD DT_256I "__m256i" TY_256 .PD DT_512 "512-bit" TY_512 .PD DT_512F "__m512" TY_512 diff --git a/tools/flang2/CMakeLists.txt b/tools/flang2/CMakeLists.txt index 9a2dde76d0..9b148d4d93 100644 --- a/tools/flang2/CMakeLists.txt +++ b/tools/flang2/CMakeLists.txt @@ -35,6 +35,11 @@ if (FLANG_OPENMP_GPU_NVIDIA) add_definitions("-DOMP_OFFLOAD_LLVM") endif() +option(FLANG_OPENMP_GPU_AMD "Enable OpenMP AMD Accelerator Offload." OFF) +if (FLANG_OPENMP_GPU_AMD) + add_definitions("-DOMP_OFFLOAD_AMD") +endif() + add_subdirectory(include) add_subdirectory(utils) add_subdirectory(flang2exe) diff --git a/tools/flang2/docs/expander.n b/tools/flang2/docs/expander.n index 46ec7e0237..0e9498a1d3 100644 --- a/tools/flang2/docs/expander.n +++ b/tools/flang2/docs/expander.n @@ -3,6 +3,12 @@ .\" * See https://llvm.org/LICENSE.txt for license information. .\" * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception .\" * +.\" * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +.\" * Notified per clause 4(b) of the license. +.\" * +.\" * Added support for quad precision +.\" * Last modified: Feb 2020 +.\" * .\" */ .NS 6 Expander .sh 2 "Overview" @@ -916,6 +922,12 @@ The remaining ILIs are for loading and storing pointers (\c .cw PLD and .cw PST ), +.\" AOCC begin +loading and storing quad (\c +.cw QPLD +and +.cw QPST ), +.\" AOCC end loading and storing doubles (\c .cw DLD and @@ -928,8 +940,8 @@ are of the form: .(b L .TS LfCW LfCW. -LDA/LDDP/LDSP adr sym PLD/DLD/RLD -STA/STDP/STSP val adr sym1 PST/DST/RST +LDA/LDDP/LDSP/LDQP adr sym PLD/DLD/RLD/QPLD +STA/STDP/STSP/STQP val adr sym1 PST/DST/RST/QPST .TE .)b .lp @@ -1403,6 +1415,10 @@ register), floating register), .cw IL_ARGDP (double precision floating register). +.\" AOCC begin +.cw IL_ARGQP +(quad precision floating register). +.\" AOCC end .np generating the ILI to push the argument count on the stack. @@ -1452,6 +1468,12 @@ This is one of: .cw "DFRDP\ lnk\ 0" \(em double precision result; 0 indicates .cw DP(0) . +.\" AOCC begin +.ip \(bu 4n +.cw "DFRQP\ lnk\ 0" +\(em quad precision result; 0 indicates +.cw QP(0) . +.\" AOCC end .ba -5n .lp If the function is a diff --git a/tools/flang2/docs/ili.n b/tools/flang2/docs/ili.n index 8c51e55a4f..752c985481 100644 --- a/tools/flang2/docs/ili.n +++ b/tools/flang2/docs/ili.n @@ -3,6 +3,12 @@ .\" * See https://llvm.org/LICENSE.txt for license information. .\" * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception .\" * +.\" * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +.\" * Notified per clause 4(b) of the license. +.\" * +.\" * Added support for quad precision +.\" * Last modified: Feb 2020 +.\" * .\" */ .NS 13 ILI .re @@ -1000,7 +1006,7 @@ The move ILI are divided into two types: .np The move ILI whose link is type IR, DP, SP, or AR to a data register, double precision register, or address register, respectively. -These ILIs (MVIR, MVDP, MVSP, and MVAR) are terminal ILIs and also +These ILIs (MVIR, MVDP, MVQP, MVSP, and MVAR) are terminal ILIs and also specify the destination register. .np The move ILIs which convert type AR to IR or IR to AR (AIMV or diff --git a/tools/flang2/docs/xflag.n b/tools/flang2/docs/xflag.n index 7e4c5983c1..8d44ba0cad 100644 --- a/tools/flang2/docs/xflag.n +++ b/tools/flang2/docs/xflag.n @@ -4,6 +4,17 @@ .\" * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception .\" * .\" */ +.\"/* +.\" * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +.\" * Notified per clause 4(b) of the license. +.\" * +.\" * Support for DNORM intrinsic +.\" * Date of Modification: 21st February 2019 +.\" * +.\" * Support for vector and novector directives +.\" * Date of Modification: 19th July 2019 +.\" * +.\" */ .NS 18 "Other Compiler Switches" .nr ii 8 @@ -161,6 +172,8 @@ describe when loops can not be parallelized For PFO. .XB 0x80000: For PRE. +.XB 0x100000: +warn if using uninitialized variables. .XF "2:" Used to turn on various non-standard optimizations @@ -222,6 +235,8 @@ F90 pointer optimizations. Use GSMOVE in exp_rte.c .XB 0x1000000 Don't expand SMOVEs (struct moves) in a single IL_SMOVEI/IL_SMOVES +.XB 0x2000000 +[experimental] Enable aggressive gep folding. .XF "3:" Used to turn on/off various dual-op/dual-inst/pipelined ops. @@ -536,11 +551,9 @@ iteration count. .XF "11:" Unrolling .XB "0x01:" -Inhibit completely unrolling a loop (constant loop count); -for control by directive/pragma +Enable completely unrolling a loop when the UNROLL directive is used. .XB "0x02:" -Inhibit unrolling a loop with a non-constant loop count; -for control by directive/pragma +Enable unrolling a loop by a factor specified via the UNROLL(n) directive. .XB "0x04:" (I386,X86_64) Ignore the check of the number of variable strides. @@ -853,7 +866,7 @@ independent loop (forall-independent loop). .XB "0x200" don't perform tail recursion elimination .XB "0x400" -don't perform idiom vector recognition for the PIII +perform loop vectorisation. .XB "Ox800" Perform zero trip elimination - will we ever be able to switch the sense? .XB "0x1000" @@ -1735,6 +1748,9 @@ Don't use cgr_modifies() (optutil.c:is_static_call_safe()). .XB 0x400000 Disable propagation of certain IPA pointer information from actual arguments to ..inline temporaries when a call-site is inlined. +.XB 0x800000 +[experimental] Assume fortran pointer address loads (not to be confused with the +load of the element at that address) can't alias. .XF "54:" More Flang behavior modification @@ -2076,6 +2092,8 @@ Inhibit MAX/MIN optimization whereby the results of the MAX/MIN are stored directly within ili template. .XB 0x08: Generate position-independent code +.XB 0x10 +(D)SIGN distinguishes negative zero. .XF "63" Used to pass opt level to CUDA back end code generator. @@ -2278,6 +2296,8 @@ Execute tasks immediately In the outliner used for KPMC openmp regions, when filling the argument .XB 0x100000: Enable nodepchk for simd construct/clause. +.XB 0x200000: +Enable nodepchk for ivdep pragma (and SIMD pragma for now). .XF "70-79:" RESERVED FOR ALTERNATE CODE GENERATION @@ -3220,9 +3240,9 @@ allocated locals on Mac OS X. .XB 0x800000: Do not emit artificial dwarf entries for compiler-created arguments to function/subroutine. .XB 0x1000000 -AVAILABLE +Set the dwarf version to 4. .XB 0x2000000 -AVAILABLE +Set the dwarf version to 5. .XB 0x4000000: Do not generate include file tables. .XB 0x8000000h @@ -3232,7 +3252,7 @@ Generating eh_frame. .XB 0x20000000: Generating eh_frame with .cfi directives: requires 120,0x10000000 to be on .XB 0x40000000 -AVAILABLE +Generate .debug_names/.debug_pubnames section. .XB 0x80000000: no license check in executable. @@ -3431,7 +3451,7 @@ Use the legacy Fortran preprocessor (fpp), and not the ANSI-C99 preprocessor. .XB 0x8000000 Preprocessor puts out dependence lines to gbl.cppfil instead of file.d or stdout .XB 0x10000000 -Unused. +With -fopenmp and -g options, XBIT(123,0x400) is set by default. This option overrides it. .XB 0x20000000 preprocessor generates makefile information to stdout; driver option -MT .XB 0x40000000 @@ -4808,7 +4828,7 @@ size from integer power elements .XB 0x2000000: Switch definition of "long double" on Power from "double double" to __float128 .XB 0x4000000: -Disable generation of !llvm.loop metadata +Disable generation of !llvm.loop metadata. !DIR$ novector / !pgi$l novector .XB 0x8000000: (C/C++ only) Disable the LLVM inliner by marking all routines with the LLVM attribute 'noinline'. .XB 0x10000000: @@ -4817,6 +4837,8 @@ Enable arithmetic widening on address arithmetic. Put constants in non read-only memories. .XB 0x40000000: Emit DWARF name for Fortran COMMON blocks. +.XB 0x80000000: +Enable generation of !llvm.loop metadata. !DIR$ vector / !pgi$l vector .XF "184:" ARM modifications @@ -5037,6 +5059,8 @@ Temporary flags .XB 0x01: Turn on C++ prototype implementation of the gnu visibility attribute "hidden" +.XB 0x02: +Enable "alwaysinline" attribute for a function, using "forceinline" pragma .XF "192:" More Accelerator flags @@ -5241,7 +5265,9 @@ Non-zero value enable -Mvect=fastfuse. This flag is/must be passed only when to enable -Mvect=fastfuse. default value is 10. .XF "200:" -how many levels of inlining to do from leaves for bottom-up auto-inlining +Extended metadata flags +.XB 0x01: +Signify IVDEP pragma. .XF "201:" Enable/Disable Accelerator optimizations @@ -5446,6 +5472,11 @@ This sets the maximum caller function size into which to Minline. .XF "222:" Functions whose size if smaller than this value will get inlined by Minline. +.XF "230" +Reserved : AMD GPU Offloading flags +.XB 0x01 +Emit target mode mode_target_teams_distribute_parallel_for_simd whenever possible + .XF "232:" OpenMP Accelerator Model flags for Flang compiler .XB 0x01: diff --git a/tools/flang2/flang2exe/CMakeLists.txt b/tools/flang2/flang2exe/CMakeLists.txt index ac29d9771d..53607e1f08 100644 --- a/tools/flang2/flang2exe/CMakeLists.txt +++ b/tools/flang2/flang2exe/CMakeLists.txt @@ -3,6 +3,12 @@ # See https://llvm.org/LICENSE.txt for license information. # SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception # +# +# Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +# Notified per clause 4(b) of the license. +# +# Last Modified: May 2020 +# if( ${TARGET_ARCHITECTURE} STREQUAL "x86_64" ) set(ARCH_DEP_FILES @@ -73,6 +79,9 @@ set(SOURCES kmpcutil.cpp verify.cpp ompaccel.cpp + # AOCC begin + ompaccel_x86.cpp + # AOCC end tgtutil.cpp ) @@ -157,7 +166,7 @@ target_include_directories(flang2 # Install flang2 executable install(TARGETS flang2 - RUNTIME DESTINATION bin) + RUNTIME DESTINATION ${DEVEL_PACKAGE}${CMAKE_INSTALL_BINDIR}) # Local Variables: # mode: cmake diff --git a/tools/flang2/flang2exe/aarch64-Linux/ll_abi.cpp b/tools/flang2/flang2exe/aarch64-Linux/ll_abi.cpp index 633b5438db..ebabd7ea71 100644 --- a/tools/flang2/flang2exe/aarch64-Linux/ll_abi.cpp +++ b/tools/flang2/flang2exe/aarch64-Linux/ll_abi.cpp @@ -4,6 +4,12 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified : Jun 2020 + */ /* ll_abi.c - Lowering arm function calls to LLVM IR. * @@ -74,6 +80,11 @@ update_homogeneous(void *context, DTYPE dtype, unsigned address, case DT_DCMPLX: dtype = DT_DBLE; break; + // AOCC begin + case DT_QCMPLX: + dtype = DT_QUAD; + break; + // AOCC end } size = size_of(dtype); diff --git a/tools/flang2/flang2exe/bih.h b/tools/flang2/flang2exe/bih.h index ced19d4733..9b8a5c0e67 100644 --- a/tools/flang2/flang2exe/bih.h +++ b/tools/flang2/flang2exe/bih.h @@ -62,7 +62,8 @@ typedef struct { unsigned parsect : 1; /* bih belongs to a parallel section */ unsigned ujres : 1; /* bih contains ujresidual start & count info */ - unsigned simd : 1; /* bih contains simd code */ + unsigned simd : 1; /* bih contains simd code */ + unsigned nosimd : 1; /* bih does not contain simd code */ unsigned ldvol : 1; /* bih contains a load from volatile space */ unsigned stvol : 1; /* bih contains a store to volatile space */ @@ -115,6 +116,9 @@ typedef struct { unsigned rpct_confl : 1; /* block contains the RPCT conflict loop */ unsigned rt_guarded : 1; /* block contains runtime guarded loop */ unsigned doconc : 1; /* bih is the head of a do concurrent loop */ + unsigned unroll : 1; /* bih is a loop to be fully unrolled */ + unsigned unroll_cnt : 1; /* bih has a user-specified unroll factor */ + unsigned nounroll : 1; /* bih is a loop that must not be unrolled */ } bits; } flags2; int lpcntFrom; /* When a loop count temp is created, record the induction @@ -190,6 +194,7 @@ typedef struct { #define BIH_PARSECT(i) bihb.stg_base[i].flags.bits.parsect #define BIH_UJRES(i) bihb.stg_base[i].flags.bits.ujres #define BIH_SIMD(i) bihb.stg_base[i].flags.bits.simd +#define BIH_NOSIMD(i) bihb.stg_base[i].flags.bits.nosimd #define BIH_LDVOL(i) bihb.stg_base[i].flags.bits.ldvol #define BIH_STVOL(i) bihb.stg_base[i].flags.bits.stvol #define BIH_ASM(i) bihb.stg_base[i].flags.bits.gasm @@ -228,6 +233,9 @@ typedef struct { #define BIH_FTAG(i) bihb.stg_base[i].ftag #define BIH_BLKCNT(i) bihb.stg_base[i].blkCnt #define BIH_AVLPCNT(i) bihb.stg_base[i].aveLpCnt +#define BIH_UNROLL(i) bihb.stg_base[i].flags2.bits.unroll +#define BIH_UNROLL_COUNT(i) bihb.stg_base[i].flags2.bits.unroll_cnt +#define BIH_NOUNROLL(i) bihb.stg_base[i].flags2.bits.nounroll #define EXEC_COUNT double #define UNKNOWN_EXEC_CNT -1.0 diff --git a/tools/flang2/flang2exe/bihutil.cpp b/tools/flang2/flang2exe/bihutil.cpp index a1c63899d0..9b9cfb0a77 100644 --- a/tools/flang2/flang2exe/bihutil.cpp +++ b/tools/flang2/flang2exe/bihutil.cpp @@ -216,6 +216,7 @@ merge_bih_flags(int to_bih, int fm_bih) BIH_INVIF(to_bih) = BIH_INVIF(to_bih) | BIH_INVIF(fm_bih); BIH_NOINVIF(to_bih) = BIH_NOINVIF(to_bih) | BIH_NOINVIF(fm_bih); BIH_SIMD(to_bih) = BIH_SIMD(to_bih) | BIH_SIMD(fm_bih); + BIH_NOSIMD(to_bih) = BIH_NOSIMD(to_bih) | BIH_NOSIMD(fm_bih); BIH_RESID(to_bih) = BIH_RESID(to_bih) | BIH_RESID(fm_bih); BIH_VCAND(to_bih) = BIH_VCAND(to_bih) | BIH_VCAND(fm_bih); BIH_MIDIOM(to_bih) = BIH_MIDIOM(to_bih) | BIH_MIDIOM(fm_bih); @@ -224,6 +225,9 @@ merge_bih_flags(int to_bih, int fm_bih) BIH_LDVOL(to_bih) = BIH_LDVOL(to_bih) | BIH_LDVOL(fm_bih); BIH_STVOL(to_bih) = BIH_STVOL(to_bih) | BIH_STVOL(fm_bih); BIH_NODEPCHK(to_bih) = BIH_NODEPCHK(to_bih) | BIH_NODEPCHK(fm_bih); + BIH_UNROLL(to_bih) = BIH_UNROLL(to_bih) | BIH_UNROLL(fm_bih); + BIH_UNROLL_COUNT(to_bih) = BIH_UNROLL_COUNT(to_bih) | BIH_UNROLL_COUNT(fm_bih); + BIH_NOUNROLL(to_bih) = BIH_NOUNROLL(to_bih) | BIH_NOUNROLL(fm_bih); if (BIH_TAIL(fm_bih)) BIH_TAIL(to_bih) = 1; diff --git a/tools/flang2/flang2exe/cgllvm.h b/tools/flang2/flang2exe/cgllvm.h index 4330249ef2..8f2ff0ba60 100644 --- a/tools/flang2/flang2exe/cgllvm.h +++ b/tools/flang2/flang2exe/cgllvm.h @@ -25,7 +25,7 @@ void cprintf(char *s, const char *format, INT *val); ((s) == ST_STRUCT || (s) == ST_UNION || (s) == ST_ARRAY) #define AGGREGATE_DTYPE(d) \ ((DTY(d)) == TY_STRUCT || (DTY(d)) == TY_UNION || (DTY(d)) == TY_ARRAY) -#define COMPLEX_DTYPE(d) ((DTY(d)) == TY_CMPLX || (DTY(d)) == TY_DCMPLX) +#define COMPLEX_DTYPE(d) ((DTY(d)) == TY_CMPLX || (DTY(d)) == TY_DCMPLX || (DTY(d)) == TY_QCMPLX) #define VECTOR_DTYPE(d) ((DTY(d)) == TY_VECT) #define LLCCF_NEG \ diff --git a/tools/flang2/flang2exe/cgmain.cpp b/tools/flang2/flang2exe/cgmain.cpp index 5e04466f5b..a2f5a8e1e5 100644 --- a/tools/flang2/flang2exe/cgmain.cpp +++ b/tools/flang2/flang2exe/cgmain.cpp @@ -5,6 +5,62 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights + * reserved. Notified per clause 4(b) of the license. + * + * Support for ivdep directive + * Date of Modification: 11th march 2019 + * + * Support for vector and novector directives + * Date of Modification: 19th July 2019 + * + * Support for x86-64 OpenMP offloading + * Last modified: Sept 2019 + * + * Support for volatile in NME + * Date of modification 05th September 2019 + * + * Added some SPTR allocation code changes + * Date of modification 19th September 2019 + * + * Changes to support AMDGPU OpenMP offloading + * Date of modification Dec 2020 + * + * Compile time improvement changes + * Date of modification 14th November 2019 + * + * Allowing declaration of sqrt function in target module + * Date of modification 31st Jan 2020 + * + * Added support for quad precision + * Last modified: Feb 2020 + * + * Allowing declaration of __ockl_get* functions in target module + * Date of modification 14th February 2020 + * + * Support for Real128 support for math intrinsics + * Date of modification 24th February 2020 + * + * get_alloca_addrspace function is made public. + * Date of modification 13th April 2020 + * + * Added code to support SHIFTA intrinsic + * Last modified: April 2020 + * + * Added code to support SHIFTA intrinsic + * Last modified: April 2020 + * + * Last modified: Jun 2020 + * + * Added quad support for floor and ceiling intrinsics + * Last modified: August 2020 + * + * Added quad support for cotan and cotand intrinsics + * Last modified: Oct 2020 + * + */ + /** \file \brief Main source module to translate into LLVM @@ -40,6 +96,10 @@ #include "ccffinfo.h" #include "main.h" #include "symfun.h" +#include "ilidir.h" +// AOCC Begin +#include "direct.h" +// AOCC End #ifdef OMP_OFFLOAD_LLVM #include "ompaccel.h" @@ -231,6 +291,13 @@ static int *idxstack = NULL; static hashmap_t sincos_map; static hashmap_t sincos_imap; static LL_MDRef cached_loop_metadata; +static LL_MDRef cached_unroll_enable_metadata; +static LL_MDRef cached_unroll_disable_metadata; +// AOCC Begin +static LL_MDRef cached_loop_vec_metadata; +static LL_MDRef cached_loop_ivdep_metadata; +static LL_MDRef access_group_metadata; +// AOCC End static bool CG_cpu_compile = false; @@ -329,6 +396,7 @@ static const char *get_atomicrmw_opname(LL_InstrListFlags); static const char *get_atomic_memory_order_name(int); static void insert_llvm_memcpy(int, int, OPERAND *, OPERAND *, int, int, int); static void insert_llvm_memset(int, int, OPERAND *, int, int, int, int); +static void insert_llvm_prefetch(int ilix, OPERAND *dest_op); static SPTR get_call_sptr(int); static LL_Type *make_function_type_from_args(LL_Type *return_type, OPERAND *first_arg_op, @@ -682,7 +750,7 @@ gen_return_operand(int ilix) if (has_multiple_entries(gbl.currsub) && (rtype->data_type == LL_VOID) && (dty != TY_NONE) && (dty != TY_CHAR) && (dty != TY_NCHAR) #if !defined(TARGET_LLVM_POWER) - && (dty != TY_CMPLX) && (dty != TY_DCMPLX) + && (dty != TY_CMPLX) && (dty != TY_DCMPLX) && (dty != TY_QCMPLX) #endif ) { LL_Type *rtype = make_lltype_from_dtype(dtype); @@ -955,8 +1023,14 @@ cons_novectorize_metadata(void) if (cpu_llvm_module->loop_md) return cpu_llvm_module->loop_md; rv = ll_create_flexible_md_node(cpu_llvm_module); - lvcomp[0] = ll_get_md_string(cpu_llvm_module, "llvm.loop.vectorize.enable"); - lvcomp[1] = ll_get_md_i1(0); + // AOCC Begin + // replaced + // llvm.loop.vectorize.enable + // with + // llvm.loop.vectorize.width + lvcomp[0] = ll_get_md_string(cpu_llvm_module, "llvm.loop.vectorize.width"); + lvcomp[1] = ll_get_md_i1(1); + // AOCC End loopVect = ll_get_md_node(cpu_llvm_module, LL_PlainMDNode, lvcomp, 2); ll_extend_md_node(cpu_llvm_module, rv, rv); ll_extend_md_node(cpu_llvm_module, rv, loopVect); @@ -964,6 +1038,24 @@ cons_novectorize_metadata(void) return rv; } +INLINE static LL_MDRef +cons_nounroll_metadata(void) +{ + LL_MDRef lvcomp[1]; + LL_MDRef loopUnroll; + LL_MDRef rv; + + if (LL_MDREF_IS_NULL(cached_unroll_disable_metadata)) { + rv = ll_create_flexible_md_node(cpu_llvm_module); + lvcomp[0] = ll_get_md_string(cpu_llvm_module, "llvm.loop.unroll.disable"); + loopUnroll= ll_get_md_node(cpu_llvm_module, LL_PlainMDNode, lvcomp, 1); + ll_extend_md_node(cpu_llvm_module, rv, rv); + ll_extend_md_node(cpu_llvm_module, rv, loopUnroll); + cached_unroll_disable_metadata=rv; + } + return cached_unroll_disable_metadata; +} + INLINE static LL_MDRef cons_vectorize_metadata(void) { @@ -974,6 +1066,16 @@ cons_vectorize_metadata(void) return ll_get_md_node(cpu_llvm_module, LL_PlainMDNode, lvcomp, 2); } +INLINE static LL_MDRef +cons_ivdep_metadata(void) +{ + LL_MDRef lvcomp[2]; + + lvcomp[0] = ll_get_md_string(cpu_llvm_module, "llvm.loop.vectorize.ivdep.enable"); + lvcomp[1] = ll_get_md_i1(1); + return ll_get_md_node(cpu_llvm_module, LL_PlainMDNode, lvcomp, 2); +} + /** \brief Second pass to clean up all the dead sincos callsites \param isns The list of instructions @@ -1248,29 +1350,118 @@ finish_routine(void) const int currFn = GBL_CURRFUNC; /***** "{" so vi matches *****/ print_line("}"); - llassem_end_func(cpu_llvm_module->debug_info, currFn); + llassem_end_func(current_module->debug_info, currFn); if (flg.smp) { ll_reset_outlined_func(); } } +// AOCC Begin +/* + * when ivdep pragma is specified, "llvm.loop.parallel_accesses" metadata has + * to be generated along with "llvm.access.group" for each load/store instructions. + */ +INLINE static LL_MDRef +cons_loop_parallel_accesse_metadata(void) +{ + LL_MDRef lvcomp[2]; + + lvcomp[0] = ll_get_md_string(cpu_llvm_module, "llvm.loop.parallel_accesses"); + lvcomp[1] = access_group_metadata; + return ll_get_md_node(cpu_llvm_module, LL_PlainMDNode, lvcomp, 2); +} // cons_loop_parallel_accesse_metadata + +/* + * When vector pragma is specified, only "llvm.loop.vectorize.enable" metadata + * has to be generated. + */ +static LL_MDRef +cons_loops_vectorize_metadata(void) +{ + if (LL_MDREF_IS_NULL(cached_loop_vec_metadata)) { + LL_MDRef vectorize = cons_vectorize_metadata(); + LL_MDRef md = ll_create_flexible_md_node(cpu_llvm_module); + ll_extend_md_node(cpu_llvm_module, md, md); + ll_extend_md_node(cpu_llvm_module, md, vectorize); + cached_loop_vec_metadata = md; + } // if + return cached_loop_vec_metadata; +} // cons_loops_vectorize_metadata + +/* + * When ivdep pragma is specified, "llvm.loop.vectorize.ivdep.enable" metadata + * has to be generated. + */ +static LL_MDRef +cons_loops_ivdep_metadata(void) +{ + if (LL_MDREF_IS_NULL(cached_loop_ivdep_metadata)) { + LL_MDRef vectorize = cons_vectorize_metadata(); + LL_MDRef ivdep = cons_ivdep_metadata(); + LL_MDRef md = ll_create_flexible_md_node(cpu_llvm_module); + ll_extend_md_node(cpu_llvm_module, md, md); + ll_extend_md_node(cpu_llvm_module, md, vectorize); + ll_extend_md_node(cpu_llvm_module, md, ivdep); + cached_loop_ivdep_metadata = md; + } // if + return cached_loop_ivdep_metadata; +} // cons_loops_vectorize_metadata +// AOCC End + static LL_MDRef cons_no_depchk_metadata(void) { if (LL_MDREF_IS_NULL(cached_loop_metadata)) { LL_MDRef vectorize = cons_vectorize_metadata(); LL_MDRef md = ll_create_flexible_md_node(cpu_llvm_module); + // AOCC Begin + // for ivdep pragma, "llvm.loop.parallel_accesses" metadata is generated + LL_MDRef lpam = cons_loop_parallel_accesse_metadata(); + // AOCC End ll_extend_md_node(cpu_llvm_module, md, md); ll_extend_md_node(cpu_llvm_module, md, vectorize); + // AOCC Begin + ll_extend_md_node(cpu_llvm_module, md, lpam); + // AOCC End cached_loop_metadata = md; } return cached_loop_metadata; } +static LL_MDRef +cons_unroll_metadata(void) //Calls the metadata for unroll +{ + LL_MDRef lvcomp[1]; + LL_MDRef unroll; + if (LL_MDREF_IS_NULL(cached_unroll_enable_metadata)) { + lvcomp[0] = ll_get_md_string(cpu_llvm_module, "llvm.loop.unroll.enable"); + unroll= ll_get_md_node(cpu_llvm_module, LL_PlainMDNode, lvcomp, 1); + LL_MDRef md = ll_create_flexible_md_node(cpu_llvm_module); + ll_extend_md_node(cpu_llvm_module, md, md); + ll_extend_md_node(cpu_llvm_module, md, unroll); + cached_unroll_enable_metadata = md; + } + return cached_unroll_enable_metadata; +} + +static LL_MDRef +cons_unroll_count_metadata(int unroll_factor) +{ + LL_MDRef lvcomp[2]; + LL_MDRef unroll; + lvcomp[0] = ll_get_md_string(cpu_llvm_module, "llvm.loop.unroll.count"); + lvcomp[1] = ll_get_md_i32(cpu_llvm_module, unroll_factor); + unroll= ll_get_md_node(cpu_llvm_module, LL_PlainMDNode, lvcomp, 2); + LL_MDRef md = ll_create_flexible_md_node(cpu_llvm_module); + ll_extend_md_node(cpu_llvm_module, md, md); + ll_extend_md_node(cpu_llvm_module, md, unroll); + return md; +} + INLINE static bool ignore_simd_block(int bih) { - return (!XBIT(183, 0x4000000)) && BIH_SIMD(bih); + return (!XBIT(183, 0x4000000)) && BIH_NOSIMD(bih); } /** @@ -1292,6 +1483,154 @@ remove_dead_instrs(void) } } +// AOCC Begin +/* + * \brief Function to calculate alloca addrespace from DL string + * + */ +#ifdef OMP_OFFLOAD_AMD +int get_alloca_addrspace(LL_Module *module) { + const char *dl = module->datalayout_string; + while ((*dl) != 'A' && (*dl) != '\0') + dl++; if (dl[0] == '\0') + return -1; + dl++; + return (*dl) - '0'; +} // get_alloca_addrspace +#endif + +/* + * Check if the break instruction is having a loop pragma + * (vector/novector/vector always) pragma effect. "!llvm.loop" metadata + * will be generated for the break instruction if + * VECTOR/NOVECTOR/VECTOR ALWAYS pragma is specified for a loop. + */ +static bool check_for_loop_directive(int break_line_number, int xbit, int xflag) { + int iter; + LPPRG *lpprg; + + // Check if any loop pragmas are specified + if (direct.lpg.avail > 1) { + // Loop thru all the loop pragmas + for (iter = 1; iter < direct.lpg.avail; iter++) { + lpprg = direct.lpg.stgb + iter; + // check if xbit/xflag pair is available + if ((lpprg->dirset.x[xbit] & xflag) + && + (break_line_number == lpprg->end_line)) { + return true; + } // if + + if (break_line_number < lpprg->beg_line) { + // break instruction is not having any pragma specified. + break; + } // if + } // for + } // if + + return false; +} // check_for_loop_directive + +/* + * Fix ivdep loop directive for nested loops + * If a loop with an IVDEP directive is enclosed within another loop with an IVDEP directive, + * the IVDEP directive on the outer loop is ignored. + * + * Loop thru the loop directives and disable ivdep directive for the outer loop. + */ +static void fix_ivdep_directives () { + static bool processed = false; + int iter; + LPPRG *lpprg, *prev_lpprg = NULL; + + if (!processed && (direct.lpg.avail > 1)) { + for (iter = 1; iter < direct.lpg.avail; iter++) { + lpprg = direct.lpg.stgb + iter; + if (!lpprg->dirset.depchk && (lpprg->dirset.x[69] & 0x200000)) { + if (prev_lpprg && (lpprg->beg_line <= prev_lpprg->end_line)) { + // Both outer loop and inner loop has ivdep directive. + // Disable ivdep directive for the outer loop. + prev_lpprg->dirset.depchk = 1; + } // if + prev_lpprg = lpprg; + } // if + } // for + processed = true; + } // if +} // fix_ivdep_directives + +/* + * ivdep directive applies only to the first loop that follows the directive + * + * Check if the code block belongs to the outer loop or the nested inner loops + * + * Eg: + * !dir$ ivdep + * do ... + * <= B1 + * do ... + * <= B2 + * end do + * <= B3 + * end do + * + * In the above example, ivdep applies only to B1 and B3. + * The below function checks for B3. + */ +static bool block_belong_to_outer_loop (int iter, int curr_line, + int outer_loop_end_line) { + bool is_outer_loop_block = true; + LPPRG *lpprg; + + while (iter < direct.lpg.avail) { + lpprg = direct.lpg.stgb + iter; + if (curr_line >= lpprg->beg_line && + curr_line < lpprg->end_line) { + is_outer_loop_block = false; + } // if + + if (outer_loop_end_line < lpprg->beg_line) { + // No more pragmas for current code block + break; + } + + iter++; + } // while + + return is_outer_loop_block; +} // block_belong_to_outer_loop +// AOCC End + +/** + \brief process debug info of constants with parameter attribute. + */ +static void process_params(void) { + unsigned smax = stb.stg_avail; + for (SPTR sptr = get_symbol_start(); sptr < smax; ++sptr) { + DTYPE dtype = DTYPEG(sptr); + if (STYPEG(sptr) == ST_PARAM && should_preserve_param(dtype) && !SCOPEG(sptr)) { + if (DTY(dtype) == TY_ARRAY || DTY(dtype) == TY_STRUCT) { + /* array and derived types have 'var$ac' constant variable + * lets use that, by renaming that to 'var'. + */ + SPTR new_sptr = (SPTR)CONVAL1G(sptr); + NMPTRP(new_sptr, NMPTRG(sptr)); + } else { + LL_DebugInfo *di = current_module->debug_info; + int fin = BIH_FINDEX(gbl.entbih); + LL_Type *type = make_lltype_from_dtype(dtype); + OPERAND *ld = make_operand(); + ld->ot_type = OT_MDNODE; + ld->val.sptr = sptr; + LL_MDRef lcl = lldbg_emit_local_variable(di, sptr, fin, true); + + /* lets generate llvm.dbg.value intrinsic for it.*/ + insert_llvm_dbg_value(ld, lcl, sptr, type); + } + } + } +} + /** \brief Perform code translation from ILI to LLVM for one routine */ @@ -1310,16 +1649,18 @@ schedule(void) bool processHostConcur = true; SPTR func_sptr = GBL_CURRFUNC; bool first = true; + // AOCC Begin + bool is_ivdep_directive = false; + // AOCC End CG_cpu_compile = true; + int unroll_factor = 0; funcId++; assign_fortran_storage_classes(); - if (XBIT(183, 0x10000000)) { - if (XBIT(68, 0x1) && (!XBIT(183, 0x40000000))) - widenAddressArith(); - if (gbl.outlined && funcHasNoDepChk()) - redundantLdLdElim(); - } + if (XBIT(68, 0x1) && (!XBIT(183, 0x40000000))) + widenAddressArith(); + if (gbl.outlined && funcHasNoDepChk()) + redundantLdLdElim(); restartConcur: FTN_HOST_REG() = 1; @@ -1420,18 +1761,18 @@ schedule(void) #ifdef OMP_OFFLOAD_LLVM if(XBIT(232, 0x8)) targetNVVM = true; - if (!ISNVVMCODEGEN && !TEXTSTARTUPG(func_sptr)) + if (!TEXTSTARTUPG(func_sptr)) #endif { - lldbg_emit_subprogram(current_module->debug_info, func_sptr, funcType, - BIH_FINDEX(gbl.entbih), targetNVVM); - lldbg_set_func_ptr(current_module->debug_info, func_ptr); + if (current_module->debug_info && (BIH_FINDEX(gbl.entbih) != 0)) { + lldbg_emit_subprogram(current_module->debug_info, func_sptr, funcType, + BIH_FINDEX(gbl.entbih), targetNVVM, false); + lldbg_set_func_ptr(current_module->debug_info, func_ptr); + } } - if (!ISNVVMCODEGEN) { - /* FIXME: should this be done for C, C++? */ - lldbg_reset_dtype_array(current_module->debug_info, DT_DEFERCHAR + 1); - } + /* FIXME: should this be done for C, C++? */ + lldbg_reset_dtype_array(current_module->debug_info, DT_DEFERCHAR + 1); } } @@ -1459,10 +1800,29 @@ schedule(void) for (ilt = BIH_ILTFIRST(bih); ilt; ilt = ILT_NEXT(ilt)) build_csed_list(ILT_ILIP(ilt)); + /* process variables with parameter attribute */ + if (!XBIT(49, 0x10) +#if defined(OMP_OFFLOAD_PGI) || defined(OMP_OFFLOAD_LLVM) + && !gbl.ompaccel_isdevice +#endif + ) + process_params(); + merge_next_block = false; bih = BIH_NEXT(0); if ((XBIT(34, 0x200) || gbl.usekmpc) && !processHostConcur) bih = gbl.entbih; + + // AOCC Begin + // If a loop with an IVDEP directive is enclosed within another loop with an + // IVDEP directive, the IVDEP directive on the outer loop is ignored. + fix_ivdep_directives(); + + // Create a distinct md_node + if (!access_group_metadata) + access_group_metadata = ll_create_distinct_md_node(cpu_llvm_module, LL_PlainMDNode, NULL, 0); + // AOCC End + for (; bih; bih = BIH_NEXT(bih)) { #if DEBUG @@ -1514,15 +1874,102 @@ schedule(void) merge_next_block = false; } - if (XBIT(183, 0x10000000)) { - if ((!XBIT(69, 0x100000)) && BIH_NODEPCHK(bih) && - (!ignore_simd_block(bih))) { - fix_nodepchk_flag(bih); - mark_rw_nodepchk(bih); - } else { - clear_rw_nodepchk(); - } - } + // AOCC Begin + // clear the global flag set from last iteration + clear_rw_nodepchk(); + // AOCC End + + open_pragma(BIH_LINENO(bih)); + if (!flg.omptarget) + BIH_NODEPCHK(bih) = !flg.depchk; + if (XBIT(19, 0x18)) + BIH_NOSIMD(bih) = true; + else if (XBIT(19, 0x400)) + BIH_SIMD(bih) = true; + if ((!XBIT(69, 0x100000)) && BIH_NODEPCHK(bih) && + (!ignore_simd_block(bih))) { + fix_nodepchk_flag(bih); + mark_rw_nodepchk(bih); + } else { + clear_rw_nodepchk(); + } + if (flg.x[9] > 0) + unroll_factor = flg.x[9]; + if (XBIT(11, 0x2) && unroll_factor) + BIH_UNROLL_COUNT(bih) = true; + else if (XBIT(11, 0x1)) + BIH_UNROLL(bih) = true; + else if (XBIT(11, 0x400)) + BIH_NOUNROLL(bih) = true; + close_pragma(); + + // AOCC Begin + /** \brief Flang codegen support for !dir$ ivdep + * + * Following piece of code is added for handling ivdep directive. This + * pragma instructs the compiler to ignore assumed vector dependencies. + * Flang handles this pragma with a flag depchk in directives structure. + * By default this flag is set, indicating that always do dependency checks + * for the loop. Whenever Flang1 encounters !dir$ ivdep, it resets the + * depchk flag from 1 to 0. This is change is reflected in directive + * section of ilm file. Flang2 captures the change/addition in directive + * section and reset's the corresponding depchk flag. With the following + * code we capture the reset of depcheck flag and add nodepchke metadata + * to all load/store instructions in the scope of the pragma. This metadata + * will be captured by llvm::Loop::isAnnotatedParallel(). + * + * The approach + * STEP 1 : Check if there are any loop pragmas. + * STEP 2 : Iterate through avaibale pragmas. + * STEP 3 : Check if depchk flag for current pragma is reset. + * By default this flag is set for all pragmas. + * STEP 4 : If the current pragma scope is within current range, the line number + * will match (ivdep directive line number and code block beg line number). + * STEP 5 : If line number matches, enable global flag to add nodepcheck metadata + * and break the loop. + * STEP 6 : If line number didn't match and the code block is in the current range, + * then the code block belongs to inner loop or after the inner loop. + * STEP 7 : Check if the code belongs to outer loop with ivdep directive. + * STEP 8 : enable global flag to add nodepcheck metadata and break the loop. + * + * 0x200000 => xflag[69] value for IVDEP + */ + if (direct.lpg.avail > 1) { + int iter; + int curr_line = BIH_LINENO(bih); + LPPRG *lpprg; + is_ivdep_directive = false; + + for (iter = 1; iter < direct.lpg.avail; iter++) { + lpprg = direct.lpg.stgb + iter; + + // Check for ivdep directive and mark nodepchk + if (!lpprg->dirset.depchk && (lpprg->dirset.x[69] & 0x200000)) { + if (curr_line == lpprg->beg_line) { + is_ivdep_directive = true; + mark_rw_nodepchk(bih); + // Once we found right pragma, stop + break; + } else if ((curr_line > lpprg->beg_line) && + (curr_line <= lpprg->end_line)) { + // Nested loop. check for next loop pragma + // check if the code block belongs to nested loops. + // if no, then the code block belongs to outer loop, mark nodepchk + if (block_belong_to_outer_loop(++iter, curr_line, lpprg->end_line)) { + is_ivdep_directive = true; + mark_rw_nodepchk(bih); + } // if + + // Pragma for code block is processed. stop + break; + } else if (curr_line < lpprg->beg_line) { + // no pragmas for current code block. stop + break; + } // if + } // if + } // for + } // if + // AOCC End for (ilt = BIH_ILTFIRST(bih); ilt; ilt = ILT_NEXT(ilt)) { if (BIH_EN(bih) && ilt == BIH_ILTFIRST(bih)) { @@ -1541,7 +1988,7 @@ schedule(void) } #endif - if (!ISNVVMCODEGEN && (flg.debug || XBIT(120, 0x1000))) { + if (flg.debug || XBIT(120, 0x1000)) { lldbg_emit_line(current_module->debug_info, ILT_LINENO(ilt)); } ilix = ILT_ILIP(ilt); @@ -1567,21 +2014,77 @@ schedule(void) next_bih_label = t_next_bih_label; } make_stmt(STMT_BR, ilix, false, next_bih_label, ilt); - if (XBIT(183, 0x10000000) && (!XBIT(69, 0x100000)) && - BIH_NODEPCHK(bih) && (!BIH_NODEPCHK2(bih)) && - (!ignore_simd_block(bih))) { - LL_MDRef loop_md = cons_no_depchk_metadata(); + + // AOCC Begin + // Added support for vector, vector always, novector and ivdep pragma to generate the + // required metadata + // 0x4000000 => xflag[183] value for NOVECTOR (and VECTOR NEVER) + // 0x80000000 => xflag[183] value for VECTOR + // 0x1 => xflag[200] value for VECTOR ALWAYS + if (ignore_simd_block(bih) + || + (check_for_loop_directive(ILT_LINENO(ilt), 183, 0x4000000))) { + LL_MDRef loop_md = cons_novectorize_metadata(); + INSTR_LIST *i = find_last_executable(llvm_info.last_instr); + if (i) { + i->flags |= LOOP_BACKEDGE_FLAG; + i->misc_metadata = loop_md; + } + } else if (((!XBIT(69, 0x100000)) && + BIH_NODEPCHK(bih) && (!BIH_NODEPCHK2(bih))) + || + (check_for_loop_directive(ILT_LINENO(ilt), 183, 0x80000000)) + || + (is_ivdep_directive) || BIH_SIMD(bih)) { + LL_MDRef loop_md; + // for ivdep pragma, rw_nodepcheck will be enabled. + // Need to generate "llvm.loop.parallel_accesses" metadata as well. + if (rw_nodepcheck) { + loop_md = cons_no_depchk_metadata(); + } else { + loop_md = cons_loops_vectorize_metadata(); + } INSTR_LIST *i = find_last_executable(llvm_info.last_instr); if (i) { - i->flags |= SIMD_BACKEDGE_FLAG; + i->flags |= LOOP_BACKEDGE_FLAG; + i->misc_metadata = loop_md; + } + } else if (((!XBIT(69, 0x100000)) && + BIH_NODEPCHK(bih) && (!BIH_NODEPCHK2(bih))) + || + (check_for_loop_directive(ILT_LINENO(ilt), 200, 0x01)) + || + (is_ivdep_directive) || BIH_SIMD(bih)) { + LL_MDRef loop_md = cons_loops_ivdep_metadata(); + INSTR_LIST *i = find_last_executable(llvm_info.last_instr); + if (i) { + i->flags |= LOOP_BACKEDGE_FLAG; i->misc_metadata = loop_md; } } - if (ignore_simd_block(bih)) { - LL_MDRef loop_md = cons_novectorize_metadata(); - llvm_info.last_instr->flags |= SIMD_BACKEDGE_FLAG; - llvm_info.last_instr->misc_metadata = loop_md; + if (BIH_UNROLL(bih)) { + LL_MDRef loop_md = cons_unroll_metadata(); + INSTR_LIST *i = find_last_executable(llvm_info.last_instr); + if (i) { + i->flags |= LOOP_BACKEDGE_FLAG; + i->misc_metadata = loop_md; + } + } else if (BIH_UNROLL_COUNT(bih)) { + LL_MDRef loop_md = cons_unroll_count_metadata(unroll_factor); + INSTR_LIST *i = find_last_executable(llvm_info.last_instr); + if (i) { + i->flags |= LOOP_BACKEDGE_FLAG; + i->misc_metadata = loop_md; + } + } else if (BIH_NOUNROLL(bih)) { + LL_MDRef loop_md = cons_nounroll_metadata(); + INSTR_LIST *i = find_last_executable(llvm_info.last_instr); + if (i) { + i->flags |= LOOP_BACKEDGE_FLAG; + i->misc_metadata = loop_md; + } } + // AOCC End } else if ((ILT_ST(ilt) || ILT_DELETE(ilt)) && (IL_TYPE(opc) == ILTY_STORE)) { /* store */ @@ -1597,6 +2100,8 @@ schedule(void) ENABLE_CSE_OPT && ILT_DELETE(ilt) && (IL_TYPE(opc) == ILTY_STORE), SPTR_NULL, ilt); +// make_stmt(STMT_ST, ilix, true, +// SPTR_NULL, ilt); } else if (opc == IL_JSR && cgmain_init_call(ILI_OPND(ilix, 1))) { make_stmt(STMT_SZERO, ILI_OPND(ilix, 2), false, SPTR_NULL, ilt); } else if (opc == IL_SMOVE) { @@ -1609,6 +2114,7 @@ schedule(void) case IL_DFRSP: case IL_DFRDP: case IL_DFRCS: + case IL_DFRQP: // AOCC #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128RESULT: #endif @@ -1636,6 +2142,9 @@ schedule(void) } } else if (opc == IL_FENCE) { gen_llvm_fence_instruction(ilix); + } else if (opc == IL_PREFETCH) { + LL_Type *optype = make_lltype_from_dtype(DT_CPTR); + insert_llvm_prefetch(ilix, gen_llvm_expr(ILI_OPND(ilix, 1), optype)); } else { /* may be a return; otherwise mostly ignored */ /* However, need to keep track of FREE* ili, to match them @@ -1711,14 +2220,22 @@ schedule(void) write_ftn_typedefs(); write_global_and_static_defines(); + FILE *backup_file; // AOCC #ifdef OMP_OFFLOAD_LLVM - if (flg.omptarget && ISNVVMCODEGEN) - use_cpu_output_file(); + if (flg.omptarget && ISNVVMCODEGEN) { + use_gpu_output_file(); + // AOCC Begin + backup_file = gbl.asmfil; + gbl.asmfil = gbl.ompaccfile; + // AOCC End + } #endif assem_data(); #ifdef OMP_OFFLOAD_LLVM - if (flg.omptarget && ISNVVMCODEGEN) + if (flg.omptarget && ISNVVMCODEGEN) { + gbl.asmfil = backup_file; // AOCC use_gpu_output_file(); + } if (flg.omptarget) write_libomtparget(); #endif @@ -1727,7 +2244,19 @@ schedule(void) func_type); /* write out local variable defines */ + +// AOCC Begin +/* + * \brief Emitting allocas with addrespace + * + */ +#ifdef OMP_OFFLOAD_AMD + int alloca_addrspace = get_alloca_addrspace(current_module); + ll_write_local_objects(llvm_file(), llvm_info.curr_func, alloca_addrspace); +#else ll_write_local_objects(llvm_file(), llvm_info.curr_func); +#endif +// AOCC End /* Emit alloca for local equivalence, c.f. get_local_overlap_var(). */ write_local_overlap(); @@ -1774,12 +2303,23 @@ schedule(void) #endif clear_prescan_complex_list(); - if (!ISNVVMCODEGEN && (flg.debug || XBIT(120, 0x1000))) + if (flg.debug || XBIT(120, 0x1000)) lldbg_cleanup_missing_bounds(current_module->debug_info, - BIH_FINDEX(gbl.entbih)); + BIH_FINDEX(gbl.entbih)); hashmap_clear(llvm_info.homed_args); /* Don't home entry trampoline parms */ - if (processHostConcur) + if (processHostConcur) { print_entry_subroutine(current_module); +// AOCC Begin + /* local variable metadata nodes are created for every entry in the + * mdnodes_fwdvars hashmap before cleanup. These local variables are created + * for the purpose of array bounds, etc. They were previously marked to be + * created in lldbg_fwd_local_variable() and gets created here. + */ + if (flg.debug || XBIT(120, 0x1000)) + lldbg_cleanup_missing_bounds(current_module->debug_info, + BIH_FINDEX(gbl.entbih)); +// AOCC End + } ll_destroy_function(llvm_info.curr_func); llvm_info.curr_func = NULL; @@ -2135,12 +2675,11 @@ msz_dtype(MSZ msz) case MSZ_PTR: return DT_CPTR; case MSZ_F16: + return DT_QUAD; // AOCC #if defined(LONG_DOUBLE_FLOAT128) return DT_FLOAT128; #elif defined(TARGET_LLVM_X8664) - return DT_128; -#else - return DT_QUAD; + return DT_QUAD; // AOCC #endif case MSZ_F32: return DT_256; @@ -2216,7 +2755,7 @@ maybe_fixup_x86_abi_return(LL_Type *sig) * \param emit_func_signature_for_call * \return 1 if debug op was written, 0 otherwise */ -static int +int write_I_CALL(INSTR_LIST *curr_instr, bool emit_func_signature_for_call) { /* Function invocation description as a list of OPERAND values */ @@ -2341,11 +2880,11 @@ write_I_CALL(INSTR_LIST *curr_instr, bool emit_func_signature_for_call) } { const bool wrDbg = true; - if (wrDbg && cpu_llvm_module->debug_info && - ll_feature_subprogram_not_in_cu(&cpu_llvm_module->ir) && + if (wrDbg && current_module->debug_info && + ll_feature_subprogram_not_in_cu(¤t_module->ir) && LL_MDREF_IS_NULL(curr_instr->dbg_line_op)) { /* we must emit !dbg metadata in this case */ - emit_dbg_from_module(cpu_llvm_module); + emit_dbg_from_module(current_module); return true; } } @@ -2464,6 +3003,26 @@ locset_to_tbaa_info(LL_Module *module, LL_MDRef omniPtr, int ilix) #if defined(REVMIDLNKG) if (REVMIDLNKG(bsym)) { const int ptr = REVMIDLNKG(bsym); + // AOCC begin + if (XBIT(53, 0x800000)) { + if (ILI_OPC(ilix) == IL_LDA && + !NOCONFLICTG(ptr) && !PTRSAFEG(ptr) && !TARGETG(ptr)) { + char *bsym_name = getprint(bsym); + size_t bsym_len = strlen(bsym_name); + if (bsym_len > 2 && bsym_name[bsym_len - 1] == 'p' + && bsym_name[bsym_len - 2] == '$') { + bsym = ptr; + rv = snprintf(name, NAME_SZ, "t%x.%x", funcId, base); + DEBUG_ASSERT(rv < NAME_SZ, "buffer overrun"); + a[0] = ll_get_md_string(module, name); + a[1] = omniPtr; + a[2] = ll_get_md_i64(module, 0); + return ll_get_md_node(module, LL_PlainMDNode, a, 3); + } + } + } + // AOCC end + if (!NOCONFLICTG(ptr) && !PTRSAFEG(ptr) && !TARGETG(ptr)) return LL_MDREF_ctor(0, 0); bsym = ptr; @@ -2648,8 +3207,12 @@ write_no_depcheck_metadata(LL_Module *module, INSTR_LIST *insn) char buf[64]; int n; DEBUG_ASSERT(insn->misc_metadata, "missing metadata"); - n = snprintf(buf, 64, ", !llvm.mem.parallel_loop_access !%u", - LL_MDREF_value(insn->misc_metadata)); + // AOCC Begin + // Replaced "llvm.mem.parallel_loop_access" with "llvm.access.group" + // Refer https://reviews.llvm.org/D52116 for more details. + n = snprintf(buf, 64, ", !llvm.access.group !%u", + LL_MDREF_value(access_group_metadata)); + // AOCC End DEBUG_ASSERT(n < 64, "buffer overrun"); print_token(buf); } @@ -2662,6 +3225,39 @@ write_verbose_type(LL_Type *ll_type) print_token(ll_type->str); } +/* whether debug location should be suppressed */ +static bool should_suppress_debug_loc(INSTR_LIST *instrs) { + if (!instrs) + return false; + + // return true if not a call instruction + switch (instrs->i_name) { + case I_INVOKE: + return false; + case I_CALL: + // f90 runtime functions fort_init and f90_* dont need debug location + if (instrs->prev && (instrs->operands->ot_type == OT_TMP) && + (instrs->operands->tmps == instrs->prev->tmps) && + (instrs->prev->operands->ot_type == OT_VAR)) { + // We dont need to expose those internals in prolog to user + // %1 = bitcast void (...)* @fort_init to void (i8*, ...)* + // call void (i8*, ...) %1(i8* %0) + // %8 = bitcast void (...)* @f90_template1_i8 to void (i8*, i8*, i8*, i8*, + // i8*, i8*, ...)* + // call void (i8*, i8*, i8*, i8*, i8*, i8*, ...) %8(i8* + // %2, i8* %3, i8* %4, i8* %5, i8* %6, i8* %7) + + if (char *name_str = instrs->prev->operands->string) { + return (!strncmp(name_str, "@fort_init", strlen("@fort_init")) || + !strncmp(name_str, "@f90_", strlen("@f90_"))); + } + } + return false; + default: + return true; + } +} + /** \brief Write the instruction list to the LLVM IR output file */ @@ -3054,7 +3650,7 @@ write_instructions(LL_Module *module) print_token(llvm_instr_names[i_name]); print_space(1); write_operands(instrs->operands, 0); - if (instrs->flags & SIMD_BACKEDGE_FLAG) { + if (instrs->flags & LOOP_BACKEDGE_FLAG) { char buf[32]; LL_MDRef loop_md = instrs->misc_metadata; snprintf(buf, 32, ", !llvm.loop !%u", LL_MDREF_value(loop_md)); @@ -3196,8 +3792,17 @@ write_instructions(LL_Module *module) ERR_Fatal); } } - if (!ISNVVMCODEGEN && - (!LL_MDREF_IS_NULL(instrs->dbg_line_op) && !dbg_line_op_written)) { + /* + * Do not dump debug location here if + * - it is NULL + * - it is already written (dbg_line_op_written) or + * - it is a known internal (f90 runtime) call in prolog (fort_init & + * f90_*) + */ + if (!(LL_MDREF_IS_NULL(instrs->dbg_line_op) || dbg_line_op_written || + ((instrs->dbg_line_op == + lldbg_get_subprogram_line(module->debug_info)) && + should_suppress_debug_loc(instrs)))) { print_dbg_line(instrs->dbg_line_op); } #if DEBUG @@ -3361,7 +3966,7 @@ make_instr(LL_InstrName instr_name) if (flg.debug || XBIT(120, 0x1000)) { switch (instr_name) { default: - iptr->dbg_line_op = lldbg_get_line(cpu_llvm_module->debug_info); + iptr->dbg_line_op = lldbg_get_line(current_module->debug_info); break; case I_NONE: case I_DECL: @@ -3554,6 +4159,8 @@ ad_instr(int ilix, INSTR_LIST *instr) static bool cancel_store(int ilix, int op_ili, int addr_ili) { + if(!ENABLE_CSE_OPT) + return false; ILI_OP op_opc = ILI_OPC(op_ili); bool csed = false; @@ -3809,6 +4416,8 @@ make_stmt(STMT_Type stmt_type, int ilix, bool deletable, SPTR next_bih_label, case IL_FCJMPZ: case IL_DCJMP: case IL_DCJMPZ: + case IL_QCJMP: // AOCC + case IL_QCJMPZ: // AOCC ad_instr(ilix, gen_instr(I_FCMP, tmps, Curr_Instr->operands->ll_type, gen_llvm_expr(ilix, NULL))); break; @@ -3965,6 +4574,16 @@ make_stmt(STMT_Type stmt_type, int ilix, bool deletable, SPTR next_bih_label, LL_Type *ty = make_lltype_from_dtype(DT_DCMPLX); op1 = gen_llvm_expr(rhs_ili, ty); store_flags = ldst_instr_flags_from_dtype(DT_DCMPLX); + // AOCC begin + } else if (ILI_OPC(ilix) == IL_STQCMPLX) { + LL_Type *ty = make_lltype_from_dtype(DT_QCMPLX); + op1 = gen_llvm_expr(rhs_ili, ty); + store_flags = ldst_instr_flags_from_dtype(DT_QCMPLX); + } else if (ILI_OPC(ilix) == IL_STQP) { + LL_Type *ty = make_lltype_from_dtype(DT_QUAD); + op1 = gen_llvm_expr(rhs_ili, ty); + store_flags = ldst_instr_flags_from_dtype(DT_QUAD); + // AOCC end #ifdef LONG_DOUBLE_FLOAT128 } else if (ILI_OPC(ilix) == IL_FLOAT128ST) { LL_Type *ty = make_lltype_from_dtype(DT_FLOAT128); @@ -4005,7 +4624,10 @@ make_stmt(STMT_Type stmt_type, int ilix, bool deletable, SPTR next_bih_label, op1 = convert_int_size(ilix, op1, store_op->ll_type->sub_types[0]); } - if (nme == NME_VOL) + // AOCC Begin + // Added NME_VOLATILE condition + if (nme == NME_VOL || NME_VOLATILE(nme)) + // AOCC End store_flags |= VOLATILE_FLAG; if (IL_HAS_FENCE(ILI_OPC(ilix))) store_flags |= ll_instr_flags_for_memory_order_and_scope(ilix); @@ -4393,6 +5015,52 @@ gen_call_pgocl_intrinsic(char *fname, OPERAND *params, LL_Type *return_ll_type, i_name); } +static void +insert_llvm_prefetch(int ilix, OPERAND *dest_op) +{ + OPERAND *call_op; + + DBGTRACEIN("") + + const char *intrinsic_name = "@llvm.prefetch"; + char *fname = (char *)getitem(LLVM_LONGTERM_AREA, strlen(intrinsic_name) + 1); + strcpy(fname, intrinsic_name); + INSTR_LIST *Curr_Instr = make_instr(I_CALL); + Curr_Instr->flags |= CALL_INTRINSIC_FLAG; + Curr_Instr->operands = call_op = make_operand(); + call_op->ot_type = OT_CALL; + call_op->ll_type = make_void_lltype(); + Curr_Instr->ll_type = call_op->ll_type; + call_op->string = fname; + call_op->next = dest_op; + + /* setup rest of the parameters for llvm.prefetch */ + LL_Type *int32_type = make_int_lltype(32); + /* prefetch type: 0 = read, 1 = write */ + dest_op->next = make_constval_op(int32_type, 0, 0); + /* temporal locality specifier: 3 = extremely local, keep in cache */ + dest_op->next->next = make_constval_op(int32_type, 3, 0); + /* cache type: 0 = instruction, 1 = data */ + dest_op->next->next->next = make_constval_op(int32_type, 1, 0); + ad_instr(ilix, Curr_Instr); + + /* add global define of @llvm.prefetch to external function list, if needed */ + static bool prefetch_defined = false; + if (!prefetch_defined) { + prefetch_defined = true; + const char *intrinsic_decl = "declare void @llvm.prefetch(i8* nocapture, i32, i32, i32)"; + char *gname = (char *)getitem(LLVM_LONGTERM_AREA, strlen(intrinsic_decl) + 1); + strcpy(gname, intrinsic_decl); + EXFUNC_LIST *exfunc = (EXFUNC_LIST *)getitem(LLVM_LONGTERM_AREA, sizeof(EXFUNC_LIST)); + memset(exfunc, 0, sizeof(EXFUNC_LIST)); + exfunc->func_def = gname; + exfunc->flags |= EXF_INTRINSIC; + add_external_function_declaration(fname, exfunc); + } + + DBGTRACEOUT("") +} /* insert_llvm_prefetch */ + static void insert_llvm_memset(int ilix, int size, OPERAND *dest_op, int len, int value, int align, int is_volatile) @@ -4489,10 +5157,8 @@ insert_llvm_memcpy(int ilix, int size, OPERAND *dest_op, OPERAND *src_op, \param sptr symbol \param llTy preferred type of \p sptr or \c NULL */ -static void -insert_llvm_dbg_declare(LL_MDRef mdnode, SPTR sptr, LL_Type *llTy, - OPERAND *exprMDOp, OperandFlag_t opflag) -{ +void insert_llvm_dbg_declare(LL_MDRef mdnode, SPTR sptr, LL_Type *llTy, + OPERAND *exprMDOp, OperandFlag_t opflag) { EXFUNC_LIST *exfunc; OPERAND *call_op; static bool dbg_declare_defined = false; @@ -4503,7 +5169,7 @@ insert_llvm_dbg_declare(LL_MDRef mdnode, SPTR sptr, LL_Type *llTy, Curr_Instr->flags |= CALL_INTRINSIC_FLAG; Curr_Instr->operands = call_op = make_operand(); Curr_Instr->dbg_line_op = - lldbg_get_var_line(cpu_llvm_module->debug_info, sptr); + lldbg_get_var_line(current_module->debug_info, sptr); call_op->ot_type = OT_CALL; call_op->ll_type = make_void_lltype(); Curr_Instr->ll_type = call_op->ll_type; @@ -4512,21 +5178,25 @@ insert_llvm_dbg_declare(LL_MDRef mdnode, SPTR sptr, LL_Type *llTy, call_op->next = make_metadata_wrapper_op(sptr, llTy); call_op->next->flags |= opflag; call_op->next->next = make_mdref_op(mdnode); - if (ll_feature_dbg_declare_needs_expression_md(&cpu_llvm_module->ir)) { + if (ll_feature_dbg_declare_needs_expression_md(¤t_module->ir)) { if (exprMDOp) { call_op->next->next->next = exprMDOp; } else { - LL_DebugInfo *di = cpu_llvm_module->debug_info; + LL_DebugInfo *di = current_module->debug_info; + const unsigned deref = lldbg_encode_expression_arg(LL_DW_OP_deref, 0); LL_MDRef md; - /* Handle the Fortran allocatable array cases. Emit expression - * mdnode with sigle argument of DW_OP_deref to workaround known - * gdb bug not able to debug array bounds. - */ - if (ftn_array_need_debug_info(sptr)) { - const unsigned deref = lldbg_encode_expression_arg(LL_DW_OP_deref, 0); - md = lldbg_emit_expression_mdnode(di, 1, deref); - } else + if (ll_feature_debug_info_ver11(¤t_module->ir)) { md = lldbg_emit_empty_expression_mdnode(di); + } else { + /* Handle the Fortran allocatable array cases. Emit expression + * mdnode with single argument of DW_OP_deref to workaround known + * gdb bug not able to debug array bounds. + */ + if (ftn_array_need_debug_info(sptr)) + md = lldbg_emit_expression_mdnode(di, 1, deref); + else + md = lldbg_emit_empty_expression_mdnode(di); + } call_op->next->next->next = make_mdref_op(md); } } @@ -4536,7 +5206,7 @@ insert_llvm_dbg_declare(LL_MDRef mdnode, SPTR sptr, LL_Type *llTy, */ if (!dbg_declare_defined) { dbg_declare_defined = true; - if (ll_feature_dbg_declare_needs_expression_md(&cpu_llvm_module->ir)) { + if (ll_feature_dbg_declare_needs_expression_md(¤t_module->ir)) { gname = "declare void @llvm.dbg.declare(metadata, metadata, metadata)"; } else { gname = "declare void @llvm.dbg.declare(metadata, metadata)"; @@ -4599,7 +5269,13 @@ gen_const_expr(int ilix, LL_Type *expected_type) expected_type->data_type, ERR_Fatal); operand->ll_type = expected_type; } else { - operand->ll_type = make_lltype_from_dtype(DT_INT); + // AOCC Begin + if (expected_type && (expected_type->data_type == LL_PTR) || + (expected_type->data_type == LL_DOUBLE)) + operand->ll_type = make_lltype_from_dtype(DT_INT8); + else + operand->ll_type = make_lltype_from_dtype(DT_INT); + // AOCC End operand->val.sptr = sptr; } break; @@ -4611,11 +5287,18 @@ gen_const_expr(int ilix, LL_Type *expected_type) operand->ll_type = make_lltype_from_dtype(DT_DBLE); operand->val.sptr = sptr; break; + // AOCC begin + case IL_QCON: + operand->ll_type = make_lltype_from_dtype(DT_QUAD); + operand->val.sptr = sptr; + break; + // AOCC end case IL_VCON: operand->ll_type = make_lltype_from_sptr(sptr); operand->val.sptr = sptr; break; case IL_SCMPLXCON: + case IL_QCMPLXCON: // AOCC case IL_DCMPLXCON: operand->ll_type = make_lltype_from_dtype(DTYPEG(sptr)); operand->val.sptr = sptr; @@ -4650,6 +5333,14 @@ gen_unary_expr(int ilix, LL_InstrName itype) op_ili = ILI_OPND(ilix, 1); switch (opc) { + // AOCC begin + case IL_QFIXUK: + case IL_QFIXU: + case IL_QFIX: + case IL_QFIXK: + opc_type = make_lltype_from_dtype(DT_QUAD); + break; + // AOCC end case IL_DFIXUK: case IL_DFIXU: case IL_DFIX: @@ -4664,10 +5355,14 @@ gen_unary_expr(int ilix, LL_InstrName itype) case IL_FIXUK: opc_type = make_lltype_from_dtype(DT_FLOAT); break; + case IL_QUAD: // AOCC + opc_type = make_lltype_from_dtype(DT_DBLE); + break; case IL_FLOAT: case IL_FLOATU: case IL_DFLOATU: case IL_DFLOAT: + case IL_QFLOAT: // AOCC case IL_ALLOC: opc_type = make_lltype_from_dtype(DT_INT); break; @@ -4675,6 +5370,7 @@ gen_unary_expr(int ilix, LL_InstrName itype) case IL_FLOATUK: case IL_DFLOATUK: case IL_DFLOATK: + case IL_QFLOATK: // AOCC opc_type = make_lltype_from_dtype(DT_INT8); break; #ifdef LONG_DOUBLE_FLOAT128 @@ -4716,8 +5412,15 @@ gen_abs_expr(int ilix) double d; INT tmp[2]; } dtmp; + // AOCC begin + union { + __float128 q; + INT tmp[2]; + } qtmp; + // AOCC end float f; double d; + __float128 q; INSTR_LIST *Curr_Instr; DBGTRACEIN2(" ilix: %d(%s) \n", ilix, IL_NAME(opc)) @@ -4762,6 +5465,17 @@ gen_abs_expr(int ilix) zero_op = gen_llvm_expr(ad1ili(IL_DCON, getcon(dtmp.tmp, DT_DBLE)), operand->ll_type); break; + // AOCC begin + case IL_QABS: + cc_itype = I_FCMP; + cc_val = convert_to_llvm_fltcc(CC_LT); + op2 = gen_llvm_expr(ad1ili(IL_QNEG, lhs_ili), operand->ll_type); + q = 0.0; + xmqtoq(q, qtmp.tmp); + zero_op = gen_llvm_expr(ad1ili(IL_QCON, getcon(qtmp.tmp, DT_QUAD)), + operand->ll_type); + break; + // AOCC end #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128ABS: cc_itype = IL_FLOAT128CMP; @@ -4835,6 +5549,7 @@ gen_minmax_expr(int ilix, OPERAND *op1, OPERAND *op2) break; case IL_FMIN: case IL_DMIN: + case IL_QMIN: // AOCC cc_itype = I_FCMP; cc_val = convert_to_llvm_fltcc(CC_NOTGE); break; @@ -4850,6 +5565,7 @@ gen_minmax_expr(int ilix, OPERAND *op1, OPERAND *op2) break; case IL_FMAX: case IL_DMAX: + case IL_QMAX: // AOCC cc_itype = I_FCMP; cc_val = convert_to_llvm_fltcc(CC_NOTLE); break; @@ -4863,6 +5579,7 @@ gen_minmax_expr(int ilix, OPERAND *op1, OPERAND *op2) switch (DTY(DTySeqTyElement(vect_dtype))) { case TY_FLOAT: case TY_DBLE: + case TY_QUAD: // AOCC cc_itype = I_FCMP; cc_val = convert_to_llvm_fltcc(cc_ctype); break; @@ -5144,7 +5861,17 @@ static OPERAND * gen_gep_op(int ilix, OPERAND *base_op, LL_Type *llt, OPERAND *index_op) { base_op->next = index_op; - return ad_csed_instr(I_GEP, ilix, llt, base_op, InstrListFlagsNull, true); + OPERAND * op = ad_csed_instr(I_GEP, ilix, llt, base_op, InstrListFlagsNull, true); + + // AOCC Begin + /* + * Setting name for generated ptrs. + */ +#ifdef OMP_OFFLOAD_AMD + set_llvm_sptr_name(op); +#endif + // AOCC End + return op; } INLINE static OPERAND * @@ -5153,13 +5880,13 @@ gen_gep_index(OPERAND *base_op, LL_Type *llt, int index) return gen_gep_op(0, base_op, llt, make_constval32_op(index)); } -static void -insertLLVMDbgValue(OPERAND *load, LL_MDRef mdnode, SPTR sptr, LL_Type *type) +void insert_llvm_dbg_value(OPERAND *load, LL_MDRef mdnode, SPTR sptr, + LL_Type *type) { static bool defined = false; OPERAND *callOp; OPERAND *oper; - LLVMModuleRef mod = cpu_llvm_module; + LLVMModuleRef mod = current_module; LL_DebugInfo *di = mod->debug_info; INSTR_LIST *callInsn = make_instr(I_CALL); @@ -5186,6 +5913,7 @@ insertLLVMDbgValue(OPERAND *load, LL_MDRef mdnode, SPTR sptr, LL_Type *type) callOp->next = oper = make_operand(); oper->ot_type = OT_MDNODE; oper->tmps = load->tmps; + oper->val = load->val; oper->ll_type = type; oper->flags |= OPF_WRAPPED_MD; oper = make_constval_op(ll_create_int_type(mod, 64), 0, 0); @@ -5207,10 +5935,10 @@ consLoadDebug(OPERAND *ld, OPERAND *addr, LL_Type *type) { SPTR sptr = addr->val.sptr; if (sptr && need_debug_info(sptr)) { - LL_DebugInfo *di = cpu_llvm_module->debug_info; + LL_DebugInfo *di = current_module->debug_info; int fin = BIH_FINDEX(gbl.entbih); LL_MDRef lcl = lldbg_emit_local_variable(di, sptr, fin, true); - insertLLVMDbgValue(ld, lcl, sptr, type); + insert_llvm_dbg_value(ld, lcl, sptr, type); } } @@ -5335,6 +6063,30 @@ gen_convert_vector(int ilix) break; } break; + // AOCC begin + case LL_FP128: + switch (ll_src->sub_types[0]->data_type) { + case LL_I1: + case LL_I8: + case LL_I16: + case LL_I24: + case LL_I32: + case LL_I40: + case LL_I48: + case LL_I56: + case LL_I64: + case LL_I128: + case LL_I256: + if (DT_ISUNSIGNED(dtype_src)) + return convert_uint_to_float(operand, ll_dst); + return convert_sint_to_float(operand, ll_dst); + case LL_FLOAT: + return convert_float_size(operand, ll_dst); + default: + break; + } + break; + // AOCC end default: assert(0, "gen_convert_vector(): unhandled vector type for dst", ll_dst->sub_types[0]->data_type, ERR_Fatal); @@ -5372,6 +6124,7 @@ gen_binary_vexpr(int ilix, int itype_int, int itype_uint, int itype_float) switch (DTY(DTySeqTyElement(vect_dtype))) { case TY_REAL: case TY_DBLE: + case TY_QUAD: // AOCC return gen_binary_expr(ilix, itype_float); case TY_INT: case TY_SINT: @@ -5473,6 +6226,10 @@ get_mac_name(int *swap, int *fneg, int ilix, int matches, int l, int r) return (*fneg) ? "x86.fma.vfnmadd.ss" : "x86.fma.vfmadd.ss"; case IL_DADD: return (*fneg) ? "x86.fma.vfnmadd.sd" : "x86.fma.vfmadd.sd"; + // AOCC begin + case IL_QADD: + return (*fneg) ? "x86.fma.vfnmadd.sq" : "x86.fma.vfmadd.sq"; + // AOCC end case IL_FSUB: if (*swap) { return (*fneg) ? "x86.fma.vfmadd.ss" : "x86.fma.vfnmadd.ss"; @@ -5483,7 +6240,14 @@ get_mac_name(int *swap, int *fneg, int ilix, int matches, int l, int r) return (*fneg) ? "x86.fma.vfmadd.sd" : "x86.fma.vfnmadd.sd"; } return (*fneg) ? "x86.fma.vfnmsub.sd" : "x86.fma.vfmsub.sd"; + // AOCC begin + case IL_QSUB: + if (*swap) { + return (*fneg) ? "x86.fma.vfmadd.sq" : "x86.fma.vfnmadd.sq"; + } + return (*fneg) ? "x86.fma.vfnmsub.sq" : "x86.fma.vfmsub.sq"; } + // AOCC end assert(0, "does not match MAC", opc, ERR_Fatal); return ""; } @@ -5769,8 +6533,15 @@ gen_binary_expr(int ilix, int itype) double d; INT tmp[2]; } dtmp; + // AOCC begin + union { + __float128 q; + INT tmp[2]; + } qtmp; + // AOCC end float f; double d; + __float128 q; DBGTRACEIN2(" ilix: %d(%s)", ilix, IL_NAME(opc)) @@ -5895,6 +6666,11 @@ gen_binary_expr(int ilix, int itype) case IL_DNEG: lhs_ili = ad1ili(IL_DCON, stb.dblm0); break; + // AOCC begin + case IL_QNEG: + lhs_ili = ad1ili(IL_QCON, stb.quadm0); + break; + // AOCC end #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128CHS: lhs_ili = ad1ili(IL_FLOAT128CON, stb.float128_0); @@ -5937,6 +6713,9 @@ gen_binary_expr(int ilix, int itype) case IL_URSHIFT: case IL_RSHIFT: case IL_ARSHIFT: + /* AOCC begin */ + case IL_SHIFTA: + /*AOCC end */ binops->next = gen_llvm_expr(rhs_ili, make_lltype_from_dtype(DT_UINT)); break; case IL_VLSHIFTS: @@ -6043,6 +6822,14 @@ make_bitcast(OPERAND *cast_op, LL_Type *rslt_type) instr = llvm_info.last_instr; while (instr) { switch (instr->i_name) { + // AOCC begin + // Restrict bitcast propagation till the CALL instruction + case I_SW: + case I_INVOKE: + case I_CALL: + instr = NULL; + break; + // AOCC end case I_BR: case I_INDBR: case I_NONE: @@ -6345,6 +7132,7 @@ find_load_cse(int ilix, OPERAND *load_op, LL_Type *llt) if (ld_nme == NME_VOL) /* don't optimize a VOLATILE load */ return NULL; + /* If there is a deletable store to 'ld_nme', 'del_store_li', set * its 'deletable' flag to false. We do this because 'ld_ili' * loads from that address, so we mustn't delete the preceding @@ -6371,6 +7159,17 @@ find_load_cse(int ilix, OPERAND *load_op, LL_Type *llt) last_instr = (instr->i_name != I_NONE) ? instr : instr->prev; break; } + //AOCC Begin + //check the exit condition similar to the loop below + //this is expected to reduce compilation time + if ((instr->i_name == I_INVOKE) || (instr->i_name == I_CALL)) { + if (!(instr->flags & FAST_CALL)) break; + } + if ((instr->i_name == I_NONE) || (instr->i_name == I_BR) || + (instr->i_name == I_INDBR)) { + if (!ENABLE_ENHANCED_CSE_OPT) break; + } + //AOCC End } for (instr = llvm_info.last_instr; instr != last_instr; instr = instr->prev) { @@ -6644,6 +7443,11 @@ update_return_type_for_ccfunc(int ilix, ILI_OP opc) case IL_DFRDP: new_dtype = cg_get_type(3, DTY(dtype), DT_DBLE); break; + //AOCC Begin + case IL_DFRQP: + new_dtype = cg_get_type(3, DTY(dtype), DT_QUAD); + break; + //AOCC End case IL_DFRIR: new_dtype = cg_get_type(3, DTY(dtype), DT_INT); break; @@ -6653,6 +7457,11 @@ update_return_type_for_ccfunc(int ilix, ILI_OP opc) case IL_DFRCS: new_dtype = cg_get_type(3, DTY(dtype), DT_CMPLX); break; + //AOCC Begin + case IL_DFRCQ: + new_dtype = cg_get_type(3, DTY(dtype), DT_QCMPLX); + break; + //AOCC End #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128RESULT: new_dtype = cg_get_type(3, DTY(dtype), DT_FLOAT128); @@ -6878,6 +7687,7 @@ get_next_arg(int arg_ili) switch (ILI_OPC(arg_ili)) { case IL_ARGAR: case IL_ARGDP: + case IL_ARGQP: // AOCC case IL_ARGIR: case IL_ARGKR: case IL_ARGSP: @@ -6890,9 +7700,15 @@ get_next_arg(int arg_ili) case IL_DAAR: case IL_DADP: + case IL_DAQP: // AOCC case IL_DAIR: case IL_DAKR: case IL_DASP: + // AOCC Begin + case IL_DACS: + case IL_DACD: + case IL_DACQ: + // AOCC end return ILI_OPND(arg_ili, 3); default: @@ -6970,6 +7786,47 @@ gen_call_expr(int ilix, DTYPE ret_dtype, INSTR_LIST *call_instr, int call_sptr) bool intrinsic_modified = false; int throw_label = ili_throw_label(ilix); + // AOCC Begin + if (call_sptr) { + // create prototypes for quad print functions. otherwise, it will take + // double as first argument + if (strcmp(SYMNAME(call_sptr),"f90io_sc_q_ldw") == 0) { + SPTR sptr = mk_prototype_llvm("f90io_sc_q_ldw", "", DT_INT, 2, DT_QUAD,DT_INT); + LL_ABI_Info *abi = ll_proto_get_abi(ll_proto_key(sptr)); + abi->is_pure = 0; + } + if (strcmp(SYMNAME(call_sptr),"fort_ptr_assn_i8") == 0) { + SPTR sptr = mk_prototype_llvm("fort_ptr_assn_i8", "", DT_INT8, 5, DT_CPTR,DT_CPTR,DT_CPTR,DT_CPTR,DT_CPTR); + LL_ABI_Info *abi = ll_proto_get_abi(ll_proto_key(sptr)); + abi->is_pure = 0; + } + if (strcmp(SYMNAME(call_sptr),"__f90_imodulov") == 0) { + SPTR sptr = mk_prototype_llvm("__f90_imodulov", "", DT_INT, 2, DT_INT, DT_INT); + LL_ABI_Info *abi = ll_proto_get_abi(ll_proto_key(sptr)); + abi->is_pure = 0; + } + if (strcmp(SYMNAME(call_sptr),"__f90_modulov") == 0) { + SPTR sptr = mk_prototype_llvm("__f90_modulov", "", DT_INT, 2, DT_INT, DT_INT); + LL_ABI_Info *abi = ll_proto_get_abi(ll_proto_key(sptr)); + abi->is_pure = 0; + } + if (strcmp(SYMNAME(call_sptr),"__f90_i8modulov_i8") == 0) { + SPTR sptr = mk_prototype_llvm("__f90_i8modulov_i8", "", DT_INT8, 2, DT_INT8, DT_INT8); + LL_ABI_Info *abi = ll_proto_get_abi(ll_proto_key(sptr)); + abi->is_pure = 0; + } + if (strcmp(SYMNAME(call_sptr),"__f90_amodulov") == 0) { + SPTR sptr = mk_prototype_llvm("__f90_amodulov", "", DT_REAL, 2, DT_REAL, DT_REAL); + LL_ABI_Info *abi = ll_proto_get_abi(ll_proto_key(sptr)); + abi->is_pure = 0; + } + if (strcmp(SYMNAME(call_sptr),"__f90_dmodulov") == 0) { + SPTR sptr = mk_prototype_llvm("__f90_dmodulov", "", DT_DBLE, 2, DT_DBLE, DT_DBLE); + LL_ABI_Info *abi = ll_proto_get_abi(ll_proto_key(sptr)); + abi->is_pure = 0; + } + } + // AOCC End if (call_instr == NULL) call_instr = make_instr((throw_label > 0) ? I_INVOKE : I_CALL); @@ -7391,16 +8248,17 @@ gen_copy_operand(OPERAND *opnd) /* Math operations for complex values. * 'itype' should be the I_FADD, I_FSUB, I_xxxx etc. - * 'dtype' should either be DT_CMPLX or DT_DCMPLX. + * 'dtype' should either be DT_CMPLX or DT_DCMPLX or DT_QCMPLX. */ static OPERAND * gen_cmplx_math(int ilix, DTYPE dtype, LL_InstrName itype) { OPERAND *r1, *r2, *i1, *i2, *rmath, *imath, *res, *c1, *c2, *cse1, *cse2; LL_Type *cmplx_type, *cmpnt_type; - const DTYPE cmpnt = (dtype == DT_CMPLX) ? DT_FLOAT : DT_DBLE; + const DTYPE cmpnt = (dtype == DT_CMPLX) ? DT_FLOAT : (dtype == DT_DCMPLX) + ? DT_DBLE : DT_QUAD; - assert(DT_ISCMPLX(dtype), "gen_cmplx_math: Expected DT_CMPLX or DT_DCMPLX", + assert(DT_ISCMPLX(dtype), "gen_cmplx_math: Expected DT_CMPLX or DT_DCMPLX or DT_QCMPLX", dtype, ERR_Fatal); cmplx_type = make_lltype_from_dtype(dtype); @@ -7437,7 +8295,9 @@ gen_cmplx_math(int ilix, DTYPE dtype, LL_InstrName itype) static OPERAND * gen_cmplx_mul(int ilix, DTYPE dtype) { - const DTYPE elt_dt = (dtype == DT_CMPLX) ? DT_FLOAT : DT_DBLE; + // AOCC: DT_QUAD + const DTYPE elt_dt = (dtype == DT_CMPLX) ? DT_FLOAT : (dtype == DT_DCMPLX) + ? DT_DBLE : DT_QUAD; LL_Type *cmpnt_type = make_lltype_from_dtype(elt_dt); OPERAND *a, *bi, *c, *di, *cse1, *cse2; OPERAND *r1, *r2, *r3, *r4, *imag, *real, *res, *c1, *c2; @@ -7803,8 +8663,15 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) double d; INT tmp[2]; } dtmp; + // AOCC begin + union { + __float128 q; + INT tmp[2]; + } qtmp; + // AOCC end float f; double d; + __float128 q; switch (ILI_OPC(ilix)) { case IL_JSR: @@ -7820,6 +8687,7 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) case IL_DCEIL: case IL_AINT: case IL_DINT: + case IL_QINT: // AOCC /* floor/ceil/aint use llvm intrinsics, not calls via alt-ili */ break; case IL_VSIN: @@ -7909,7 +8777,9 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) /* If no type found assume generic pointer */ if (dtype == DT_NONE) dtype = DT_CPTR; - + // for allocatable array's dont do double indirection + if (!strncmp(SYMNAME(sptr),"Arg_.Z",6)) + break; if (operand->ll_type->sub_types[0]->data_type == LL_PTR || ILI_OPC(ld_ili) != IL_ACON) { operand = @@ -8047,12 +8917,15 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) } } break; case IL_LDSCMPLX: + case IL_LDQCMPLX: // AOCC case IL_LDDCMPLX: { unsigned flags; ld_ili = ILI_OPND(ilix, 1); nme_ili = ILI_OPND(ilix, 2); msz = (MSZ)ILI_OPND(ilix, 3); - flags = opc == IL_LDSCMPLX ? DT_CMPLX : DT_DCMPLX; + // AOCC: DT_QCMPLX + flags = opc == IL_LDSCMPLX ? DT_CMPLX : opc == IL_LDDCMPLX + ? DT_DCMPLX : DT_QCMPLX; operand = gen_address_operand(ld_ili, nme_ili, false, make_ptr_lltype(expected_type), (MSZ)-1); assert(operand->ll_type->data_type == LL_PTR, @@ -8063,6 +8936,7 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) case IL_LD: case IL_LDSP: case IL_LDDP: + case IL_LDQP: // AOCC case IL_LDKR: #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128LD: @@ -8128,8 +9002,10 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) case IL_ICON: case IL_FCON: case IL_DCON: + case IL_QCON: // AOCC case IL_SCMPLXCON: case IL_DCMPLXCON: + case IL_QCMPLXCON: // AOCC #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128CON: #endif @@ -8137,15 +9013,18 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) break; case IL_FIX: case IL_DFIX: + case IL_QFIX: //AOCC operand = gen_unary_expr(ilix, I_FPTOSI); break; case IL_FIXK: case IL_DFIXK: + case IL_QFIXK: //AOCC operand = gen_unary_expr(ilix, I_FPTOSI); break; case IL_FIXUK: case IL_DFIXUK: case IL_DFIXU: + case IL_QFIXU: //AOCC case IL_UFIX: operand = gen_unary_expr(ilix, I_FPTOUI); break; @@ -8159,14 +9038,24 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) case IL_DFLOAT: case IL_DFLOATK: case IL_FLOATK: + case IL_QFLOAT: // AOCC + case IL_QFLOATK: // AOCC operand = gen_unary_expr(ilix, I_SITOFP); break; case IL_SNGL: operand = gen_unary_expr(ilix, I_FPTRUNC); break; case IL_DBLE: + if (ILI_OPC(ILI_OPND(ilix, 1)) == IL_LDQP) + operand = gen_llvm_expr(ILI_OPND(ilix, 1), NULL); + else + operand = gen_unary_expr(ilix, I_FPEXT); + break; + // AOCC begin + case IL_QUAD: operand = gen_unary_expr(ilix, I_FPEXT); break; + // AOCC end #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128FROM: operand = gen_unary_expr(ilix, I_FPEXT); @@ -8191,6 +9080,7 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) break; case IL_FADD: case IL_DADD: + case IL_QADD: // AOCC #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128ADD: #endif @@ -8202,6 +9092,11 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) case IL_DCMPLXADD: operand = gen_cmplx_math(ilix, DT_DCMPLX, I_FADD); break; + // AOCC begin + case IL_QCMPLXADD: + operand = gen_cmplx_math(ilix, DT_QCMPLX, I_FADD); + break; + // AOCC end case IL_VSUB: operand = gen_binary_vexpr(ilix, I_SUB, I_SUB, I_FSUB); break; @@ -8213,6 +9108,7 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) break; case IL_FSUB: case IL_DSUB: + case IL_QSUB: // AOCC #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128SUB: #endif @@ -8224,6 +9120,11 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) case IL_DCMPLXSUB: operand = gen_cmplx_math(ilix, DT_DCMPLX, I_FSUB); break; + // AOCC begin + case IL_QCMPLXSUB: + operand = gen_cmplx_math(ilix, DT_QCMPLX, I_FSUB); + break; + // AOCC end case IL_VMUL: operand = gen_binary_vexpr(ilix, I_MUL, I_MUL, I_FMUL); break; @@ -8239,6 +9140,7 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) break; case IL_FMUL: case IL_DMUL: + case IL_QMUL: // AOCC #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128MUL: #endif @@ -8250,6 +9152,11 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) case IL_DCMPLXMUL: operand = gen_cmplx_mul(ilix, DT_DCMPLX); break; + // AOCC begin + case IL_QCMPLXMUL: + operand = gen_cmplx_mul(ilix, DT_QCMPLX); + break; + // AOCC end case IL_VDIV: operand = gen_binary_vexpr(ilix, I_SDIV, I_UDIV, I_FDIV); break; @@ -8263,6 +9170,7 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) break; case IL_FDIV: case IL_DDIV: + case IL_QDIV: // AOCC #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128DIV: #endif @@ -8289,6 +9197,9 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) case IL_RSHIFT: case IL_ARSHIFT: case IL_KARSHIFT: + /* AOCC begin */ + case IL_SHIFTA: + /* AOCC end */ operand = gen_binary_expr(ilix, I_ASHR); break; case IL_VAND: @@ -8349,6 +9260,11 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) case IL_DCMPLXXOR: operand = gen_cmplx_math(ilix, DT_DCMPLX, I_XOR); break; + // AOCC begin + case IL_QCMPLXXOR: + operand = gen_cmplx_math(ilix, DT_QCMPLX, I_XOR); + break; + // AOCC end case IL_KMOD: case IL_MOD: operand = gen_binary_expr(ilix, I_SREM); @@ -8388,6 +9304,26 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) operand->ll_type = make_type_from_opc(opc); goto process_cc; break; + // AOCC begin + case IL_QCJMPZ: + if (!zero_ili) { + q = 0.0; + xmqtoq(q, qtmp.tmp); + zero_ili = ad1ili(IL_QCON, getcon(qtmp.tmp, DT_QUAD)); + comp_exp_type = make_lltype_from_dtype(DT_QUAD); + } + operand->ot_type = OT_CC; + first_ili = ILI_OPND(ilix, 1); + second_ili = zero_ili; + ili_cc = ILI_ccOPND(ilix, 2); + if (IEEE_CMP) + float_jmp = true; + operand->val.cc = convert_to_llvm_fltcc(ili_cc); + float_jmp = false; + operand->ll_type = make_type_from_opc(opc); + goto process_cc; + break; + // AOCC end case IL_UKCJMPZ: zero_ili = ad_kconi(0); operand->ot_type = OT_CC; @@ -8443,6 +9379,7 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) /* jumps with cc and expression */ case IL_FCJMP: case IL_DCJMP: + case IL_QCJMP: // AOCC operand->ot_type = OT_CC; first_ili = ILI_OPND(ilix, 1); second_ili = ILI_OPND(ilix, 2); @@ -8484,6 +9421,7 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) break; case IL_FCMP: case IL_DCMP: + case IL_QCMP: // AOCC #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128CMP: #endif @@ -8685,6 +9623,14 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) if (expected_type == NULL) expected_type = make_lltype_from_dtype(DT_DBLE); goto _process_define_ili; + //AOCC Begin + case IL_FREEQP: + cse_opc = true; + case IL_DFRQP: + if (expected_type == NULL) + expected_type = make_lltype_from_dtype(DT_QUAD); + goto _process_define_ili; + //AOCC End case IL_DFR128: if (expected_type == NULL) expected_type = make_lltype_from_dtype(DT_128); @@ -8719,6 +9665,14 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) case IL_DFRCD: if (expected_type == NULL) expected_type = make_lltype_from_dtype(DT_DCMPLX); + goto _process_define_ili; + // AOCC begin + case IL_FREECQ: + cse_opc = true; + case IL_DFRCQ: + if (expected_type == NULL) + expected_type = make_lltype_from_dtype(DT_QCMPLX); + // AOCC end _process_define_ili: /* llvm_info.curr_ret_ili = ilix; */ @@ -8821,6 +9775,7 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) case IL_UKNEG: operand = gen_binary_expr(ilix, I_SUB); break; + case IL_QNEG: // AOCC case IL_DNEG: case IL_FNEG: #ifdef LONG_DOUBLE_FLOAT128 @@ -8829,13 +9784,14 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) operand = gen_binary_expr(ilix, I_FSUB); break; case IL_SCMPLXNEG: + case IL_QCMPLXNEG: // AOCC case IL_DCMPLXNEG: { OPERAND *res, *op_rneg, *op_ineg, *c1, *cse1; LL_Type *cmplx_ty, *cmpnt_ty; - const DTYPE dt = opc == IL_SCMPLXNEG ? DT_CMPLX : DT_DCMPLX; - const DTYPE et = opc == IL_SCMPLXNEG ? DT_FLOAT : DT_DBLE; + const DTYPE dt = opc == IL_SCMPLXNEG ? DT_CMPLX : opc == IL_DCMPLXNEG ? DT_DCMPLX : DT_QCMPLX; + const DTYPE et = opc == IL_SCMPLXNEG ? DT_FLOAT : opc == IL_DCMPLXNEG ? DT_DBLE : DT_QUAD; - cmpnt_ty = make_lltype_from_dtype(dt == DT_CMPLX ? DT_FLOAT : DT_DBLE); + cmpnt_ty = make_lltype_from_dtype(dt == DT_CMPLX ? DT_FLOAT : dt == DT_DCMPLX ? DT_DBLE : DT_QUAD); c1 = gen_eval_cmplx_value(ILI_OPND(ilix, 1), dt); cse1 = gen_copy_operand(c1); @@ -8862,9 +9818,11 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) case IL_CSEIR: case IL_CSESP: case IL_CSEDP: + case IL_CSEQP: // AOCC case IL_CSEAR: case IL_CSECS: case IL_CSECD: + case IL_CSECQ: // AOCC #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128CSE: #endif @@ -8932,6 +9890,12 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) dt = DT_DCMPLX; cmpnt = DT_NONE; goto component; + // AOCC begin + case IL_QCMPLX2REAL: + dt = DT_QCMPLX; + cmpnt = DT_NONE; + goto component; + // AOCC end case IL_SCMPLX2IMAG: dt = DT_CMPLX; cmpnt = (DTYPE)1; @@ -8940,21 +9904,34 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) dt = DT_DCMPLX; cmpnt = (DTYPE)1; goto component; + // AOCC begin + case IL_QCMPLX2IMAG: + dt = DT_QCMPLX; + cmpnt = (DTYPE)1; + goto component; + // AOCC end component: c1 = gen_eval_cmplx_value(ILI_OPND(ilix, 1), dt); operand = - gen_extract_value(c1, dt, dt == DT_CMPLX ? DT_FLOAT : DT_DBLE, cmpnt); + gen_extract_value(c1, dt, dt == DT_CMPLX ? DT_FLOAT : dt == DT_DCMPLX + ? DT_DBLE : DT_QUAD , cmpnt); break; case IL_SPSP2SCMPLX: + case IL_QPQP2QCMPLX: // AOCC case IL_DPDP2DCMPLX: { LL_Type *dt, *et; if (opc == IL_SPSP2SCMPLX) { dt = make_lltype_from_dtype(DT_CMPLX); et = make_lltype_from_dtype(DT_FLOAT); - } else { + } else if (opc == IL_DPDP2DCMPLX) { dt = make_lltype_from_dtype(DT_DCMPLX); et = make_lltype_from_dtype(DT_DBLE); + // AOCC begin + } else { + dt = make_lltype_from_dtype(DT_QCMPLX); + et = make_lltype_from_dtype(DT_QUAD); } + // AOCC end cc_op1 = gen_llvm_expr(ILI_OPND(ilix, 1), et); cc_op2 = gen_llvm_expr(ILI_OPND(ilix, 2), et); operand = make_undef_op(dt); @@ -8969,6 +9946,12 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) dt = DT_DCMPLX; cmpnt = DT_DBLE; goto component_zero; + // AOCC begin + case IL_QPQP2QCMPLXI0: + dt = DT_QCMPLX; + cmpnt = DT_QUAD; + goto component_zero; + // AOCC end component_zero: /* Set imaginary value to 0 */ cc_op1 = gen_llvm_expr(ILI_OPND(ilix, 1), make_lltype_from_dtype(cmpnt)); cc_op2 = make_constval_op(make_lltype_from_dtype(cmpnt), 0, 0); @@ -8984,6 +9967,12 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) dt = DT_DCMPLX; cmpnt = DT_DBLE; goto cmplx_conj; + // AOCC begin + case IL_QCMPLXCONJG: + dt = DT_QCMPLX; + cmpnt = DT_QUAD; + goto cmplx_conj; + // AOCC end cmplx_conj: /* result = {real , 0 - imag} */ c1 = gen_eval_cmplx_value(ILI_OPND(ilix, 1), dt); @@ -9129,6 +10118,14 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) case IL_KABS: operand = gen_abs_expr(ilix); break; + // AOCC begin + case IL_QABS: + operand = gen_call_llvm_intrinsic( + "fabsq", + gen_llvm_expr(ILI_OPND(ilix, 1), make_lltype_from_dtype(DT_QUAD)), + make_lltype_from_dtype(DT_QUAD), NULL, I_PICALL); + break; + // AOCC end case IL_FFLOOR: operand = gen_call_llvm_intrinsic( "floor.f32", @@ -9141,6 +10138,14 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) gen_llvm_expr(ILI_OPND(ilix, 1), make_lltype_from_dtype(DT_DBLE)), make_lltype_from_dtype(DT_DBLE), NULL, I_PICALL); break; + // AOCC begin + case IL_QFLOOR: + operand = gen_call_llvm_intrinsic( + "floorq", + gen_llvm_expr(ILI_OPND(ilix, 1), make_lltype_from_dtype(DT_QUAD)), + make_lltype_from_dtype(DT_QUAD), NULL, I_PICALL); + break; + // AOCC end case IL_FCEIL: operand = gen_call_llvm_intrinsic( "ceil.f32", @@ -9153,6 +10158,14 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) gen_llvm_expr(ILI_OPND(ilix, 1), make_lltype_from_dtype(DT_DBLE)), make_lltype_from_dtype(DT_DBLE), NULL, I_PICALL); break; + // AOCC begin + case IL_QCEIL: + operand = gen_call_llvm_intrinsic( + "ceilq", + gen_llvm_expr(ILI_OPND(ilix, 1), make_lltype_from_dtype(DT_QUAD)), + make_lltype_from_dtype(DT_QUAD), NULL, I_PICALL); + break; + // AOCC end case IL_AINT: operand = gen_call_llvm_intrinsic( "trunc.f32", @@ -9171,11 +10184,13 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) case IL_UKMIN: case IL_FMIN: case IL_DMIN: + case IL_QMIN: case IL_IMAX: case IL_UIMAX: case IL_KMAX: case IL_UKMAX: case IL_FMAX: + case IL_QMAX: // AOCC case IL_DMAX: { LL_Type *llTy; lhs_ili = ILI_OPND(ilix, 2); @@ -9213,8 +10228,10 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) case IL_ASELECT: case IL_FSELECT: case IL_DSELECT: + case IL_QSELECT: case IL_CSSELECT: case IL_CDSELECT: + case IL_CQSELECT: operand = gen_select_expr(ilix); break; case IL_FSQRT: @@ -9229,6 +10246,14 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) gen_llvm_expr(ILI_OPND(ilix, 1), make_lltype_from_dtype(DT_DBLE)), make_lltype_from_dtype(DT_DBLE), NULL, I_PICALL); break; + // AOCC begin + case IL_QSQRT: + operand = gen_call_llvm_intrinsic( + "sqrtq", + gen_llvm_expr(ILI_OPND(ilix, 1), make_lltype_from_dtype(DT_QUAD)), + make_lltype_from_dtype(DT_QUAD), NULL, I_PICALL); + break; + // AOCC end case IL_FLOG: operand = gen_call_llvm_intrinsic( "log.f32", @@ -9253,6 +10278,14 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) gen_llvm_expr(ILI_OPND(ilix, 1), make_lltype_from_dtype(DT_DBLE)), make_lltype_from_dtype(DT_DBLE), NULL, I_PICALL); break; + // AOCC begin + case IL_QLOG10: + operand = gen_call_llvm_intrinsic( + "log10.f128", + gen_llvm_expr(ILI_OPND(ilix, 1), make_lltype_from_dtype(DT_QUAD)), + make_lltype_from_dtype(DT_QUAD), NULL, I_PICALL); + break; + // AOCC end case IL_FSIN: operand = gen_call_llvm_intrinsic( "sin.f32", @@ -9271,6 +10304,14 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) gen_llvm_expr(ILI_OPND(ilix, 1), make_lltype_from_dtype(DT_FLOAT)), make_lltype_from_dtype(DT_FLOAT), NULL, I_CALL); break; + /* AOCC begin */ + case IL_FCOTAN: + operand = gen_call_pgocl_intrinsic( + "cotan_f", + gen_llvm_expr(ILI_OPND(ilix, 1), make_lltype_from_dtype(DT_FLOAT)), + make_lltype_from_dtype(DT_FLOAT), NULL, I_CALL); + break; + /* AOCC end */ case IL_DTAN: operand = gen_call_pgocl_intrinsic( "tan_d", @@ -9324,6 +10365,22 @@ gen_llvm_expr(int ilix, LL_Type *expected_type) gen_llvm_expr(ILI_OPND(ilix, 1), make_lltype_from_dtype(DT_DBLE)), make_lltype_from_dtype(DT_DBLE), NULL, I_PICALL); break; + // AOCC begin + case IL_QEXP: + operand = gen_call_llvm_intrinsic( + "expq", + gen_llvm_expr(ILI_OPND(ilix, 1), make_lltype_from_dtype(DT_QUAD)), + make_lltype_from_dtype(DT_QUAD), NULL, I_PICALL); + break; + case IL_QPOWQ: + operand = gen_llvm_expr(ILI_OPND(ilix, 1), make_lltype_from_dtype(DT_QUAD)); + operand->next = + gen_llvm_expr(ILI_OPND(ilix, 2), make_lltype_from_dtype(DT_QUAD)); + operand = gen_call_pgocl_intrinsic( + "pow_q", operand, make_lltype_from_dtype(DT_QUAD), NULL, I_CALL); + break; + // AOCC end + case IL_FAND: { /* bitwise logical AND op. operand has floating-point type %copnd1 = bitcast float %opnd1 to iX @@ -9799,6 +10856,11 @@ vect_llvm_intrinsic_name(int ilix) case DT_DBLE: fsize = 64; break; + // AOCC begin + case DT_QUAD: + fsize = 128; + break; + // AOCC end default: assert(0, "vect_llvm_intrinsic_name(): unhandled type", type, ERR_Fatal); } @@ -10136,9 +11198,9 @@ add_global_define(GBL_LIST *gitem) if (gitem->sptr && ST_ISVAR(STYPEG(gitem->sptr)) && !CCSYMG(gitem->sptr)) { LL_Type *type = make_lltype_from_sptr(gitem->sptr); - LL_Value *value = ll_create_value_from_type(cpu_llvm_module, type, + LL_Value *value = ll_create_value_from_type(current_module, type, SNAME(gitem->sptr)); - lldbg_emit_global_variable(cpu_llvm_module->debug_info, gitem->sptr, 0, + lldbg_emit_global_variable(current_module->debug_info, gitem->sptr, 0, 1, value); } } @@ -10405,6 +11467,25 @@ dtype_struct_name(DTYPE dtype) return dtype_str; } +// AOCC Begin +static bool is_device_arg(int sptr) { + if (!ISNVVMCODEGEN) + return false; + if (!flg.amdgcn_target) + return false; + const int stype = STYPEG(sptr); + if (stype == ST_ENTRY || stype == ST_PROC) + return false; + if (stype == ST_CONST) + return false; + if (DESCARRAYG(sptr) && CLASSG(sptr)) + return false; + if (SCG(sptr) == SC_STATIC && OMPACCFUNCKERNELG(gbl.currsub)) + return true; + return false; +} +// AOCC End + /* Set the LLVM name of a global sptr to '@' + name. * * This is appropriate for external identifiers and internal identifiers with a @@ -10415,7 +11496,12 @@ set_global_sname(int sptr, const char *name) { name = map_to_llvm_name(name); SNAME(sptr) = (char *)getitem(LLVM_LONGTERM_AREA, strlen(name) + 2); - sprintf(SNAME(sptr), "@%s", name); + // AOCC Begin + if (flg.amdgcn_target && is_device_arg(sptr)) + sprintf(SNAME(sptr), "%%%s", name); + // AOCC End + else + sprintf(SNAME(sptr), "@%s", name); return SNAME(sptr); } @@ -10476,8 +11562,7 @@ create_global_initializer(GBL_LIST *gitem, const char *flag_str, dty = DTY(DTYPEG(sptr)); stype = STYPEG(sptr); - if ( - (stype == ST_VAR && dty == TY_PTR)) + if ((stype == ST_VAR && dty == TY_PTR)) initializer = "null"; else if (AGGREGATE_STYPE(stype) || COMPLEX_DTYPE(DTYPEG(sptr)) || VECTOR_DTYPE(DTYPEG(sptr))) @@ -10493,6 +11578,22 @@ create_global_initializer(GBL_LIST *gitem, const char *flag_str, gitem->global_def = gname; } +/** + \brief Check if sptr is the midnum of a scalar and scalar has POINTER/ALLOCATABLE attribute + \param sptr A symbol + */ +bool +pointer_scalar_need_debug_info(SPTR sptr) +{ + if ((sptr > NOSYM) && REVMIDLNKG(sptr)) { + SPTR scalar_sptr = (SPTR)REVMIDLNKG(sptr); + if ((POINTERG(scalar_sptr) || ALLOCATTRG(scalar_sptr)) && + ((STYPEG(scalar_sptr) == ST_VAR) || (STYPEG(scalar_sptr) == ST_STRUCT))) + return true; + } + return false; +} + /** \brief Check if sptr is the midnum of an array and the array has descriptor \param sptr A symbol @@ -10520,7 +11621,9 @@ needDebugInfoFilt(SPTR sptr) return true; /* Fortran case needs to be revisited when we start to support debug, for now * just the obvious case */ - return (!CCSYMG(sptr) || DCLDG(sptr) || ftn_array_need_debug_info(sptr)); + return (!CCSYMG(sptr) || DCLDG(sptr) || + is_procedure_ptr((SPTR)REVMIDLNKG(sptr)) || + ftn_array_need_debug_info(sptr)); } #ifdef OMP_OFFLOAD_LLVM INLINE static bool @@ -10532,7 +11635,12 @@ is_ompaccel(SPTR sptr) INLINE static bool generating_debug_info(void) { - return flg.debug && cpu_llvm_module->debug_info; + bool generate_debug = flg.debug && cpu_llvm_module->debug_info; +#ifdef OMP_OFFLOAD_LLVM + if (flg.omptarget) + generate_debug = flg.debug && gpu_llvm_module->debug_info; +#endif + return generate_debug; } /** @@ -10577,6 +11685,11 @@ addDebugForGlobalVar(SPTR sptr, ISZ_T off) { if (need_debug_info(sptr)) { LL_Module *mod = cpu_llvm_module; +#ifdef OMP_OFFLOAD_LLVM + if (flg.omptarget && (current_module != NULL)) + mod = current_module; +#endif + /* TODO: defeat unwanted side-effects. make_lltype_from_sptr() will update the LLTYPE() type (sptr_type_array) along some paths. This may be undesirable at this point, because the array gets updated with an @@ -10586,6 +11699,7 @@ addDebugForGlobalVar(SPTR sptr, ISZ_T off) LL_Type *sty = make_lltype_from_sptr(sptr); LL_Type *dty = ll_get_pointer_type(make_lltype_from_dtype(DTYPEG(sptr))); const char *glob = SNAME(sptr); + LL_Type *vty = mergeDebugTypesForGlobal(&glob, sty, dty); LL_Value *val = ll_create_value_from_type(mod, vty, glob); lldbg_emit_global_variable(mod->debug_info, sptr, off, 1, val); @@ -10600,9 +11714,18 @@ process_cmnblk_data(SPTR sptr, ISZ_T off) SPTR scope = SCOPEG(cmnblk); if (flg.debug && !CCSYMG(cmnblk) && (scope > 0)) { + /* For non-openmp applications, current_module is not used or is set to + * NULL, hence we can not use current_module for both openmp and non-openmp + * applications, instead we need to use respective LL_Module. + */ + LL_Module *mod = cpu_llvm_module; +#ifdef OMP_OFFLOAD_LLVM + if (flg.omptarget) + mod = current_module; +#endif const char *name = new_debug_name(SYMNAME(scope), SYMNAME(cmnblk), NULL); - if (!ll_get_module_debug(cpu_llvm_module->common_debug_map, name)) - lldbg_emit_common_block_mdnode(cpu_llvm_module->debug_info, cmnblk); + if (!ll_get_module_debug(mod->common_debug_map, name)) + lldbg_emit_common_block_mdnode(mod->debug_info, cmnblk); } } @@ -10873,11 +11996,25 @@ process_extern_variable_sptr(SPTR sptr, ISZ_T off) INLINE static void addDebugForLocalVar(SPTR sptr, LL_Type *type) { - if (need_debug_info(sptr)) { + if (need_debug_info(sptr) || pointer_scalar_need_debug_info(sptr)) { /* Dummy sptrs are treated as local (see above) */ - LL_MDRef param_md = lldbg_emit_local_variable( - cpu_llvm_module->debug_info, sptr, BIH_FINDEX(gbl.entbih), true); - insert_llvm_dbg_declare(param_md, sptr, type, NULL, OPF_NONE); + if ((ll_feature_debug_info_ver11(¤t_module->ir) && + ftn_array_need_debug_info(sptr)) && + (DTYPEG(REVMIDLNKG(sptr)) != DT_DEFERCHAR)) { + SPTR array_sptr = (SPTR)REVMIDLNKG(sptr); + LL_MDRef array_md = + lldbg_emit_local_variable(current_module->debug_info, array_sptr, + BIH_FINDEX(gbl.entbih), true); + LL_Type *sd_type = LLTYPE(SDSCG(array_sptr)); + if (sd_type && sd_type->data_type == LL_PTR) + sd_type = sd_type->sub_types[0]; + insert_llvm_dbg_declare(array_md, SDSCG(array_sptr), + sd_type, NULL, OPF_NONE); + } else { + LL_MDRef param_md = lldbg_emit_local_variable( + current_module->debug_info, sptr, BIH_FINDEX(gbl.entbih), true); + insert_llvm_dbg_declare(param_md, sptr, type, NULL, OPF_NONE); + } } } @@ -11060,7 +12197,7 @@ process_auto_sptr(SPTR sptr) /* Now create the alloca for this variable. Since the alloca produces the * address of the local, name it "%foo.addr". */ local = ll_create_local_object(llvm_info.curr_func, type, align_of_var(sptr), - "%s.addr", SYMNAME(sptr)); + "%s.addr", SYMNAME(sptr)); SNAME(sptr) = (char *)local->address.data; addDebugForLocalVar(sptr, type); @@ -11145,6 +12282,7 @@ process_sptr_offset(SPTR sptr, ISZ_T off) hashmap_lookup(llvm_info.homed_args, INT2HKEY(midnum), NULL)) { LLTYPE(sptr) = LLTYPE(midnum); SNAME(sptr) = SNAME(midnum); + DBGTRACEOUT("") return; } if (hashmap_lookup(llvm_info.homed_args, INT2HKEY(sptr), NULL)) { @@ -11307,13 +12445,16 @@ match_types(LL_Type *ty1, LL_Type *ty2) assert(ty1 && ty2, "match_types(): missing argument", 0, ERR_Fatal); DBGTRACEIN2("match_types: ty1=%s, ty2=%s\n", ty1->str, ty2->str); - if (ty1 == ty2) - return MATCH_OK; + if (ty1 == ty2) { + ret_type = MATCH_OK; + goto return_match_types; + } if (ty1->data_type == LL_ARRAY) { LL_Type *ele1 = ll_type_array_elety(ty1); LL_Type *ele2 = ll_type_array_elety(ty2); - return ele2 ? match_types(ele1, ele2) : MATCH_NO; + ret_type = (ele2 ? match_types(ele1, ele2) : MATCH_NO); + goto return_match_types; } if ((ty1->data_type == LL_PTR) || (ty2->data_type == LL_PTR)) { @@ -11368,8 +12509,9 @@ match_types(LL_Type *ty1, LL_Type *ty2) ret_type = MATCH_NO; } +return_match_types: if (ll_type_int_bits(ty1)) { - DBGTRACEOUT4(" returns %d(%s) ty1 = %s%d", ret_type, match_names(ret_type), + DBGTRACEOUT4(" returns %d(%s) ty1 = %s ty1 size = %d", ret_type, match_names(ret_type), ty1->str, (int)(ll_type_bytes(ty1) * BITS_IN_BYTE)) } else { DBGTRACEOUT3(" returns %d(%s) ty1 = %s", ret_type, match_names(ret_type), @@ -11436,6 +12578,8 @@ make_type_from_opc(ILI_OP opc) case IL_UINEG: case IL_DFIX: case IL_DFIXU: + case IL_QFIX: // AOCC + case IL_QFIXU: // AOCC case IL_ICMP: case IL_ICMPZ: case IL_ISELECT: @@ -11445,6 +12589,9 @@ make_type_from_opc(ILI_OP opc) case IL_UIMAX: case IL_IABS: case IL_CMPXCHG_OLDI: + /* AOCC begin */ + case IL_SHIFTA: + /* AOCC end */ llt = make_lltype_from_dtype(DT_INT); break; case IL_KAND: @@ -11484,6 +12631,7 @@ make_type_from_opc(ILI_OP opc) case IL_UKCMP: case IL_DFIXK: case IL_DFIXUK: + case IL_QFIXK: // AOCC case IL_UKCJMP: case IL_UKADD: case IL_UKSUB: @@ -11547,6 +12695,32 @@ make_type_from_opc(ILI_OP opc) case IL_DABS: llt = make_lltype_from_dtype(DT_DBLE); break; + // AOCC begin + case IL_QCJMP: + case IL_QCJMPZ: + case IL_QCMP: + case IL_QFLOAT: + case IL_QFLOATU: + case IL_QFLOATK: + case IL_QUAD: + case IL_QADD: + case IL_QSUB: + case IL_QNEG: + case IL_QMAX: + case IL_QMIN: + case IL_QMOD: + case IL_QMUL: + case IL_QDIV: + case IL_QCON: + case IL_QSELECT: + case IL_QABS: + llt = make_lltype_from_dtype(DT_QUAD); + break; + case IL_CQSELECT: + case IL_QCMPLXADD: + llt = make_lltype_from_dtype(DT_QCMPLX); + break; + // AOCC end case IL_CSSELECT: case IL_SCMPLXADD: llt = make_lltype_from_dtype(DT_CMPLX); @@ -11901,6 +13075,62 @@ gen_acon_expr(int ilix, LL_Type *expected_type) return operand; } +// AOCC begin +static OPERAND * +attempt_ptr_gep_folding(int baseOp, int idxOp) { + int base_acon = ILI_OPND(baseOp, 1); + SPTR addr_sptr = ILI_SymOPND(base_acon, 1); + SPTR base_sptr = (SPTR)CONVAL1G(addr_sptr); + + int _base_nme = ILI_OPND(baseOp, 2); + + if (_base_nme < 0 || _base_nme >= nmeb.stg_avail) + return NULL; + + int base_nme = basenme_of(_base_nme); + if (base_nme) { + if (NME_SYM(base_nme) != base_sptr) + return NULL; + } + + if (DTY(DTYPEG(addr_sptr)) != TY_PTR) + return NULL; + + if (STYPEG(base_sptr) != ST_VAR) + return NULL; + + // FIXME! It would be nice if we could get the underlying shape here and only + // perform the folding if we're working on pointers to simpler shapes like 1D + // arrays for now. + // + // ADSC *ad = AD_DPTR(DTYPEG(base_nme)); + // printf("%d\n", AD_NUMDIM(ad)); // ? + // + // #include "mwd.h" + // gbl.dbgfil = stdout; + // dumpdtype(DTYPEG(NME_SYM(base_nme))); + // dumpdtype(DTYPEG(base_sptr)); + + if (ILI_OPC(idxOp) != IL_KAMV) + return NULL; + + int kmul = ILI_OPND(idxOp, 1); + if (ILI_OPC(kmul) != IL_KMUL) + return NULL; + + int ldkr = ILI_OPND(kmul, 1); + if (ILI_OPC(ldkr) != IL_LDKR) + return NULL; + + int acon = ILI_OPND(ldkr, 1); + if (ILI_OPC(acon) != IL_ACON) + return NULL; + + OPERAND *op = gen_llvm_expr(ILI_OPND(kmul, 2), make_int_lltype(64)); + return op; +} +// AOCC end + /** \brief Pattern match the ILI tree and fold when there is a match \param addr The ILI to pattern match @@ -11975,6 +13205,17 @@ maybe_do_gep_folding(int aadd, int idxOp, LL_Type *ty) return rv; } + // AOCC begin + if (XBIT(2, 0x2000000)) { + rv = attempt_ptr_gep_folding(baseOp, idxOp); + if (rv) { + OPERAND *base = gen_base_addr_operand(baseOp, ty); + rv = gen_gep_op(aadd, base, ty, rv); + return rv; + } + } + // AOCC end + addressElementSize = savedAddressElementSize; return NULL; } @@ -12347,7 +13588,6 @@ gen_constant(SPTR sptr, DTYPE tdtype, INT conval0, INT conval1, int flags) break; case DT_DBLE: - case DT_QUAD: if (sptr) { num[0] = CONVAL1G(sptr); @@ -12375,6 +13615,14 @@ gen_constant(SPTR sptr, DTYPE tdtype, INT conval0, INT conval1, int flags) DBGTRACE1("#set double exponent value to %s", d) } break; + // AOCC begin + case DT_QUAD: + size += 36; + constant = getitem(LLVM_LONGTERM_AREA, size); + snprintf(constant, size, "0xL%08x%08x%08x%08x", CONVAL1G(sptr), + CONVAL2G(sptr), CONVAL3G(sptr), CONVAL4G(sptr)); + break; + // AOCC end case DT_REAL: /* our internal representation of floats is in 8 digit hex form; * internal LLVM representation of floats in hex form is 16 digits; @@ -12490,9 +13738,66 @@ isNVVM(char *fn_name) { if (!flg.omptarget) return false; + + // AOCC begin + if (flg.x86_64_omptarget) { + if ((strncmp(fn_name, "f90_", 4) == 0) || + (strncmp(fn_name, "f90io_", 6) == 0) || + (strncmp(fn_name, "_mp_", 4) == 0) || + (strncmp(fn_name, "__ps", 4) == 0)) { + return true; + } + } + // AOCC end + if ((strcmp(fn_name,"__tgt_target") == 0 || + (strcmp(fn_name,"__tgt_register_requires") == 0 || + (strcmp(fn_name,"__tgt_register_lib") == 0)))) + return false; + + // AOCC + // we can have target function calls within the target region. + // returning true for all function calls + return true; + + // the following code will be deleted return (strncmp(fn_name, "__kmpc", 6) == 0) || (strncmp(fn_name, "llvm.nvvm", 9) == 0) || + // AOCC Begin + /* + * We need some math intrinsics to be emitted. + * TODO : Handle special cases if any, which are not supported by target. + * + */ +#ifdef OMP_OFFLOAD_AMD + (strncmp(fn_name, "nvvm.", 5) == 0) || + (strncmp(fn_name, "llvm.", 5) == 0) || + (strncmp(fn_name, "sqrt", 4) == 0) || + (strncmp(fn_name, "sin", 3) == 0) || + (strncmp(fn_name, "cos", 3) == 0) || + (strncmp(fn_name, "tanf", 4) == 0) || + (strncmp(fn_name, "tan", 3) == 0) || + (strncmp(fn_name, "pow", 3) == 0) || + (strncmp(fn_name, "exp", 3) == 0) || + (strncmp(fn_name, "log", 3) == 0) || + (strncmp(fn_name, "log10", 5) == 0) || + (strncmp(fn_name, "sinhf", 5) == 0) || + (strncmp(fn_name, "sinh", 4) == 0) || + (strncmp(fn_name, "coshf", 5) == 0) || + (strncmp(fn_name, "cosh", 4) == 0) || + (strncmp(fn_name, "tanhf", 5) == 0) || + (strncmp(fn_name, "tanh", 4) == 0) || + (strncmp(fn_name, "atanf", 5) == 0) || + (strncmp(fn_name, "atan", 4) == 0) || + (strncmp(fn_name, "acosf", 5) == 0) || + (strncmp(fn_name, "acos", 4) == 0) || + (strncmp(fn_name, "asinf", 5) == 0) || + (strncmp(fn_name, "asin", 4) == 0) || + (strncmp(fn_name, "__ockl_get", 10) == 0) || + (strncmp(fn_name, "temperton", 9) == 0) || +#endif + // AOCC End (strncmp(fn_name, "omp_", 4) == 0) || + (strncmp(fn_name, "fib_", 4) == 0) || (strncmp(fn_name, "llvm.fma", 8) == 0); } #endif @@ -12590,6 +13895,28 @@ build_unused_global_define_from_params(void) return; } +// AOCC Begin +/** + \brief Helper function: test if the param length exists as compiler created + symbol which represents length of any assumed length string argument + in the arg list + \param length is the compiler created symbol which represents length of + assumed length string argument + */ +INLINE static bool +cg_fetch_clen_parent(SPTR length) +{ + int i; + SPTR parent; + for (i = 1; i <= llvm_info.abi_info->nargs; ++i) { + parent = llvm_info.abi_info->arg[i].sptr; + if ((DTY(DTYPEG(parent)) == TY_CHAR) && (DTYPEG(parent) == DT_ASSCHAR) && + (CLENG(parent) == length)) return true; + } + return false; +} +// AOCC End + /** \brief Helper function: In Fortran, test if \c MIDNUM is not \c SC_DUMMY \param sptr a symbol @@ -12616,7 +13943,7 @@ cons_expression_metadata_operand(LL_Type *llTy) { // FIXME: we don't need to always do this, do we? do a type check here if (llTy->data_type == LL_PTR) { - LL_DebugInfo *di = cpu_llvm_module->debug_info; + LL_DebugInfo *di = current_module->debug_info; unsigned v = lldbg_encode_expression_arg(LL_DW_OP_deref, 0); LL_MDRef exprMD = lldbg_emit_expression_mdnode(di, 1, v); return make_mdref_op(exprMD); @@ -12642,7 +13969,21 @@ INLINE static void formalsAddDebug(SPTR sptr, unsigned i, LL_Type *llType, bool mayHide) { if (formalsNeedDebugInfo(sptr)) { - LL_DebugInfo *db = cpu_llvm_module->debug_info; + bool is_ptr_alc_arr = false; + SPTR new_sptr = (SPTR)REVMIDLNKG(sptr); + if (ll_feature_debug_info_ver11(&cpu_llvm_module->ir) && + CCSYMG(sptr) /* Otherwise it can be a cray pointer */ && + (new_sptr && (STYPEG(new_sptr) == ST_ARRAY) && + (POINTERG(new_sptr) || ALLOCATTRG(new_sptr))) && + SDSCG(new_sptr)) { + is_ptr_alc_arr = true; + sptr = new_sptr; + } + LL_DebugInfo *db = current_module->debug_info; + if (ll_feature_debug_info_ver11(&cpu_llvm_module->ir) && + STYPEG(sptr) == ST_ARRAY && CCSYMG(sptr) && + !LL_MDREF_IS_NULL(get_param_mdnode(db, sptr))) + return; LL_MDRef param_md = lldbg_emit_param_variable( db, sptr, BIH_FINDEX(gbl.entbih), i, CCSYMG(sptr)); if (!LL_MDREF_IS_NULL(param_md)) { @@ -12651,6 +13992,12 @@ formalsAddDebug(SPTR sptr, unsigned i, LL_Type *llType, bool mayHide) ? NULL : cons_expression_metadata_operand(llTy); OperandFlag_t flag = (mayHide && CCSYMG(sptr)) ? OPF_HIDDEN : OPF_NONE; + // For pointer, allocatable, assumed shape and assumed rank arrays, pass + // descriptor in place of base address. + if (ll_feature_debug_info_ver11(&cpu_llvm_module->ir) && + (is_ptr_alc_arr || ASSUMRANKG(sptr) || ASSUMSHPG(sptr)) && + SDSCG(sptr)) + sptr = SDSCG(sptr); insert_llvm_dbg_declare(param_md, sptr, llTy, exprMDOp, flag); } } @@ -12683,8 +14030,10 @@ process_formal_arguments(LL_ABI_Info *abi) bool ftn_byval = false; assert(arg->sptr, "Unnamed function argument", i, ERR_Fatal); +#if 0 assert(SNAME(arg->sptr) == NULL, "Argument sptr already processed", arg->sptr, ERR_Fatal); +#endif if ((SCG(arg->sptr) != SC_DUMMY) && formalsMidnumNotDummy(arg->sptr)) { process_sptr(arg->sptr); continue; @@ -12756,7 +14105,7 @@ process_formal_arguments(LL_ABI_Info *abi) /* Make a name for the real LLVM IR argument. This will also be used by * build_routine_and_parameter_entries(). */ arg_op->string = (char *)ll_create_local_name( - llvm_info.curr_func, "%s%s", get_llvm_name(arg->sptr), suffix); + llvm_info.curr_func, "%s%s", get_llvm_name(arg->sptr), suffix); /* Emit code in the entry block that saves the argument into the local * variable. */ @@ -12859,7 +14208,18 @@ process_formal_arguments(LL_ABI_Info *abi) assert(llTy->data_type == LL_PTR, "expected a pointer type", llTy->data_type, ERR_Fatal); /* Emit an @llvm.dbg.declare right after the store. */ - formalsAddDebug(arg->sptr, i, llTy, true); +// AOCC Begin + /* if arg->sptr is the compiler created symbol which represents the length + * of assumed length string type, then make the first metadata argument type + * of this symbol as address instead of value in the llvm.dbg.declare + * intrinsic. + */ + if ((arg->kind == LL_ARG_DIRECT) && CCSYMG(arg->sptr) && + PASSBYVALG(arg->sptr) && cg_fetch_clen_parent(arg->sptr)) + formalsAddDebug(arg->sptr, i, llTy, false); + else +// AOCC End + formalsAddDebug(arg->sptr, i, llTy, true); } } @@ -12868,8 +14228,18 @@ process_formal_arguments(LL_ABI_Info *abi) \param arg an argument's info record */ static void -print_arg_attributes(LL_ABI_ArgInfo *arg) +print_arg_attributes(LL_ABI_ArgInfo *arg, bool noalias_prop) { + + // AOCC:Functions arguments are by default assumed to be not aliased + // with each other. As per the fortran 2003 standard specification + // document (NOTE 12.29 and NOTE 12.30 version: J3/04-007 May 10, 2004 11:07), + // the values in the overlapping region of arguments is unpredictable. + // Use option -func-args_alias to disable the same. + if (!flg.func_args_alias && arg->type->data_type == LL_PTR && noalias_prop) { + print_token(" noalias"); + } + switch (arg->kind) { case LL_ARG_DIRECT: case LL_ARG_COERCE: @@ -12884,6 +14254,12 @@ print_arg_attributes(LL_ABI_ArgInfo *arg) break; case LL_ARG_BYVAL: print_token(" byval"); + print_token(" ("); + if (arg->type->data_type == LL_PTR) + write_type(arg->type->sub_types[0]); + else + write_type(arg->type); + print_token(" )"); break; default: interr("Unknown argument kind", arg->kind, ERR_Fatal); @@ -12930,7 +14306,10 @@ print_function_signature(int func_sptr, const char *fn_name, LL_ABI_Info *abi, if (LL_ABI_HAS_SRET(abi)) { print_token(" void"); } else { - print_arg_attributes(&abi->arg[0]); + bool noalias_prop = false; + if (strstr(fn_name, "f90_alloc") != 0) + noalias_prop = true; + print_arg_attributes(&abi->arg[0], noalias_prop); print_space(1); print_token(abi->extend_abi_return ? make_lltype_from_dtype(DT_INT)->str : abi->arg[0].type->str); @@ -12959,7 +14338,7 @@ print_function_signature(int func_sptr, const char *fn_name, LL_ABI_Info *abi, print_token(", "); print_token(arg->type->str); - print_arg_attributes(arg); + print_arg_attributes(arg,true); if (print_arg_names && arg->sptr) { int key; @@ -12997,11 +14376,18 @@ print_function_signature(int func_sptr, const char *fn_name, LL_ABI_Info *abi, if (need_debug_info(SPTR_NULL)) { /* 'attributes #0 = { ... }' to be emitted later */ print_token(" #0"); - } else if (!XBIT(183, 0x10)) { + } else if (!XBIT(183, 0x10) || XBIT(14, 0x8)) { /* Nobody sets -x 183 0x10, besides Flang. We're disabling LLVM inlining for * proprietary compilers. */ + /* 2nd XBIT - Apply noinline attribute if the pragma "noinline" is given */ print_token(" noinline"); } +// AOCC BEGIN + if (XBIT(191, 0x2)) { + /* Apply alwaysinline attribute if the pragma "forceinline" is given */ + print_token(" alwaysinline"); + } +// AOCC END if (func_sptr > NOSYM) { /* print_function_signature() can be called with func_sptr=0 */ @@ -13023,14 +14409,89 @@ print_function_signature(int func_sptr, const char *fn_name, LL_ABI_Info *abi, } #ifdef OMP_OFFLOAD_LLVM -INLINE void static add_property_struct(char *func_name, int nreductions, - int reductionsize) +INLINE void static add_property_struct(char *func_name, + int n_reduction_symbols, + int reductionsize, + OMP_TARGET_MODE mode) { print_token("@"); print_token(func_name); - print_token("__exec_mode = weak constant i8 0\n"); + + if (is_SPMD_mode(mode)) { + print_token("__exec_mode = weak constant i8 2\n"); + } + else { + print_token("__exec_mode = weak constant i8 1\n"); + } +} +#endif + +// AOCC begin +#ifdef OMP_OFFLOAD_LLVM +/** + * \brief emits the tgt-offload-entry structure globals in the device IR for x86 + * offloading for the function \p func_sptr. + * + * These global structs will go to the .omp_offloading.entries data section + * which will be fetched by x86's RTL in libomptarget. These are not meant to be + * referenced in anywhere else in the IR, hence we're hard-coding them here. + * + */ +static void +emit_x86_device_offload_entry(SPTR func_sptr) +{ + bool debug_me = false; + + assert(get_llasm_output_file() == gbl.ompaccfile && flg.x86_64_omptarget, + "This function should only be called for x86 offloading and only " + "during it's device IR emission", func_sptr, ERR_Fatal); + + if (!ompaccel_x86_is_entry_func(func_sptr)) + return; + + char *omp_entry_var_name, *omp_entry_sym_name; + size_t name_sz = 100 + strlen(SYMNAME(func_sptr)); + FILE *ll_file = get_llasm_output_file(); + static bool offload_structty_defined = false; + + NEW(omp_entry_var_name, char, name_sz); + NEW(omp_entry_sym_name, char, name_sz); + + strcpy(omp_entry_sym_name, SYMNAME(func_sptr)); + + if (debug_me) { + printf("[ompaccel-x86]: generating entry for %s\n", omp_entry_sym_name); + } + strcpy(omp_entry_var_name, ".openmp.offload.entry."); + strcat(omp_entry_var_name, omp_entry_sym_name); + + LL_Type *kernel_ty = make_lltype_from_sptr(func_sptr); + + if (!offload_structty_defined) { + fprintf(ll_file, "%%struct.__tgt_offload_entry = type { i8*, i8*, i64, i32, i32 }\n"); + offload_structty_defined = true; + } + + fprintf(ll_file, "@.omp_offloading.entry_name_%s = internal unnamed_addr constant [%d x i8] c\"%s\\00\"\n", + omp_entry_sym_name, + strlen(omp_entry_sym_name) + 1, + omp_entry_sym_name); + + fprintf(ll_file, "@%s = ", omp_entry_var_name); + fprintf(ll_file, "weak constant %%struct.__tgt_offload_entry { "); + if (ompaccel_x86_is_fork_wrapper_func(func_sptr)) + fprintf(ll_file, "i8* bitcast (%s @%s to i8*), ", kernel_ty->str, omp_entry_sym_name); + else + fprintf(ll_file, "i8* bitcast (%s @%s_ to i8*), ", kernel_ty->str, omp_entry_sym_name); + fprintf(ll_file, "i8* getelementptr inbounds ([%d x i8], [%d x i8]* @.omp_offloading.entry_name_%s, i32 0, i32 0), ", + strlen(omp_entry_sym_name) + 1, + strlen(omp_entry_sym_name) + 1, + omp_entry_sym_name); + fprintf(ll_file, "i64 0, i32 0, i32 0 }, "); + fprintf(ll_file, "section \"omp_offloading_entries\", align 1\n"); } #endif +// AOCC end /** \brief write out the header of the function definition @@ -13044,10 +14505,15 @@ build_routine_and_parameter_entries(SPTR func_sptr, LL_ABI_Info *abi, const char *linkage = NULL; int reductionsize = 0; #ifdef OMP_OFFLOAD_LLVM + // AOCC begin + if (get_llasm_output_file() == gbl.ompaccfile && flg.x86_64_omptarget) { + emit_x86_device_offload_entry(func_sptr); + } + // AOCC end if (OMPACCFUNCKERNELG(func_sptr)) { OMPACCEL_TINFO *tinfo = ompaccel_tinfo_get(func_sptr); if (tinfo->n_reduction_symbols == 0) { - add_property_struct(SYMNAME(func_sptr), 0, 0); + add_property_struct(SYMNAME(func_sptr), 0, 0, tinfo->mode); } else { for (int i = 0; i < tinfo->n_reduction_symbols; ++i) { reductionsize += @@ -13055,7 +14521,7 @@ build_routine_and_parameter_entries(SPTR func_sptr, LL_ABI_Info *abi, BITS_IN_BYTE); } add_property_struct(SYMNAME(func_sptr), tinfo->n_reduction_symbols, - reductionsize); + reductionsize, tinfo->mode); } } #endif @@ -13067,8 +14533,24 @@ build_routine_and_parameter_entries(SPTR func_sptr, LL_ABI_Info *abi, linkage = " internal"; #ifdef OMP_OFFLOAD_LLVM if (OMPACCFUNCKERNELG(func_sptr)) { - linkage = " ptx_kernel"; + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + if (flg.amdgcn_target) + linkage = " amdgpu_kernel"; + else if (flg.x86_64_omptarget) + linkage = " "; + else +#endif + // AOCC End + linkage = " ptx_kernel"; + } + + // AOCC Begin + if (!linkage && CONSTRUCTORG(func_sptr) && + (flg.amdgcn_target || flg.x86_64_omptarget)) { + linkage = " linkonce"; } + // AOCC End #endif if (linkage) print_token(linkage); @@ -13121,6 +14603,7 @@ exprjump(ILI_OP opc) case IL_ICJMP: case IL_FCJMP: case IL_DCJMP: + case IL_QCJMP: case IL_ACJMP: case IL_UICJMP: return true; @@ -13176,6 +14659,16 @@ static void update_llvm_sym_arrays(void) { const int new_size = stb.stg_avail + MEM_EXTRA; + // AOCC Begin + // Adding back the removed code. + // This was removed in + // commit fdcf2bc30393c4b9ff55fa78516088fc836bb3bd + // Merge of PR #790 from PGI + int old_last_sym_avail = llvm_info.last_sym_avail; // NEEDB assigns + NEEDB(stb.stg_avail, sptrinfo.array.stg_base, char *, llvm_info.last_sym_avail, new_size); + NEEDB(stb.stg_avail, sptrinfo.type_array.stg_base, LL_Type *, old_last_sym_avail, + new_size); + // AOCC End if ((flg.debug || XBIT(120, 0x1000)) && cpu_llvm_module) { lldbg_update_arrays(cpu_llvm_module->debug_info, llvm_info.last_dtype_avail, stb.dt.stg_avail + MEM_EXTRA); @@ -13223,6 +14716,19 @@ cg_llvm_init(void) /* last_sym_avail is used for all the arrays below */ llvm_info.last_sym_avail = stb.stg_avail + MEM_EXTRA; + // AOCC Begin + NEW(sptrinfo.array.stg_base, char *, stb.stg_avail + MEM_EXTRA); + BZERO(sptrinfo.array.stg_base, char *, stb.stg_avail + MEM_EXTRA); + /* set up the type array shadowing the symbol table */ + NEW(sptrinfo.type_array.stg_base, LL_Type *, stb.stg_avail + MEM_EXTRA); + BZERO(sptrinfo.type_array.stg_base, LL_Type *, stb.stg_avail + MEM_EXTRA); + + // Using above allocation method instead of below allocation method. + // As below allocation seems to fail with GPU codegen. + // This was added after + // commit fdcf2bc30393c4b9ff55fa78516088fc836bb3bd + // Merge of PR #790 from PGI +#if 0 if (sptrinfo.array.stg_base) { STG_CLEAR_ALL(sptrinfo.array); STG_CLEAR_ALL(sptrinfo.type_array); @@ -13231,6 +14737,8 @@ cg_llvm_init(void) /* set up the type array shadowing the symbol table */ STG_ALLOC_SIDECAR(stb, sptrinfo.type_array); } +#endif + // AOCC End Globals = NULL; recorded_Globals = NULL; @@ -13256,7 +14764,7 @@ cg_llvm_init(void) if (flg.debug || XBIT(120, 0x1000)) { lldbg_init(cpu_llvm_module); #ifdef OMP_OFFLOAD_LLVM - if (flg.omptarget && XBIT(232, 0x8)) + if (flg.omptarget) lldbg_init(gpu_llvm_module); #endif } @@ -13285,7 +14793,6 @@ cg_llvm_end(void) ll_write_metadata(llvm_file(), cpu_llvm_module); #ifdef OMP_OFFLOAD_LLVM if (flg.omptarget) { - ll_write_metadata(llvm_file(), gpu_llvm_module); ll_build_metadata_device(gbl.ompaccfile, gpu_llvm_module); ll_write_metadata(gbl.ompaccfile, gpu_llvm_module); } @@ -13547,7 +15054,6 @@ llvm_write_ctor_dtor_list(init_list_t *list, const char *global_name) print_token(" = appending global ["); sprintf(int_str_buffer, "%d", list->size); print_token(int_str_buffer); - if (ll_feature_three_argument_ctor_and_dtor(¤t_module->ir)) { print_token(" x { i32, void ()*, i8* }]["); for (node = list->head; node != NULL; node = node->next) { @@ -13638,6 +15144,24 @@ add_debug_cmnblk_variables(LL_DebugInfo *db, SPTR sptr) SNAME(var) = save_ptr; } } + // Constants debuginfo support is part of LLVM13. + if(ll_feature_debug_info_ver13(¤t_module->ir)) { + for (SPTR sptr = get_symbol_start(); sptr < stb.stg_avail; ++sptr) { + TY_KIND Ty = DTY(DTYPEG(sptr)); + // Constants support is limited to integers for now. + if (STYPEG(sptr) == ST_PARAM && SCOPEG(sptr) && !CCSYMG(sptr) && Ty == TY_INT) { + debug_name = new_debug_name(SYMNAME(SCOPEG(sptr)), SYMNAME(sptr), + SYMNAME(var)); + if (hashset_lookup(sptr_added, debug_name)) + continue; + hashset_insert(sptr_added, debug_name); + save_ptr = SNAME(sptr); + SNAME(sptr) = SYMNAME(sptr); + addDebugForGlobalVar(sptr, variable_offset_in_aggregate(var, 0)); + SNAME(sptr) = save_ptr; + } + } + } if (gbl.rutype != RU_BDATA && NEEDMODG(scope) && !has_alias) { /* This is a MODULE to be imported to a subroutine * later in lldbg_emit_subprogram(). */ @@ -13704,3 +15228,15 @@ is_vector_x86_mmx(LL_Type *type) { } return false; } + +int +get_parnum(SPTR sptr) +{ + for (int parnum = 1; parnum <= llvm_info.abi_info->nargs; parnum++) { + if (llvm_info.abi_info->arg[parnum].sptr == sptr) { + return parnum; + } + } + + return 0; +} diff --git a/tools/flang2/flang2exe/cgmain.h b/tools/flang2/flang2exe/cgmain.h index 7a6f0d5d6e..18f8344d15 100644 --- a/tools/flang2/flang2exe/cgmain.h +++ b/tools/flang2/flang2exe/cgmain.h @@ -4,6 +4,12 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified: May 2020 + */ #ifndef CGMAIN_H_ #define CGMAIN_H_ @@ -152,6 +158,11 @@ TMPS *gen_extract_insert(LL_InstrName i_name, LL_Type *struct_type, TMPS *tmp, void build_routine_and_parameter_entries(SPTR func_sptr, LL_ABI_Info *abi, LL_Module *module); +/** + \brief ... + */ +int write_I_CALL(INSTR_LIST *curr_instr, bool emit_func_signature_for_call); + /** \brief ... */ @@ -277,4 +288,39 @@ void add_debug_cmnblk_variables(LL_DebugInfo *db, SPTR sptr); */ bool ftn_array_need_debug_info(SPTR sptr); +/** + \brief Insert @llvm.dbg.declare call for debug + \param mdnode metadata node + \param sptr symbol + \param llTy preferred type of \p sptr or \c NULL + */ +void insert_llvm_dbg_declare(LL_MDRef mdnode, SPTR sptr, LL_Type *llTy, + OPERAND *exprMDOp, OperandFlag_t opflag); + +/** + \brief Insert @llvm.dbg.value call for debug + \param OPERAND operand + \param sptr symbol + \param llTy preferred type of \p sptr or \c NULL + */ +void insert_llvm_dbg_value(OPERAND *load, LL_MDRef mdnode, SPTR sptr, + LL_Type *type); + +// AOCC Begin +/** + \brief Function to calculate alloca address space. + \param module LL_Module for which address space to be calculated. +*/ +#ifdef OMP_OFFLOAD_AMD +int get_alloca_addrspace(LL_Module *module); +#endif +// AOCC End + +/** + \brief Check if sptr is the midnum of a scalar and scalar has POINTER/ALLOCATABLE attribute + \param sptr A symbol + */ +bool pointer_scalar_need_debug_info(SPTR sptr); + +int get_parnum(SPTR sptr); #endif diff --git a/tools/flang2/flang2exe/dinit.cpp b/tools/flang2/flang2exe/dinit.cpp index ecb619897f..78ea62f59f 100644 --- a/tools/flang2/flang2exe/dinit.cpp +++ b/tools/flang2/flang2exe/dinit.cpp @@ -5,11 +5,30 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Support for transpose intrinsic during initialization + * Date of Modification: 1st March 2019 + * + * Added support for quad precision + * Last modified: Feb 2020 + * + * Support for nearest intrinsic + * Last modified: 01 March 2020 + * Last Modified : Jun 2020 + * + * Added code support for cotan intrinsic + * Last modified on Oct 2020 + */ + /** \file * \brief SCFTN routine to process data initialization statements; called by * semant. */ +#include "gbldefs.h" /* AOCC */ #include "dinit.h" #include "dinitutl.h" #include "dtypeutl.h" @@ -19,6 +38,7 @@ #include "machardf.h" #include "semutil0.h" #include "symfun.h" +#include //AOCC /** \brief Effective address of a reference being initialized */ typedef struct { @@ -66,7 +86,7 @@ static CONST const_err; static int substr_len; /* length of char substring being init'd */ -#define MAXDIMS 7 +#define MAXDIMS MAXSUBS /* AOCC */ #define MAXDEPTH 8 static DOSTACK dostack[MAXDEPTH]; static DOSTACK *top; @@ -453,6 +473,16 @@ is_zero(DTYPE dtype, INT conval) if (conval == stb.dbl0) return true; break; + // AOCC begin + case TY_QUAD: + if (conval == stb.quad0) + return true; + break; + case TY_QCMPLX: + if (CONVAL1G(conval) == stb.quad0 && CONVAL2G(conval) == stb.quad0) + return true; + break; + // AOCC end case TY_CMPLX: if (CONVAL1G(conval) == 0 && CONVAL2G(conval) == 0) return true; @@ -1267,6 +1297,13 @@ _ddiv(INT *dividend, INT *divisor, INT *quotient) #endif } +// AOCC begin +static void +_qdiv(INT *dividend, INT *divisor, INT *quotient) +{ + xqdiv(dividend, divisor, quotient); +} +// AOCC end static int get_ast_op(int op) { @@ -1300,6 +1337,11 @@ get_ast_op(int op) case AC_LOR: ast_op = OP_LOR; break; + // AOCC + case AC_LXOR: + ast_op = OP_XOR; + break; + // AOCC end case AC_LAND: ast_op = OP_LAND; break; @@ -1343,6 +1385,9 @@ get_ast_op(int op) static INT init_fold_const(int opr, INT conval1, INT conval2, DTYPE dtype) { + IEEE128 qtemp, qresult, qnum1, qnum2; // AOCC + IEEE128 qreal1, qreal2, qrealrs, qimag1, qimag2, qimagrs; + IEEE128 qtemp1, qtemp2; DBLE dtemp, dresult, num1, num2; DBLE dreal1, dreal2, drealrs, dimag1, dimag2, dimagrs; DBLE dtemp1, dtemp2; @@ -1498,6 +1543,40 @@ init_fold_const(int opr, INT conval1, INT conval2, DTYPE dtype) } return getcon(dresult, DT_DBLE); + // AOCC begin + case TY_QUAD: + qnum1[0] = CONVAL1G(conval1); + qnum1[1] = CONVAL2G(conval1); + qnum1[2] = CONVAL3G(conval1); + qnum1[3] = CONVAL4G(conval1); + qnum2[0] = CONVAL1G(conval2); + qnum2[1] = CONVAL2G(conval2); + qnum2[2] = CONVAL3G(conval2); + qnum2[3] = CONVAL4G(conval2); + switch (opr) { + case OP_ADD: + xqadd(qnum1, qnum2, qresult); + break; + case OP_SUB: + xqsub(qnum1, qnum2, qresult); + break; + case OP_MUL: + xqmul(qnum1, qnum2, qresult); + break; + case OP_DIV: + xqdiv(qnum1, qnum2, qresult); + break; + case OP_CMP: + return xqcmp(qnum1, qnum2); + case OP_XTOX: + xqpow(qnum1, qnum2, qresult); + break; + default: + goto err_exit; + } + return getcon(qresult, DT_QUAD); + // AOCC end + case TY_CMPLX: real1 = CONVAL1G(conval1); imag1 = CONVAL2G(conval1); @@ -1717,6 +1796,129 @@ init_fold_const(int opr, INT conval1, INT conval2, DTYPE dtype) num1[1] = getcon(dimagrs, DT_DBLE); return getcon(num1, DT_DCMPLX); + // AOCC begin + case TY_QCMPLX: + qreal1[0] = CONVAL1G(CONVAL1G(conval1)); + qreal1[1] = CONVAL2G(CONVAL1G(conval1)); + qreal1[2] = CONVAL3G(CONVAL1G(conval1)); + qreal1[3] = CONVAL4G(CONVAL1G(conval1)); + qimag1[0] = CONVAL1G(CONVAL2G(conval1)); + qimag1[1] = CONVAL2G(CONVAL2G(conval1)); + qimag1[2] = CONVAL3G(CONVAL2G(conval1)); + qimag1[3] = CONVAL4G(CONVAL2G(conval1)); + qreal2[0] = CONVAL1G(CONVAL1G(conval2)); + qreal2[1] = CONVAL2G(CONVAL1G(conval2)); + qreal2[2] = CONVAL3G(CONVAL1G(conval2)); + qreal2[3] = CONVAL4G(CONVAL1G(conval2)); + qimag2[0] = CONVAL1G(CONVAL2G(conval2)); + qimag2[1] = CONVAL2G(CONVAL2G(conval2)); + qimag2[2] = CONVAL3G(CONVAL2G(conval2)); + qimag2[3] = CONVAL4G(CONVAL2G(conval2)); + switch (opr) { + case OP_ADD: + xqadd(qreal1, qreal2, qrealrs); + xqadd(qimag1, qimag2, qimagrs); + break; + case OP_SUB: + xqsub(qreal1, qreal2, qrealrs); + xqsub(qimag1, qimag2, qimagrs); + break; + case OP_MUL: + /* (a + bi) * (c + di) ==> (ac-bd) + (ad+cb)i */ + xqmul(qreal1, qreal2, qtemp1); + xqmul(qimag1, qimag2, qtemp); + xqsub(qtemp1, qtemp, qrealrs); + xqmul(qreal1, qimag2, qtemp1); + xqmul(qreal2, qimag1, qtemp); + xqadd(qtemp1, qtemp, qimagrs); + break; + case OP_DIV: + qtemp2[0] = CONVAL1G(stb.dbl0); + qtemp2[1] = CONVAL2G(stb.dbl0); + /* qrealrs = qreal2; + * if (qrealrs < 0) + * qrealrs = -qrealrs; + * qimagrs = qimag2; + * if (qimagrs < 0) + * qimagrs = -qimagrs; + */ + if (xqcmp(qreal2, qtemp2) < 0) + xqsub(qtemp2, qreal2, qrealrs); + else { + qrealrs[0] = qreal2[0]; + qrealrs[1] = qreal2[1]; + } + if (xqcmp(qimag2, qtemp2) < 0) + xqsub(qtemp2, qimag2, qimagrs); + else { + qimagrs[0] = qimag2[0]; + qimagrs[1] = qimag2[1]; + } + + /* avoid overflow */ + + qtemp2[0] = CONVAL1G(stb.quad1); + qtemp2[1] = CONVAL2G(stb.quad1); + if (xqcmp(qrealrs, qimagrs) <= 0) { + /* if (qrealrs <= qimagrs) { + * qtemp = qreal2 / qimag2; + * qtemp1 = 1.0 / (qimag2 * (1 + qtemp * qtemp)); + * qrealrs = (qreal1 * qtemp + qimag1) * qtemp1; + * qimagrs = (qimag1 * qtemp - qreal1) * qtemp1; + * } + */ + _qdiv(qreal2, qimag2, qtemp); + + xqmul(qtemp, qtemp, qtemp1); + xqadd(qtemp2, qtemp1, qtemp1); + xqmul(qimag2, qtemp1, qtemp1); + _qdiv(qtemp2, qtemp1, qtemp1); + + xqmul(qreal1, qtemp, qrealrs); + xqadd(qrealrs, qimag1, qrealrs); + xqmul(qrealrs, qtemp1, qrealrs); + + xqmul(qimag1, qtemp, qimagrs); + xqsub(qimagrs, qreal1, qimagrs); + xqmul(qimagrs, qtemp1, qimagrs); + } else { + /* else { + * qtemp = qimag2 / qreal2; + * qtemp1 = 1.0 / (qreal2 * (1 + qtemp * qtemp)); + * qrealrs = (qreal1 + qimag1 * qtemp) * qtemp1; + * qimagrs = (qimag1 - qreal1 * qtemp) * qtemp1; + * } + */ + _qdiv(qimag2, qreal2, qtemp); + + xqmul(qtemp, qtemp, qtemp1); + xqadd(qtemp2, qtemp1, qtemp1); + xqmul(qreal2, qtemp1, qtemp1); + _qdiv(qtemp2, qtemp1, qtemp1); + + xqmul(qimag1, qtemp, qrealrs); + xqadd(qreal1, qrealrs, qrealrs); + xqmul(qrealrs, qtemp1, qrealrs); + + xqmul(qreal1, qtemp, qimagrs); + xqsub(qimag1, qimagrs, qimagrs); + xqmul(qimagrs, qtemp1, qimagrs); + } + break; + case OP_CMP: + /* + * for complex, only EQ and NE comparisons are allowed, so return + * 0 if the two constants are the same, else 1: + */ + return (conval1 != conval2); + default: + goto err_exit; + } + + num1[0] = getcon(qrealrs, DT_QUAD); + num1[1] = getcon(qimagrs, DT_QUAD); + return getcon(num1, DT_QCMPLX); + // AOCC end case TY_BLOG: case TY_SLOG: case TY_LOG: @@ -1815,6 +2017,7 @@ static INT init_negate_const(INT conval, DTYPE dtype) { SNGL result; + IEEE128 qresult, qrealrs, qimagrs; // AOCC DBLE drealrs, dimagrs; static INT num[4]; @@ -1841,6 +2044,16 @@ init_negate_const(INT conval, DTYPE dtype) xdneg(num, drealrs); return getcon(drealrs, DT_DBLE); + // AOCC begin + case TY_QUAD: + num[0] = CONVAL1G(conval); + num[1] = CONVAL2G(conval); + num[2] = CONVAL3G(conval); + num[3] = CONVAL4G(conval); + xqneg(num, qrealrs); + return getcon(qrealrs, DT_QUAD); + // AOCC end + case TY_CMPLX: xfneg(CONVAL1G(conval), &num[0]); /* real part */ xfneg(CONVAL2G(conval), &num[1]); /* imag part */ @@ -1857,6 +2070,23 @@ init_negate_const(INT conval, DTYPE dtype) num[1] = getcon(dimagrs, DT_DBLE); return getcon(num, DT_DCMPLX); + // AOCC begin + case TY_QCMPLX: + num[0] = CONVAL1G(CONVAL1G(conval)); + num[1] = CONVAL2G(CONVAL1G(conval)); + num[2] = CONVAL3G(CONVAL1G(conval)); + num[3] = CONVAL4G(CONVAL1G(conval)); + xqneg(num, qrealrs); + num[0] = CONVAL1G(CONVAL2G(conval)); + num[1] = CONVAL2G(CONVAL2G(conval)); + num[2] = CONVAL3G(CONVAL2G(conval)); + num[3] = CONVAL4G(CONVAL2G(conval)); + xqneg(num, qimagrs); + num[0] = getcon(drealrs, DT_QUAD); + num[1] = getcon(dimagrs, DT_QUAD); + return getcon(num, DT_QCMPLX); + // AOCC end + default: interr("init_negate_const: bad dtype", dtype, ERR_Severe); return (0); @@ -1875,12 +2105,12 @@ static struct { ISZ_T lowb; ISZ_T upb; ISZ_T stride; - } sub[7]; + } sub[MAXSUBS]; /* AOCC */ struct { ISZ_T lowb; ISZ_T upb; ISZ_T mplyr; - } dim[7]; + } dim[MAXSUBS]; /* AOCC */ } sb; static ISZ_T @@ -2069,7 +2299,7 @@ eval_const_array_triple_section(CONST *curr_e) } sb.sub[ndims].stride = get_ival(v->dtype, v->u1.conval); - if (++ndims >= 7) { + if (++ndims >= get_legal_maxdim()) { /* AOCC */ interr("initialization expression: too many dimensions\n", 0, ERR_Severe); return CONST_ERR(dtype); } @@ -2229,6 +2459,100 @@ INTINTRIN2("iand", eval_iand, &) INTINTRIN2("ior", eval_ior, |) INTINTRIN2("ieor", eval_ieor, ^) +/* AOCC begin */ +static CONST * +eval_merge_bits(CONST *arg, DTYPE dtype) +{ + CONST *arg_i = eval_init_expr_item(arg); + CONST *arg_j = eval_init_expr_item(arg->next); + CONST *arg_mask = eval_init_expr_item(arg->next->next); + + CONST *arg_notmask = clone_init_const(arg_mask, true); + + /* 32-bit values get stored in the conval field, while larger values need to + * be looked up in the symbol table. + */ + if (size_of(arg_mask->dtype) > 4) { + INT ival[2]; + ISZ_T mask_val, notmask_val; + + ival[0] = CONVAL1G(arg_mask->u1.conval); + ival[1] = CONVAL2G(arg_mask->u1.conval); + + INT64_2_ISZ(ival, mask_val); + notmask_val = ~mask_val; + ISZ_2_INT64(notmask_val, ival); /* Now ival will represent notmask_val */ + + arg_notmask->u1.conval = getcon(ival, arg_mask->dtype); + } else { + arg_notmask->u1.conval = ~(arg_mask->u1.conval); + } + + CONST *arg_i_and_mask = clone_init_const(arg_i, true); + arg_i_and_mask->next = arg_mask; + + CONST *arg_j_and_notmask = clone_init_const(arg_j, true); + arg_j_and_notmask->next = arg_notmask; + + CONST *iand_i = eval_iand(arg_i_and_mask, dtype); + CONST *iand_j = eval_iand(arg_j_and_notmask, dtype); + + iand_i->next = iand_j; + + return eval_ior(iand_i, dtype); +} + +static CONST * +eval_dshift(CONST *arg, DTYPE dtype, bool is_left) +{ + CONST *arg_i = eval_init_expr_item(arg); + CONST *arg_j = eval_init_expr_item(arg->next); + CONST *arg_shift = eval_init_expr_item(arg->next->next); + + short bit_size_i = dtypeinfo[arg_i->dtype].bits; + short bit_size_j = dtypeinfo[arg_j->dtype].bits; + + if (is_left) { + /* Evaluating IOR(SHIFTL(I, SHIFT), SHIFTR(J, BIT_SIZE(J) - SHIFT)). */ + + /* evaluating lhs of IOR */ + CONST *arg_i_and_shift = clone_init_const(arg_i, true); + arg_i_and_shift->next = arg_shift; + CONST * arg_shiftl_i = eval_ishft(arg_i_and_shift, arg_i->dtype); + + /* evaluating rhs of IOR */ + CONST *arg_j_and_bs_j = clone_init_const(arg_j, true); + arg_j_and_bs_j->next = clone_init_const(arg_shift, true); + /* The negation below is to force ishft to do a right shift */ + arg_j_and_bs_j->next->u1.conval = -(bit_size_j - arg_shift->u1.conval); + CONST *arg_shiftr_bs_j = eval_ishft(arg_j_and_bs_j, arg_j->dtype); + + /* Setting up args for the final ior */ + arg_shiftl_i->next = arg_shiftr_bs_j; + return eval_ior(arg_shiftl_i, arg_i->dtype); + + } else { + /* Evaluating IOR(SHIFTL(I, BIT_SIZE(I) - SHIFT), SHIFTR(J, SHIFT)) */ + + /* evaluating lhs of IOR */ + CONST *arg_i_and_bs_i = clone_init_const(arg_i, true); + arg_i_and_bs_i->next = clone_init_const(arg_shift, true); + arg_i_and_bs_i->next->u1.conval = bit_size_i - arg_shift->u1.conval; + CONST *arg_shiftl_bs_i = eval_ishft(arg_i_and_bs_i, arg_i->dtype); + + /* evaluating rhs of IOR */ + CONST *arg_j_and_shift = clone_init_const(arg_j, true); + arg_j_and_shift->next = clone_init_const(arg_shift, true); + arg_j_and_shift->next->u1.conval = -(arg_j_and_shift->next->u1.conval); + CONST * arg_shiftr_j = eval_ishft(arg_j_and_shift, arg_j->dtype); + + /* Setting up args for the final ior */ + arg_shiftl_bs_i->next = arg_shiftr_j; + return eval_ior(arg_shiftl_bs_i, arg_i->dtype); + } +} +/* AOCC end */ + static CONST * eval_ichar(CONST *arg, DTYPE dtype) { @@ -2377,6 +2701,14 @@ eval_abs(CONST *arg, DTYPE dtype) xdabsv(num1, res); con1 = getcon(res, dtype); break; + // AOCC begin + case TY_QUAD: + con1 = wrkarg->u1.conval; + GET_QUAD(num1, con1); + xqabsv(num1, res); + con1 = getcon(res, dtype); + break; + // AOCC end case TY_CMPLX: con1 = wrkarg->u1.conval; num1[0] = CONVAL1G(con1); @@ -2509,6 +2841,15 @@ eval_min(CONST *arg, DTYPE dtype) c->dtype = wrkarg2->dtype; } break; + // AOCC begin + case TY_QUAD: + if (init_fold_const(OP_CMP, wrkarg2->u1.conval, wrkarg1->u1.conval, + dtype) < 0) { + c->u1 = wrkarg2->u1; + c->dtype = wrkarg2->dtype; + } + break; + // AOCC end } c = c->next; if (root == wrkarg1) { @@ -2523,9 +2864,8 @@ eval_min(CONST *arg, DTYPE dtype) wrkarg2 = wrkarg2->next; if (wrkarg2) { repeatc2 = wrkarg2->repeatc; - } + } } - } wrkarg1 = c = root; } @@ -2640,6 +2980,15 @@ eval_max(CONST *arg, DTYPE dtype) c->dtype = wrkarg2->dtype; } break; + // AOCC begin + case TY_QUAD: + if (init_fold_const(OP_CMP, wrkarg2->u1.conval, wrkarg1->u1.conval, + dtype) > 0) { + c->u1 = wrkarg2->u1; + c->dtype = wrkarg2->dtype; + } + break; + // AOCC end } c = c->next; if (root == wrkarg1) { @@ -2691,6 +3040,11 @@ cmp_acl(DTYPE dtype, CONST *x, CONST *y, bool want_max, bool back) case TY_DBLE: cmp = init_fold_const(OP_CMP, x->u1.conval, y->u1.conval, dtype); break; + // AOCC begin + case TY_QUAD: + cmp = init_fold_const(OP_CMP, x->u1.conval, y->u1.conval, dtype); + break; + // AOCC end default: interr("cmp_acl: bad dtype", dtype, ERR_Severe); return false; @@ -2779,6 +3133,20 @@ _huge(DTYPE dtype) val[1] = 0xffffffff; } goto const_dble_val; + // AOCC begin + case TY_QUAD: + if (XBIT(49, 0x40000)) { /* C90 */ +#define C90_HUGE "0.1363435169524269911828730305882e+2466L" + /* 0577757777777777777777 */ + atoxq(C90_HUGE, &val[0], strlen(C90_HUGE)); /* 7777777777777776 */ + } else { + /* 1.189731495357231765085759326628007016E+4932 */ + val[0] = 0x7ffeffffffffffff; + val[1] = 0xffffffffffffffff; + } + goto const_quad_val; +// AOCC end + default: return 0; /* caller must check */ } @@ -2793,6 +3161,11 @@ _huge(DTYPE dtype) const_dble_val: tmp = getcon(val, DT_DBLE); return tmp; +// AoCC begin +const_quad_val: + tmp = getcon(val, DT_QUAD); + return tmp; +// AOCC end } static INT @@ -2844,6 +3217,23 @@ negate_const_be(INT conval, DTYPE dtype) num[1] = getcon(dimagrs, DT_DBLE); return getcon(num, DT_DCMPLX); + // AOCC begin + case TY_QCMPLX: + qresult[0] = CONVAL1G(CONVAL1G(conval)); + qresult[1] = CONVAL2G(CONVAL1G(conval)); + qresult[2] = CONVAL3G(CONVAL1G(conval)); + qresult[3] = CONVAL4G(CONVAL1G(conval)); + xqneg(qresult, qrealrs); + qresult[0] = CONVAL1G(CONVAL2G(conval)); + qresult[1] = CONVAL2G(CONVAL2G(conval)); + qresult[2] = CONVAL3G(CONVAL2G(conval)); + qresult[3] = CONVAL4G(CONVAL2G(conval)); + xqneg(dresult, qimagrs); + num[0] = getcon(qrealrs, DT_QUAD); + num[1] = getcon(qimagrs, DT_QUAD); + return getcon(num, DT_QCMPLX); + // AOCC end + default: interr("negate_const: bad dtype", dtype, ERR_Severe); return (0); @@ -2872,8 +3262,10 @@ mk_unop(int optype, int lop, DTYPE dtype) break; case TY_DBLE: + case TY_QUAD: // AOCC case TY_CMPLX: case TY_DCMPLX: + case TY_QCMPLX: // AOCC case TY_INT8: case TY_LOG8: conval = negate_const_be(lop, dtype); @@ -3086,34 +3478,35 @@ eval_scale(CONST *arg, int type) DBLINT64 inum1, inum2; INT e; DBLE dconval; - + IEEE128 qconval, qnum1, qnum2; // AOCC + rslt = (CONST*)getitem(4, sizeof(CONST)); BZERO(rslt, CONST, 1); rslt->id = AC_CONST; rslt->repeatc = 1; - rslt->dtype = arg->dtype; + rslt->dtype = arg->dtype; arg = eval_init_expr(arg); conval1 = arg->u1.conval; arg2 = arg->next; - - + + if (arg2->dtype == DT_INT8) error(S_0205_Illegal_specification_of_scale_factor, ERR_Warning, gbl.lineno, SYMNAME(arg2->u1.conval), "- Illegal specification of scale factor"); - + i = (arg2->dtype == DT_INT8) ? CONVAL2G(arg2->u1.conval) : arg2->u1.conval; switch (size_of(arg->dtype)) { case 4: - /* 8-bit exponent (127) to get an exponent value in the + /* 8-bit exponent (127) to get an exponent value in the * range -126 .. +127 */ e = 127 + i; if (e < 0) e = 0; else if (e > 255) e = 255; - + /* calculate decimal value from it's IEEE 754 form*/ conval2 = e << 23; xfmul(conval1, conval2, &conval); @@ -3135,7 +3528,29 @@ eval_scale(CONST *arg, int type) xdmul(inum1, inum2, dconval); rslt->u1.conval = getcon(dconval, DT_DBLE); break; + + // AOCC begin + case 16: + e = 16383 + i; + if (e < 0) + e = 0; + else if (e > 32767) + e = 32767; + + qnum1[0] = CONVAL1G(conval1); + qnum1[1] = CONVAL2G(conval1); + qnum1[2] = CONVAL3G(conval1); + qnum1[3] = CONVAL4G(conval1); + + qnum2[0] = e << 20; + qnum2[1] = 0; + qnum2[2] = 0; + qnum2[3] = 0; + xqmul(qnum1, qnum2, qconval); + rslt->u1.conval = getcon(qconval, DT_QUAD); + break; } + // AOCC end return rslt; } @@ -3232,7 +3647,16 @@ eval_nint(CONST *arg, DTYPE dtype) res[0] = init_fold_const(OP_SUB, con1, stb.dblhalf, DT_DBLE); conval = cngcon(res[0], DT_DBLE, DT_INT); break; + // AOCC begin + case TY_QUAD: + if (init_fold_const(OP_CMP, con1, stb.quad0, DT_QUAD) >= 0) + res[0] = init_fold_const(OP_ADD, con1, stb.quadhalf, DT_QUAD); + else + res[0] = init_fold_const(OP_SUB, con1, stb.quadhalf, DT_QUAD); + conval = cngcon(res[0], DT_QUAD, DT_INT); + break; } + // AOCC end wrkarg->id = AC_CONST; wrkarg->dtype = DT_INT; @@ -3275,6 +3699,16 @@ eval_floor(CONST *arg, DTYPE dtype) adjust = 1; } break; + // AOCC begin + case TY_QUAD: + conval = cngcon(con1, DT_QUAD, dtype); + if (init_fold_const(OP_CMP, con1, stb.quad0, DT_QUAD) < 0) { + con1 = cngcon(conval, dtype, DT_QUAD); + if (init_fold_const(OP_CMP, con1, wrkarg->u1.conval, DT_QUAD) != 0) + adjust = 1; + } + break; + // AOCC end } if (adjust) { if (DT_ISWORD(dtype)) @@ -3327,6 +3761,16 @@ eval_ceiling(CONST *arg, DTYPE dtype) adjust = 1; } break; + // AOCC begin + case TY_QUAD: + conval = cngcon(con1, DT_QUAD, dtype); + if (init_fold_const(OP_CMP, con1, stb.quad0, DT_QUAD) > 0) { + con1 = cngcon(conval, dtype, DT_QUAD); + if (init_fold_const(OP_CMP, con1, wrkarg->u1.conval, DT_QUAD) != 0) + adjust = 1; + } + break; + // AOCC end } if (adjust) { if (DT_ISWORD(dtype)) @@ -3397,8 +3841,32 @@ eval_mod(CONST *arg, DTYPE dtype) xdsub(num1, num3, num3); conval = getcon(num3, DT_DBLE); break; + // AOCC begin + case TY_QUAD: + num1[0] = CONVAL1G(con1); + num1[1] = CONVAL2G(con1); + num1[2] = CONVAL3G(con1); + num1[3] = CONVAL4G(con1); + num2[0] = CONVAL1G(con2); + num2[1] = CONVAL2G(con2); + num2[2] = CONVAL3G(con2); + num2[3] = CONVAL4G(con2); + xqdiv(num1, num2, num3); + con3 = getcon(num3, DT_QUAD); + con3 = cngcon(con3, DT_QUAD, DT_INT8); + con3 = cngcon(con3, DT_INT8, DT_QUAD); + num3[0] = CONVAL1G(con3); + num3[1] = CONVAL2G(con3); + num3[2] = CONVAL3G(con3); + num3[3] = CONVAL4G(con3); + xqmul(num3, num2, num3); + xqsub(num1, num3, num3); + conval = getcon(num3, DT_QUAD); + break; + // AOCC end case TY_CMPLX: case TY_DCMPLX: + case TY_QCMPLX: // AOCC error(S_0155_OP1_OP2, ERR_Severe, gbl.lineno, "Intrinsic not supported in initialization:", "mod"); break; @@ -3483,36 +3951,64 @@ eval_selected_real_kind(CONST *arg, DTYPE dtype) { CONST *rslt = eval_init_expr_item(arg); CONST *wrkarg; - int r; + int r, range, prec; int con; r = 4; - + // AOCC + range = 0; + prec = 0; wrkarg = eval_init_expr_item(arg); con = wrkarg->u1.conval; /* what about zero ?? */ if (con <= 6) r = 4; else if (con <= 15) r = 8; - else + else if (con <= 31 && (!XBIT(57, 0x4))) + r = 16; + else { r = -1; + prec =-1; + } if (arg->next) { wrkarg = eval_init_expr_item(arg->next); con = wrkarg->u1.conval; /* what about zero ?? */ if (con <= 37) { - if (r > 0 && r < 4) + if (r > 0 && r <= 4) r = 4; } else if (con <= 307) { - if (r > 0 && r < 8) + if (r > 0 && r <= 8) r = 8; + } else if ((con <= 4931) && (!XBIT(57, 0x4))) { + if (r > 0 && r <= 16) + r = 16; } else { if (r > 0) r = 0; - r -= 2; + r = -2; + range = -2; } } + // AOCC begin + if (arg->next->next) { + wrkarg = eval_init_expr_item(arg->next->next); + con = wrkarg->u1.conval; /* what about zero ?? */ + if (con == 2 || con == 0) { + if (r > 0 && r <= 4) + r = 4; + else if (r > 0 && r <= 8) + r = 8; + else if (r > 0 && r <=16) + r = 16; + else if (prec < 0 && range < 0) + r = -3; + } + else if (con != 2) + r = -5; + } + // AOCC end rslt = (CONST *)getitem(4, sizeof(CONST)); BZERO(rslt, CONST, 1); rslt->id = AC_CONST; @@ -3570,6 +4066,54 @@ eval_selected_char_kind(CONST *arg, DTYPE dtype) rslt->u1.conval = r; return rslt; } +//AOCC Begin +static CONST * +eval_nearest(CONST *arg, DTYPE dtype) +{ + CONST *rslt; + CONST *arg1, *arg2; + INT conval; + arg1 = eval_init_expr_item(arg); + arg2 = eval_init_expr_item(arg->next); + rslt = clone_init_const_list(arg1, true); + arg1 = (rslt->id == AC_ACONST ? rslt->subc : rslt); + arg2 = (arg2->id == AC_ACONST ? arg2->subc : arg2); + for (; arg1; arg1 = arg1->next, arg2 = arg2->next) { + INT num1[4], num2[4]; + INT res[4]; + INT con1, con2; + con1 = arg1->u1.conval; + con2 = arg2->u1.conval; + switch (DTY(arg1->dtype)) { + case TY_REAL: + xfnearest(con1, con2, &res[0]); + conval = res[0]; + break; + case TY_DBLE: + num1[0] = CONVAL1G(con1); + num2[0] = CONVAL1G(con2); + xdnearest(num1, num2, res); + conval = getcon(res, DT_DBLE); + break; + case TY_CMPLX: + case TY_DCMPLX: + case TY_QCMPLX: // AOCC + error(S_0155_OP1_OP2, ERR_Severe, gbl.lineno, + "Intrinsic not supported in initialization:", "nearest"); + break; + default: + error(S_0155_OP1_OP2, ERR_Severe, gbl.lineno, + "Intrinsic not supported in initialization:", "nearst"); + break; + } + conval = cngcon(conval, arg1->dtype, dtype); + arg1->u1.conval = conval; + arg1->dtype = dtype; + arg1->id = AC_CONST; + arg1->repeatc = 1; + } + return rslt; +} static CONST * eval_scan(CONST *arg, DTYPE dtype) @@ -3971,7 +4515,7 @@ copy_initconst_to_array(CONST **arr, CONST *c, int count) } static CONST * -eval_reshape(CONST *arg, DTYPE dtype) +eval_reshape(CONST *arg, DTYPE dtype, LOGICAL transpose) // AOCC { CONST *srclist = eval_init_expr_item(arg); CONST *tacl; @@ -3985,23 +4529,29 @@ eval_reshape(CONST *arg, DTYPE dtype) int *new_index; int src_sz, dest_sz; int rank; - int order[7]; - int lwb[7]; - int upb[7]; - int mult[7]; + // AOCC begin + int order[MAXSUBS]; + int lwb[MAXSUBS]; + int upb[MAXSUBS]; + int mult[MAXSUBS]; + // AOCC end int i; int count; int sz; - eval_init_expr_item(arg->next); + // AOCC begin + if (arg->next) { + eval_init_expr_item(arg->next); - if (arg->next->next) { - pad = arg->next->next; - if (pad->id != AC_CONST) { - pad = eval_init_expr_item(pad); - } - if (arg->next->next->next && arg->next->next->next->id != AC_CONST) { - orderarg = eval_init_expr_item(arg->next->next->next); + if (arg->next->next) { + pad = arg->next->next; + if (pad->id != AC_CONST) { + pad = eval_init_expr_item(pad); + } + if (arg->next->next->next && arg->next->next->next->id != AC_CONST) { + orderarg = eval_init_expr_item(arg->next->next->next); + } + // AOCC end } } src_sz = ad_val_of(AD_NUMELM(AD_DPTR(arg->dtype))); @@ -4017,11 +4567,18 @@ eval_reshape(CONST *arg, DTYPE dtype) } if (orderarg == NULL) { - if (src_sz == dest_sz) { - return srclist; - } - for (i = 0; i < rank; i++) { - order[i] = i; + // AOCC begin + if (transpose) { + order[0] = 1; + order[1] = 0; + } else { + if (src_sz == dest_sz) { + return srclist; + } + for (i = 0; i < rank; i++) { + order[i] = i; + } + // AOCC end } } else { bool out_of_order; @@ -4183,6 +4740,15 @@ transfer_store(INT conval, DTYPE dtype, char *destination) dest[1] = CONVAL1G(conval); break; + // AOCC begin + case TY_QUAD: + dest[0] = CONVAL3G(conval); + dest[1] = CONVAL4G(conval); + dest[2] = CONVAL1G(conval); + dest[3] = CONVAL2G(conval); + break; + // AOCC end + case TY_CMPLX: dest[0] = CONVAL1G(conval); dest[1] = CONVAL2G(conval); @@ -4197,6 +4763,21 @@ transfer_store(INT conval, DTYPE dtype, char *destination) dest[3] = CONVAL1G(imag); break; + // AOCC begin + case TY_QCMPLX: + real = CONVAL1G(conval); + imag = CONVAL2G(conval); + dest[0] = CONVAL4G(real); + dest[1] = CONVAL3G(real); + dest[2] = CONVAL2G(real); + dest[3] = CONVAL1G(real); + dest[0] = CONVAL4G(imag); + dest[1] = CONVAL3G(imag); + dest[2] = CONVAL2G(imag); + dest[3] = CONVAL1G(imag); + break; + // AOCC begin + case TY_CHAR: memcpy(dest, stb.n_base + CONVAL1G(conval), size_of(dtype)); break; @@ -4211,7 +4792,7 @@ static INT transfer_load(DTYPE dtype, char *source) { int *src = (int *)source; - INT num[2], real[2], imag[2]; + INT num[4], real[2], imag[2]; if (DT_ISWORD(dtype)) return src[0]; @@ -4225,6 +4806,15 @@ transfer_load(DTYPE dtype, char *source) num[0] = src[1]; break; + // AOCC begin + case TY_QUAD: + num[0] = src[2]; + num[1] = src[3]; + num[2] = src[0]; + num[3] = src[1]; + break; + // AOCC end + case TY_CMPLX: num[0] = src[0]; num[1] = src[1]; @@ -4239,6 +4829,21 @@ transfer_load(DTYPE dtype, char *source) num[1] = getcon(imag, DT_DBLE); break; + // AOCC begin + case TY_QCMPLX: + real[0] = src[2]; + real[1] = src[3]; + real[2] = src[0]; + real[3] = src[1]; + imag[0] = src[2]; + imag[1] = src[3]; + imag[2] = src[0]; + imag[3] = src[1]; + num[0] = getcon(real, DT_QUAD); + num[1] = getcon(imag, DT_QUAD); + break; + // AOCC end + case TY_CHAR: return getstring(source, size_of(dtype)); @@ -4377,8 +4982,19 @@ eval_sqrt(CONST *arg, DTYPE dtype) xdsqrt(num1, res); conval = getcon(res, DT_DBLE); break; + // AOCC begin + case TY_QUAD: + num1[0] = CONVAL1G(con1); + num1[1] = CONVAL2G(con1); + num1[2] = CONVAL3G(con1); + num1[3] = CONVAL4G(con1); + xqsqrt(num1, res); + conval = getcon(res, DT_QUAD); + break; + // AOCC end case TY_CMPLX: case TY_DCMPLX: + case TY_QCMPLX: /* a = sqrt(real**2 + imag**2); "hypot(real,imag) if (a == 0) { @@ -4418,7 +5034,8 @@ eval_sqrt(CONST *arg, DTYPE dtype) /*---------------------------------------------------------------------*/ -#define FPINTRIN1(iname, ent, fscutil, dscutil) \ +// AOCC parameter: qscutil +#define FPINTRIN1(iname, ent, fscutil, dscutil, qscutil) \ static CONST *ent(CONST *arg, DTYPE dtype) \ { \ CONST *rslt = eval_init_expr_item(arg); \ @@ -4441,8 +5058,19 @@ eval_sqrt(CONST *arg, DTYPE dtype) dscutil(num1, res); \ conval = getcon(res, DT_DBLE); \ break; \ + /* AOCC begin */ \ + case TY_QUAD: \ + num1[0] = CONVAL1G(con1); \ + num1[1] = CONVAL2G(con1); \ + num1[2] = CONVAL3G(con1); \ + num1[3] = CONVAL4G(con1); \ + qscutil(num1, res); \ + conval = getcon(res, DT_QUAD); \ + break; \ + /* AOCC end */ \ case TY_CMPLX: \ case TY_DCMPLX: \ + case TY_QCMPLX: \ error(S_0155_OP1_OP2, ERR_Severe, gbl.lineno, \ "Intrinsic not supported in initialization:", iname); \ break; \ @@ -4460,25 +5088,28 @@ eval_sqrt(CONST *arg, DTYPE dtype) return rslt; \ } -FPINTRIN1("exp", eval_exp, xfexp, xdexp) +FPINTRIN1("exp", eval_exp, xfexp, xdexp, xqexp) -FPINTRIN1("log", eval_log, xflog, xdlog) +FPINTRIN1("log", eval_log, xflog, xdlog, xqlog) -FPINTRIN1("log10", eval_log10, xflog10, xdlog10) +FPINTRIN1("log10", eval_log10, xflog10, xdlog10, xqlog10) -FPINTRIN1("sin", eval_sin, xfsin, xdsin) +FPINTRIN1("sin", eval_sin, xfsin, xdsin, xqsin) -FPINTRIN1("cos", eval_cos, xfcos, xdcos) +FPINTRIN1("cos", eval_cos, xfcos, xdcos, xqcos) -FPINTRIN1("tan", eval_tan, xftan, xdtan) +FPINTRIN1("tan", eval_tan, xftan, xdtan, xqtan) -FPINTRIN1("asin", eval_asin, xfasin, xdasin) +FPINTRIN1("asin", eval_asin, xfasin, xdasin, xqasin) -FPINTRIN1("acos", eval_acos, xfacos, xdacos) +FPINTRIN1("acos", eval_acos, xfacos, xdacos, xqacos) -FPINTRIN1("atan", eval_atan, xfatan, xdatan) +FPINTRIN1("atan", eval_atan, xfatan, xdatan, xqatan) -#define FPINTRIN2(iname, ent, fscutil, dscutil) \ +FPINTRIN1("cotan", eval_cotan, xfcotan, xdcotan, xqcotan) // AOCC + +// AOCC parameter: qscutil +#define FPINTRIN2(iname, ent, fscutil, dscutil, qscutil) \ static CONST *ent(CONST *arg, DTYPE dtype) \ { \ CONST *rslt; \ @@ -4508,8 +5139,23 @@ FPINTRIN1("atan", eval_atan, xfatan, xdatan) dscutil(num1, num2, res); \ conval = getcon(res, DT_DBLE); \ break; \ + /* AOCC begin */ \ + case TY_QUAD: \ + num1[0] = CONVAL1G(con1); \ + num1[1] = CONVAL2G(con1); \ + num1[2] = CONVAL3G(con1); \ + num1[3] = CONVAL4G(con1); \ + num2[0] = CONVAL1G(con2); \ + num2[1] = CONVAL2G(con2); \ + num2[2] = CONVAL3G(con2); \ + num2[3] = CONVAL4G(con2); \ + qscutil(num1, num2, res); \ + conval = getcon(res, DT_QUAD); \ + break; \ + /* AOCC end */ \ case TY_CMPLX: \ case TY_DCMPLX: \ + case TY_QCMPLX: \ error(S_0155_OP1_OP2, ERR_Severe, gbl.lineno, \ "Intrinsic not supported in initialization:", iname); \ break; \ @@ -4527,7 +5173,7 @@ FPINTRIN1("atan", eval_atan, xfatan, xdatan) return rslt; \ } -FPINTRIN2("atan2", eval_atan2, xfatan2, xdatan2) +FPINTRIN2("atan2", eval_atan2, xfatan2, xdatan2, xqatan2) INLINE static CONST * eval_merge(CONST *arg, DTYPE dtype) @@ -4607,12 +5253,17 @@ mk_cmp(CONST *c, int op, INT l_conval, INT r_conval, DTYPE rdtype, DTYPE dt) case OP_LOR: c->u1.conval = l_conval | r_conval; break; + // AOCC begin + case OP_XOR: + c->u1.conval = l_conval ^ r_conval; + break; + // AOCC end case OP_LAND: c->u1.conval = l_conval & r_conval; break; case OP_XTOI: case OP_XTOK: - c->u1.conval = init_fold_const(get_ast_op(op), l_conval, r_conval, rdtype); + c->u1.conval = init_fold_const(get_ast_op(op), l_conval, r_conval, rdtype); default: c->u1.conval = init_fold_const(get_ast_op(op), l_conval, r_conval, dt); } @@ -4746,14 +5397,36 @@ eval_init_op(int op, CONST *lop, DTYPE ldtype, CONST *rop, DTYPE rdtype, case AC_I_nint: root = eval_nint(rop, dtype); break; + // AOCC begin + case AC_I_anint: + root = eval_nint(rop, dtype); + break; + case AC_I_aint: + root = eval_nint(rop, dtype); + break; + // AOCC end case AC_I_fltconvert: root = eval_fltconvert(rop, dtype); break; case AC_I_repeat: root = eval_repeat(rop, dtype); break; + // AOCC begin + case AC_I_transpose: + root = eval_reshape(rop, dtype, /*transpose*/ TRUE); + break; + case AC_I_merge_bits: + root = eval_merge_bits(rop, dtype); + break; + case AC_I_dshiftl: + root = eval_dshift(rop, dtype, /*is_left*/ TRUE); + break; + case AC_I_dshiftr: + root = eval_dshift(rop, dtype, /*is_left*/ FALSE); + break; + // AOCC end case AC_I_reshape: - root = eval_reshape(rop, dtype); + root = eval_reshape(rop, dtype, /*transpose*/ FALSE); // AOCC break; case AC_I_selected_int_kind: root = eval_selected_int_kind(rop, dtype); @@ -4764,6 +5437,9 @@ eval_init_op(int op, CONST *lop, DTYPE ldtype, CONST *rop, DTYPE rdtype, case AC_I_selected_char_kind: root = eval_selected_char_kind(rop, dtype); break; + case AC_I_nearest: + root = eval_nearest(rop, dtype); //AOCC + break; case AC_I_scan: root = eval_scan(rop, dtype); break; @@ -4812,6 +5488,11 @@ eval_init_op(int op, CONST *lop, DTYPE ldtype, CONST *rop, DTYPE rdtype, case AC_I_cos: root = eval_cos(rop, dtype); break; + /* AOCC begin */ + case AC_I_cotan: + root = eval_cotan(rop, dtype); + break; + /* AOCC end */ case AC_I_tan: root = eval_tan(rop, dtype); break; @@ -5113,6 +5794,11 @@ eval_init_op(int op, CONST *lop, DTYPE ldtype, CONST *rop, DTYPE rdtype, case OP_LOR: root->u1.conval = lop->u1.conval | rop->u1.conval; break; + // AOCC begin + case OP_XOR: + root->u1.conval = lop->u1.conval ^ rop->u1.conval; + break; + // AOCC end case OP_LAND: root->u1.conval = lop->u1.conval & rop->u1.conval; break; diff --git a/tools/flang2/flang2exe/dinitutl.cpp b/tools/flang2/flang2exe/dinitutl.cpp index a79eaec5ba..f959d82896 100644 --- a/tools/flang2/flang2exe/dinitutl.cpp +++ b/tools/flang2/flang2exe/dinitutl.cpp @@ -5,6 +5,14 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Date of Modification: 4th Nov 2019 + * handling of common blocks in multiple subroutines + */ + /** \file * \brief SCFTN data initialization file utilities. */ @@ -223,6 +231,7 @@ dinit_end(void) FREE(ilmb.ilm_base); ilmb.ilm_base = NULL; } + gbl.cmblks = NOSYM; // AOCC mode = ' '; /* no file */ } diff --git a/tools/flang2/flang2exe/dtypeutl.cpp b/tools/flang2/flang2exe/dtypeutl.cpp index 7c247df17c..59bedbf7ea 100644 --- a/tools/flang2/flang2exe/dtypeutl.cpp +++ b/tools/flang2/flang2exe/dtypeutl.cpp @@ -5,17 +5,27 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ + /** \file * \brief data type utility functions. */ +#include "gbldefs.h" /* AOCC */ #include "dtypeutl.h" #include "machar.h" #include "machardf.h" #include "symfun.h" static int size_sym = 0; -/* The no_data_components() function and its supporting predicate functions +/* The no_data_components() function and its supporting predicate functions * are mirrored from the front end */ struct visit_list { DTYPE dtype; @@ -221,9 +231,10 @@ _size_of(DTYPE dtype) case TY_UBINT: case TY_BLOG: case TY_DBLE: - case TY_QUAD: + case TY_QUAD: // AOCC case TY_CMPLX: case TY_DCMPLX: + case TY_QCMPLX: // AOCC case TY_INT8: case TY_UINT8: case TY_LOG8: @@ -357,6 +368,7 @@ dlen(TY_KIND dty) case TY_CMPLX: case TY_DBLE: case TY_DCMPLX: + case TY_QCMPLX: // AOCC case TY_DWORD: case TY_HOLL: case TY_INT: @@ -487,6 +499,7 @@ alignment(DTYPE dtype) case TY_UINT128: case TY_LOG128: case TY_FLOAT128: + case TY_QCMPLX: // AOCC case TY_CMPLX128: return dtypeinfo[ty].align; case TY_INT8: @@ -794,7 +807,7 @@ getdtype(DTYPE dtype, char *ptr) if (DTyArrayDesc(dtype) != 0) { ad = AD_DPTR(dtype); numdim = AD_NUMDIM(ad); - if (numdim < 1 || numdim > 7) { + if (!is_legal_numdim(numdim)) { /* AOCC */ interr("getdtype:bad numdim", 0, ERR_Informational); numdim = 0; } @@ -861,7 +874,7 @@ extent_of(DTYPE dtype) if (DTyArrayDesc(dtype) != 0) { ad = AD_DPTR(dtype); numdim = AD_NUMDIM(ad); - if (numdim < 1 || numdim > 7) { + if (!is_legal_numdim(numdim)) { /* AOCC */ interr("extent_of: bad numdim", 0, ERR_Informational); numdim = 0; } @@ -959,6 +972,7 @@ _dmp_dent(DTYPE dtypeind, FILE *outfile) case TY_QUAD: case TY_CMPLX: case TY_DCMPLX: + case TY_QCMPLX: // AOCC case TY_BLOG: case TY_SLOG: case TY_LOG: @@ -995,7 +1009,7 @@ _dmp_dent(DTYPE dtypeind, FILE *outfile) } ad = AD_DPTR(dtypeind); numdim = AD_NUMDIM(ad); - if (numdim < 1 || numdim > 7) { + if (!is_legal_numdim(numdim)) { /* AOCC */ interr("dmp_dent:bad numdim", 0, ERR_Informational); numdim = 0; } @@ -1108,8 +1122,10 @@ Scale_Of(DTYPE dtype, ISZ_T *size) case TY_UBINT: case TY_BLOG: case TY_DBLE: + case TY_QUAD: case TY_CMPLX: case TY_DCMPLX: + case TY_QCMPLX: // AOCC case TY_INT8: case TY_UINT8: case TY_LOG8: diff --git a/tools/flang2/flang2exe/dwarf2.h b/tools/flang2/flang2exe/dwarf2.h index 31af355e4b..090fef4d34 100644 --- a/tools/flang2/flang2exe/dwarf2.h +++ b/tools/flang2/flang2exe/dwarf2.h @@ -527,6 +527,11 @@ void emit_dwf2_ftn_func_begin(int sptr); #define DW_LANG_ObjC_plus_plus 0x0011 #define DW_LANG_UPC 0x0012 #define DW_LANG_D 0x0013 +/* AOCC begin */ +/* dwarf5 additions */ +#define DW_LANG_Fortran03 0x0014 +#define DW_LANG_Fortran08 0x0015 +/* AOCC end */ /* MIPS extension */ #define DW_LANG_Mips_Assembler 0x8001 /* UPC extension */ diff --git a/tools/flang2/flang2exe/dwarf_names.cpp b/tools/flang2/flang2exe/dwarf_names.cpp index fe675dae86..ee1044063d 100644 --- a/tools/flang2/flang2exe/dwarf_names.cpp +++ b/tools/flang2/flang2exe/dwarf_names.cpp @@ -474,6 +474,10 @@ dwarf_lang_name(unsigned value) CASERET(DW_LANG_D); CASERET(DW_LANG_Mips_Assembler); CASERET(DW_LANG_Upc); + // AOCC begin + CASERET(DW_LANG_Fortran08); + CASERET(DW_LANG_Fortran03); + // AOCC end } return "DW_LANG_"; } diff --git a/tools/flang2/flang2exe/exp_ftn.cpp b/tools/flang2/flang2exe/exp_ftn.cpp index 253528f7a1..f8856e8caa 100644 --- a/tools/flang2/flang2exe/exp_ftn.cpp +++ b/tools/flang2/flang2exe/exp_ftn.cpp @@ -5,10 +5,37 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Complex datatype support for acosh , asinh , atanh + * Modified on 07 January 2020 + * + * Added support for quad precision + * Last modified: Feb 2020 + * + * Support for TRAILZ intrinsic. + * Month of Modification: July 2019 + * + * Complex datatype support for atan2 under flag f2008 + * Modified on 13th March 2020 + * + * Last Modified : Jun 2020 + * + * complex quad support for asin, asinh, acos, acosh, atan, atanh + * Modified on 19th August 2020 + * + * complex support for cotan + * Last modified on Oct 2020 + * + */ + /** \file * \brief Fortran-specific expander routines */ +#include "gbldefs.h" /* AOCC */ #include "exp_ftn.h" #include "exputil.h" #include "exp_rte.h" @@ -38,6 +65,14 @@ #endif #include "ccffinfo.h" #include "symfun.h" +// AOCC BEGIN +#include "debug.h" + +// string for using with -debug-only= command line argument +#ifdef DEBUG +static const char *DEBUG_ONLY = "exp-ftn"; +#endif // DEBUG +// AOCC END #ifdef __cplusplus /* clang-format off */ @@ -142,6 +177,51 @@ is_ishft(int curilm) return false; } +#ifdef OMP_OFFLOAD_LLVM +static ILI_OP +verify_supported_device_mathfn(ILM_OP opc) +{ + switch (opc) { + default: return (ILI_OP)0; + + case IM_CEXP: return IL_SCMPLXEXP; + case IM_CDEXP: return IL_DCMPLXEXP; + + case IM_CABS: return IL_SCMPLXABS; + case IM_CDABS: return IL_DCMPLXABS; + + case IM_CLOG: return IL_SCMPLXLOG; + case IM_CDLOG: return IL_DCMPLXLOG; + + case IM_CSIN: return IL_SCMPLXSIN; + case IM_CDSIN: return IL_DCMPLXSIN; + case IM_CSINH: return IL_SCMPLXSINH; + case IM_CDSINH: return IL_DCMPLXSINH; + case IM_CASIN: return IL_SCMPLXASIN; + case IM_CDASIN: return IL_DCMPLXASIN; + + case IM_CCOS: return IL_SCMPLXCOS; + case IM_CDCOS: return IL_DCMPLXCOS; + case IM_CCOSH: return IL_SCMPLXCOSH; + case IM_CDCOSH: return IL_DCMPLXCOSH; + case IM_CACOS: return IL_SCMPLXACOS; + case IM_CDACOS: return IL_DCMPLXACOS; + + case IM_CTAN: return IL_SCMPLXTAN; + case IM_CDTAN: return IL_DCMPLXTAN; + case IM_CTANH: return IL_SCMPLXTANH; + case IM_CDTANH: return IL_DCMPLXTANH; + case IM_CATAN: return IL_SCMPLXATAN; + case IM_CDATAN: return IL_DCMPLXATAN; + + case IM_CCOTAN: return IL_SCMPLXTAN; + case IM_CDCOTAN: return IL_DCMPLXTAN; + return (ILI_OP)0; + } + return (ILI_OP)0; +} +#endif + void exp_ac(ILM_OP opc, ILM *ilmp, int curilm) { @@ -160,10 +240,50 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) * a names entry. */ nme = 0; +#ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + ILI_OP iliop = verify_supported_device_mathfn(opc); + if (iliop != 0) { + op1 = ILI_OF(ILM_OPND(ilmp, 1)); + ILM_RESULT(curilm) = ad1ili(iliop, op1); + return; + } + } +#endif switch (opc) { default: interr("exp_ac:ilm not cased", opc, ERR_Severe); return; + + // AOCC BEGIN + /* Create isnan() isnanf() libm calls based on the argument types. + */ + case IM_RISNAN: + case IM_DISNAN: + case IM_QISNAN: + op1 = ILI_OF(ILM_OPND(ilmp, 1)); + tmp = ad1ili(IL_NULL, 0); + switch (opc) { + case IM_RISNAN: + tmp = ad2ili(IL_ARGSP, op1, tmp); + op2 = mk_prototype("isnanf", "pure", DT_LOG, 1, DT_REAL); + break; + case IM_DISNAN: + tmp = ad2ili(IL_ARGDP, op1, tmp); + op2 = mk_prototype("isnan", "pure", DT_LOG, 1, DT_DBLE); + break; + case IM_QISNAN: + tmp = ad2ili(IL_ARGQP, op1, tmp); + op2 = mk_prototype("isnanq", "pure", DT_LOG, 1, DT_QUAD); + tmp = ad2ili(IL_QJSR, op2, tmp); + ILM_RESULT(curilm) = ad2ili(IL_DFRQP, tmp, QP_RETVAL); + return; + } + + tmp = ad2ili(IL_QJSR, op2, tmp); + ILM_RESULT(curilm) = ad2ili(IL_DFRKR, tmp, KR_RETVAL); + return; + // AOCC END case IM_LNOT: op1 = ILI_OF(ILM_OPND(ilmp, 1)); if (XBIT(125, 0x8)) @@ -276,6 +396,18 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) } ILM_RESULT(curilm) = ilix; return; + // AOCC begin + case IM_KTRAILZ: + op1 = ILI_OF(ILM_OPND(ilmp, 1)); + if (XBIT(124, 0x400)) + ilix = ad1ili(IL_KTRAILZ, op1); + else { + op1 = kimove(op1); + ilix = ad1ili(IL_ITRAILZ, op1); + } + ILM_RESULT(curilm) = ilix; + return; + // AOCC end case IM_KPOPPAR: op1 = ILI_OF(ILM_OPND(ilmp, 1)); if (XBIT(124, 0x400)) @@ -292,6 +424,11 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) case IM_DDIV: tmp = exp_mac(IM_DDIV, ilmp, curilm); return; + // AOCC begin + case IM_QDIV: + tmp = exp_mac(IM_QDIV, ilmp, curilm); + return; + // AOCC end case IM_REAL: if (XBIT(70, 0x40000000)) { @@ -320,6 +457,26 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) } tmp = exp_mac(opc, ilmp, curilm); return; + // AOCC begin + case IM_QREAL: + if (XBIT(70, 0x40000000)) { + op1 = ILI_OF(ILM_OPND(ilmp, 1)); + ilix = ad1ili(IL_QCMPLX2REAL, op1); + ILM_RESULT(curilm) = ilix; + return; + } + tmp = exp_mac(opc, ilmp, curilm); + return; + case IM_QIMAG: + if (XBIT(70, 0x40000000)) { + op1 = ILI_OF(ILM_OPND(ilmp, 1)); + ilix = ad1ili(IL_QCMPLX2IMAG, op1); + ILM_RESULT(curilm) = ilix; + return; + } + tmp = exp_mac(opc, ilmp, curilm); + return; + // AOCC end case IM_DIMAG: if (XBIT(70, 0x40000000)) { op1 = ILI_OF(ILM_OPND(ilmp, 1)); @@ -363,6 +520,23 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) ILM_RESTYPE(curilm) = ILM_ISDCMPLX; } return; + // AOCC begin + case IM_QCMPLX: + ilixr = ILI_OF(ILM_OPND(ilmp, 1)); /* real part */ + ilixi = ILI_OF(ILM_OPND(ilmp, 2)); /* imag part */ + if (XBIT(70, 0x40000000)) { + if (ILI_OPC(ilixi) == IL_QCON && ILI_OPND(ilixi, 1) == stb.quad0) + ilix = ad1ili(IL_QPQP2QCMPLXI0, ilixr); + else + ilix = ad2ili(IL_QPQP2QCMPLX, ilixr, ilixi); + ILM_RESULT(curilm) = ilix; + } else { + ILM_RRESULT(curilm) = ilixr; + ILM_IRESULT(curilm) = ilixi; + ILM_RESTYPE(curilm) = ILM_ISQCMPLX; + } + return; + // AOCC end case IM_ITOSC: val[1] = size_of(DT_BINT); goto sconv_shared; @@ -423,6 +597,22 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) } else tmp = exp_mac(IM_CDABS, ilmp, curilm); return; + // AOCC begin + case IM_CQABS: + if (XBIT(70, 0x40000000)) { + int r = ILM_RESULT(ILM_OPND(ilmp, 1)); + op1 = ad1ili(IL_QCMPLX2IMAG, r); + op2 = ad1ili(IL_QCMPLX2REAL, r); + tmp = ad1ili(IL_NULL, 0); + tmp = ad3ili(IL_DAQP, op1, QP(0), tmp); + tmp = ad3ili(IL_DAQP, op2, QP(1), tmp); + op3 = mk_prototype("cqabs", "pure", DT_QUAD, 2, DT_QUAD, DT_QUAD); + tmp = ad2ili(IL_QJSR, op3, tmp); + ILM_RESULT(curilm) = ad2ili(IL_DFRQP, tmp, QP_RETVAL); + } else + tmp = exp_mac(IM_CQABS, ilmp, curilm); + return; + // AOCC end /* * For the old calling sequence, all arithmetic/intrinsic QJSRs which * return complex are turned into regular complex function calls where the @@ -471,6 +661,37 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) } exp_qjsr("__mth_i_cdpowcd", DT_DCMPLX, ilmp, curilm); return; + // AOCC begin + case IM_CQTOI: + if (XBIT(70, 0x40000000) && XBIT_NEW_MATH_NAMES_CMPLX) { + op1 = ILI_OF(ILM_OPND(ilmp, 1)); + op2 = ILI_OF(ILM_OPND(ilmp, 2)); + ilix = ad2ili(IL_QCMPLXPOWI, op1, op2); + ILM_RESULT(curilm) = ilix; + return; + } + exp_qjsr("__mth_i_cqpowi", DT_QCMPLX, ilmp, curilm); + return; + case IM_CQTOCQ: + if (XBIT(70, 0x40000000) && XBIT_NEW_MATH_NAMES_CMPLX) { + op1 = ILI_OF(ILM_OPND(ilmp, 1)); + op2 = ILI_OF(ILM_OPND(ilmp, 2)); + ilix = ad2ili(IL_QCMPLXPOW, op1, op2); + ILM_RESULT(curilm) = ilix; + return; + } + exp_qjsr("cqpow", DT_QCMPLX, ilmp, curilm); + return; + case IM_CQSQRT: + exp_qjsr("cqsqrt", DT_QCMPLX, ilmp, curilm); + return; + case IM_QCONJG: + exp_qjsr("cqconj", DT_QCMPLX, ilmp, curilm); + return; + case IM_QNINT: + exp_qjsr("__mth_i_qnint", DT_QUAD, ilmp, curilm); + return; + // AOCC end case IM_CSQRT: exp_qjsr("__mth_i_csqrt", DT_CMPLX, ilmp, curilm); return; @@ -564,6 +785,57 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) exp_qjsr("__mth_i_cdexp", DT_DCMPLX, ilmp, curilm); #endif return; + // AOCC begin + case IM_CQEXP: + /* + * exp(cmplx(0.0, a)) -> cmplx(cos(a), sin(a)) + */ + ilixr = ILM_RESULT(ILM_OPND(ilmp, 1)); /* real part */ + if (ILI_OPC(ilixr) == IL_QCON && + is_quad0(ILI_SymOPND(ilixr, 1))) { + ilixi = ILM_IRESULT(ILM_OPND(ilmp, 1)); /* imag part */ + ilixr = ad1ili(IL_QCOS, ilixi); + ilixi = ad1ili(IL_QSIN, ilixi); + ILM_RRESULT(curilm) = ilixr; + ILM_IRESULT(curilm) = ilixi; + ILM_RESTYPE(curilm) = ILM_ISQCMPLX; + return; + } else if (XBIT(70, 0x40000000)) { + if (ILI_OPC(ilixr) == IL_QCMPLXCON) { + SPTR stmp = ILI_SymOPND(ilixr, 1); + tmp = stmp; + if (is_quad0(SymConval1(stmp))) { + ilixi = ad1ili(IL_QCON, CONVAL2G(stmp)); + ilixr = ad1ili(IL_QCOS, ilixi); + ilixi = ad1ili(IL_QSIN, ilixi); + ilix = ad2ili(IL_QPQP2QCMPLX, ilixr, ilixi); + ILM_RESULT(curilm) = ilix; + return; + } + } else if (ILI_OPC(ilixr) == IL_QPQP2QCMPLX) { + ilixi = ILI_OPND(ilixr, 2); + ilixr = ILI_OPND(ilixr, 1); + if (ILI_OPC(ilixr) == IL_QCON && + is_quad0(ILI_SymOPND(ilixr, 1))) { + ilixr = ad1ili(IL_QCOS, ilixi); + ilixi = ad1ili(IL_QSIN, ilixi); + ilix = ad2ili(IL_QPQP2QCMPLX, ilixr, ilixi); + ILM_RESULT(curilm) = ilix; + return; + } + } + } +#if defined(TARGET_X8664) + exp_qjsr(relaxed_math("exp", 's', 'z', "cqexp"), DT_QCMPLX, ilmp, + curilm); +#else + exp_qjsr("cqexp", DT_QCMPLX, ilmp, curilm); +#endif + return; + case IM_CQLOG: + exp_qjsr("cqlog", DT_QCMPLX, ilmp, curilm); + return; + // AOCC end case IM_CLOG: exp_qjsr("__mth_i_clog", DT_CMPLX, ilmp, curilm); return; @@ -576,12 +848,34 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) case IM_CDSIN: exp_qjsr("__mth_i_cdsin", DT_DCMPLX, ilmp, curilm); return; + // AOCC begin + case IM_CQSIN: + exp_qjsr("cqsin", DT_QCMPLX, ilmp, curilm); + return; + case IM_CQASIN: + exp_qjsr("cqasin", DT_QCMPLX, ilmp, curilm); + return; + case IM_CQASINH: + exp_qjsr("cqasinh", DT_QCMPLX, ilmp, curilm); + return; + // AOCC end case IM_CCOS: exp_qjsr("__mth_i_ccos", DT_CMPLX, ilmp, curilm); return; case IM_CDCOS: exp_qjsr("__mth_i_cdcos", DT_DCMPLX, ilmp, curilm); return; + // AOCC begin + case IM_CQCOS: + exp_qjsr("cqcos", DT_QCMPLX, ilmp, curilm); + return; + case IM_CQACOS: + exp_qjsr("cqacos", DT_QCMPLX, ilmp, curilm); + return; + case IM_CQACOSH: + exp_qjsr("cqacosh", DT_QCMPLX, ilmp, curilm); + return; + // AOCC end case IM_CASIN: exp_qjsr("__mth_i_casin", DT_CMPLX, ilmp, curilm); return; @@ -597,6 +891,13 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) case IM_CATAN: exp_qjsr("__mth_i_catan", DT_CMPLX, ilmp, curilm); return; + //AOCC begin + case IM_CATAN2: + if (flg.std == F2008) { + exp_qjsr("__mth_i_catan2", DT_CMPLX, ilmp, curilm); + return; + } + //AOCC end case IM_CDATAN: exp_qjsr("__mth_i_cdatan", DT_DCMPLX, ilmp, curilm); return; @@ -606,24 +907,73 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) case IM_CDCOSH: exp_qjsr("__mth_i_cdcosh", DT_DCMPLX, ilmp, curilm); return; + //AOCC begin + case IM_CQCOSH: + exp_qjsr("cqcosh", DT_QCMPLX, ilmp, curilm); + return; + //AOCC begin case IM_CSINH: exp_qjsr("__mth_i_csinh", DT_CMPLX, ilmp, curilm); return; case IM_CDSINH: exp_qjsr("__mth_i_cdsinh", DT_DCMPLX, ilmp, curilm); return; + //AOCC begin + case IM_CQSINH: + exp_qjsr("cqsinh", DT_QCMPLX, ilmp, curilm); + return; + //AOCC begin case IM_CTANH: exp_qjsr("__mth_i_ctanh", DT_CMPLX, ilmp, curilm); return; case IM_CDTANH: exp_qjsr("__mth_i_cdtanh", DT_DCMPLX, ilmp, curilm); return; + /* AOCC begin */ + case IM_CCOTAN: + exp_qjsr("__mth_i_ccotan", DT_CMPLX, ilmp, curilm); + return; + case IM_CDCOTAN: + exp_qjsr("__mth_i_cdcotan", DT_DCMPLX, ilmp, curilm); + return; + case IM_CQCOTAN: + exp_qjsr("cqcotan", DT_QCMPLX, ilmp, curilm); + return; + /* AOCC end */ case IM_CTAN: exp_qjsr("__mth_i_ctan", DT_CMPLX, ilmp, curilm); return; case IM_CDTAN: exp_qjsr("__mth_i_cdtan", DT_DCMPLX, ilmp, curilm); return; + // AOCC begin + case IM_CQTANH: + exp_qjsr("cqtanh", DT_QCMPLX, ilmp, curilm); + return; + case IM_CQTAN: + exp_qjsr("cqtan", DT_QCMPLX, ilmp, curilm); + return; + //AOCC begin + case IM_CQATAN: + exp_qjsr("cqatan", DT_QCMPLX, ilmp, curilm); + return; + case IM_CQATAN2: + exp_qjsr("cqatan2", DT_QCMPLX, ilmp, curilm); + return; + case IM_CQATANH: + exp_qjsr("cqatanh", DT_QCMPLX, ilmp, curilm); + return; + //AOCC end + case IM_CACOSH: + exp_qjsr("__mth_i_cacosh", DT_CMPLX, ilmp, curilm); + return; + case IM_CASINH: + exp_qjsr("__mth_i_casinh", DT_CMPLX, ilmp, curilm); + return; + case IM_CATANH: + exp_qjsr("__mth_i_catanh", DT_CMPLX, ilmp, curilm); + return; + //AOCC end case IM_CDIV: { if (XBIT(70, 0x40000000)) { @@ -664,6 +1014,28 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) } } return; + // AOCC begin + case IM_CQDIV: + { + if (XBIT(70, 0x40000000)) { + exp_qjsr("__mth_i_cqdiv", DT_QCMPLX, ilmp, curilm); + return; + } else { + tmp = ILM_OPND(ilmp, 2); + ilix = ILM_IRESULT(tmp); + if (!flg.ieee && !XBIT(70, 0x40000000) && ILI_OPC(ilix) == IL_QCON && + is_quad0(ILI_SymOPND(ilix, 1)) && (ILM_RRESULT(tmp) != ilix)) { + SetILM_OPC(ilmp, IM_CQDIVQ); + ILM_RESULT(tmp) = ILM_RRESULT(tmp); + ILM_RESTYPE(tmp) = 0; /* quad result */ + tmp = exp_mac(ILM_OPC(ilmp), ilmp, curilm); + return; + } + exp_qjsr("__mth_i_cqdiv", DT_QCMPLX, ilmp, curilm); + } + } + return; + // AOCC end case IM_CADD: if (XBIT(70, 0x40000000)) { op1 = ILI_OF(ILM_OPND(ilmp, 1)); @@ -684,6 +1056,18 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) tmp = exp_mac(IM_CDADD, ilmp, curilm); } return; + // AOCC begin + case IM_CQADD: + if (XBIT(70, 0x40000000)) { + op1 = ILI_OF(ILM_OPND(ilmp, 1)); + op2 = ILI_OF(ILM_OPND(ilmp, 2)); + ilix = ad2ili(IL_QCMPLXADD, op1, op2); + ILM_RESULT(curilm) = ilix; + } else { + tmp = exp_mac(IM_CQADD, ilmp, curilm); + } + return; + // AOCC end case IM_CSUB: if (XBIT(70, 0x40000000)) { op1 = ILI_OF(ILM_OPND(ilmp, 1)); @@ -704,6 +1088,18 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) tmp = exp_mac(IM_CDSUB, ilmp, curilm); } return; + // AOCC begin + case IM_CQSUB: + if (XBIT(70, 0x40000000)) { + op1 = ILI_OF(ILM_OPND(ilmp, 1)); + op2 = ILI_OF(ILM_OPND(ilmp, 2)); + ilix = ad2ili(IL_QCMPLXSUB, op1, op2); + ILM_RESULT(curilm) = ilix; + } else { + tmp = exp_mac(IM_CQSUB, ilmp, curilm); + } + return; + // AOCC end case IM_CMUL: if (XBIT(70, 0x40000000)) { op1 = ILI_OF(ILM_OPND(ilmp, 1)); @@ -724,6 +1120,28 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) tmp = exp_mac(IM_CDMUL, ilmp, curilm); } return; + // AOCC begin + case IM_CQMUL: + if (XBIT(70, 0x40000000)) { + op1 = ILI_OF(ILM_OPND(ilmp, 1)); + op2 = ILI_OF(ILM_OPND(ilmp, 2)); + ilix = ad2ili(IL_QCMPLXMUL, op1, op2); + ILM_RESULT(curilm) = ilix; + } else { + tmp = exp_mac(IM_CQMUL, ilmp, curilm); + } + return; + case IM_CQNEG: + if (XBIT(70, 0x40000000)) { + op1 = ILI_OF(ILM_OPND(ilmp, 1)); + op2 = ILI_OF(ILM_OPND(ilmp, 2)); + ilix = ad1ili(IL_QCMPLXNEG, op1); + ILM_RESULT(curilm) = ilix; + } else { + tmp = exp_mac(opc, ilmp, curilm); + } + return; + // AOCC end case IM_CNEG: if (XBIT(70, 0x40000000)) { op1 = ILI_OF(ILM_OPND(ilmp, 1)); @@ -763,6 +1181,17 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) tmp = exp_mac(opc, ilmp, curilm); } return; + // AOCC begin + /*case IM_QCONJG: + if (XBIT(70, 0x40000000)) { + op1 = ILI_OF(ILM_OPND(ilmp, 1)); + ilix = ad1ili(IL_QCMPLXCONJG, op1); + ILM_RESULT(curilm) = ilix; + } else { + tmp = exp_mac(opc, ilmp, curilm); + } + return;*/ + // AOCC end /* special handling of 64 bit precision integer ilms */ /* -- type -- arithmetic */ @@ -791,6 +1220,12 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) op1 = ILI_OF(ILM_OPND(ilmp, 1)); ILM_RESULT(curilm) = ad1ili(IL_DFIXK, op1); return; + // AOCC begin + case IM_KQFIX: + op1 = ILI_OF(ILM_OPND(ilmp, 1)); + ILM_RESULT(curilm) = ad1ili(IL_QFIXK, op1); + return; + // AOCC end case IM_ITOI8: op1 = ILI_OF(ILM_OPND(ilmp, 1)); ILM_RESULT(curilm) = ad1ili(IL_IKMV, op1); @@ -853,6 +1288,13 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) op2 = ILI_OF(ILM_OPND(ilmp, 2)); ILM_RESULT(curilm) = ad2ili(IL_KXOR, op1, op2); return; + // AOCC begin + case IM_XOR: + op1 = ILI_OF(ILM_OPND(ilmp, 1)); + op2 = ILI_OF(ILM_OPND(ilmp, 2)); + ILM_RESULT(curilm) = ad2ili(IL_XOR, op1, op2); + return; + // AOCC end case IM_KNOT: op1 = ILI_OF(ILM_OPND(ilmp, 1)); ILM_RESULT(curilm) = ad1ili(IL_KNOT, op1); @@ -955,6 +1397,16 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) tmp = ad2ili(IL_QJSR, op2, tmp); ILM_RESULT(curilm) = ad2ili(IL_DFRDP, tmp, DP(0)); return; + // AOCC begin + case IM_QFLOATK: + op1 = ILI_OF(ILM_OPND(ilmp, 1)); + tmp = ad1ili(IL_NULL, 0); + op2 = mk_prototype(MTH_I_QFLOATK, "pure", DT_QUAD, 1, DT_INT8); + tmp = ad2ili(IL_ARGKR, op1, tmp); + tmp = ad2ili(IL_QJSR, op2, tmp); + ILM_RESULT(curilm) = ad2ili(IL_DFRQP, tmp, QP(0)); + return; + // AOCC end case IM_D2K: op1 = ILI_OF(ILM_OPND(ilmp, 1)); ILM_RESULT(curilm) = ad1ili(IL_DP2KR, op1); @@ -1028,6 +1480,18 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) } exp_qjsr("__mth_i_cdpowk", DT_DCMPLX, ilmp, curilm); return; + // AOCC begin + case IM_CQTOK: + if (XBIT(70, 0x40000000) && XBIT_NEW_MATH_NAMES_CMPLX) { + op1 = ILI_OF(ILM_OPND(ilmp, 1)); + op2 = ILI_OF(ILM_OPND(ilmp, 2)); + ilix = ad2ili(IL_QCMPLXPOWK, op1, op2); + ILM_RESULT(curilm) = ilix; + return; + } + exp_qjsr("__mth_i_cqpowk", DT_QCMPLX, ilmp, curilm); + return; + // AOCC end case IM_KDIM: op1 = ILI_OF(ILM_OPND(ilmp, 1)); op2 = ILI_OF(ILM_OPND(ilmp, 2)); @@ -1113,6 +1577,29 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) ILM_RESTYPE(curilm) = ILM_ISDCMPLX; } break; + // AOCC begin + case IM_CQCON: + if (XBIT(70, 0x40000000)) { + tmp = ILM_OPND(ilmp, 1); + ILM_RESULT(curilm) = ad1ili(IL_QCMPLXCON, tmp); + } else { + /* complex quad constant; create 2 dcons */ + tmp = ILM_OPND(ilmp, 1); + val[0] = CONVAL1G(CONVAL1G(tmp)); + val[1] = CONVAL2G(CONVAL1G(tmp)); + val[2] = CONVAL3G(CONVAL1G(tmp)); + val[3] = CONVAL4G(CONVAL1G(tmp)); + ILM_RRESULT(curilm) = ad1ili(IL_QCON, getcon(val, DT_QUAD)); + val[0] = CONVAL1G(CONVAL2G(tmp)); + val[1] = CONVAL2G(CONVAL2G(tmp)); + val[2] = CONVAL3G(CONVAL2G(tmp)); + val[3] = CONVAL4G(CONVAL2G(tmp)); + ILM_IRESULT(curilm) = ad1ili(IL_QCON, getcon(val, DT_QUAD)); + ILM_RESTYPE(curilm) = ILM_ISQCMPLX; + } + break; + + // AOCC end case IM_LOC: /* merely copy up results, move from AR to DR */ @@ -1178,6 +1665,11 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) case IM_DCMP: ILM_NME(curilm) = IL_DCMP; return; + // AOCC begin + case IM_QCMP: + ILM_NME(curilm) = IL_QCMP; + return; + // AOCC end case IM_UICMP: ILM_NME(curilm) = IL_UICMP; return; @@ -1242,6 +1734,16 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) ILM_RESTYPE(curilm) = ILM_ISCMPLX; ILM_NME(curilm) = IL_DCMP; return; + // AOCC begin + case IM_CQCMP: + if (XBIT(70, 0x40000000)) { + ILM_NME(curilm) = IL_QCMP; + return; + } + ILM_RESTYPE(curilm) = ILM_ISCMPLX; + ILM_NME(curilm) = IL_QCMP; + return; + // AOCC end /* * For a relational, pick up the ILI opcode to be used from the names @@ -1304,8 +1806,8 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) if (XBIT(124, 0x400) && opc >= IM_EQ8 && opc <= IM_GT8) ILM_RESULT(curilm) = ad1ili(IL_IKMV, ILM_RESULT(curilm)); return; - } else if ((ILM_OPC(ilmpx) == IM_CCMP || ILM_OPC(ilmpx) == IM_CDCMP) && - XBIT(70, 0x40000000)) { + } else if ((ILM_OPC(ilmpx) == IM_CCMP || ILM_OPC(ilmpx) == IM_CDCMP || + ILM_OPC(ilmpx) == IM_CQCMP) && XBIT(70, 0x40000000)) { int il1, il2; ILI_OP opci, opcr; int ilm1 = ILM_OPND(ilmpx, 1); // ILM index of first operand of compare @@ -1314,9 +1816,12 @@ exp_ac(ILM_OP opc, ILM *ilmp, int curilm) if (ILM_OPC(ilmpx) == IM_CCMP) { opcr = IL_SCMPLX2REAL; opci = IL_SCMPLX2IMAG; - } else { + } else if (ILM_OPC(ilmpx) == IM_CDCMP) { opcr = IL_DCMPLX2REAL; opci = IL_DCMPLX2IMAG; + } else if (ILM_OPC(ilmpx) == IM_CQCMP) { + opcr = IL_QCMPLX2REAL; + opci = IL_QCMPLX2IMAG; } il1 = ad3ili(opcx, ad1ili(opcr, ILM_RESULT(ilm1)), ad1ili(opcr, ILM_RESULT(ilm2)), tmp); @@ -1417,8 +1922,8 @@ static struct { int elmsz; /* ili of actual element size (type ir) */ DTYPE eldt; /* data type of element */ int nsubs; /* number of subscripts */ - int sub[7]; /* ili for each (actual) subscript */ - int osub[7]; /* ili for original subscript (before expanding to 64-bit) */ + int sub[MAXSUBS]; /* AOCC: ili for each (actual) subscript */ + int osub[MAXSUBS]; /* ili for original subscript (before expanding to 64-bit) */ int finalnme; /* final NME */ } subscr; @@ -1438,7 +1943,7 @@ compute_subscr(ILM *ilmp, bool bigobj) int ili2; ISZ_T coffset; int sub_1; - int subs[7]; + int subs[MAXSUBS]; /* AOCC */ subscr.nsubs = ILM_OPND(ilmp, 1); #if DEBUG @@ -1720,15 +2225,24 @@ compute_sdsc_subscr(ILM *ilmp, bool bigobj) if (STYPEG(sdsc) == ST_MEMBER) { /* find the base ILM and NME */ basep = (ILM *)(ilmb.ilm_base + ILM_OPND(ilmp, 2)); - assert(ILM_OPC(basep) == IM_PLD, "compute_sdsc_subscr: not PLD", - ILM_OPND(ilmp, 2), ERR_Severe); - basep = (ILM *)(ilmb.ilm_base + ILM_OPND(basep, 1)); - assert(ILM_OPC(basep) == IM_MEMBER, "compute_sdsc_subscr: not MEMBER", - ILM_OPND(ilmp, 2), ERR_Severe); - base = ILM_OPND(basep, 1); - basenm = NME_OF(base); - base = ILI_OF(base); - assert(base, "compute_sdsc_subscr: base is NULL", base, ERR_Severe); + if (ILM_OPC(basep) == IM_PLD) { + assert(ILM_OPC(basep) == IM_PLD, "compute_sdsc_subscr: not PLD", + ILM_OPND(ilmp, 2), ERR_Severe); + basep = (ILM *)(ilmb.ilm_base + ILM_OPND(basep, 1)); + assert(ILM_OPC(basep) == IM_MEMBER, "compute_sdsc_subscr: not MEMBER", + ILM_OPND(ilmp, 2), ERR_Severe); + base = ILM_OPND(basep, 1); + basenm = NME_OF(base); + base = ILI_OF(base); + assert(base, "compute_sdsc_subscr: base is NULL", base, ERR_Severe); + } else { + assert(ILM_OPC(basep) == IM_MEMBER, "compute_sdsc_subscr: not PLD", + ILM_OPND(ilmp, 2), ERR_Severe); + base = ILM_OPND(basep, 1); + basenm = NME_OF(base); + base = ILI_OF(base); + assert(base, "compute_sdsc_subscr: base is NULL", base, ERR_Severe); + } } /* compute the static descriptor linearized version of this @@ -2943,7 +3457,7 @@ exp_array(ILM_OP opc, ILM *ilmp, int curilm) #endif if (XBIT(125, 0x10000)) { - int subs[7], i; + int subs[MAXSUBS], i; /* AOCC */ int arrilm; DTYPE dtype; SPTR sym; @@ -3409,7 +3923,7 @@ exp_bran(ILM_OP opc, ILM *ilmp, int curilm) ILI_OP subop; /* subtract op */ ILI_OP cjmpop; /* compare and jump op */ short msz; /* msz for load/store */ - } aif[5] = { + } aif[6] = { {IL_ICJMPZ, IL_CSEIR, DT_INT, IL_ST, IL_LD, IL_ICMPZ, IL_ISUB, IL_ICJMP, MSZ_WORD}, {IL_FCJMPZ, IL_CSESP, DT_REAL, IL_STSP, IL_LDSP, IL_FCMPZ, IL_FSUB, @@ -3418,6 +3932,10 @@ exp_bran(ILM_OP opc, ILM *ilmp, int curilm) IL_DCJMP, MSZ_F8}, {IL_KCJMPZ, IL_CSEKR, DT_INT8, IL_STKR, IL_LDKR, IL_KCMPZ, IL_KSUB, IL_KCJMP, MSZ_I8}, + // AOCC begin + {IL_QCJMPZ, IL_CSEQP, DT_QUAD, IL_STQP, IL_LDQP, IL_QCMPZ, IL_QSUB, + IL_QCJMP, MSZ_F16}, + // AOCC end }; int i; /* temp */ int ilix; /* ILI index */ @@ -3440,9 +3958,10 @@ exp_bran(ILM_OP opc, ILM *ilmp, int curilm) case IM_AGOTO: /* assigned goto */ exp_agoto(ilmp, curilm); break; - + //AOCC Begin case IM_KAIF: /* integer*8 arithmetic IF */ - type = 4; + type = 3; + //AOCC End goto comaif; case IM_IAIF: /* integer arithmetic IF */ type = 0; @@ -3452,6 +3971,11 @@ exp_bran(ILM_OP opc, ILM *ilmp, int curilm) goto comaif; case IM_DAIF: /* double arithmetic IF */ type = 2; + // AOCC begin + goto comaif; + case IM_QAIF: /* quad arithmetic IF */ + type = 2; + // AOCC end comaif: /* arithmetic if processing */ ilix = ILM_RESULT(ILM_OPND(ilmp, 1)); @@ -3954,18 +4478,40 @@ exp_misc(ILM_OP opc, ILM *ilmp, int curilm) break; #endif + // AOCC begin + case IM_MM_PREFETCH: + { + sym = mk_prototype("llvm.prefetch", "f pure", DT_NONE, 4, DT_ADDR, DT_INT, + DT_INT, DT_INT); + + int addr_ili = ILI_OF(ILM_OPND(ilmp, 1)); + int hint_ili = ILI_OF(ILM_OPND(ilmp, 2)); + + // type = 1 for data + int type_garg = ad4ili(IL_GARG, ad_icon(1), ad1ili(IL_NULL, 0), DT_INT, 0); + + int hint_garg = ad4ili(IL_GARG, hint_ili, type_garg, DT_INT, 0); + + // rw = 0 for read + int rw_garg = ad4ili(IL_GARG, ad_icon(0), hint_garg, DT_INT, 0); + + int addr_garg = ad4ili(IL_GARG, addr_ili, rw_garg, DT_ADDR, 0); + + ilix = ad2ili(IL_JSR, sym, addr_garg); + iltb.callfg = 1; + chk_block(ilix); + break; + } + // AOCC end + case IM_PREFETCH: ilix = ILI_OF(ILM_OPND(ilmp, 1)); /* address */ nme = NME_OF(ILM_OPND(ilmp, 1)); - if (XBIT(39, 0x4000) && TEST_MACH(MACH_AMD_HAMMER)) { - ilix = ad3ili(IL_PREFETCHT0, ilix, 0, nme); - } else if (TEST_MACH(MACH_AMD_HAMMER)) { - ilix = ad3ili(IL_PREFETCHNTA, ilix, 0, NME_UNK); - } else if (TEST_MACH(MACH_AMD)) { - ilix = ad3ili(IL_PREFETCH, ilix, 0, nme); /* Athlon */ - } else { - ilix = ad3ili(IL_PREFETCHNTA, ilix, 0, nme); /* PIII+ sse */ - } + // AOCC BEGIN + DEBUG_LOG("Encountered mem prefetch directive.\n"); + // AOCC END + /* Use the generic LLVM prefetch intrinsic. */ + ilix = ad3ili(IL_PREFETCH, ilix, 0, nme); chk_block(ilix); break; case IM_FARG: diff --git a/tools/flang2/flang2exe/exp_rte.cpp b/tools/flang2/flang2exe/exp_rte.cpp index b862dd7e13..011e8047c4 100644 --- a/tools/flang2/flang2exe/exp_rte.cpp +++ b/tools/flang2/flang2exe/exp_rte.cpp @@ -4,6 +4,21 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading + * Last modified: Nov 2019 + * + * Added support for quad precision + * Last modified: Feb 2020 + * Last Modified: Jun 2020 + * + * + * Added IM_QFUNC + * Date of modification: 18th July 2020 + */ /** \file @@ -41,6 +56,13 @@ #include "dtypeutl.h" #include "upper.h" #include "symfun.h" +// AOCC Begin +#ifdef OMP_OFFLOAD_AMD +#include "ompaccel.h" +#include "tgtutil.h" +#include "kmpcutil.h" +#endif +// AOCC End static int exp_strx(int, STRDESC *, STRDESC *); static int exp_strcpy(STRDESC *, STRDESC *); @@ -83,6 +105,7 @@ static int add_gargl_closure(SPTR sdsc); #define CLASS_MEM 13 #define MAX_PASS_STRUCT_SIZE 16 +#define ISNVVMCODEGEN gbl.ompaccel_isdevice #define mk_prototype mk_prototype_llvm @@ -90,7 +113,7 @@ static int add_gargl_closure(SPTR sdsc); (opc == IM_PCALLA || opc == IM_PCHFUNCA || opc == IM_PNCHFUNCA || \ opc == IM_PKFUNCA || opc == IM_PLFUNCA || opc == IM_PIFUNCA || \ opc == IM_PRFUNCA || opc == IM_PDFUNCA || opc == IM_PCFUNCA || \ - opc == IM_PCDFUNCA || opc == IM_PPFUNCA) + opc == IM_PCDFUNCA || opc == IM_PPFUNCA || opc == IM_PQFUNCA) static SPTR exp_call_sym; /**< sptr subprogram being called */ static SPTR fptr_iface; /**< sptr of function pointer's interface */ @@ -1582,11 +1605,14 @@ pp_params(SPTR func) pf->mem_off += 8; else if (argdtype == DT_DCMPLX) pf->mem_off += 16; + // AOCC + else if (argdtype == DT_QCMPLX) + pf->mem_off += 32; else if (DTY(argdtype) == TY_STRUCT) pf->mem_off += size_of(argdtype); else pf->mem_off += 4; - if (DTY(DTYPEG(argsym)) == TY_STRUCT) { + if (DTY(DTYPEG(argsym)) == TY_STRUCT && !OMPACCDEVSYMG(argsym) ) { int src_addr, n; int src_nme; int dest_addr; @@ -1719,6 +1745,7 @@ pp_params_mixedstrlen(int func) break; case TY_CMPLX: case TY_DCMPLX: + case TY_QCMPLX: // AOCC /* * If this is a function which returns complex, the first arg is * also for the return value. The last entry in the function's @@ -1800,6 +1827,8 @@ pp_params_mixedstrlen(int func) pf->mem_off += 8; else if (argdtype == DT_DCMPLX) pf->mem_off += 16; + else if (argdtype == DT_QCMPLX) // AOCC + pf->mem_off += 32; else if (DTY(argdtype) == TY_STRUCT) pf->mem_off += size_of(argdtype); else @@ -1897,6 +1926,12 @@ ldst_size(DTYPE dtype, ILI_OP *ldo, ILI_OP *sto, int *siz) *sto = IL_STKR; break; case TY_QUAD: + // AOCC begin + *siz = MSZ_F16; + *ldo = IL_LDQP; + *sto = IL_STQP; + break; + // AOCC end case TY_DBLE: case TY_DCMPLX: *siz = MSZ_F8; @@ -1943,6 +1978,12 @@ ldst_size(DTYPE dtype, ILI_OP *ldo, ILI_OP *sto, int *siz) *ldo = IL_LDDP; *sto = IL_STDP; break; + // AOCC begin + case MSZ_F16: + *ldo = IL_LDQP; + *sto = IL_STQP; + break; + // AOCC end } } /* ldst_size */ @@ -2108,6 +2149,24 @@ exp_end(ILM *ilmp, int curilm, bool is_func) finfo_t *pf; int exit_bih; + // AOCC Begin + /* + * De-Allocate the memory allocated via __kmpc_spmd_kernel_init() + * This function will be inserted right before return in main program + */ +#ifdef OMP_OFFLOAD_AMD + int ilix; + if (flg.omptarget && !is_func) { + if (XBIT(232, 0x40) && gbl.ompaccel_intarget && !OMPACCFUNCDEVG(gbl.currsub) /*is_gpu_output_file() */ ) { + ilix = ll_make_kmpc_target_deinit( + ompaccel_tinfo_get(gbl.currsub)->mode); + iltb.callfg = 1; + chk_block(ilix); + } + } +#endif + // AOCC End + if (expb.retlbl != 0) { exp_label(expb.retlbl); expb.retlbl = SPTR_NULL; @@ -2380,6 +2439,20 @@ gen_bindC_retval(finfo_t *fp) ilix = ad2ili(IL_MVQ, ilix, RES_XR(0)); /*m128*/ } break; + // AOCC begin + case ILIA_QP: + if (ILI_OPC(ilix) != IL_LDQP && ILI_OPC(ilix) != IL_QCON) { + const SPTR sfval = fp->fval; + ilix = ad4ili(IL_STQP, ilix, ad_acon(sfval, 0), + addnme(NT_VAR, sfval, 0, 0), MSZ_F16); + chk_block(ilix); + ilix = ad3ili(IL_LDQP, ad_acon(sfval, 0), + addnme(NT_VAR, sfval, 0, 0), MSZ_F16); + } else { + ilix = ad2ili(IL_MVQP, ilix, RES_XR(0)); /*m128*/ + } + break; + // AOCC end case ILIA_KR: ilix = ad2ili(IL_MVKR, ilix, RES_IR(0)); break; @@ -2425,6 +2498,7 @@ gen_funcret(finfo_t *fp) return; case TY_CMPLX: case TY_DCMPLX: + case TY_QCMPLX: // AOCC if (!CFUNCG(gbl.currsub) && !CMPLXFUNC_C) return; move = ad2ili(IL_MVAR, addr, RES_IR(0)); @@ -2443,6 +2517,12 @@ gen_funcret(finfo_t *fp) ili1 = ad3ili(IL_LDDP, addr, nme, MSZ_F8); move = ad2ili(IL_MVDP, ili1, FR_RETVAL); break; + // AOCC begin + case TY_QUAD: + ili1 = ad3ili(IL_LDQP, addr, nme, MSZ_F16); + move = ad2ili(IL_MVQP, ili1, FR_RETVAL); + break; + // AOCC end case TY_BINT: case TY_BLOG: ili1 = ad3ili(IL_LD, addr, nme, MSZ_SBYTE); @@ -2793,6 +2873,7 @@ static void arg_ar(int, ainfo_t *, int); static void arg_hp(int, ainfo_t *); static void arg_sp(int, ainfo_t *); static void arg_dp(int, ainfo_t *); +static void arg_qp(int, ainfo_t *); // AOCC static void arg_charlen(int, ainfo_t *); static void arg_length(STRDESC *, ainfo_t *); @@ -2870,6 +2951,11 @@ add_arg_ili(int ilix, int nme, int dtype) case ILIA_DP: add_to_args(IL_ARGDP, ilix); break; + // AOCC begin + case ILIA_QP: + add_to_args(IL_ARGQP, ilix); + break; + // AOCC end case ILIA_AR: add_to_args(IL_ARGAR, ilix); break; @@ -2905,6 +2991,11 @@ put_arg_ili(int i, ainfo_t *ainfo) case IL_ARGDP: arg_dp(arg_ili[i].ili_arg, ainfo); break; + // AOCC begin + case IL_ARGQP: + arg_qp(arg_ili[i].ili_arg, ainfo); + break; + // AOCC end default: interr("exp_call: ili arg type not cased", arg_ili[i].ili_arg, ERR_Severe); break; @@ -3041,7 +3132,7 @@ cmplx_to_mem(int real, int imag, DTYPE dtype, int *addr, int *nme) store = IL_STSP; msz = MSZ_F4; } - } else { + } else if (DTY(dtype) == TY_DCMPLX) { if (XBIT(70, 0x40000000) && !imag) { load = IL_LDDCMPLX; store = IL_STDCMPLX; @@ -3051,7 +3142,19 @@ cmplx_to_mem(int real, int imag, DTYPE dtype, int *addr, int *nme) store = IL_STDP; msz = MSZ_F8; } + // AOCC begin + } else { + if (XBIT(70, 0x40000000) && !imag) { + load = IL_LDQCMPLX; + store = IL_STQCMPLX; + msz = MSZ_F32; + } else { + load = IL_LDQP; + store = IL_STQP; + msz = MSZ_F16; + } } + // AOCC end if (!XBIT(70, 0x40000000)) { size = size_of(dtype) / 2; } else { @@ -3109,8 +3212,10 @@ cmplx_to_mem(int real, int imag, DTYPE dtype, int *addr, int *nme) if (XBIT(70, 0x40000000) && !imag) { if (dtype == DT_CMPLX) chk_block(ad4ili(IL_STSCMPLX, real, *addr, *nme, msz)); - else + else if (dtype == DT_DCMPLX) chk_block(ad4ili(IL_STDCMPLX, real, *addr, *nme, msz)); + else + chk_block(ad4ili(IL_STQCMPLX, real, *addr, *nme, msz)); } else { chk_block(ad4ili(store, real, *addr, addnme(NT_MEM, SPTR_NULL, *nme, 0), msz)); chk_block(ad4ili(store, imag, @@ -3268,10 +3373,30 @@ exp_call(ILM_OP opc, ILM *ilmp, int curilm) int struct_tmp; int chain_pointer_arg = 0; int result_arg = 0; + int tgtargili; + int ilmarg; + SPTR isptrarg; nargs = ILM_OPND(ilmp, 1); /* # args */ func_addr = 0; funcptr_flags = 0; + + // AOCC begin +#ifdef OMP_OFFLOAD_LLVM + // We can't do this evaulation at ast since for omp target-if the same + // ast-block is used for the outlined target function and host function. + // Since this evalutation must only happen at the outlined target function, we + // perform it here under gbl.ompaccel_intarget so that we're guaranteed not + // to modify the same call(if any) in the host. + if (gbl.ompaccel_intarget && flg.x86_64_omptarget) { + SPTR func_sptr = ILM_SymOPND(ilmp, 2); + if (strcmp(SYMNAME(func_sptr), "omp_is_initial_device") == 0) { + ILI_OF(curilm) = ad_icon(0); // ie. return false + return; + } + } +#endif + // AOCC end switch (opc) { case IM_CALL: exp_call_sym = ILM_SymOPND(ilmp, 2); /* external reference */ @@ -3287,8 +3412,10 @@ exp_call(ILM_OP opc, ILM *ilmp, int curilm) case IM_IFUNC: case IM_RFUNC: case IM_DFUNC: + case IM_QFUNC: // AOCC case IM_CFUNC: case IM_CDFUNC: + case IM_CQFUNC: // AOCC case IM_PFUNC: case IM_SFUNC: exp_call_sym = ILM_SymOPND(ilmp, 2); /* external reference */ @@ -3315,6 +3442,11 @@ exp_call(ILM_OP opc, ILM *ilmp, int curilm) case IM_PCDFUNCA: case IM_PFUNCA: case IM_PPFUNCA: + // AOCC begin + case IM_QFUNCA: + case IM_CQFUNCA: + case IM_PQFUNCA: + // AOCC end funcptr_flags = ILM_OPND(ilmp, 2); exp_call_sym = SPTR_NULL; /* via procedure ptr */ if (!IS_INTERNAL_PROC_CALL(opc)) { @@ -3364,6 +3496,14 @@ exp_call(ILM_OP opc, ILM *ilmp, int curilm) case IM_DVFUNCA: descno = 5; goto vcalla_common; + // AOCC begin + case IM_QVFUNCA: + descno = 5; + goto vcalla_common; + case IM_CQVFUNCA: + descno = 5; + goto vcalla_common; + // AOCC end case IM_CVFUNCA: descno = 5; goto vcalla_common; @@ -3466,14 +3606,17 @@ exp_call(ILM_OP opc, ILM *ilmp, int curilm) break; case IM_CFUNC: case IM_CDFUNC: + case IM_CQFUNC: // AOCC i = 3; goto share_cfunc; case IM_PCFUNCA: case IM_PCDFUNCA: + case IM_PCQFUNCA: i = 5; goto share_cfunc; case IM_CFUNCA: case IM_CDFUNCA: + case IM_CQFUNCA: // AOCC i = 4; share_cfunc: ilm1 = ILM_OPND(ilmp, i); @@ -3485,7 +3628,7 @@ exp_call(ILM_OP opc, ILM *ilmp, int curilm) if (CFUNCG(exp_call_sym) || (funcptr_flags & FUNCPTR_BINDC) || CMPLXFUNC_C) { ADDRTKNP(IILM_OPND(ilm1, 1), 1); - if (opc == IM_CFUNCA || opc == IM_CDFUNCA) { + if (opc == IM_CFUNCA || opc == IM_CDFUNCA || opc == IM_CQFUNCA) { ilm1 = ILM_OPND(ilmp, i); } else { ilm1 = ILM_OPND(ilmp, (i + 2)); @@ -3532,6 +3675,7 @@ exp_call(ILM_OP opc, ILM *ilmp, int curilm) break; case IM_CVFUNCA: case IM_CDVFUNCA: + case IM_CQVFUNCA: // AOCC ilm1 = ILM_OPND(ilmp, 6); if (IILM_OPC(ilm1) == IM_FARG) ilm1 = IILM_OPND(ilm1, 1); @@ -3549,6 +3693,7 @@ exp_call(ILM_OP opc, ILM *ilmp, int curilm) case IM_IVFUNCA: case IM_RVFUNCA: case IM_DVFUNCA: + case IM_QVFUNCA: // AOCC case IM_PVFUNCA: i = 6; break; @@ -3590,6 +3735,7 @@ exp_call(ILM_OP opc, ILM *ilmp, int curilm) case IM_PIFUNCA: case IM_PRFUNCA: case IM_PDFUNCA: + case IM_PQFUNCA: // AOCC case IM_PLFUNCA: case IM_PPFUNCA: case IM_PKFUNCA: @@ -3637,8 +3783,44 @@ exp_call(ILM_OP opc, ILM *ilmp, int curilm) loc_of(NME_OF(ilm1)); argili = ILI_OF(ilm1); ilm1 = ILM_OPND(ilmlnk, 2); /* BASE ILM of the object */ + + /* special case for handling allocatable array in GPU + * temporary alloca for the allocatable array is created and passed + * as an argument for the function inside target region + */ + //AOCC BEGIN + ILM *ilmp2; + ilmarg = ILM_OPND(ilmlnk, 2); + ilmp2 = (ILM *)(ilmb.ilm_base + ilmarg); + isptrarg=ILM_SymOPND(ilmp2,1); + dtype = DTYPEG(isptrarg); if (ILM_RESTYPE(ilm1) != ILM_ISCHAR || !pass_len) { - add_to_args(IL_ARGAR, argili); +#if 0 +#ifdef OMP_OFFLOAD_AMD + // AOCC Begin + if( flg.amdgcn_target && DTY(dtype)==TY_ARRAY){ + SPTR tgt_arg; + tgt_arg = installsym("tgtargtemp", strlen("temp")); + if (STYPEG(tgt_arg) == ST_UNKNOWN) + setimplicit(tgt_arg); + DTYPEP(tgt_arg , DT_ADDR); + STYPEP(tgt_arg , ST_VAR); + SCP(tgt_arg , SC_LOCAL); + OMPACCDEVSYMP(tgt_arg , 1); + int nme = addnme(NT_VAR, tgt_arg , 0, (INT)0); + tgtargili = mk_address(tgt_arg); + ilix = mk_ompaccel_store(argili, DT_ADDR, nme, tgtargili); + chk_block(ilix); + ilix = mk_ompaccel_ldsptr(tgt_arg); + chk_block(ilix); + add_to_args(IL_ARGAR, tgtargili); + gargili = tgtargili; + break; + } else + //AOCC END +#endif +#endif + add_to_args(IL_ARGAR, argili); } else { pass_char_arg(IL_ARGAR, argili, ILM_CLEN(ilm1)); } @@ -3686,14 +3868,17 @@ exp_call(ILM_OP opc, ILM *ilmp, int curilm) } if (ILM_RESTYPE(ilm1) == ILM_ISCMPLX || ILM_RESTYPE(ilm1) == ILM_ISDCMPLX || dtype == DT_CMPLX || - dtype == DT_DCMPLX) { + dtype == DT_DCMPLX || dtype == DT_QCMPLX) { int res, mem_msz, msz; ILI_OP st_opc, ld_opc, arg_opc; argili = ILM_RRESULT(ilm1); if (ILM_RESTYPE(ilm1) == ILM_ISCMPLX) arg_opc = IL_ARGSP; - else + else if (ILM_RESTYPE(ilm1) == ILM_ISDCMPLX) arg_opc = IL_ARGDP; + // AOCC + else + arg_opc = IL_ARGQP; if (XBIT(70, 0x40000000)) { int rili; @@ -3711,12 +3896,18 @@ exp_call(ILM_OP opc, ILM *ilmp, int curilm) add_to_args(arg_opc, argili); argili = ad1ili(IL_SCMPLX2REAL, rili); add_to_args(arg_opc, argili); - } else { + } else if (dtype == DT_DCMPLX) { arg_opc = IL_ARGDP; argili = ad1ili(IL_DCMPLX2IMAG, rili); add_to_args(arg_opc, argili); argili = ad1ili(IL_DCMPLX2REAL, rili); add_to_args(arg_opc, argili); + } else { + arg_opc = IL_ARGQP; + argili = ad1ili(IL_QCMPLX2IMAG, rili); + add_to_args(arg_opc, argili); + argili = ad1ili(IL_QCMPLX2REAL, rili); + add_to_args(arg_opc, argili); } cmplx_to_mem(ILM_RESULT(ilm1), 0, dtype, &addr, &nme); gargili = addr; @@ -3728,14 +3919,17 @@ exp_call(ILM_OP opc, ILM *ilmp, int curilm) #if defined(IL_GJSR) && defined(USE_LLVM_CMPLX) /* New functionality */ res = ILI_OPND(ILM_RESULT(ilm1), 1); basenm = 0; - dtype = ILM_RESTYPE(ilm1) == ILM_ISCMPLX ? DT_CMPLX : DT_DCMPLX; - ld_opc = dtype == DT_CMPLX ? IL_LDSCMPLX : IL_LDDCMPLX; - msz = dtype == DT_CMPLX ? MSZ_F8 : MSZ_F16; - mem_msz = dtype == DT_CMPLX ? MSZ_F4 : MSZ_F8; + dtype = ILM_RESTYPE(ilm1) == ILM_ISCMPLX ? DT_CMPLX : + ILM_RESTYPE(ilm1) == ILM_ISDCMPLX ? DT_DCMPLX : DT_QCMPLX; + ld_opc = dtype == DT_CMPLX ? IL_LDSCMPLX : dtype == DT_DCMPLX + ? IL_LDDCMPLX : IL_LDQCMPLX; + msz = dtype == DT_CMPLX ? MSZ_F8 : dtype == DT_DCMPLX ? MSZ_F16 : MSZ_F32; + mem_msz = dtype == DT_CMPLX ? MSZ_F4 : dtype == DT_DCMPLX ? MSZ_F8 : MSZ_F16; if (!ILIA_ISAR(IL_RES(ILI_OPC(res)))) { /* Not an address, so we need to add a temp store */ - st_opc = dtype == DT_CMPLX ? IL_STSP : IL_STDP; - skip = dtype == DT_CMPLX ? size_of(DT_FLOAT) : size_of(DT_DBLE); + st_opc = dtype == DT_CMPLX ? IL_STSP : dtype == DT_DCMPLX ? IL_STDP : IL_STQP; + skip = dtype == DT_CMPLX ? size_of(DT_FLOAT) : dtype == DT_DCMPLX + ? size_of(DT_DBLE) : size_of(DT_QUAD); sym = mkrtemp_cpx_sc(dtype, expb.sc); ADDRTKNP(sym, 1); basenm = addnme(NT_VAR, sym, 0, 0); @@ -3854,6 +4048,24 @@ exp_call(ILM_OP opc, ILM *ilmp, int curilm) add_to_args(IL_ARGDP, argili); break; } + // AOCC begin + if (ILM_RESTYPE(ilm1) == ILM_ISQCMPLX) { + dtype = DT_QUAD; + argili = ILM_RRESULT(ilm1); + add_to_args(IL_ARGQP, argili); + if (XBIT(121, 0x800)) { + garg_ili[gi].ilix = gargili; + garg_ili[gi].dtype = dtype; + garg_ili[gi].val_flag = NME_VOL; + gi++; + ngargs++; + } + argili = ILM_IRESULT(ilm1); + gargili = argili; + add_to_args(IL_ARGQP, argili); + break; + } + // AOCC end /* word expression by value */ argili = ILM_RESULT(ilm1); switch (IL_RES(ILI_OPC(argili))) { @@ -3873,6 +4085,12 @@ exp_call(ILM_OP opc, ILM *ilmp, int curilm) add_to_args(IL_ARGDP, argili); dtype = DT_DBLE; break; + // AOCC begin + case ILIA_QP: + add_to_args(IL_ARGQP, argili); + dtype = DT_QUAD; + break; + // AOCC end case ILIA_AR: add_to_args(IL_ARGAR, argili); dtype = DT_ADDR; @@ -3909,6 +4127,22 @@ exp_call(ILM_OP opc, ILM *ilmp, int curilm) gargili = argili; add_to_args(IL_ARGDP, argili); break; + // AOCC begin + case ILIA_CQ: + dtype = DT_QUAD; + argili = ad1ili(IL_QCMPLX2REAL, ILM_RESULT(ilm1)); + add_to_args(IL_ARGQP, argili); + if (XBIT(121, 0x800)) { + garg_ili[gi].ilix = argili; + garg_ili[gi].dtype = dtype; + gi++; + ngargs++; + } + argili = ad1ili(IL_QCMPLX2IMAG, ILM_RESULT(ilm1)); + gargili = argili; + add_to_args(IL_ARGQP, argili); + break; + // AOCC end default: interr("exp_call:bad ili for DPVAL", argili, ERR_Severe); } @@ -3982,6 +4216,10 @@ exp_call(ILM_OP opc, ILM *ilmp, int curilm) sym = mkrtemp_cpx_sc(DT_CMPLX, expb.sc); } else if (ILM_RESTYPE(ilm1) == ILM_ISDCMPLX) { sym = mkrtemp_cpx_sc(DT_DCMPLX, expb.sc); + // AOCC begin + } else if (ILM_RESTYPE(ilm1) == ILM_ISQCMPLX) { + sym = mkrtemp_cpx_sc(DT_QCMPLX, expb.sc); + // AOCC end } else sym = mkrtemp_sc(ILM_RESULT(ilm1), expb.sc); ADDRTKNP(sym, 1); @@ -4008,6 +4246,18 @@ exp_call(ILM_OP opc, ILM *ilmp, int curilm) ilix = ad4ili(IL_STDP, ilix, ad_acon(sym, skip), addnme(NT_MEM, NOSYM, basenm, skip), MSZ_F8); chk_block(ilix); + // AOCC begin + } else if (ILM_RESTYPE(ilm1) == ILM_ISQCMPLX) { + skip = size_of(DT_QUAD); + ilix = ILM_RRESULT(ilm1); + ilix = ad4ili(IL_STQP, ilix, argili, + addnme(NT_MEM, SPTR_NULL, basenm, 0), MSZ_F16); + chk_block(ilix); + ilix = ILM_IRESULT(ilm1); + ilix = ad4ili(IL_STQP, ilix, ad_acon(sym, skip), + addnme(NT_MEM, NOSYM, basenm, skip), MSZ_F16); + chk_block(ilix); + // AOCC end } else { ilix = ILM_RESULT(ilm1); switch (IL_RES(ILI_OPC(ilix))) { @@ -4026,12 +4276,22 @@ exp_call(ILM_OP opc, ILM *ilmp, int curilm) case ILIA_DP: ilix = ad4ili(IL_STDP, ilix, argili, basenm, MSZ_F8); break; + // AOCC begin + case ILIA_QP: + ilix = ad4ili(IL_STQP, ilix, argili, basenm, MSZ_F16); + break; + // AOCC end case ILIA_CS: ilix = ad4ili(IL_STSCMPLX, ilix, argili, basenm, MSZ_F8); break; case ILIA_CD: ilix = ad4ili(IL_STDCMPLX, ilix, argili, basenm, MSZ_F16); break; + // AOCC begin + case ILIA_CQ: + ilix = ad4ili(IL_STQCMPLX, ilix, argili, basenm, MSZ_F32); + break; + // AOCC end default: // in exp_call for IM_SFUNC, we decide to save IL_JSR // in the ILI_OF(or ILM_RESULT) field. @@ -4237,8 +4497,10 @@ exp_call(ILM_OP opc, ILM *ilmp, int curilm) case IM_IVFUNCA: case IM_RVFUNCA: case IM_DVFUNCA: + case IM_QVFUNCA: // AOCC case IM_CVFUNCA: case IM_CDVFUNCA: + case IM_CQVFUNCA: // AOCC case IM_PVFUNCA: { SPTR sptr_descno = (SPTR) descno; ililnk = exp_type_bound_proc_call(exp_call_sym, sptr_descno, vtoff, arglnk); @@ -4322,6 +4584,13 @@ exp_call(ILM_OP opc, ILM *ilmp, int curilm) case IM_DVFUNCA: ILI_OF(curilm) = ad2ili(IL_DFRDP, ililnk, FR_RETVAL); break; + //AOCC Begin + case IM_PQFUNCA: + case IM_QVFUNCA: + case IM_QFUNC: + ILI_OF(curilm) = ad2ili(IL_DFRQP, ililnk, FR_RETVAL); + break; + //AOCC End case IM_CFUNC: case IM_CFUNCA: case IM_PCFUNCA: @@ -4351,6 +4620,23 @@ exp_call(ILM_OP opc, ILM *ilmp, int curilm) ILM_RESTYPE(curilm) = ILM_ISDCMPLX; } break; + // AOCC begin + case IM_CQFUNC: + case IM_CQFUNCA: + case IM_PCQFUNCA: + case IM_CQVFUNCA: + chk_block(ililnk); + if (XBIT(70, 0x40000000)) { + ILM_RESULT(curilm) = ad3ili(IL_LDQCMPLX, cfunc, cfunc_nme, MSZ_F32); + } else { + ILM_RRESULT(curilm) = ad3ili(IL_LDQP, cfunc, addnme(NT_MEM, SPTR_NULL, cfunc_nme, 0), MSZ_F16); + ILM_IRESULT(curilm) = + ad3ili(IL_LDQP, ad3ili(IL_AADD, cfunc, ad_aconi(16), 0), + addnme(NT_MEM, NOSYM, cfunc_nme, 16), MSZ_F16); + ILM_RESTYPE(curilm) = ILM_ISQCMPLX; + } + break; + // AOCC end case IM_PFUNC: case IM_PFUNCA: case IM_PPFUNCA: @@ -4464,6 +4750,12 @@ exp_qjsr(char *ext, DTYPE res_dtype, ILM *ilmp, int curilm) arg_dp(ILM_IRESULT(ilm1), &ainfo); arg_dp(ILM_RRESULT(ilm1), &ainfo); break; + // AOCC begin + case ILM_ISQCMPLX: + arg_qp(ILM_IRESULT(ilm1), &ainfo); + arg_qp(ILM_RRESULT(ilm1), &ainfo); + break; + // AOCC end default: ilix = ILM_RESULT(ilm1); switch (IL_RES(ILI_OPC(ilix))) { @@ -4479,6 +4771,11 @@ exp_qjsr(char *ext, DTYPE res_dtype, ILM *ilmp, int curilm) case ILIA_DP: arg_dp(ilix, &ainfo); break; + // AOCC begin + case ILIA_QP: + arg_qp(ilix, &ainfo); + break; + // AOCC end case ILIA_KR: arg_kr(ilix, &ainfo); break; @@ -4495,6 +4792,14 @@ exp_qjsr(char *ext, DTYPE res_dtype, ILM *ilmp, int curilm) ilix = ad1ili(IL_DCMPLX2REAL, ILM_RESULT(ilm1)); arg_dp(ilix, &ainfo); break; + // AOCC begin + case ILIA_CQ: + ilix = ad1ili(IL_QCMPLX2IMAG, ILM_RESULT(ilm1)); + arg_qp(ilix, &ainfo); + ilix = ad1ili(IL_QCMPLX2REAL, ILM_RESULT(ilm1)); + arg_qp(ilix, &ainfo); + break; + // AOCC end #endif default: interr("exp_qjsr: ili ret type not cased", ilix, ERR_Severe); @@ -4519,7 +4824,7 @@ exp_qjsr(char *ext, DTYPE res_dtype, ILM *ilmp, int curilm) addnme(NT_MEM, NOSYM, res_nme, 4), MSZ_F4); ILM_RESTYPE(curilm) = ILM_ISCMPLX; } - } else { + } else if (res_dtype == DT_DCMPLX) { if (XBIT(70, 0x40000000)) { ILM_RESULT(curilm) = ad3ili(IL_LDDCMPLX, res_addr, res_nme, MSZ_F16); } else { @@ -4530,7 +4835,20 @@ exp_qjsr(char *ext, DTYPE res_dtype, ILM *ilmp, int curilm) addnme(NT_MEM, NOSYM, res_nme, 8), MSZ_F8); ILM_RESTYPE(curilm) = ILM_ISDCMPLX; } + // AOCC begin + } else { + if (XBIT(70, 0x40000000)) { + ILM_RESULT(curilm) = ad3ili(IL_LDQCMPLX, res_addr, res_nme, MSZ_F32); + } else { + + ILM_RRESULT(curilm) = ad3ili(IL_LDQP, res_addr, addnme(NT_MEM, SPTR_NULL, res_nme, 0), MSZ_F16); + ILM_IRESULT(curilm) = + ad3ili(IL_LDQP, ad3ili(IL_AADD, res_addr, ad_aconi(16), 0), + addnme(NT_MEM, NOSYM, res_nme, 16), MSZ_F16); + ILM_RESTYPE(curilm) = ILM_ISQCMPLX; + } } + // AOCC end end_ainfo(&ainfo); } @@ -4594,6 +4912,12 @@ exp_zqjsr(char *ext, DTYPE res_dtype, ILM *ilmp, int curilm) arg_dp(ILM_IRESULT(ilm1), &ainfo); arg_dp(ILM_RRESULT(ilm1), &ainfo); break; + // AOCC begin + case ILM_ISQCMPLX: + arg_qp(ILM_IRESULT(ilm1), &ainfo); + arg_qp(ILM_RRESULT(ilm1), &ainfo); + break; + // AOCC end default: ilix = ILM_RESULT(ilm1); switch (IL_RES(ILI_OPC(ilix))) { @@ -4609,6 +4933,11 @@ exp_zqjsr(char *ext, DTYPE res_dtype, ILM *ilmp, int curilm) case ILIA_DP: arg_dp(ilix, &ainfo); break; + // AOCC begin + case ILIA_QP: + arg_qp(ilix, &ainfo); + break; + // AOCC end case ILIA_KR: arg_kr(ilix, &ainfo); break; @@ -4626,6 +4955,14 @@ exp_zqjsr(char *ext, DTYPE res_dtype, ILM *ilmp, int curilm) arg_dp(ilix, &ainfo); break; #endif + // AOCC begin + case ILIA_CQ: + ilix = ad1ili(IL_QCMPLX2IMAG, ILM_RESULT(ilm1)); + arg_qp(ilix, &ainfo); + ilix = ad1ili(IL_QCMPLX2REAL, ILM_RESULT(ilm1)); + arg_qp(ilix, &ainfo); + break; + // AOCC end default: interr("exp_zqjsr: ili ret type not cased", ilix, ERR_Severe); break; @@ -4650,7 +4987,7 @@ exp_zqjsr(char *ext, DTYPE res_dtype, ILM *ilmp, int curilm) addnme(NT_MEM, NOSYM, res_nme, 4), MSZ_F4); ILM_RESTYPE(curilm) = ILM_ISCMPLX; } - } else { + } else if (res_dtype == DT_DCMPLX) { if (XBIT(70, 0x40000000)) { ILM_RESULT(curilm) = ad3ili(IL_LDDCMPLX, res_addr, res_nme, MSZ_F16); } else { @@ -4660,7 +4997,19 @@ exp_zqjsr(char *ext, DTYPE res_dtype, ILM *ilmp, int curilm) addnme(NT_MEM, NOSYM, res_nme, 8), MSZ_F8); ILM_RESTYPE(curilm) = ILM_ISDCMPLX; } + // AOCC begin + } else { + if (XBIT(70, 0x40000000)) { + ILM_RESULT(curilm) = ad3ili(IL_LDQCMPLX, res_addr, res_nme, MSZ_F32); + } else { + ILM_RRESULT(curilm) = + ad3ili(IL_LDQP, res_addr, addnme(NT_MEM, SPTR_NULL, res_nme, 0), MSZ_F16); + ILM_IRESULT(curilm) = ad3ili(IL_LDQP, ad3ili(IL_AADD, res_addr, ad_aconi(16), 0), + addnme(NT_MEM, NOSYM, res_nme, 16), MSZ_F16); + ILM_RESTYPE(curilm) = ILM_ISQCMPLX; + } } + // AOCC end end_ainfo(&ainfo); } @@ -4697,6 +5046,14 @@ arg_dp(int ilix, ainfo_t *ap) ap->lnk = ad2ili(IL_ARGDP, ilix, ap->lnk); } +// AOCC begin +static void +arg_qp(int ilix, ainfo_t *ap) +{ + ap->lnk = ad2ili(IL_ARGQP, ilix, ap->lnk); +} +// AOCC end + static void arg_charlen(int ilix, ainfo_t *ap) { @@ -5267,13 +5624,16 @@ exp_strcpy(STRDESC *str1, STRDESC *str2) init_ainfo(&ainfo); if (str1->dtype == TY_CHAR) { + // AOCC restrict the checks for target overloading + // we need to inline all f90_strcpy calls if (!strovlp(str1, str2)) { /* * single source, no overlap */ -#define STR_MOVE_THRESH 16 +#define STR_MOVE_THRESH 256 // AOCC if (!XBIT(125, 0x800) && str1->liscon && str2->liscon && - str1->lval <= STR_MOVE_THRESH) { + // AOCC (allow strcpy inlining for target offloading ) + (flg.omptarget /* && str1->lval <= STR_MOVE_THRESH */)) { /* * perform a 'block move' of the rhs to the lhs -- the move * will move a combination of 8 (64-bit only) 4, 2, and 1 @@ -5472,6 +5832,10 @@ strovlp(STRDESC *lhs, STRDESC *rhs) if (rhs->next != NULL) /* single rhs only */ return true; + // AOCC. if rhs is a constant string it cannot overlap + // TODO: omptarget check is not required + if (flg.omptarget && rhs->liscon) + return false; if (!rhs->aisvar) /* rhs must be simple var or constant */ return true; rsym = CONVAL1G(rhs->aval); diff --git a/tools/flang2/flang2exe/expand.cpp b/tools/flang2/flang2exe/expand.cpp index 2865545524..031ebc2e0b 100644 --- a/tools/flang2/flang2exe/expand.cpp +++ b/tools/flang2/flang2exe/expand.cpp @@ -5,6 +5,21 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Bug fixes. + * Date of Modification: September 2018 + * Changes to support AMDGPU OpenMP offloading + * Date of modification : Dec 2020 + * Added support for quad precision + * Last modified: Feb 2020 + * Last Modified: Jun 2020 + * + */ + + /** \file * \brief Common expander routines */ @@ -360,6 +375,7 @@ expand(void) } dmpili(); } + #if DEBUG verify_function_ili(VERIFY_ILI_DEEP); if (DBGBIT(10, 16)) { @@ -448,6 +464,12 @@ eval_ilm(int ilmx) int first_op = 0; + /* Label which denotes blocks generated on the basis of user code */ + SPTR target_code_lab; + + /* Label which denotes block with return instruction */ + SPTR exit_code_lab; + opcx = ILM_OPC(ilmpx = (ILM *)(ilmb.ilm_base + ilmx)); if (flg.smp) { @@ -467,12 +489,29 @@ eval_ilm(int ilmx) { #ifdef OMP_OFFLOAD_LLVM if (flg.omptarget && gbl.ompaccel_intarget) { - if (opcx == IM_MP_BREDUCTION) { - ompaccel_notify_reduction(true); - exp_ompaccel_reduction(ilmpx, ilmx); - } else if (opcx == IM_MP_EREDUCTION) { - ompaccel_notify_reduction(false); - return; + if (!flg.x86_64_omptarget) { // AOCC + if (opcx == IM_MP_BREDUCTION) { + ompaccel_notify_reduction(true); + if (!flg.amdgcn_target) { + exp_ompaccel_reduction(ilmpx, ilmx); + } else { + // AOCC Begin + // When reduction and non-reduction kernels are next to each other + // curr_tinfo for reduction kernel is not set properly. Set it + // properly by identifying tinfo from function name. + OMPACCEL_TINFO *tinfo = ompaccel_tinfo_get(gbl.currsub); + OMPACCEL_TINFO *temp_tinfo = ompaccel_tinfo_current_get(); + if (tinfo) { + ompaccel_tinfo_current_set(tinfo); + exp_ompaccel_reduction(ilmpx, ilmx); + } + ompaccel_tinfo_current_set(temp_tinfo); + // AOCC End + } + } else if (opcx == IM_MP_EREDUCTION) { + ompaccel_notify_reduction(false); + return; + } } if (ompaccel_is_reduction_region()) @@ -484,7 +523,7 @@ eval_ilm(int ilmx) * For each operand which is a link to another ilm, recurse (evaluate it) * if not already evaluated */ - if (opcx == IM_DCMPLX || opcx == IM_CMPLX) { + if (opcx == IM_DCMPLX || opcx == IM_CMPLX || opcx == IM_QCMPLX) { for (tmp = 1, noprs = 1; noprs <= ilms[opcx].oprs; ++tmp, ++noprs) { if (IM_OPRFLAG(opcx, noprs) == OPR_LNK) { eval_ilm_argument1(noprs, ilmpx, ilmx); @@ -517,6 +556,7 @@ eval_ilm(int ilmx) ILM_EXPANDED_FOR(op1) = ilmx; } else if (ilix && ILM_EXPANDED_FOR(op1) != ilmx) { if (ILM_RESTYPE(op1) != ILM_ISCMPLX && + ILM_RESTYPE(op1) != ILM_ISQCMPLX && // AOCC ILM_RESTYPE(op1) != ILM_ISDCMPLX #ifdef LONG_DOUBLE_FLOAT128 && ILM_RESTYPE(op1) != ILM_ISFLOAT128CMPLX @@ -542,7 +582,8 @@ eval_ilm(int ilmx) ILM_EXPANDED_FOR(op1) = ilmx; } else if (ilix && ILM_EXPANDED_FOR(op1) != ilmx) { if (ILM_RESTYPE(op1) != ILM_ISCMPLX && - ILM_RESTYPE(op1) != ILM_ISDCMPLX + ILM_RESTYPE(op1) != ILM_ISDCMPLX && + ILM_RESTYPE(op1) != ILM_ISQCMPLX // AOCC #ifdef LONG_DOUBLE_FLOAT128 && ILM_RESTYPE(op1) != ILM_ISFLOAT128CMPLX #endif @@ -626,7 +667,15 @@ eval_ilm(int ilmx) /* Enables creation of libomptarget related structs in the main function, * but it is not recommended option. Default behaviour is to initialize and * create them in the global constructor. */ - if (XBIT(232, 0x10)) { + + // AOCC Begin + /* + * Restrict target lib initialization only to entry function + *TODO : Handle multi kernel applications. + * + */ + if (XBIT(232, 0x10) && gbl.rutype == RU_PROG) { + // AOCC End if (!ompaccel_is_tgt_registered() && !OMPACCRTG(gbl.currsub) && !gbl.outlined) { ilix = ll_make_tgt_register_lib2(); @@ -639,10 +688,40 @@ eval_ilm(int ilmx) * sharing model. It does extra work and allocates device on-chip memory. * */ if (XBIT(232, 0x40) && gbl.ompaccel_intarget) { - ilix = ompaccel_nvvm_get(threadIdX); - ilix = ll_make_kmpc_spmd_kernel_init(ilix); - iltb.callfg = 1; + ilix = ll_make_kmpc_target_init(ompaccel_tinfo_get(gbl.currsub)->mode); + + /* Generate new control flow for generic kernel */ + target_code_lab = getlab(); + exit_code_lab = getlab(); + ilix = ad4ili(IL_ICJMP, ilix, ad_icon(-1), CC_EQ, target_code_lab); + + /* Write block which contains OpenMP initialization call */ chk_block(ilix); + wr_block(); + cr_block(); + + /* Create and write block which contains return instruction. */ + RFCNTI(exit_code_lab); + exp_label(exit_code_lab); + expb.curilt = addilt(expb.curilt, ad1ili(IL_EXIT, gbl.currsub)); + BIH_XT(expb.curbih) = 1; + BIH_LAST(expb.curbih) = 1; + wr_block(); + + /* Create and set as active block where target pragma code + * will be located */ + RFCNTI(target_code_lab); + exp_label(target_code_lab); + + if (is_SPMD_mode(ompaccel_tinfo_get(gbl.currsub)->mode)) { + iltb.callfg = 1; + ilix = ll_make_kmpc_global_thread_num(); + chk_block(ilix); + } + + iltb.callfg = 1; + wr_block(); + cr_block(); } } #endif @@ -980,6 +1059,16 @@ replace_by_zero(ILM_OP opc, ILM *ilmp, int curilm) zero = getcon(num, DT_DCMPLX); newopc = IM_CCON; break; + // AOCC begin + case IM_CQLD: + num[0] = stb.quad0; + num[1] = stb.quad0; + num[2] = stb.quad0; + num[3] = stb.quad0; + zero = getcon(num, DT_QCMPLX); + newopc = IM_CCON; + break; + // AOCC end case IM_ILD: case IM_LLD: case IM_LFUNC: /* LFUNC, for PRESENT calls replaced by zero */ @@ -1010,6 +1099,13 @@ replace_by_zero(ILM_OP opc, ILM *ilmp, int curilm) newopc = IM_DCON; break; +// AOCC begin + case IM_QPLD: + zero = stb.quad0; + newopc = IM_QCON; + break; +// AoCC end + case IM_PLD: zero = stb.i0; newopc = IM_ICON; @@ -1155,7 +1251,7 @@ exp_load(ILM_OP opc, ILM *ilmp, int curilm) case IM_LLD: confl = false; dt = dt_nme(nme); - if (dt && DT_ISSCALAR(dt) && SCALAR_SIZE(dt, 4) != 4) + if (!flg.amdgcn_target && dt && DT_ISSCALAR(dt) && SCALAR_SIZE(dt, 4) != 4) confl = true; CHECK_NME(nme, confl); load = ad3ili(IL_LD, addr, nme, MSZ_WORD); @@ -1213,6 +1309,29 @@ exp_load(ILM_OP opc, ILM *ilmp, int curilm) CHECK_NME(nme, dt_nme(nme) != DT_DBLE); load = ad3ili(IL_LDDP, addr, nme, MSZ_F8); goto cand_load; + + // AOCC begin + // Load quad value + case IM_QPLD: + CHECK_NME(nme, DTY(dt_nme(nme)) != TY_128); + load = ad3ili(IL_LDQP, addr, nme, MSZ_F16); + goto cand_load; + case IM_CQLD: + if (XBIT(70, 0x40000000)) { + CHECK_NME(nme, dt_nme(nme) != DT_QCMPLX); + load = ad3ili(IL_LDQCMPLX, addr, nme, MSZ_F16); + goto cand_load; + } else { + imag = ad3ili(IL_AADD, addr, ad_aconi(size_of(DT_QUAD)), 0); + tmp = addnme(NT_MEM, SPTR_NULL, nme, 0); + ILM_RRESULT(curilm) = ad3ili(IL_LDQP, addr, tmp, MSZ_F16); + tmp = addnme(NT_MEM, NOSYM, nme, 8); + ILM_IRESULT(curilm) = ad3ili(IL_LDQP, imag, tmp, MSZ_F16); + ILM_RESTYPE(curilm) = ILM_ISQCMPLX; + return; + } + // AOCC end + case IM_QLD: /*m128*/ CHECK_NME(nme, DTY(dt_nme(nme)) != TY_128); load = ad3ili(IL_LDQ, addr, nme, MSZ_F16); @@ -1581,12 +1700,24 @@ exp_store(ILM_OP opc, ILM *ilmp, int curilm) CHECK_NME(nme, dt_nme(nme) != DT_DBLE); store = ad4ili(IL_STDP, (int)ILI_OF(op2), (int)ILI_OF(op1), nme, MSZ_F8); goto cand_store; + + // AOCC begin + // quad store + case IM_QPST: + if (NME_TYPE(nme) == NT_VAR && DTY(DTYPEG(NME_SYM(nme))) == TY_ARRAY) + nme = add_arrnme(NT_ARR, SPTR_NULL, nme, 0, ad_icon(0), NME_INLARR(nme)); + CHECK_NME(nme, dt_nme(nme) != DT_QUAD); + store = ad4ili(IL_STQP, (int)ILI_OF(op2), (int)ILI_OF(op1), nme, MSZ_F16); + goto cand_store; + // AOCC end + case IM_QST: /*m128*/ if (NME_TYPE(nme) == NT_VAR && DTY(DTYPEG(NME_SYM(nme))) == TY_ARRAY) nme = add_arrnme(NT_ARR, SPTR_NULL, nme, 0, ad_icon(0), NME_INLARR(nme)); CHECK_NME(nme, DTY(dt_nme(nme)) != TY_128); store = ad4ili(IL_STQ, (int)ILI_OF(op2), (int)ILI_OF(op1), nme, MSZ_F16); goto cand_store; + case IM_M256ST: /*m256*/ if (NME_TYPE(nme) == NT_VAR && DTY(DTYPEG(NME_SYM(nme))) == TY_ARRAY) nme = add_arrnme(NT_ARR, SPTR_NULL, nme, 0, ad_icon(0), NME_INLARR(nme)); @@ -1688,6 +1819,22 @@ exp_store(ILM_OP opc, ILM *ilmp, int curilm) } store = ad1ili(IL_FREEDP, expr); break; + + // AOCC begin + case ILIA_QP: + if (ILM_RESTYPE(op2) == ILM_ISQCMPLX) { + store = ad1ili(IL_FREEQP, (int)ILM_IRESULT(op2)); + chk_block(store); + ILM_IRESULT(curilm) = store; + ILM_RESTYPE(curilm) = ILM_ISQCMPLX; + if (EXPDBG(8, 16)) + fprintf(gbl.dbgfil, "store imag: ilm %d, block %d, ili %d\n", curilm, + expb.curbih, store); + } + store = ad1ili(IL_FREEQP, expr); + break; + // AOCC end + #ifdef ILIA_CS case ILIA_CS: store = ad1ili(IL_FREECS, expr); @@ -1695,6 +1842,11 @@ exp_store(ILM_OP opc, ILM *ilmp, int curilm) case ILIA_CD: store = ad1ili(IL_FREECD, expr); break; + // AOCC begin + case ILIA_CQ: + store = ad1ili(IL_FREECQ, expr); + break; + // AOCC end #endif case ILIA_AR: store = ad1ili(IL_FREEAR, expr); @@ -1807,6 +1959,41 @@ exp_store(ILM_OP opc, ILM *ilmp, int curilm) nme, MSZ_F8); ILM_RESTYPE(curilm) = ILM_ISDCMPLX; } + goto cmplx_shared; + // AOCC begin + case IM_CQST: + if (XBIT(70, 0x40000000)) { + if (NME_TYPE(nme) == NT_VAR && DTY(DTYPEG(NME_SYM(nme))) == TY_ARRAY) + nme = + add_arrnme(NT_ARR, SPTR_NULL, nme, 0, ad_icon(0), NME_INLARR(nme)); + CHECK_NME(nme, dt_nme(nme) != DT_QCMPLX); + store = ad4ili(IL_STQCMPLX, ILI_OF(op2), ILI_OF(op1), nme, MSZ_F16); + goto cand_store; + } else { + tmp = expb.curilt; + store = ad1ili(IL_FREEQP, (int)ILM_RRESULT(op2)); + chk_block(store); + if (tmp != expb.curilt) + ILT_CPLX(expb.curilt) = 1; + + nme = addnme(NT_MEM, NOSYM, NME_OF(op1), 8); + imag = ad3ili(IL_AADD, ILI_OF(op1), ad_aconi(size_of(DT_QUAD)), 0); + store = ad4ili(IL_STQP, ILM_IRESULT(op2), imag, nme, MSZ_F16); + tmp = expb.curilt; + chk_block(store); + if (tmp != expb.curilt) + ILT_CPLX(expb.curilt) = 1; + ILM_IRESULT(curilm) = store; + if (EXPDBG(8, 16)) + fprintf(gbl.dbgfil, "store imag: ilm %d, block %d, ili %d\n", curilm, + expb.curbih, store); + + nme = addnme(NT_MEM, SPTR_NULL, NME_OF(op1), 0); + store = ad4ili(IL_STQP, ad1ili(IL_CSEQP, ILM_RRESULT(op2)), ILI_OF(op1), + nme, MSZ_F16); + ILM_RESTYPE(curilm) = ILM_ISQCMPLX; + } + // AOCC end cmplx_shared: SET_ASSN(NME_OF(op1)); tmp = expb.curilt; @@ -1876,6 +2063,33 @@ exp_store(ILM_OP opc, ILM *ilmp, int curilm) expb.curbih, store); SET_ASSN(nme); break; + // AOCC begin + case IM_CQSTR: + /* ONLY store the real part of a complex */ + nme = NME_OF(op1); + nme = addnme(NT_MEM, SPTR_NULL, nme, 0); + addr = ILI_OF(op1); + store = ad4ili(IL_STQP, ILI_OF(op2), addr, nme, MSZ_F16); + ILM_RESULT(curilm) = store; + if (EXPDBG(8, 16)) + fprintf(gbl.dbgfil, "ONLY store real: ilm %d, block %d, ili %d\n", curilm, + expb.curbih, store); + SET_ASSN(nme); + break; + case IM_CQSTI: + /* ONLY store the imaginary part of a complex */ + nme = NME_OF(op1); + nme = addnme(NT_MEM, NOSYM, nme, 16); + addr = ILI_OF(op1); + addr = ad3ili(IL_AADD, addr, ad_aconi(size_of(DT_QUAD)), 0); + store = ad4ili(IL_STQP, ILI_OF(op2), addr, nme, MSZ_F16); + ILM_RESULT(curilm) = store; + if (EXPDBG(8, 16)) + fprintf(gbl.dbgfil, "ONLY store imag: ilm %d, block %d, ili %d\n", curilm, + expb.curbih, store); + SET_ASSN(nme); + break; + // AOCC end #ifdef LONG_DOUBLE_FLOAT128 case IM_CFLOAT128ST: { @@ -1983,6 +2197,12 @@ exp_mac(ILM_OP opc, ILM *ilmp, int curilm) ilmtpl = (ILMMAC *)&ilmtp[pattern]; newili.opc = (ILI_OP)ilmtpl->opc; /* get ili opcode */ // ??? + // initialize newili + newili.opnd[0] = 0; + newili.opnd[1] = 0; /* cause some FREE ili have two opnds (target dep)*/ + newili.opnd[2] = 0; + newili.opnd[3] = 0; + newili.opnd[4] = 0; /* Loop for each operand in this ili template */ for (i = 0, noprs = ilis[newili.opc].oprs; noprs > 0; ++i, --noprs) { @@ -2025,6 +2245,14 @@ exp_mac(ILM_OP opc, ILM *ilmp, int curilm) case ILMO_DP: newili.opnd[i] = DP(ilmopr->aux); break; + // AOCC begin + case ILMO_QP: + newili.opnd[i] = QP(ilmopr->aux); + break; + case ILMO_IQP: + newili.opnd[i] = IQP(ilmopr->aux); + break; + // AOCC end case ILMO_ISP: newili.opnd[i] = ISP(ilmopr->aux); break; @@ -2032,6 +2260,7 @@ exp_mac(ILM_OP opc, ILM *ilmp, int curilm) newili.opnd[i] = IDP(ilmopr->aux); break; +#define IQP(i) (i + 100) case ILMO_SZ: dtype = DT_INT; num.numi[0] = 0; @@ -2154,6 +2383,13 @@ exp_mac(ILM_OP opc, ILM *ilmp, int curilm) newili.opnd[i] = DP_RETVAL; #else interr("exp_mac: need DP_RETVAL", (int)ilmopr->type, ERR_Severe); +#endif + break; + case ILMO_QPRET: +#if defined(QP_RETVAL) + newili.opnd[i] = QP_RETVAL; +#else + interr("exp_mac: need QP_RETVAL", (int)ilmopr->type, ERR_Severe); #endif break; case ILMO_KRRET: @@ -2190,9 +2426,18 @@ exp_mac(ILM_OP opc, ILM *ilmp, int curilm) newili.opnd[i] = DP((ilmopr->aux >> 8) & 0xff); #else newili.opnd[i] = DP((ilmopr->aux) & 0xff); +#endif + break; + // AOCC begin + case ILMO_QPPOS: +#if defined(TARGET_WIN) + newili.opnd[i] = QP((ilmopr->aux >> 8) & 0xff); +#else + newili.opnd[i] = QP((ilmopr->aux) & 0xff); #endif break; #endif + // AOCC end default: interr("exp_mac: opnd not handled", opc /*(int)ilmopr->type*/, @@ -2234,12 +2479,14 @@ exp_mac(ILM_OP opc, ILM *ilmp, int curilm) case ILMO_RR: ILM_RRESULT(curilm) = index; - ILM_RESTYPE(curilm) = IM_DCPLX(opc) ? ILM_ISDCMPLX : ILM_ISCMPLX; + ILM_RESTYPE(curilm) = IM_DCPLX(opc) ? ILM_ISDCMPLX : ILM_RESTYPE(curilm) + = IM_QCPLX(opc) ? ILM_ISQCMPLX : ILM_ISCMPLX; break; case ILMO_IR: ILM_IRESULT(curilm) = index; - ILM_RESTYPE(curilm) = IM_DCPLX(opc) ? ILM_ISDCMPLX : ILM_ISCMPLX; + ILM_RESTYPE(curilm) = IM_DCPLX(opc) ? ILM_ISDCMPLX : ILM_RESTYPE(curilm) + = IM_QCPLX(opc) ? ILM_ISQCMPLX : ILM_ISCMPLX; break; default: @@ -2281,6 +2528,9 @@ efunc(const char *nm) case 'l': resdt = DT_INT8; break; + case 'q': + resdt = DT_QUAD; + break; case 'u': p++; if (*p == 'i') @@ -2331,14 +2581,36 @@ exp_ref(ILM_OP opc, ILM *ilmp, int curilm) int base; /* base ili of reference */ int basenm; /* names entry of base ili */ int dtype; + int istarget_data_ptr = 0; // AOCC switch (opc) { case IM_BASE: /* get the base symbol entry */ sym = ILM_SymOPND(ilmp, 1); - ili1 = create_ref(sym, &basenm, 0, 0, &ILM_CLEN(curilm), &ILM_MXLEN(curilm), - &ILM_RESTYPE(curilm)); + // AOCC Begin + // check whether a device ptr in returned + // when use_device_ptr() clause is used + if(!gbl.outlined && !targetDataTinfos.empty()) { + char name[16]; + OMPACCEL_TINFO * ctinfo1 = targetDataTinfos.back(); + for (int i = 0; i < ctinfo1->n_symbols; ++i) { + if (sym == ctinfo1->symbols[i].host_sym && + (ctinfo1->symbols[i].map_type & OMP_TGT_MAPTYPE_RETURN_PARAM)) { + // address is returened in base array + sprintf(name, "edata%d_base", dataregion-1); + SPTR arg_base_sptr = getsymbol(name); + basenm = add_arrnme(NT_ARR, arg_base_sptr, + addnme(NT_VAR, arg_base_sptr, 0, 0), 0, ad_icon(i), FALSE); + ili1 = ad_acon(arg_base_sptr, i * TARGET_PTRSIZE); + istarget_data_ptr = 1; // found the address on device + } + } + } + if(!istarget_data_ptr) + // AOCC End + ili1 = create_ref(sym, &basenm, 0, 0, &ILM_CLEN(curilm), + &ILM_MXLEN(curilm), &ILM_RESTYPE(curilm)); break; case IM_MEMBER: @@ -2533,7 +2805,7 @@ create_ref(SPTR sym, int *pnmex, int basenm, int baseilix, int *pclen, ilix = ad3ili(IL_AADD, ili1, ili2, 0); } #endif /* TARGET_WIN */ - else if (flg.smp && SCG(sym) == SC_CMBLK && IS_THREAD_TP(sym)) { + else if (SCG(sym) == SC_CMBLK && IS_THREAD_TP(sym)) { /* * BASE is of a member which is in a threadprivate common. * generate an indirection using the threadprivate common's diff --git a/tools/flang2/flang2exe/expatomics.cpp b/tools/flang2/flang2exe/expatomics.cpp index fc212cd30e..4c3e5523a5 100644 --- a/tools/flang2/flang2exe/expatomics.cpp +++ b/tools/flang2/flang2exe/expatomics.cpp @@ -4,6 +4,17 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + * Fixing bugs with complex reduction variables. + * Last modified: Aug 2020 + * + */ /** \file * \brief OpenMP/OpenACC/C++11 atomics expander routines; all targets including @@ -446,6 +457,10 @@ get_atomic_function(ILI_OP opcode) return mk_prototype("atomicexchf", "pure", DT_FLOAT, 2, DT_CPTR, DT_FLOAT); case IL_STDP: return mk_prototype("atomicexchd", "pure", DT_DBLE, 2, DT_CPTR, DT_DBLE); + // AOCC begin + case IL_STQP: + return mk_prototype("atomicexchq", "pure", DT_QUAD, 2, DT_CPTR, DT_QUAD); + // AOCC end case IL_STKR: return mk_prototype("atomicexchul", "pure", DT_INT8, 2, DT_CPTR, DT_INT8); case IL_SCMPLXADD: @@ -620,7 +635,7 @@ int create_atomic_capture_seq(int update_ili, int read_ili, int capture_first) { int function; - ILI_OP intarg_opcode, floatarg_opcode, doublearg_opcode, longarg_opcode; + ILI_OP intarg_opcode, floatarg_opcode, doublearg_opcode, longarg_opcode, quadarg_opcode; int ld_opcode; ILI_OP st_opcode, arg_opcode; int store_pt, store_nme, arg, garg; @@ -641,11 +656,13 @@ create_atomic_capture_seq(int update_ili, int read_ili, int capture_first) intarg_opcode = IL_DAIR; floatarg_opcode = IL_DASP; doublearg_opcode = IL_DADP; + quadarg_opcode = IL_DAQP; // AOCC longarg_opcode = IL_DAKR; #else intarg_opcode = IL_ARGIR; floatarg_opcode = IL_ARGSP; doublearg_opcode = IL_ARGDP; + quadarg_opcode = IL_ARGQP; // AOCC longarg_opcode = IL_ARGKR; #endif @@ -1711,6 +1728,17 @@ msz_from_atomic_pd(PD_KIND pd) static MSZ msz_from_atomic_dtype(DTYPE dtype) { + // AOCC Begin + switch(dtype) { + //TODO: Use MSZ_I16 or MSZ_32 + case DT_CMPLX: + return MSZ_I8; + case DT_DCMPLX: + return MSZ_I8; + default: + break; + } + // AOCC End switch(zsize_of(dtype)) { case 1: return MSZ_BYTE; @@ -2438,9 +2466,19 @@ _exp_mp_atomic_read(int stc, DTYPE dtype, int* opnd, int* nme) #endif size = zsize_of(dtype); - if (dtype == DT_CMPLX || + // AOCC Begin + if (flg.omptarget && (dtype == DT_CMPLX || dtype == DT_DCMPLX)) { + OPCODES const * ops; + ldst_msz(dtype, &ld, &st, &msz); + ops = get_ops(msz, 1); + opnd[TMP_SPTR_IDX] = 0; + ILI_OP opc = dtype == DT_CMPLX ? IL_LDSCMPLX : IL_LDDCMPLX; + result = ad3ili(IL_LDSCMPLX, opnd[LHS_IDX], nme[LHS_IDX], msz); + return result; + } else if (dtype == DT_CMPLX || + // AOCC End dtype == DT_DCMPLX - || (size !=1 && size != 2 && size != 4 && size != 8)) + || (size !=1 && size != 2 && size != 4 && size != 8)) { tmp_sptr = GetSPTRVal(opnd); if (tmp_sptr <= NOSYM) /* atomic capture may have set this already */ @@ -2858,20 +2896,22 @@ get_complex_update_operand(int* opnd, ILM* ilmp, int* nme, DTYPE dtype) rhs = opnd[RHS_IDX]; ldst_msz(dtype, &ld, &st, &msz); load = ad3ili(ld, lhs, nme[LHS_IDX], msz); - if (!find_ili(rhs, load)) { - ili_unvisit(); - if (find_ili(rhs, lhs)) { - ili_unvisit(); /* illlegel update statement */ - return 0; - } else { + ATOMIC_RMW_OP aop = (ATOMIC_RMW_OP) ILM_OPND(ilmp, 4); + if ( aop == AOP_UNDEF ) { // AOCC + if (!find_ili(rhs, load)) { ili_unvisit(); - if ((lop = load_op_match_lhs(lhs, rhs)) == 0) + if (find_ili(rhs, lhs)) { + ili_unvisit(); /* illlegel update statement */ return 0; - - load = lop; - } - } else - ili_unvisit(); + } else { + ili_unvisit(); + if ((lop = load_op_match_lhs(lhs, rhs)) == 0) + return 0; + load = lop; + } + } else + ili_unvisit(); + } stc = atomic_encode(msz, SS_PROCESS, AORG_OPENMP); expected_val = _exp_mp_atomic_read(stc, dtype, opnd, nme); @@ -2918,9 +2958,9 @@ _exp_mp_atomic_update(DTYPE dtype, int* opnd, int* nme) ASSNP(desired_sptr, 1); chk_block(result); - if (dtype == DT_CMPLX || + if (!flg.omptarget && (dtype == DT_CMPLX || //AOCC dtype == DT_DCMPLX - || (size != 1 && size != 2 && size !=4 && size !=8)) + || (size != 1 && size != 2 && size !=4 && size !=8))) { size_ili = ad_icon(size); ADDRTKNP(expected_sptr, 1); diff --git a/tools/flang2/flang2exe/expsmp.cpp b/tools/flang2/flang2exe/expsmp.cpp index 2468879462..8cc3d1b50f 100644 --- a/tools/flang2/flang2exe/expsmp.cpp +++ b/tools/flang2/flang2exe/expsmp.cpp @@ -4,6 +4,20 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading. + * Last modified: Aug 2020 + * + * Support for x86-64 OpenMP offloading + * Last modified: May 2020 + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ /** \file * \brief SMP expander routines @@ -46,6 +60,15 @@ inline SPTR GetPARUPLEVEL(SPTR sptr) { #define PARUPLEVELG GetPARUPLEVEL #endif +// AOCC Begin +#include +#include +#include +static bool in_parallel = false; +std::list targetVector; +int HasRequiresUnifiedSharedMemory = false; +// AOCC End + static int incrOutlinedCnt(void); static int decrOutlinedCnt(void); static int getOutlinedTemp(char *, int); @@ -577,6 +600,7 @@ jsrAddArg(int arglist, ILI_OP opc, int argili) case IL_ARGKR: case IL_ARGSP: case IL_ARGDP: + case IL_ARGQP: // AOCC ili = ad2ili(opc, argili, arglist); return ili; default: @@ -917,10 +941,48 @@ genIntLoad(SPTR sym) return ili; } +// AOCC begin +int +_make_mp_push_num_teams(int nteams, int n_limit) +{ + int null_arg; + INT tmp[2]; + tmp[0] = 0; + tmp[1] = 0; + int con = getcon(tmp, DT_INT); + null_arg = ad1ili(IL_ACON, con); + + char *fn_name = "__kmpc_push_num_teams"; + mk_prototype(fn_name, NULL, DT_NONE, 4, DT_CPTR, DT_INT, + DT_INT, DT_INT); + + int argili = jsrAddArg(0, IL_ARGIR, n_limit); + argili = jsrAddArg(argili, IL_ARGIR, nteams); + argili = jsrAddArg(argili, IL_ARGIR, ll_get_gtid_val_ili()); + argili = jsrAddArg(argili, IL_ARGAR, null_arg); + + int ili = makeCall(fn_name, IL_QJSR, argili); + return ili; +} +// AOCC end + void exp_smp(ILM_OP opc, ILM *ilmp, int curilm) { #ifdef IM_BPAR + // AOCC begin +#if defined(OMP_OFFLOAD_LLVM) + if (flg.x86_64_omptarget && + (opc == IM_BPARA || opc == IM_MPLOOP || opc == IM_PDO) && + gbl.ompaccel_intarget) { + if (!gbl.outlined && gbl.ompoutlinedfunc) + ompaccel_x86_add_parallel_func(gbl.ompoutlinedfunc); + if (gbl.outlined) + ompaccel_x86_add_parallel_func(gbl.currsub); + } +#endif + // AOCC end + int argili = 0; int ili, tili, ili_arg; int lastilt; @@ -1011,6 +1073,7 @@ exp_smp(ILM_OP opc, ILM *ilmp, int curilm) break; } #endif + in_parallel = true; // AOCC if (flg.opt != 0) { wr_block(); cr_block(); @@ -1184,10 +1247,59 @@ exp_smp(ILM_OP opc, ILM *ilmp, int curilm) ccff_info(MSGOPENMP, "OMP001", gbl.findex, gbl.lineno, "Parallel region activated", NULL); break; + // AOCC Begin + case IM_MP_TARGETDECLARE: +#ifdef OMP_OFFLOAD_LLVM + if(flg.omptarget && !(IS_OMP_DEVICE_CG)) { + ompaccel_set_target_declare(); + } +#endif + break; + case IM_MP_DEFAULTMAP: { +#ifdef OMP_OFFLOAD_LLVM + if(flg.omptarget && !(IS_OMP_DEVICE_CG)) { + int maptype = ILM_OPND(ilmp, 1); + ompaccel_set_default_map(maptype); + } +#endif + break; + } + case IM_MP_NUMTEAMS: { +#ifdef OMP_OFFLOAD_LLVM + if(flg.omptarget && !(IS_OMP_DEVICE_CG)) { + ompaccel_set_numteams_sptr(ILM_SymOPND(ilmp, 1)); + } +#endif + break; + } + case IM_MP_NUMTHREADS: { +#ifdef OMP_OFFLOAD_LLVM + if(flg.omptarget && !(IS_OMP_DEVICE_CG)) { + ompaccel_set_numthreads_sptr(ILM_SymOPND(ilmp, 1)); + } +#endif + break; + } + // AOCC End case IM_BTEAMS: case IM_BTEAMSN: #ifdef OMP_OFFLOAD_LLVM if(flg.omptarget && gbl.ompaccel_intarget) { + // AOCC begin + if (flg.x86_64_omptarget && opc == IM_BTEAMSN) { + int iliarg, nteams, n_limit; + nteams = ILI_OF(ILM_OPND(ilmp, 1)); + n_limit = ILI_OF(ILM_OPND(ilmp, 2)); + // For now serializing, ili when gbl.outlined is zero (illegal). + if (!nteams || !n_limit) + nteams = n_limit = ad_icon(1); + + ili = _make_mp_push_num_teams(nteams, n_limit); + + iltb.callfg = 1; + chk_block(ili); + } + // AOCC end exp_ompaccel_bteams(ilmp, curilm, outlinedCnt, uplevel_sptr, scopeSptr, incrOutlinedCnt); break; } @@ -1269,6 +1381,11 @@ exp_smp(ILM_OP opc, ILM *ilmp, int curilm) "Target region activated", NULL); break; case IM_ETARGET: + // AOCC Begin + if (in_parallel) { + targetVector.push_back(curilm); + } + // AOCC End if (outlinedCnt == 1) { ilm_outlined_pad_ilm(curilm); } @@ -1290,6 +1407,16 @@ exp_smp(ILM_OP opc, ILM *ilmp, int curilm) // In Flang, We outline the region once, and offload it in the device // We don't generate outlined function for the host. so we don't have host fallback. exp_ompaccel_etarget(ilmp, curilm, targetfunc_sptr, outlinedCnt, (SPTR) uplevel_sptr, decrOutlinedCnt); + // AOCC Begin + std::list::iterator it = std::find (targetVector.begin(), + targetVector.end(), curilm); + if (it != targetVector.end()) { + ili = ll_make_kmpc_barrier(); + iltb.callfg = 1; + chk_block(ili); + targetVector.erase(it); + } + // AOCC End break; } #endif @@ -1313,9 +1440,17 @@ exp_smp(ILM_OP opc, ILM *ilmp, int curilm) #ifdef OMP_OFFLOAD_LLVM if (flg.omptarget && gbl.ompaccel_intarget) { exp_ompaccel_epar(ilmp, curilm, outlinedCnt, decrOutlinedCnt); + // AOCC begin + if (flg.x86_64_omptarget && gbl.outlined && !XBIT(232, 0x1)) { + ili = ll_make_kmpc_barrier(); + iltb.callfg = 1; + chk_block(ili); + } + // AOCC end break; } #endif + in_parallel = false; // AOCC if (outlinedCnt == 1) { ilm_outlined_pad_ilm(curilm); } @@ -1341,7 +1476,7 @@ exp_smp(ILM_OP opc, ILM *ilmp, int curilm) break; case IM_ETEAMS: #ifdef OMP_OFFLOAD_LLVM - if (flg.omptarget) { + if (flg.omptarget && gbl.ompaccel_intarget) { exp_ompaccel_eteams(ilmp, curilm, outlinedCnt, decrOutlinedCnt); break; } @@ -1378,9 +1513,17 @@ exp_smp(ILM_OP opc, ILM *ilmp, int curilm) BIH_QJSR(expb.curbih) = true; BIH_NOMERGE(expb.curbih) = true; bihb.csfg = BIH_CS(expb.curbih) = true; - ili = addMpBcsNest(); - iltb.callfg = 1; - chk_block(ili); + // AOCC Begin +#ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + } else +#endif + { + // AOCC End + ili = addMpBcsNest(); + iltb.callfg = 1; + chk_block(ili); + } ccff_info(MSGOPENMP, "OMP003", gbl.findex, gbl.lineno, "Begin critical section", NULL); break; @@ -1392,9 +1535,19 @@ exp_smp(ILM_OP opc, ILM *ilmp, int curilm) BIH_QJSR(expb.curbih) = true; BIH_NOMERGE(expb.curbih) = true; BIH_CS(expb.curbih) = true; - ili = addMpEcsNest(); - iltb.callfg = 1; - chk_block(ili); + // AOCC Begin + // ili = addMpEcsNest(); +#ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + } else +#endif + { + ili = addMpEcsNest(); + iltb.callfg = 1; + chk_block(ili); + } + + // AOCC End wr_block(); cr_block(); if (critCnt <= 0) @@ -1516,10 +1669,17 @@ exp_smp(ILM_OP opc, ILM *ilmp, int curilm) if (outlinedCnt >= 1) break; #ifdef OMP_OFFLOAD_LLVM - if (flg.omptarget && gbl.ompaccel_intarget) { - exp_ompaccel_mploop(ilmp, curilm); - break; - } + // AOCC begin + if (flg.x86_64_omptarget && ompaccel_x86_is_parallel_func(gbl.currsub)) { + if (!XBIT(232, 0x1)) + ompaccel_x86_add_tid_params(gbl.currsub); + } + // AOCC end + + if (flg.omptarget && gbl.ompaccel_intarget) { + exp_ompaccel_mploop(ilmp, curilm); + break; + } #endif loop_args.sched = (kmpc_sched_e)ILM_OPND(ilmp, 7); sched = mp_sched_to_kmpc_sched(loop_args.sched); @@ -2628,6 +2788,14 @@ exp_smp(ILM_OP opc, ILM *ilmp, int curilm) chk_block(ili); break; + case IM_REQUIRES: { + int requireClause = ILM_OPND(ilmp,1); + if (requireClause == OMP_REQ_UNIFIED_SHARED_MEMORY) { + HasRequiresUnifiedSharedMemory = true; + } + break; + } + case IM_BMPPG: if (ll_ilm_is_rewriting()) break; @@ -2663,7 +2831,31 @@ exp_smp(ILM_OP opc, ILM *ilmp, int curilm) resetMppBih(RESTORE_MPPBIH, IS_PREVMPPG); break; + + case IM_TARGETUPDATE: + // AOCC Begin case IM_BTARGETUPDATE: + if (ll_ilm_is_rewriting()) + break; + // AOCC End +#ifdef OMP_OFFLOAD_AMD + dotarget = ILI_OF(ILM_OPND(ilmp, 1)); + beg_label = getlab(); + end_label = getlab(); + + dotarget = ad3ili(IL_ICJMPZ, dotarget, CC_EQ, end_label); + RFCNTI(end_label); + chk_block(dotarget); + + wr_block(); + cr_block(); + exp_label(beg_label); + if (flg.amdgcn_target || flg.x86_64_omptarget) + exp_ompaccel_target_update(ilmp, curilm, opc); + exp_label(end_label); +#endif + // AOCC End + break; case IM_BTARGETDATA: case IM_TARGETENTERDATA: case IM_TARGETEXITDATA: @@ -2682,7 +2874,7 @@ exp_smp(ILM_OP opc, ILM *ilmp, int curilm) cr_block(); exp_label(beg_label); - if(!IS_OMP_DEVICE_CG) + if(flg.amdgcn_target || !IS_OMP_DEVICE_CG) exp_ompaccel_targetdata(ilmp, curilm, opc); exp_label(end_label); @@ -2746,8 +2938,22 @@ exp_smp(ILM_OP opc, ILM *ilmp, int curilm) exp_mp_atomic_write(ilmp); break; case IM_MP_ATOMICUPDATE: - if (ll_ilm_is_rewriting()) + if (ll_ilm_is_rewriting()) { + // AOCC Begin + // For non teams reduction flang1 will generate only atomic updates. Here + // we capture such symbols and marks the tofrom. This will not have side + // effects as even teams reduction variable should be tofrom. +#ifdef OMP_OFFLOAD_LLVM + ILM *ilm = (ILM *)(ilmb.ilm_base+ILM_OPND(ilmp, 1)); + if (flg.omptarget && ILM_OPC(ilm) == IM_BASE) { + SPTR sym = ILM_SymOPND(ilm, 1); + ompaccel_update_devsym_maptype(sym, OMP_TGT_MAPTYPE_TO | + OMP_TGT_MAPTYPE_FROM); + } +#endif + // AOCC End break; + } exp_mp_atomic_update(ilmp); break; case IM_MP_ATOMICCAPTURE: @@ -2804,14 +3010,21 @@ exp_smp(ILM_OP opc, ILM *ilmp, int curilm) exp_ompaccel_looptripcount(ilmp, curilm); break; case IM_MP_MAP: - if(flg.omptarget && !(IS_OMP_DEVICE_CG || gbl.ompaccel_intarget)) + case IM_MP_MAP_MEM: // AOCC + // AOCC : Modification + // Removed gbl.ompaccel_intarget from condition or else it will disable + // replacer, leading to usage of host symbols in device + if(flg.omptarget && !(IS_OMP_DEVICE_CG)) exp_ompaccel_map(ilmp, curilm, outlinedCnt); break; case IM_MP_EMAP: - if(flg.omptarget && !(IS_OMP_DEVICE_CG || gbl.ompaccel_intarget)) { - exp_ompaccel_emap(ilmp, curilm); - } - break; + // AOCC : Modification + // Removed gbl.ompaccel_intarget from condition or else it will disable + // replacer, leading to usage of host symbols in device + if(flg.omptarget && !(IS_OMP_DEVICE_CG)) { + exp_ompaccel_emap(ilmp, curilm); + } + break; case IM_MP_TARGETMODE: if(flg.omptarget) { ompaccel_tinfo_set_mode_next_target((OMP_TARGET_MODE)ILM_OPND(ilmp, 1)); @@ -2820,6 +3033,20 @@ exp_smp(ILM_OP opc, ILM *ilmp, int curilm) target_ili_num_threads = ILI_OF(ILM_OPND(ilmp, 4)); } break; + case IM_MP_USE_DEVICE_PTR: + if(flg.omptarget && !(IS_OMP_DEVICE_CG)) + exp_ompaccel_use_device_ptr(ilmp, curilm, outlinedCnt); + break; + // AOCC Begin + case IM_MP_IS_DEVICE_PTR: + if(flg.omptarget && !(IS_OMP_DEVICE_CG)) + exp_ompaccel_is_device_ptr(ilmp, curilm); + break; + case IM_MP_USE_DEVICE_ADDR: + if(flg.omptarget && !(IS_OMP_DEVICE_CG)) + exp_ompaccel_use_device_addr(ilmp, curilm, outlinedCnt); + break; + // AOCC End #endif /* end #ifdef OMP_OFFLOAD_LLVM */ default: interr("exp_smp: unsupported opc", opc, ERR_Severe); @@ -2899,6 +3126,7 @@ static int addMpBcsNest(void) { int ili; + mk_prototype("_mp_bcs_nest_red", NULL, DT_NONE,0); ili = makeCall("_mp_bcs_nest_red", IL_JSR, 0); return ili; } @@ -2907,6 +3135,7 @@ static int addMpEcsNest(void) { int ili; + mk_prototype("_mp_ecs_nest_red", NULL, DT_NONE,0); ili = makeCall("_mp_ecs_nest_red", IL_JSR, 0); return ili; } diff --git a/tools/flang2/flang2exe/exputil.cpp b/tools/flang2/flang2exe/exputil.cpp index 7c7d67f55f..f4037c8fff 100644 --- a/tools/flang2/flang2exe/exputil.cpp +++ b/tools/flang2/flang2exe/exputil.cpp @@ -4,6 +4,14 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ /** \file * \brief Expander utility routines @@ -644,6 +652,12 @@ check_ilm(int ilmx, int ilix) case IL_FREEDP: ilix = ad4ili(IL_STDP, cse, base, nme, MSZ_F8); break; + // AOCC begin + case IL_STQP: + case IL_FREEQP: + ilix = ad4ili(IL_STQP, cse, base, nme, MSZ_F16); + break; + // AOCC end case IL_STSCMPLX: case IL_FREECS: ilix = ad4ili(IL_STSCMPLX, cse, base, nme, MSZ_F8); @@ -652,6 +666,12 @@ check_ilm(int ilmx, int ilix) case IL_FREECD: ilix = ad4ili(IL_STDCMPLX, cse, base, nme, MSZ_F16); break; + // AOCC begin + case IL_STQCMPLX: + case IL_FREECQ: + ilix = ad4ili(IL_STQCMPLX, cse, base, nme, MSZ_F32); + break; + // AOCC end #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128ST: case IL_FLOAT128FREE: @@ -1269,6 +1289,11 @@ add_reg_arg_ili(int arglist, int argili, int nmex, DTYPE dtype) if (DTY(dtype) == TY_DBLE) { opc = IL_DADP; avail_freg++; + // AOCC begin + } else if (DTY(dtype) == TY_QUAD) { + opc = IL_DAQP; + avail_freg++; + // AOCC end } else { opc = IL_DASP; } diff --git a/tools/flang2/flang2exe/fenddf.cpp b/tools/flang2/flang2exe/fenddf.cpp index 378aefc7b7..768dd995e9 100644 --- a/tools/flang2/flang2exe/fenddf.cpp +++ b/tools/flang2/flang2exe/fenddf.cpp @@ -5,6 +5,15 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ + /** \file * \brief Data definitions for FTN front-end data structures */ @@ -49,24 +58,24 @@ OP_CMP OP_AIF OP_LD OP_ST OP_FUNC OP_CON /** ILM opcodes for basic types: */ short ilm_opcode[NOPC][2][NTYPE + 1] = { {/* NEG */ {0, IM_INEG, 0, 0, IM_INEG, IM_INEG, IM_INEG, IM_KNEG, IM_RNEG, IM_RNEG, - IM_DNEG, 0, IM_CNEG, IM_CNEG, IM_CDNEG, IM_INEG, IM_INEG, IM_INEG, - IM_KNEG, 0, 0}, + IM_DNEG, IM_QNEG, IM_CNEG, IM_CNEG, IM_CDNEG, IM_INEG, IM_INEG, IM_INEG, + IM_KNEG, IM_CQNEG, 0}, /* VNEG */ {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}}, {/* ADD */ {0, IM_IADD, 0, 0, IM_IADD, IM_IADD, IM_IADD, IM_KADD, IM_RADD, IM_RADD, - IM_DADD, 0, IM_CADD, IM_CADD, IM_CDADD, IM_IADD, IM_IADD, IM_IADD, - IM_KADD, 0, 0}, + IM_DADD, IM_QADD, IM_CADD, IM_CADD, IM_CDADD, IM_IADD, IM_IADD, IM_IADD, + IM_KADD, IM_CQADD, 0}, /* VADD */ {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}}, {/* SUB */ {0, IM_ISUB, 0, 0, IM_ISUB, IM_ISUB, IM_ISUB, IM_KSUB, IM_RSUB, IM_RSUB, - IM_DSUB, 0, IM_CSUB, IM_CSUB, IM_CDSUB, IM_ISUB, IM_ISUB, IM_ISUB, - IM_KSUB, 0, 0}, + IM_DSUB, IM_QSUB, IM_CSUB, IM_CSUB, IM_CDSUB, IM_ISUB, IM_ISUB, IM_ISUB, + IM_KSUB, IM_CQSUB, 0}, /* VSUB */ {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}}, {/* MUL */ {0, IM_IMUL, 0, 0, IM_IMUL, IM_IMUL, IM_IMUL, IM_KMUL, IM_RMUL, IM_RMUL, - IM_DMUL, 0, IM_CMUL, IM_CMUL, IM_CDMUL, IM_IMUL, IM_IMUL, IM_IMUL, - IM_KMUL, 0, 0}, + IM_DMUL, IM_QMUL, IM_CMUL, IM_CMUL, IM_CDMUL, IM_IMUL, IM_IMUL, IM_IMUL, + IM_KMUL, IM_CQMUL, 0}, /* VMUL */ {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}}, {/* DIV */ {0, IM_IDIV, 0, 0, IM_IDIV, IM_IDIV, IM_IDIV, IM_KDIV, IM_RDIV, IM_RDIV, - IM_DDIV, 0, IM_CDIV, IM_CDIV, IM_CDDIV, IM_IDIV, IM_IDIV, IM_IDIV, - IM_KDIV, 0, 0}, + IM_DDIV, IM_QDIV, IM_CDIV, IM_CDIV, IM_CDDIV, IM_IDIV, IM_IDIV, IM_IDIV, + IM_KDIV, IM_CQDIV, 0}, /* VDIV */ {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}}, {/* xTOI */ {0, IM_ITOI, 0, 0, IM_ITOI, IM_ITOI, IM_ITOI, IM_KTOI, IM_RTOI, IM_RTOI, IM_DTOI, 0, IM_CTOI, IM_CTOI, IM_CDTOI, IM_ITOI, IM_ITOI, IM_ITOI, @@ -77,21 +86,21 @@ short ilm_opcode[NOPC][2][NTYPE + 1] = { IM_KTOK, 0, 0}, /* VxTOI */ {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}}, {/* xTOx */ {0, IM_ITOI, 0, 0, IM_ITOI, IM_ITOI, IM_ITOI, IM_KTOK, IM_RTOR, IM_RTOR, - IM_DTOD, 0, IM_CTOC, IM_CTOC, IM_CDTOCD, IM_ITOI, IM_ITOI, IM_ITOI, - IM_KTOK, 0, 0}, + IM_DTOD, IM_QTOQ, IM_CTOC, IM_CTOC, IM_CDTOCD, IM_ITOI, IM_ITOI, IM_ITOI, + IM_KTOK, IM_CQTOCQ, 0}, /* VxTOx */ {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}}, {/* CMP */ {0, IM_UICMP, IM_UDICMP, 0, IM_ICMP, IM_ICMP, IM_ICMP, IM_KCMP, IM_RCMP, - IM_RCMP, IM_DCMP, 0, IM_CCMP, IM_CCMP, IM_CDCMP, IM_ICMP, IM_ICMP, + IM_RCMP, IM_DCMP, IM_CQCMP, IM_CCMP, IM_CCMP, IM_CDCMP, IM_ICMP, IM_ICMP, IM_ICMP, IM_KCMP, 0, IM_SCMP, IM_NSCMP}, /* VCMP */ {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}}, {/* AIF */ {0, IM_IAIF, 0, 0, IM_IAIF, IM_IAIF, IM_IAIF, IM_KAIF, IM_RAIF, IM_RAIF, - IM_DAIF, 0, 0, 0, IM_IAIF, IM_IAIF, IM_IAIF, IM_KAIF, 0, 0}, + IM_DAIF, IM_QAIF, 0, 0, IM_IAIF, IM_IAIF, IM_IAIF, IM_KAIF, 0, 0}, /* VAIF non-existent */ {0}}, - {/* LD */ {0, 0, 0, 0, IM_CHLD, IM_SILD, IM_ILD, IM_KLD, IM_RLD, IM_RLD, IM_DLD, 0, - IM_CLD, IM_CLD, IM_CDLD, IM_CHLD, IM_SLLD, IM_LLD, IM_KLLD, 0, 0}, + {/* LD */ {0, 0, 0, 0, IM_CHLD, IM_SILD, IM_ILD, IM_KLD, IM_RLD, IM_RLD, IM_DLD, IM_QPLD, + IM_CLD, IM_CLD, IM_CDLD, IM_CHLD, IM_SLLD, IM_LLD, IM_KLLD, IM_CQLD}, /* VLD */ {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}}, {/* ST */ {0, IM_IST, IM_IST, 0, IM_CHST, IM_SIST, IM_IST, IM_KST, IM_RST, IM_RST, - IM_DST, 0, IM_CST, IM_CST, IM_CDST, IM_CHST, IM_SLST, IM_LST, IM_KLST, 0, + IM_DST, IM_QPST, IM_CST, IM_CST, IM_CDST, IM_CHST, IM_SLST, IM_LST, IM_KLST, IM_CQST, IM_SST, IM_NSST}, /* VST */ {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}}, {/* FUNC */ {0, IM_IFUNC, 0, 0, IM_IFUNC, IM_IFUNC, IM_IFUNC, IM_KFUNC, @@ -99,8 +108,8 @@ short ilm_opcode[NOPC][2][NTYPE + 1] = { IM_LFUNC, IM_KFUNC, 0, 0}, /* VFUNC non-existent */ {0}}, {/* CON */ {0, IM_UCON, IM_UDCON, 0, IM_ICON, IM_ICON, IM_ICON, IM_KCON, - IM_RCON, IM_RCON, IM_DCON, 0, IM_CCON, IM_CCON, IM_CDCON, IM_LCON, IM_LCON, - IM_LCON, IM_KCON, 0, IM_BASE}, + IM_RCON, IM_RCON, IM_DCON, IM_QCON, IM_CCON, IM_CCON, IM_CDCON, IM_LCON, IM_LCON, + IM_LCON, IM_KCON, IM_CQCON, IM_BASE}, /* VCON non-existent */ {0}}}; /** We only allow casting to and from TY_WORD and TY_DWORD. Therefore, you diff --git a/tools/flang2/flang2exe/gbldefs.h b/tools/flang2/flang2exe/gbldefs.h index fba12f1111..3f379b19db 100644 --- a/tools/flang2/flang2exe/gbldefs.h +++ b/tools/flang2/flang2exe/gbldefs.h @@ -4,6 +4,12 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified: May 2020 + */ /** \file @@ -62,6 +68,11 @@ #define MAX_FUNCTION_NAME_LEN (1024) #define MAX_VARIABLE_NAME_LEN (1024) +// AOCC begin +/* maximum number of array subscripts */ +#define MAXSUBS 15 +// AOCC end + typedef int8_t INT8; typedef int16_t INT16; typedef uint16_t UINT16; diff --git a/tools/flang2/flang2exe/ili.h b/tools/flang2/flang2exe/ili.h index 628e6a5113..d4e1379e95 100644 --- a/tools/flang2/flang2exe/ili.h +++ b/tools/flang2/flang2exe/ili.h @@ -5,6 +5,15 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ + #ifndef ILI_H_ #define ILI_H_ @@ -138,34 +147,35 @@ typedef enum ILIO_KIND { ILIO_HP = 8, ILIO_SP = 9, ILIO_DP = 10, - ILIO_CS = 11, - ILIO_CD = 12, - ILIO_AR = 13, - ILIO_KR = 14, - ILIO_XMM = 15, /* xmm register number */ - ILIO_X87 = 16, - ILIO_DOUBLEDOUBLE = 17, - ILIO_FLOAT128 = 18, - ILIO_LNK = 19, - ILIO_IRLNK = 20, - ILIO_HPLNK = 21, - ILIO_SPLNK = 22, - ILIO_DPLNK = 23, - ILIO_ARLNK = 24, - ILIO_KRLNK = 25, - ILIO_QPLNK = 26, - ILIO_CSLNK = 27, - ILIO_CDLNK = 28, - ILIO_CQLNK = 29, - ILIO_128LNK = 30, - ILIO_256LNK = 31, - ILIO_512LNK = 32, - ILIO_X87LNK = 33, - ILIO_DOUBLEDOUBLELNK = 34, - ILIO_FLOAT128LNK = 35 + ILIO_QP = 11, // AOCC + ILIO_CS = 12, + ILIO_CD = 13, + ILIO_AR = 14, + ILIO_KR = 15, + ILIO_XMM = 16, /* xmm register number */ + ILIO_X87 = 17, + ILIO_DOUBLEDOUBLE = 18, + ILIO_FLOAT128 = 19, + ILIO_LNK = 20, + ILIO_IRLNK = 21, + ILIO_HPLNK = 22, + ILIO_SPLNK = 23, + ILIO_DPLNK = 24, + ILIO_ARLNK = 25, + ILIO_KRLNK = 26, + ILIO_QPLNK = 27, + ILIO_CSLNK = 28, + ILIO_CDLNK = 29, + ILIO_CQLNK = 30, + ILIO_128LNK = 31, + ILIO_256LNK = 32, + ILIO_512LNK = 33, + ILIO_X87LNK = 34, + ILIO_DOUBLEDOUBLELNK = 35, + ILIO_FLOAT128LNK = 36 } ILIO_KIND; -#define ILIO_MAX 35 +#define ILIO_MAX 36 #define ILIO_ISLINK(n) ((n) >= ILIO_IRLNK) /* Reflexive defines */ @@ -178,6 +188,7 @@ typedef enum ILIO_KIND { #define ILIO_HP ILIO_HP #define ILIO_SP ILIO_SP #define ILIO_DP ILIO_DP +#define ILIO_QP ILIO_QP #define ILIO_CS ILIO_CS #define ILIO_CD ILIO_CD #define ILIO_AR ILIO_AR @@ -264,6 +275,7 @@ typedef enum ILIA_RESULT { #define ILIA_ISIR(t) ((t) == ILIA_IR) #define ILIA_ISSP(t) ((t) == ILIA_SP) #define ILIA_ISDP(t) ((t) == ILIA_DP) +#define ILIA_ISQP(t) ((t) == ILIA_QP) // AOCC #define ILIA_ISAR(t) ((t) == ILIA_AR) #define ILIA_ISKR(t) ((t) == ILIA_KR) #define ILIA_ISCS(t) ((t) == ILIA_CS) @@ -414,7 +426,7 @@ inline MSZ MSZ_ILI_OPND(int i, int opn) { 0 /* 0x10 */, 0 /* 0x11 */, 0 /* 0x12 */, 8 /* PTR */, \ 0 /* 0x14 */, 0 /* 0x15 */, 16 /* F10 */, 16 /* F16 */, \ 0 /* 0x18 */, 0 /* 0x19 */, 32 /* F32 */, 16 /* F8x2 */, \ - 0 /* 0x1c */, 0 /* 0x1d */, 0 /* 0x1e */, 0 /* 0x1f */ \ + 0 /* 0x1c */, 0 /* 0x1d */, 16 /* QWORD */, 16 /* QLWORD */ \ } /* Reflexive defines for values that are inspected by preprocessor directives */ @@ -488,7 +500,7 @@ extern bool share_qjsr_ili; /* defd in iliutil.c */ /* Get MSZ of an IL_LD or IL_ATOMICLDx instruction */ #define ILI_MSZ_OF_LD(ilix) (ILI_MSZ_FROM_STC(ILI_OPND((ilix), 3))) -/* Get MSZ of an IL_ST, IL_STHP, IL_STSP, IL_STDP, or IL_ATOMICSTx instruction */ +/* Get MSZ of an IL_ST, IL_STHP, IL_STSP, IL_STDP, IL_STQP or IL_ATOMICSTx instruction */ #define ILI_MSZ_OF_ST(ilix) (ILI_MSZ_FROM_STC(ILI_OPND((ilix), 4))) #include "iliutil.h" diff --git a/tools/flang2/flang2exe/iliutil.cpp b/tools/flang2/flang2exe/iliutil.cpp index fd059ff321..429b531950 100644 --- a/tools/flang2/flang2exe/iliutil.cpp +++ b/tools/flang2/flang2exe/iliutil.cpp @@ -1,10 +1,69 @@ /* + * * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. * See https://llvm.org/LICENSE.txt for license information. * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Use LLVM math intrinsics instead of using flang runtime math library + * Date of Modification: February 2018 + * + * Lowering floor intrinsic to llvm calls. + * Date of Modification: July 2018 + * + * Support for TRAILZ intrinsic. + * Month of Modification: July 2019 + * + * Lowering to amdgcn sin and cos + * Date of Modification: November 2019 + * + * Lowring llvm.exp.f64 to llvm.exp.f32 for AMDGPU + * Date of modification 15th November 2019 + * + * Lowring llvm.log.f64 to llvm.log.f32 for AMDGPU + * Lowring llvm.log10.f64 to llvm.log10.f32 for AMDGPU + * Lowring llvm.pow.f64 to llvm.pow.f32 for AMDGPU + * Date of modification 21st January 2020 + * + * Using sqrt from amdgcn math lib + * Date of modification 31st January 2020 + * + * Added TY_BINT in mem_size function + * Date of modification 12th February 2020 + * + * Added support for quad precision + * Last modified: Feb 2020 + * + * Real128 support for math intrinsics + * Last modified: Feb 2020 + * + * Added code to support SHIFTA intrinsic + * Last modified: April 2020 + * Last Modified: Jun 2020 + * + * Using i64 shift for pow(2) expansion + * Last modified : 23rd May 2020 + * + * Added quad support for floor and ceiling intrinsics + * Last modified: August 2020 + * + * complex quad support for asin, asinh, acos, acosh, atan, atanh + * Modified on 19th August 2020 + * + * Added code support for dasinh + * Modified on 31st Aug 2020 + * + * Added code support for cotan and cotand + * Modified on Oct 2020 + * + * + */ + /** \file \brief ILI utility module @@ -59,6 +118,7 @@ union ATOMIC_ENCODER { #define IL_spfunc IL_DFRSP #define IL_dpfunc IL_DFRDP +#define IL_qpfunc IL_DFRQP // AOCC bool share_proc_ili = false; bool share_qjsr_ili = false; @@ -94,6 +154,7 @@ static int _xpowi(int, int, ILI_OP); static int _frsqrt(int); static int _mkfunc(char *); static int DblIsSingle(SPTR dd); +static int QuadIsSingle(SPTR dd); static int _lshift_one(int); static int cmpz_of_cmp(int, CC_RELATION); static bool is_zero_one(int); @@ -288,6 +349,7 @@ addili(ILI *ilip) case IL_MVQ: /*m128*/ case IL_MV256: /*m256*/ case IL_MVDP: + case IL_MVQP: case IL_MVAR: #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128RETURN: @@ -498,9 +560,19 @@ ad1func_cmplx(ILI_OP opc, char *name, int opn1) tmp = ad2ili(opc, _mkfunc(name), tmp2); return ad2ili(IL_DFRCS, tmp, CS_RETVAL); } - tmp2 = ad3ili(IL_DACD, opn1, DP(0), tmp1); - tmp = ad2ili(opc, _mkfunc(name), tmp2); + if (IL_RES(ILI_OPC(opn1)) == ILIA_CD) { + tmp2 = ad3ili(IL_DACD, opn1, DP(0), tmp1); + tmp = ad2ili(opc, _mkfunc(name), tmp2); return ad2ili(IL_DFRCD, tmp, CD_RETVAL); + } + // AOCC begin + if (IL_RES(ILI_OPC(opn1)) == ILIA_CQ) { + tmp2 = ad3ili(IL_DACQ, opn1, QP(0), tmp1); + tmp = ad2ili(opc, _mkfunc(name), tmp2); + return ad2ili(IL_DFRCQ, tmp, CQ_RETVAL); + } + // AOCC end + return -1; } /** \brief Add func call with 2 arguments returning complex value @@ -532,6 +604,11 @@ ad2func_cmplx(ILI_OP opc, char *name, int opn1, int opn2) case ILIA_CD: tmp1 = ad3ili(IL_DACD, opn2, DP(1), tmp1); break; + // AOCC begin + case ILIA_CQ: + tmp1 = ad3ili(IL_DACQ, opn2, DP(1), tmp1); + break; + // AOCC end case ILIA_IR: #if defined(TARGET_X8664) tmp1 = ad3ili(IL_DAIR, opn2, ireg, tmp1); @@ -555,9 +632,19 @@ ad2func_cmplx(ILI_OP opc, char *name, int opn1, int opn2) tmp = ad2ili(opc, _mkfunc(name), tmp2); return ad2ili(IL_DFRCS, tmp, CS_RETVAL); } - tmp2 = ad3ili(IL_DACD, opn1, DP(0), tmp1); - tmp = ad2ili(opc, _mkfunc(name), tmp2); - return ad2ili(IL_DFRCD, tmp, CD_RETVAL); + if (IL_RES(ILI_OPC(opn1)) == ILIA_CD) { + tmp2 = ad3ili(IL_DACD, opn1, DP(0), tmp1); + tmp = ad2ili(opc, _mkfunc(name), tmp2); + return ad2ili(IL_DFRCD, tmp, CD_RETVAL); + } + // AOCC begin + if (IL_RES(ILI_OPC(opn1)) == ILIA_CQ) { + tmp2 = ad3ili(IL_DACQ, opn1, QP(0), tmp1); + tmp = ad2ili(opc, _mkfunc(name), tmp2); + return ad2ili(IL_DFRCQ, tmp, CQ_RETVAL); + } + // AOCC end + return -1; } /** \brief Add func call with 1 complex argument returning complex value @@ -580,9 +667,19 @@ ad1func_cmplx_abi(ILI_OP opc, char *name, int opn1) tmp = ad2ili(opc, _mkfunc(name), tmp2); return ad2ili(IL_DFRCS, tmp, CS_RETVAL); } - tmp2 = ad3ili(IL_DACD, opn1, DP(0), tmp1); - tmp = ad2ili(opc, _mkfunc(name), tmp2); - return ad2ili(IL_DFRCD, tmp, CD_RETVAL); + if (IL_RES(ILI_OPC(opn1)) == ILIA_CD) { + tmp2 = ad3ili(IL_DACD, opn1, DP(0), tmp1); + tmp = ad2ili(opc, _mkfunc(name), tmp2); + return ad2ili(IL_DFRCD, tmp, CD_RETVAL); + } + // AOCC begin + if (IL_RES(ILI_OPC(opn1)) == ILIA_CQ) { + tmp2 = ad3ili(IL_DACQ, opn1, QP(0), tmp1); + tmp = ad2ili(opc, _mkfunc(name), tmp2); + return ad2ili(IL_DFRCQ, tmp, CQ_RETVAL); + } + // AOCC end + return -1; } /** \brief Add func call with 2 arguments returning complex value @@ -615,6 +712,11 @@ ad2func_cmplx_abi(ILI_OP opc, char *name, int opn1, int opn2) case ILIA_CD: tmp1 = ad3ili(IL_DACD, opn2, DP(1), tmp1); break; + // AOCC begin + case ILIA_CQ: + tmp1 = ad3ili(IL_DACQ, opn2, QP(1), tmp1); + break; + // AOCC end case ILIA_IR: #if defined(TARGET_X8664) tmp1 = ad3ili(IL_DAIR, opn2, ireg, tmp1); @@ -638,9 +740,19 @@ ad2func_cmplx_abi(ILI_OP opc, char *name, int opn1, int opn2) tmp = ad2ili(opc, _mkfunc(name), tmp2); return ad2ili(IL_DFRCS, tmp, CS_RETVAL); } - tmp2 = ad3ili(IL_DACD, opn1, DP(0), tmp1); - tmp = ad2ili(opc, _mkfunc(name), tmp2); + if (IL_RES(ILI_OPC(opn1)) == ILIA_CD) { + tmp2 = ad3ili(IL_DACD, opn1, DP(0), tmp1); + tmp = ad2ili(opc, _mkfunc(name), tmp2); return ad2ili(IL_DFRCD, tmp, CD_RETVAL); + } + // AOCC begin + if (IL_RES(ILI_OPC(opn1)) == ILIA_CQ) { + tmp2 = ad3ili(IL_DACQ, opn1, QP(0), tmp1); + tmp = ad2ili(opc, _mkfunc(name), tmp2); + return ad2ili(IL_DFRCQ, tmp, CQ_RETVAL); + } + // AOCC end + return -1; } /** \brief Add func call with 1 complex argument returning complex value @@ -769,6 +881,20 @@ ad_func(ILI_OP result_opc, ILI_OP call_opc, char *func_name, int nargs, ...) rg++; frg++; break; + // AOCC begin + case ILIA_QP: + args[i].opc = IL_DAQP; + args[i].reg = QP(frg); + rg++; + frg++; + break; + case ILIA_CQ: + args[i].opc = IL_DACQ; /* assumed to be packed when passed */ + args[i].reg = QP(frg); + rg++; + frg++; + break; + // AOCC end case ILIA_CS: args[i].opc = IL_DACS; args[i].reg = DP(frg); @@ -869,6 +995,11 @@ ad_func(ILI_OP result_opc, ILI_OP call_opc, char *func_name, int nargs, ...) case IL_DFRCS: ilix = ad2ili(result_opc, ilix, CS_RETVAL); break; + // AOCC begin + case IL_DFRQP: + ilix = ad2ili(result_opc, ilix, QP_RETVAL); + break; + // AOCC end #ifdef IL_DFRSPX87 case IL_DFRSPX87: ilix = ad1ili(result_opc, ilix); @@ -967,6 +1098,12 @@ vect_math(MTH_FN fn, char *root, int nargs, DTYPE vdt, int vopc, int vdt1, typec = 'd'; sprintf(oldname, "__fvd_%s", root); break; + // AOCC begin + case TY_QUAD: + typec = 'q'; + sprintf(oldname, "__fvq_%s", root); + break; + // AOCC end default: interr("vect_math: unexpected element dtype", DTySeqTyElement(vdt), ERR_Severe); @@ -1082,7 +1219,7 @@ fast_math(char *root, int widthc, int typec, char *oldname) * widthc - width indicator: 's' (scalar), 'v' (vector), * or a vector length (2, 4, 8, ..); if length * is passed, 'v' is used. - * typec - 's' (single), 'd' (double) + * typec - 's' (single), 'd' (double), 'q' (quad) * oldname - old 'fastmath' name */ static char bf[32]; @@ -1360,6 +1497,11 @@ ad_cse(int ilix) case ILIA_DP: ilix = ad1ili(IL_CSEDP, ilix); break; + // AOCC begin + case ILIA_QP: + ilix = ad1ili(IL_CSEQP, ilix); + break; + // AOCC end #ifdef ILIA_CS case ILIA_CS: ilix = ad1ili(IL_CSECS, ilix); @@ -1367,6 +1509,9 @@ ad_cse(int ilix) case ILIA_CD: ilix = ad1ili(IL_CSECD, ilix); break; + case ILIA_CQ: + ilix = ad1ili(IL_CSECQ, ilix); + break; #endif #ifdef LONG_DOUBLE_FLOAT128 case ILIA_FLOAT128: @@ -1411,12 +1556,22 @@ ad_load(int stx) case IL_STDP: load = ad3ili(IL_LDDP, base, nme, MSZ_F8); break; + // AOCC begin + case IL_STQP: + load = ad3ili(IL_LDQP, base, nme, MSZ_F16); + break; + // AOCC end case IL_STSCMPLX: load = ad3ili(IL_LDSCMPLX, base, nme, MSZ_F8); break; case IL_STDCMPLX: load = ad3ili(IL_LDDCMPLX, base, nme, MSZ_F16); break; + // AOCC begin + case IL_STQCMPLX: + load = ad3ili(IL_LDQCMPLX, base, nme, MSZ_F32); + break; + // AOCC end case IL_STQ: load = ad3ili(IL_LDQ, base, nme, MSZ_F16); break; @@ -1460,6 +1615,11 @@ ad_free(int ilix) case ILIA_DP: opc = IL_FREEDP; break; + // AOCC begin + case ILIA_QP: + opc = IL_FREEQP; + break; + // AOCC end #ifdef ILIA_CS case ILIA_CS: opc = IL_FREECS; @@ -1510,6 +1670,14 @@ ldopc_from_stopc(ILI_OP stopc) case IL_STDP: ldopc = IL_LDDP; break; + // AOCC begin + case IL_STQP: + ldopc = IL_LDQP; + break; + case IL_STQCMPLX: + ldopc = IL_LDQCMPLX; + break; + // AOCC end case IL_STSCMPLX: ldopc = IL_LDSCMPLX; break; @@ -1572,12 +1740,23 @@ ldst_msz(DTYPE dtype, ILI_OP *ld, ILI_OP *st, MSZ *siz) *ld = IL_LDKR; *st = IL_STKR; return; - case TY_QUAD: case TY_DBLE: *siz = MSZ_F8; *ld = IL_LDDP; *st = IL_STDP; break; + // AOCC begin + case TY_QUAD: + *siz = MSZ_F16; + *ld = IL_LDQP; + *st = IL_STQP; + break; + case TY_QCMPLX: + *siz = MSZ_F32; + *ld = IL_LDQCMPLX; + *st = IL_STQCMPLX; + break; + // AOCC end case TY_DCMPLX: *siz = MSZ_F16; *ld = IL_LDDCMPLX; @@ -1602,6 +1781,11 @@ ldst_msz(DTYPE dtype, ILI_OP *ld, ILI_OP *st, MSZ *siz) case 16: *siz = MSZ_F16; break; + // AOCC begin + case 32: + *siz = MSZ_F32; + break; + // AOCC end case 4: default: *siz = MSZ_WORD; @@ -1672,6 +1856,7 @@ insert_argrsrv(ILI *ilip) case IL_DASP: case IL_DASPSP: case IL_DADP: + case IL_DAQP: // AOCC #ifdef IL_DA128 case IL_DA128: #endif @@ -1694,6 +1879,7 @@ insert_argrsrv(ILI *ilip) case IL_ARGIR: case IL_ARGSP: case IL_ARGDP: + case IL_ARGQP: // AOCC case IL_ARGAR: case IL_ARGKR: #ifdef LONG_DOUBLE_FLOAT128 @@ -2345,11 +2531,161 @@ inline bool IS_DBL0(int x) { return is_dbl0(static_cast(x)); } + +// AOCC begin +inline bool IS_QUAD0(int x) +{ + return is_quad0(static_cast(x)); +} +// AOCC end #else #define IS_FLT0 is_flt0 #define IS_DBL0 is_dbl0 +#define IS_QUAD0 is_quad0 // AOCC #endif +#ifdef OMP_OFFLOAD_LLVM +static int +lowered_to_device_libm(ILI_OP opc,int op1,int op2) +{ + int ilix; + switch (opc) { + case IL_DPOWD: + (void)mk_prototype("pow", "f pure", DT_DBLE, 2, DT_DBLE,DT_DBLE); + ilix = ad_func(IL_DFRDP, IL_QJSR, "pow", 2, op1,op2); + return ad2altili(opc, op1,op2, ilix); + case IL_DCOS: + (void)mk_prototype("cos", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRDP, IL_QJSR, "cos", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DSIN: + (void)mk_prototype("sin", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRDP, IL_QJSR, "sin", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DSQRT: + (void)mk_prototype("sqrt", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRDP, IL_QJSR, "sqrt", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DEXP: + (void)mk_prototype("exp", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRDP, IL_QJSR, "exp", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DLOG: + (void)mk_prototype("log", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRDP, IL_QJSR, "log", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DLOG10: + (void)mk_prototype("log10", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRDP, IL_QJSR, "log10", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_NINT: + (void)mk_prototype("llvm.nearbyint.f32", "f pure", DT_FLOAT, 1, DT_FLOAT); + ilix = ad_func(IL_qpfunc, IL_QJSR, "llvm.nearbyint.f32", 1, op1); + return ad2altili(opc, op1, op2, ilix); + case IL_IDNINT: + (void)mk_prototype("llvm.nearbyint.f64", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_qpfunc, IL_QJSR, "llvm.nearbyint.f64", 1, op1); + return ad2altili(opc, op1, op2, ilix); + case IL_SCMPLXEXP: + (void)mk_prototype("cexp", "f pure", DT_CMPLX, 1, DT_CMPLX); + ilix = ad_func(IL_DFRDP, IL_QJSR, "cexp", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DCMPLXEXP: + (void)mk_prototype("cdexp", "f pure", DT_DCMPLX, 1, DT_DCMPLX); + ilix = ad_func(IL_DFRDP, IL_QJSR, "cdexp", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_SCMPLXABS: + (void)mk_prototype("cabs", "f pure", DT_FLOAT, 1, DT_CMPLX); + ilix = ad_func(IL_DFRDP, IL_QJSR, "cabs", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DCMPLXABS: + (void)mk_prototype("cdabs", "f pure", DT_DBLE, 1, DT_DCMPLX); + ilix = ad_func(IL_DFRDP, IL_QJSR, "cdabs", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_SCMPLXLOG: + (void)mk_prototype("clog", "f pure", DT_CMPLX, 1, DT_CMPLX); + ilix = ad_func(IL_DFRDP, IL_QJSR, "clog", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DCMPLXLOG: + (void)mk_prototype("cdlog", "f pure", DT_DCMPLX, 1, DT_DCMPLX); + ilix = ad_func(IL_DFRDP, IL_QJSR, "cdlog", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_SCMPLXSIN: + (void)mk_prototype("csin", "f pure", DT_CMPLX, 1, DT_CMPLX); + ilix = ad_func(IL_DFRDP, IL_QJSR, "csin", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DCMPLXSIN: + (void)mk_prototype("cdsin", "f pure", DT_DCMPLX, 1, DT_DCMPLX); + ilix = ad_func(IL_DFRDP, IL_QJSR, "cdsin", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_SCMPLXSINH: + (void)mk_prototype("csinh", "f pure", DT_CMPLX, 1, DT_CMPLX); + ilix = ad_func(IL_DFRDP, IL_QJSR, "csinh", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DCMPLXSINH: + (void)mk_prototype("cdsinh", "f pure", DT_DCMPLX, 1, DT_DCMPLX); + ilix = ad_func(IL_DFRDP, IL_QJSR, "cdsinh", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_SCMPLXASIN: + (void)mk_prototype("casin", "f pure", DT_CMPLX, 1, DT_CMPLX); + ilix = ad_func(IL_DFRDP, IL_QJSR, "casin", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DCMPLXASIN: + (void)mk_prototype("cdasin", "f pure", DT_DCMPLX, 1, DT_DCMPLX); + ilix = ad_func(IL_DFRDP, IL_QJSR, "cdasin", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_SCMPLXCOS: + (void)mk_prototype("ccos", "f pure", DT_CMPLX, 1, DT_CMPLX); + ilix = ad_func(IL_DFRDP, IL_QJSR, "ccos", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DCMPLXCOS: + (void)mk_prototype("cdcos", "f pure", DT_DCMPLX, 1, DT_DCMPLX); + ilix = ad_func(IL_DFRDP, IL_QJSR, "cdcos", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_SCMPLXCOSH: + (void)mk_prototype("ccosh", "f pure", DT_CMPLX, 1, DT_CMPLX); + ilix = ad_func(IL_DFRDP, IL_QJSR, "ccosh", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DCMPLXCOSH: + (void)mk_prototype("cdcosh", "f pure", DT_DCMPLX, 1, DT_DCMPLX); + ilix = ad_func(IL_DFRDP, IL_QJSR, "cdcosh", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_SCMPLXACOS: + (void)mk_prototype("cacos", "f pure", DT_CMPLX, 1, DT_CMPLX); + ilix = ad_func(IL_DFRDP, IL_QJSR, "cacos", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DCMPLXACOS: + (void)mk_prototype("cdacos", "f pure", DT_DCMPLX, 1, DT_DCMPLX); + ilix = ad_func(IL_DFRDP, IL_QJSR, "cdacos", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_SCMPLXTAN: + (void)mk_prototype("ctan", "f pure", DT_CMPLX, 1, DT_CMPLX); + ilix = ad_func(IL_DFRDP, IL_QJSR, "ctan", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DCMPLXTAN: + (void)mk_prototype("cdtan", "f pure", DT_DCMPLX, 1, DT_DCMPLX); + ilix = ad_func(IL_DFRDP, IL_QJSR, "cdtan", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_SCMPLXTANH: + (void)mk_prototype("ctanh", "f pure", DT_CMPLX, 1, DT_CMPLX); + ilix = ad_func(IL_DFRDP, IL_QJSR, "ctanh", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DCMPLXTANH: + (void)mk_prototype("cdtanh", "f pure", DT_DCMPLX, 1, DT_DCMPLX); + ilix = ad_func(IL_DFRDP, IL_QJSR, "cdtanh", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_SCMPLXATAN: + (void)mk_prototype("catan", "f pure", DT_CMPLX, 1, DT_CMPLX); + ilix = ad_func(IL_DFRDP, IL_QJSR, "catan", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DCMPLXATAN: + (void)mk_prototype("cdatan", "f pure", DT_DCMPLX, 1, DT_DCMPLX); + ilix = ad_func(IL_DFRDP, IL_QJSR, "cdatan", 1, op1); + return ad1altili(opc, op1, ilix); + } + return 0; +} +#endif /** * \brief adds arithmetic ili */ @@ -2387,9 +2723,10 @@ addarth(ILI *ilip) int i, tmp, tmp1; /* temporary */ union { /* constant value structure */ - INT numi[2]; + INT numi[4]; UINT numu[2]; DBLE numd; + QUAD numq; // AOCC } res, num1, num2; CC_RELATION cond; char *root; @@ -2407,7 +2744,22 @@ addarth(ILI *ilip) a.numi[0] = CONVAL1G(b); \ a.numi[1] = CONVAL2G(b); \ } - +// AOCC begin +#define GETVAL128(a, b) \ + { \ + a.numq[0] = CONVAL1G(b); \ + a.numq[1] = CONVAL2G(b); \ + a.numq[2] = CONVAL3G(b); \ + a.numq[3] = CONVAL4G(b); \ + } +#define GETVALI128(a, b) \ + { \ + a.numi[0] = CONVAL1G(b); \ + a.numi[1] = CONVAL2G(b); \ + a.numi[2] = CONVAL3G(b); \ + a.numi[3] = CONVAL4G(b); \ + } +// AOCC end ncons = 0; opc = ilip->opc; op1 = ilip->opnd[0]; @@ -2476,6 +2828,275 @@ addarth(ILI *ilip) } } } + + /* AOCC Begin + * Use LLVM math intrinsics instead of + * using flang runtime math library + */ +#ifdef OMP_OFFLOAD_LLVM + (void)mk_prototype("__tgt_fort_ptr_assn_i8", "f", DT_INT8, 5, DT_CPTR,DT_CPTR, DT_CPTR,DT_CPTR,DT_CPTR); + (void)mk_prototype("__atomic_compare_exchange", "f", DT_INT,6, DT_INT8,DT_CPTR,DT_CPTR,DT_CPTR,DT_INT, DT_INT); + + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + ilix = lowered_to_device_libm(opc,op1,op2); + if (ilix) return ilix; + } +#endif + + if (flg.use_llvm_math_intrin) { + switch(opc) { + case IL_DPOWD: + (void)mk_prototype("llvm.pow.f64", "f pure", DT_DBLE, 2, DT_DBLE, DT_DBLE); + ilix = ad_func(IL_dpfunc, IL_QJSR, "llvm.pow.f64", 2, op1, op2); + ilix = ad2altili(opc, op1, op2, ilix); + return ilix; + // AOCC Begin + case IL_QPOWQ: + (void)mk_prototype("powq", "f pure", DT_QUAD, 2, DT_QUAD, DT_QUAD); + ilix = ad_func(IL_qpfunc, IL_QJSR, "powq", 2, op1, op2); + ilix = ad2altili(opc, op1, op2, ilix); + return ilix; + // AOCC End + case IL_FPOWF: + (void)mk_prototype("llvm.pow.f32", "f pure", DT_FLOAT, 2, DT_FLOAT, DT_FLOAT); + ilix = ad_func(IL_spfunc, IL_QJSR, "llvm.pow.f32", 2, op1, op2); + ilix = ad2altili(opc, op1, op2, ilix); + return ilix; + case IL_FCOS: + (void)mk_prototype("llvm.cos.f32", "f pure", DT_FLOAT, 1, DT_FLOAT); + ilix = ad_func(IL_DFRSP, IL_QJSR, "llvm.cos.f32", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DCOS: + (void)mk_prototype("llvm.cos.f64", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRDP, IL_QJSR, "llvm.cos.f64", 1, op1); + return ad1altili(opc, op1, ilix); + //AOCC Begin + case IL_QCOS: +#if 0 +#ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("cos", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, "cos", 1, op1); + return ad1altili(opc, op1, ilix); + } +#endif +#endif + (void)mk_prototype("cosq", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, "cosq", 1, op1); + return ad1altili(opc, op1, ilix); + //AOCC End + + case IL_FSIN: + (void)mk_prototype("llvm.sin.f32", "f pure", DT_FLOAT, 1, DT_FLOAT); + ilix = ad_func(IL_DFRSP, IL_QJSR, "llvm.sin.f32", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DSIN: + (void)mk_prototype("llvm.sin.f64", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRDP, IL_QJSR, "llvm.sin.f64", 1, op1); + return ad1altili(opc, op1, ilix); + //AOCC Begin + case IL_QSIN: +#if 0 +#ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("sin", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, "sin", 1, op1); + return ad1altili(opc, op1, ilix); + } +#endif +#endif + (void)mk_prototype("sinq", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, "sinq", 1, op1); + return ad1altili(opc, op1, ilix); + //AOCC End + case IL_FFLOOR: + (void)mk_prototype("llvm.floor.f32", "f pure", DT_FLOAT, 1, DT_FLOAT); + ilix = ad_func(IL_DFRSP, IL_QJSR, "llvm.floor.f32", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DFLOOR: + (void)mk_prototype("llvm.floor.f64", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRDP, IL_QJSR, "llvm.floor.f64", 1, op1); + return ad1altili(opc, op1, ilix); + // AOCC Begin + case IL_QFLOOR: + (void)mk_prototype("floorq", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, "floorq", 1, op1); + return ad1altili(opc, op1, ilix); + // AOCC End + + case IL_FSQRT: + (void)mk_prototype("llvm.sqrt.f32", "f pure", DT_FLOAT, 1, DT_FLOAT); + ilix = ad_func(IL_DFRSP, IL_QJSR, "llvm.sqrt.f32", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DSQRT: + (void)mk_prototype("llvm.sqrt.f64", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRDP, IL_QJSR, "llvm.sqrt.f64", 1, op1); + return ad1altili(opc, op1, ilix); + + // AOCC Begin + case IL_QSQRT: +#if 0 +#ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("sqrtq", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, "sqrtq", 1, op1); + return ad1altili(opc, op1, ilix); + } +#endif +#endif + (void)mk_prototype("sqrtq", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, "sqrtq", 1, op1); + return ad1altili(opc, op1, ilix); + // AOCC End + + case IL_FEXP: + (void)mk_prototype("llvm.exp.f32", "f pure", DT_FLOAT, 1, DT_FLOAT); + ilix = ad_func(IL_spfunc, IL_QJSR, "llvm.exp.f32", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DEXP: + (void)mk_prototype("llvm.exp.f64", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_dpfunc, IL_QJSR, "llvm.exp.f64", 1, op1); + return ad1altili(opc, op1, ilix); + + // AOCC Begin + case IL_QEXP: +#if 0 +#ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("exp", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, "exp", 1, op1); + return ad1altili(opc, op1, ilix); + } +#endif +#endif + (void)mk_prototype("expq", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_qpfunc, IL_QJSR, "expq", 1, op1); + return ad1altili(opc, op1, ilix); + // AOCC End + + + case IL_FLOG: + (void)mk_prototype("llvm.log.f32", "f pure", DT_FLOAT, 1, DT_FLOAT); + ilix = ad_func(IL_spfunc, IL_QJSR, "llvm.log.f32", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DLOG: + (void)mk_prototype("llvm.log.f64", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_dpfunc, IL_QJSR, "llvm.log.f64", 1, op1); + return ad1altili(opc, op1, ilix); + // AOCC begin + case IL_QLOG: +#if 0 +#ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("log", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, "log", 1, op1); + return ad1altili(opc, op1, ilix); + } +#endif +#endif + (void)mk_prototype("logq", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_qpfunc, IL_QJSR, "logq", 1, op1); + return ad1altili(opc, op1, ilix); + // AOCC End + + //log 10 + case IL_FLOG10: + (void)mk_prototype("llvm.log10.f32", "f pure", DT_FLOAT, 1, DT_FLOAT); + ilix = ad_func(IL_spfunc, IL_QJSR, "llvm.log10.f32", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DLOG10: + (void)mk_prototype("llvm.log10.f64", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_dpfunc, IL_QJSR, "llvm.log10.f64", 1, op1); + return ad1altili(opc, op1, ilix); + + // AOCC Begin + case IL_QLOG10: +#if 0 +#ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("log10", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRDP, IL_QJSR, "log10", 1, op1); + return ad1altili(opc, op1, ilix); + } +#endif +#endif + (void)mk_prototype("log10q", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_qpfunc, IL_QJSR, "log10q", 1, op1); + return ad1altili(opc, op1, ilix); + // AOCC End + + //fabs + case IL_FABS: + (void)mk_prototype("llvm.fabs.f32", "f pure", DT_FLOAT, 1, DT_FLOAT); + ilix = ad_func(IL_spfunc, IL_QJSR, "llvm.fabs.f32", 1, op1); + return ad1altili(opc, op1, ilix); + case IL_DABS: + (void)mk_prototype("llvm.fabs.f64", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_spfunc, IL_QJSR, "llvm.fabs.f64", 1, op1); + return ad1altili(opc, op1, ilix); + // AOCC begin + case IL_QABS: + (void)mk_prototype("fabsq", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_qpfunc, IL_QJSR, "fabsq", 1, op1); + return ad1altili(opc, op1, ilix); + //fmin and fminf + case IL_FMIN: + (void)mk_prototype("llvm.minnum.f32", "f pure", DT_FLOAT, 2, DT_FLOAT, DT_FLOAT); + ilix = ad_func(IL_spfunc, IL_QJSR, "llvm.minnum.f32", 2, op1, op2); + return ad2altili(opc, op1, op2, ilix); + case IL_DMIN: + (void)mk_prototype("llvm.minnum.f64", "f pure", DT_DBLE, 2, DT_DBLE, DT_DBLE); + ilix = ad_func(IL_dpfunc, IL_QJSR, "llvm.minnum.f64", 2, op1, op2); + return ad2altili(opc, op1, op2, ilix); + // AOCC begin + case IL_QMIN: + (void)mk_prototype("fminq", "f pure", DT_QUAD, 2, DT_QUAD, DT_QUAD); + ilix = ad_func(IL_qpfunc, IL_QJSR, "fminq", 2, op1, op2); + return ad2altili(opc, op1, op2, ilix); + // AOCC end + + //fmax + case IL_FMAX: + (void)mk_prototype("llvm.maxnum.f32", "f pure", DT_FLOAT, 2, DT_FLOAT, DT_FLOAT); + ilix = ad_func(IL_spfunc, IL_QJSR, "llvm.maxnum.f32", 2, op1, op2); + return ad2altili(opc, op1, op2, ilix); + case IL_DMAX: + (void)mk_prototype("llvm.maxnum.f64", "f pure", DT_DBLE, 2, DT_DBLE, DT_DBLE); + ilix = ad_func(IL_dpfunc, IL_QJSR, "llvm.maxnum.f64", 2, op1, op2); + return ad2altili(opc, op1, op2, ilix); + // AOCC begin + case IL_QMAX: + (void)mk_prototype("fmaxq", "f pure", DT_QUAD, 2, DT_QUAD, DT_QUAD); + ilix = ad_func(IL_qpfunc, IL_QJSR, "fmaxq", 2, op1, op2); + return ad2altili(opc, op1, op2, ilix); +#if 0 + case IL_NINT: +#ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("llvm.nearbyint.f32", "f pure", DT_FLOAT, 1, DT_FLOAT); + ilix = ad_func(IL_qpfunc, IL_QJSR, "llvm.nearbyint.f32", 1, op1); + return ad2altili(opc, op1, op2, ilix); + } +#endif + break; + case IL_IDNINT: +#ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("llvm.nearbyint.f64", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_qpfunc, IL_QJSR, "llvm.nearbyint.f64", 1, op1); + return ad2altili(opc, op1, op2, ilix); + } +#endif + break; +#endif + // AOCC end + + default: + break; + }; + } + // AOCC End + switch (opc) { case IL_UITOI: case IL_ITOUI: @@ -2506,6 +3127,9 @@ addarth(ILI *ilip) break; case IL_DP2KR: break; + // AOCC + case IL_QP2KR: + break; case IL_CS2KR: break; @@ -2545,6 +3169,7 @@ addarth(ILI *ilip) case IL_IDIM: case IL_FDIM: case IL_DDIM: + case IL_QDIM: /* add constant folding later */ break; @@ -2613,6 +3238,15 @@ addarth(ILI *ilip) goto add_dcon; } break; + // AOCC begin + case IL_QSQRT: + if (ncons == 1) { + GETVAL128(num1, cons1); + xqsqrt(num1.numq, res.numq); + goto add_qcon; + } + break; + // AOCC end #ifdef IL_FRSQRT case IL_FRSQRT: @@ -2707,6 +3341,16 @@ addarth(ILI *ilip) } break; + // AOCC begin + case IL_QABS: + if (ncons == 1) { + GETVAL128(num1, cons1); + xqabsv(num1.numq, res.numq); + goto add_qcon; + } + break; + // AOCC end + case IL_KNEG: case IL_UKNEG: if (ncons == 1) { @@ -2748,6 +3392,8 @@ addarth(ILI *ilip) break; case IL_DCMPLXCMP: break; + case IL_QCMPLXCMP: + break; case IL_SCMPLXCONJG: if (ncons == 1) { res.numi[0] = con1v1; @@ -2766,6 +3412,19 @@ addarth(ILI *ilip) } break; + // AOCC begin + case IL_QCMPLXCONJG: + if (ncons == 1) { + GETVAL128(num2, con1v2); + xqneg(num2.numq, res.numq); + cons2 = getcon(res.numq, DT_QUAD); + res.numi[0] = con1v1; + res.numi[1] = cons2; + return ad1ili(IL_QCMPLXCON, getcon(res.numi, DT_QCMPLX)); + } + break; + // AOCC end + case IL_SCMPLXNEG: if (ncons == 1) { xfneg(con1v1, &res.numi[0]); @@ -2819,6 +3478,46 @@ addarth(ILI *ilip) } break; + // AOCC begin + case IL_QNEG: + if (ncons == 1) { + GETVAL128(num2, cons1); + xqneg(num2.numq, res.numq); + goto add_qcon; + } + if (!flg.ieee && ILI_OPC(op1) == IL_QSUB) { + /* -(a - b) --> b - a */ + op2 = ILI_OPND(op1, 1); + op1 = ILI_OPND(op1, 2); + return ad2ili(IL_QSUB, op1, op2); + } + if (ILI_OPC(op1) == IL_QMUL) { + ilix = red_negate(op1, IL_QNEG, IL_QMUL, IL_QDIV); + if (ilix != op1) + return ilix; + } + break; + + case IL_QCMPLXNEG: + if (ncons == 1) { + GETVAL128(num1, con1v1); + GETVAL128(num2, con1v2); + xqneg(num1.numq, res.numq); + cons1 = getcon(res.numq, DT_QUAD); + xqneg(num2.numq, res.numq); + cons2 = getcon(res.numq, DT_QUAD); + res.numi[0] = cons1; + res.numi[1] = cons2; + return ad1ili(IL_QCMPLXCON, getcon(res.numi, DT_QCMPLX)); + } + if (!flg.ieee && ILI_OPC(op1) == IL_QCMPLXSUB) { + /* -(a - b) --> b - a */ + op2 = ILI_OPND(op1, 1); + op1 = ILI_OPND(op1, 2); + return ad2ili(IL_QCMPLXSUB, op1, op2); + } + break; + // AOCC end case IL_FIX: if (ncons == 1) { xfix(con1v2, &res.numi[1]); @@ -2940,6 +3639,54 @@ addarth(ILI *ilip) goto add_dcon; } break; + // AOCC begin + case IL_QFIXU: + if (ncons == 1) { + GETVAL128(num1, cons1); + xqfixu(num1.numq, &res.numu[1]); + goto add_icon; + } + break; + + case IL_QFIXK: + case IL_QFIXUK: + if (ncons == 1) { + GETVAL128(num1, cons1); + xqfix64(num1.numi, res.numi); + goto add_kcon; + } + break; + + case IL_QFIX: + if (ncons == 1) { + GETVAL128(num1, cons1); + xqfix(num1.numq, &res.numi[1]); + goto add_icon; + } + break; + + case IL_QUAD: + if (ncons == 1) { + xdtoq(&con1v2, res.numq); + goto add_qcon; + } + break; + + case IL_QFLOATK: + if (ncons == 1) { + GETVALI128(num1, cons1); + xqflt64(num1.numi, res.numi); + goto add_qcon; + } + break; + + case IL_QFLOAT: + if (ncons == 1) { + xqfloat(con1v2, res.numq); + goto add_qcon; + } + break; + // AOCC end case IL_UNOT: case IL_NOT: @@ -3089,6 +3836,22 @@ addarth(ILI *ilip) #endif break; + // AOCC begin + case IL_FCMPZNZ: + if (!IEEE_CMP && ILI_OPC(op1) == IL_FSUB) + return ad3ili(IL_FCMP, (int)ILI_OPND(op1, 1), (int)ILI_OPND(op1, 2), op2); + { + int fcon_one = ad1ili(IL_FCON, stb.flt1); + + (void)mk_prototype("llvm.copysign.f32", "f pure", DT_FLOAT, 2, DT_FLOAT, DT_FLOAT); + ilix = ad_func(IL_spfunc, IL_QJSR, "llvm.copysign.f32", 2, fcon_one, op1); + + int fcon_zero = ad1ili(IL_FCON, stb.flt0); + return ad3ili(IL_FCMP, ad2altili(opc, fcon_one, op1, ilix), fcon_zero, op2); + } + break; + // AOCC end + case IL_DCMPZ: if (ncons == 1) { GETVAL64(num1, cons1); @@ -3106,15 +3869,67 @@ addarth(ILI *ilip) #endif break; - case IL_ACMPZ: - if (ncons == 1) { - int sym; - sym = con1v1; - if (sym == 0) { - res.numi[1] = cmp_to_log(icmp(con1v2, (INT)0), op2); - goto add_icon; - } - /* comparing an address with NULL */ + // AOCC begin + case IL_DCMPZNZ: + if (!IEEE_CMP && ILI_OPC(op1) == IL_DSUB) + return ad3ili(IL_DCMP, (int)ILI_OPND(op1, 1), (int)ILI_OPND(op1, 2), op2); + if (ILI_OPC(op1) == IL_DBLE && !XBIT(15, 0x80)) + return ad2ili(IL_FCMPZ, ILI_OPND(op1, 1), op2); + { + int dcon_one = ad1ili(IL_DCON, stb.dbl1); + + (void)mk_prototype("llvm.copysign.f64", "f pure", DT_DBLE, 2, DT_DBLE, DT_DBLE); + ilix = ad_func(IL_dpfunc, IL_QJSR, "llvm.copysign.f64", 2, dcon_one, op1); + + int dcon_zero = ad1ili(IL_DCON, stb.dbl0); + return ad3ili(IL_DCMP, ad2altili(opc, dcon_one, op1, ilix), dcon_zero, op2); + } + break; + // AOCC end + + // AOCC begin + case IL_QCMPZ: + if (ncons == 1) { + GETVAL128(num1, cons1); + GETVAL128(num2, stb.quad0); + res.numi[1] = cmp_to_log(xqcmp(num1.numq, num2.numq), op2); + goto add_icon; + } + if (!IEEE_CMP && ILI_OPC(op1) == IL_QSUB) + return ad3ili(IL_QCMP, (int)ILI_OPND(op1, 1), (int)ILI_OPND(op1, 2), op2); + if (ILI_OPC(op1) == IL_QUAD && !XBIT(15, 0x80)) + return ad2ili(IL_FCMPZ, ILI_OPND(op1, 1), op2); +#ifndef TM_QCMPZ + tmp = ad1ili(IL_QCON, stb.quad0); + return ad3ili(IL_QCMP, op1, tmp, op2); +#endif + break; + + case IL_QCMPZNZ: + if (!IEEE_CMP && ILI_OPC(op1) == IL_QSUB) + return ad3ili(IL_QCMP, (int)ILI_OPND(op1, 1), (int)ILI_OPND(op1, 2), op2); + if (ILI_OPC(op1) == IL_QUAD && !XBIT(15, 0x80)) + return ad2ili(IL_FCMPZ, ILI_OPND(op1, 1), op2); + { + int qcon_one = ad1ili(IL_QCON, stb.quad1); + + (void)mk_prototype("llvm.copysign.f128", "f pure", DT_QUAD, 2, DT_QUAD, DT_QUAD); + ilix = ad_func(IL_qpfunc, IL_QJSR, "llvm.copysign.f128", 2, qcon_one, op1); + + int qcon_zero = ad1ili(IL_QCON, stb.quad0); + return ad3ili(IL_QCMP, ad2altili(opc, qcon_one, op1, ilix), qcon_zero, op2); + } + break; + // AOCC end + case IL_ACMPZ: + if (ncons == 1) { + int sym; + sym = con1v1; + if (sym == 0) { + res.numi[1] = cmp_to_log(icmp(con1v2, (INT)0), op2); + goto add_icon; + } + /* comparing an address with NULL */ switch (op2) { case CC_LT: res.numi[1] = 0; @@ -3341,6 +4156,52 @@ addarth(ILI *ilip) op2 = ILI_OPND(op2, 1); } break; + + // AOCC begin + case IL_QADD: + if (ncons == 2 && is_quad0(cons2)) + return op1; + like_qadd: + if (!flg.ieee && ncons == 3) { + GETVAL128(num1, cons1); + GETVAL128(num1, cons2); + GETVAL128(num2, cons1); + GETVAL128(num2, cons2); + xqadd(num1.numq, num2.numq, res.numd); + goto add_qcon; + } + if (ILI_OPC(op1) == IL_QNEG) { + /* -a + b --> b - a */ + opc = IL_QSUB; + tmp = op2; + op2 = ILI_OPND(op1, 1); + op1 = tmp; + } else if (ILI_OPC(op2) == IL_QNEG) { + /* a + -b --> a - b */ + opc = IL_QSUB; + op2 = ILI_OPND(op2, 1); + } + break; + + case IL_QSUB: + if (ncons == 2 && is_quad0(cons2)) + return op1; + if (!flg.ieee && ncons == 3) { + GETVAL128(num1, cons1); + GETVAL128(num1, cons2); + GETVAL128(num2, cons1); + GETVAL128(num2, cons2); + xqsub(num1.numq, num2.numq, res.numd); + goto add_qcon; + } + if (ILI_OPC(op2) == IL_QNEG) { + /* a - -b --> a + b */ + opc = IL_QADD; + op2 = ILI_OPND(op2, 1); + } + break; + // AOCC end + case IL_SCMPLXADD: if (ncons == 2 && IS_FLT0(con2v1) && IS_FLT0(con2v2)) return op1; @@ -3388,6 +4249,36 @@ addarth(ILI *ilip) } break; + // AOCC begin + case IL_QCMPLXADD: + if (ncons == 2 && IS_QUAD0(con2v1) && IS_QUAD0(con2v2)) + return op1; + like_qcmplxadd: + if (!flg.ieee && ncons == 3) { + GETVAL128(num1, con1v1); + GETVAL128(num2, con2v1) + xqadd(num1.numq, num2.numq, res.numq); + cons1 = getcon(res.numq, DT_QUAD); + GETVAL128(num1, con1v2); + GETVAL128(num2, con2v2); + xqadd(num1.numq, num2.numq, res.numq); + cons2 = getcon(res.numq, DT_QUAD); + res.numi[0] = cons1; + res.numi[1] = cons2; + return ad1ili(IL_QCMPLXCON, getcon(res.numi, DT_QCMPLX)); + } + if (ILI_OPC(op1) == IL_QCMPLXNEG) { + opc = IL_QCMPLXSUB; + tmp = op2; + op2 = ILI_OPND(op1, 1); + op1 = tmp; + } else if (ILI_OPC(op2) == IL_QCMPLXNEG) { + opc = IL_QCMPLXSUB; + op2 = ILI_OPND(op2, 1); + } + break; + // AOCC end + case IL_AADD: newili.opnd[2] = ilip->opnd[2]; /* save away scale factor */ #define RED_DAMV (!XBIT(15, 0x100)) @@ -3630,6 +4521,51 @@ addarth(ILI *ilip) } break; + // AOCC begin + case IL_QCMPLXSUB: +#ifdef FPSUB2ADD + if (!flg.ieee && ncons >= 2) { + GETVAL128(num1, stb.quad0); + GETVAL128(num2, con2v1); + xqsub(num1.numq, num2.numq, res.numq); + cons1 = getcon(res.numi, DT_QUAD); + GETVAL128(num1, stb.quad0); + GETVAL128(num2, con2v2); + xqsub(num1.numq, num2.numq, res.numq); + cons2 = getcon(res.numi, DT_QUAD); + res.numi[0] = cons1; + res.numi[1] = cons2; + op2 = ad1ili(IL_QCMPLXCON, getcon(res.numi, DT_QCMPLX)); + opc = IL_QCMPLXADD; + goto like_qcmplxadd; + } +#else + if (!flg.ieee && ncons == 3) { + GETVAL128(num1, con1v1); + GETVAL128(num2, con2v1); + xqsub(num1.numq, num2.numq, res.numq); + cons1 = getcon(res.numq, DT_QUAD); + GETVAL128(num1, con1v2); + GETVAL128(num2, con2v2); + xqsub(num1.numq, num2.numq, res.numq); + cons2 = getcon(res.numq, DT_QUAD); + res.numi[0] = cons1; + res.numi[1] = cons2; + op2 = ad1ili(IL_QCMPLXCON, getcon(res.numi, DT_QCMPLX)); + return op2; + } + if (ncons == 2 && IS_QUAD0(con2v1) && IS_QUAD0(con2v2)) + return op1; +#endif + if (ncons == 1 && IS_QUAD0(con1v1) && IS_QUAD0(con1v2)) + return ad1ili(IL_QCMPLXNEG, op2); + if (ILI_OPC(op2) == IL_QCMPLXNEG) { + opc = IL_QCMPLXADD; + op2 = ILI_OPND(op2, 1); + } + break; + // AOCC end + case IL_ASUB: /* (p + ) - p -> */ if (ilip->opnd[2] == 0 && ILI_OPC(op1) == IL_AADD && @@ -3807,6 +4743,48 @@ addarth(ILI *ilip) return ad1ili(IL_DNEG, ad2ili(IL_DMUL, op1, ILI_OPND(op2, 1))); } break; + + // AOCC begin + case IL_QMUL: + if (!flg.ieee) { + if (ncons == 2) { + if (is_quad0(cons2) && !func_in(op1)) + return op2; + if (cons2 == stb.quad1) + return op1; + if (cons2 == stb.quad2) { + /* assertion: no need for cse since sched treats multiple uses + * of the same function ili as one call. + */ + return ad2ili(IL_QADD, op1, op1); + } + } else if (ncons == 3) { + GETVAL128(num1, cons1); + GETVAL128(num2, cons2); + GETVAL128(num1, cons1); + GETVAL128(num2, cons2); + xqmul(num1.numq, num2.numq, res.numq); + /* don't constant fold if error occurred */ + if (gbl.fperror_status) + break; + goto add_qcon; + } + } + /* QMUL QNEG x, y --> QNEG QMUL x,y */ + if (ILI_OPC(op1) == IL_QNEG && ILI_OPC(op2) == IL_QNEG) { + op1 = ILI_OPND(op1, 1); + op2 = ILI_OPND(op2, 1); + break; + } + if (ILI_OPC(op1) == IL_QNEG) { + return ad1ili(IL_DNEG, ad2ili(IL_QMUL, ILI_OPND(op1, 1), op2)); + } + if (ILI_OPC(op2) == IL_QNEG) { + return ad1ili(IL_DNEG, ad2ili(IL_QMUL, op1, ILI_OPND(op2, 1))); + } + break; + // AOCC end + case IL_SCMPLXMUL: if (ncons == 1 && IS_FLT0(con1v1) && IS_FLT0(con1v2) && !func_in(op2)) return op1; @@ -3849,8 +4827,32 @@ addarth(ILI *ilip) return ad1ili(IL_DPDP2DCMPLXI0, ilir); } } + break; + // AOCC begin + case IL_QCMPLXMUL: + /* check if any is of complex is 0 then 0*/ + if (ncons == 1 && IS_QUAD0(con1v1) && IS_QUAD0(con1v2) && !func_in(op2)) + return op1; + else if (ncons == 2 && IS_QUAD0(con2v1) && IS_QUAD0(con2v2) && !func_in(op1)) + return op2; + else if (ncons == 3) { /* should be done by front end already */ + if (IS_QUAD0(con1v1) && IS_QUAD0(con1v2)) + return op1; + if (IS_QUAD0(con2v1) && IS_QUAD0(con2v2)) + return op2; + } else { + op1 = ilip->opnd[0]; + op2 = ilip->opnd[1]; + if (ILI_OPC(op1) == IL_QPQP2QCMPLXI0 && + ILI_OPC(op2) == IL_QPQP2QCMPLXI0) { + int ilir; + ilir = ad2ili(IL_QMUL, ILI_OPND(op1, 1), ILI_OPND(op2, 1)); + return ad1ili(IL_QPQP2QCMPLXI0, ilir); + } + } break; + // AOCC end case IL_FSINCOS: case IL_DSINCOS: @@ -4351,6 +5353,86 @@ addarth(ILI *ilip) return ilix; #endif #endif /*} no hardware divide */ + // AOCC begin + case IL_QDIV: +#ifdef TM_QDIV /*{ hardware divide present */ + if (ncons == 3 && !is_quad0(cons2)) { + GETVAL128(num1, cons1); + GETVAL128(num2, cons2); + xqdiv(num1.numq, num2.numq, res.numq); + goto add_qcon; + } + if (!flg.ieee) { + if (XBIT(15, 0x1) && (ncons & 2) && !is_quad0(cons2)) { + /* x / y --> x * (1 / y) */ + GETVAL128(num1, stb.quad1); + GETVAL128(num2, cons2); + xqdiv(num1.numq, num2.numq, res.numq); + ilix = ad1ili(IL_QCON, getcon(res.numi, DT_QUAD)); + return ad2ili(IL_QMUL, ilix, op1); + } else if (XBIT(15, 0x4) && (!((ncons & 1) && (cons1 == stb.quad1)))) { + /* x / y --> x * (1 / y) */ + ilix = ad2ili(IL_QDIV, ad1ili(IL_QCON, stb.quad1), op2); + return ad2ili(IL_QMUL, ilix, op1); + } + } + break; +#endif /*} hardware divide */ + +#ifndef TM_QDIV /*{ no hardware divide */ +#ifdef TM_QRCP /*{ mult - recip */ + /* perform divide by reciprocal approximation */ + if (flg.ieee) { + if (ncons == 3 && !is_quad0(cons2)) { + GETVAL128(num1, cons1); + GETVAL128(num2, cons2); + qdiv(num1.numq, num2.numq, res.numq); + goto add_qcon; + } + op1 = ad3ili(IL_DAQP, op1, QP(0), ad1ili(IL_NULL, 0)); + op2 = ad3ili(IL_DAQP, op2, QP(1), op1); + ilix = ad2ili(IL_QJSR, _mkfunc(MTH_I_QDIV), op2); + ilix = ad2ili(IL_DFRQP, ilix, QP(0)); + return ilix; + } + tmp1 = ad1ili(IL_QCON, stb.quad2); + /* assertion: no need for cse since sched treats multiple uses of + * the same function ili as one call. + */ + ilix = ad1ili(IL_QRCP, op2); + for (i = 2; i > 0; i--) { + tmp = ad2ili(IL_QMUL, op2, ilix); + tmp = ad2ili(IL_QSUB, tmp1, tmp); + ilix = ad2ili(IL_QMUL, ilix, tmp); + } + tmp = ad2ili(IL_QMUL, op2, ilix); + tmp = ad2ili(IL_QSUB, tmp1, tmp); + ilix = ad3ili(IL_QNEWT, (int)ilip->opnd[1], tmp, ilix); + ilix = ad2ili(IL_QMUL, op1, ilix); + return ilix; + + case IL_QNEWT: + /* since constant folding of the drcp instruction is not performed, + * the 2nd & 3rd operands are never constants + */ + if (ncons == 1) { + /* TBD - need to constant fold by recip(cons1) */ + GETVAL128(num2, cons1); + drcp(num2.numq, res.numq); + goto add_qcon; + } + newili.opnd[2] = ilip->opnd[2]; /* get 3rd operand */ + break; +#else /*} end: mult - recip */ + + op1 = ad3ili(IL_DAQP, op1, QP(0), ad1ili(IL_NULL, 0)); + op2 = ad3ili(IL_DAQP, op2, QP(1), op1); + ilix = ad2ili(IL_QJSR, _mkfunc(MTH_I_QDIV), op2); + ilix = ad2ili(IL_DFRQP, ilix, QP(0)); + return ilix; +#endif +#endif /*} no hardware divide */ + // AOCC end #if defined(TARGET_X8664) case IL_SCMPLXDIV: @@ -4361,6 +5443,12 @@ addarth(ILI *ilip) ilix = ad2func_cmplx(IL_QJSR, fast_math("div", 's', 'z', FMTH_I_CDDIV), op1, op2); return ad2altili(opc, op1, op2, ilix); + // AOCC begin + case IL_QCMPLXDIV: + ilix = ad2func_cmplx(IL_QJSR, fast_math("div", 's', 'q', FMTH_I_CQDIV), op1, + op2); + return ad2altili(opc, op1, op2, ilix); + // AOCC end #endif case IL_MOD: if (ncons == 3 && con2v2 != 0) { @@ -4499,8 +5587,20 @@ addarth(ILI *ilip) /* Can't constant fold until there is a utility routine */ break; #endif +#ifdef TM_QRCP + case IL_QRCP: + /* Can't constant fold until there is a utility routine */ + break; +#endif case IL_FMOD: + #ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("modff", "f pure", DT_FLOAT, 2, DT_FLOAT, DT_FLOAT); + ilix = ad_func(IL_DFRSP, IL_QJSR, "modff", 2, op1, op2); + return ad2altili(opc, op1, op2, ilix); + } +#endif #if defined(TARGET_X8664) if (!flg.ieee) { (void)mk_prototype(fast_math("mod", 's', 's', FMTH_I_AMOD), "f pure", @@ -4520,6 +5620,13 @@ addarth(ILI *ilip) return ilix; break; case IL_DMOD: + #ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("modf", "f pure", DT_DBLE, 2, DT_DBLE, DT_DBLE); + ilix = ad_func(IL_DFRDP, IL_QJSR, "modf", 2, op1, op2); + return ad2altili(opc, op1,op2, ilix); + } +#endif if (!flg.ieee) { #ifdef TARGET_X8664 (void)mk_prototype(fast_math("mod", 's', 'd', FMTH_I_DMOD), "f pure", @@ -4539,7 +5646,36 @@ addarth(ILI *ilip) ilix = ad2altili(opc, op1, op2, ilix); return ilix; + // AOCC begin + case IL_QMOD: + if (!flg.ieee) { +#ifdef TARGET_X8664 + (void)mk_prototype(fast_math("mod", 's', 'q', FMTH_I_QMOD), "f pure", + DT_QUAD, 2, DT_QUAD, DT_QUAD); +#else + (void)mk_prototype(MTH_I_QMOD, "f pure", DT_QUAD, 2, DT_QUAD, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, MTH_I_QMOD, 2, op1, op2); + ilix = ad2altili(opc, op1, op2, ilix); + return ilix; +#endif + ilix = ad_func(IL_DFRQP, IL_QJSR, fast_math("fmodq", 's', 'q', FMTH_I_QMOD), + 2, op1, op2); + } else { + (void)mk_prototype("fmodq", "f pure", DT_QUAD, 2, DT_QUAD, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, "fmodq", 2, op1, op2); + } + ilix = ad2altili(opc, op1, op2, ilix); + return ilix; + // AOCC end + case IL_FSINH: + #ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("sinhf", "f pure", DT_FLOAT, 1, DT_FLOAT); + ilix = ad_func(IL_DFRSP, IL_QJSR, "sinhf", 1, op1); + return ad1altili(opc, op1, ilix); + } +#endif if (XBIT_NEW_MATH_NAMES) { fname = make_math(MTH_sinh, &funcsptr, 1, false, DT_FLOAT, 1, DT_FLOAT); ilix = ad_func(IL_spfunc, IL_QJSR, fname, 1, op1); @@ -4567,6 +5703,13 @@ addarth(ILI *ilip) return ilix; case IL_DSINH: + #ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("sinh", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRSP, IL_QJSR, "sinh", 1, op1); + return ad1altili(opc, op1, ilix); + } +#endif if (XBIT_NEW_MATH_NAMES) { fname = make_math(MTH_sinh, &funcsptr, 1, false, DT_DBLE, 1, DT_DBLE); ilix = ad_func(IL_dpfunc, IL_QJSR, fname, 1, op1); @@ -4592,7 +5735,49 @@ addarth(ILI *ilip) ilix = ad1altili(opc, op1, ilix); return ilix; + // AOCC begin + case IL_DASINH: + #ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("asinh", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRSP, IL_QJSR, "asinh", 1, op1); + return ad1altili(opc, op1, ilix); + } +#endif + if (XBIT_NEW_MATH_NAMES) { + fname = make_math(MTH_sinh, &funcsptr, 1, false, DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_dpfunc, IL_QJSR, fname, 1, op1); + ilix = ad1altili(opc, op1, ilix); + return ilix; + } + if (!flg.ieee) { +#ifdef TARGET_X8664 + (void)mk_prototype(fast_math("asinh", 's', 'd', FMTH_I_DSINH), "f pure", + DT_DBLE, 1, DT_DBLE); +#else + (void)mk_prototype(MTH_I_DSINH, "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRDP, IL_QJSR, MTH_I_DSINH, 1, op1); + ilix = ad1altili(opc, op1, ilix); + return ilix; +#endif + ilix = ad_func(IL_DFRDP, IL_QJSR, + fast_math("asinh", 's', 'd', FMTH_I_DSINH), 1, op1); + } else { + (void)mk_prototype(MTH_I_DSINH, "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRDP, IL_QJSR, MTH_I_DSINH, 1, op1); + } + ilix = ad1altili(opc, op1, ilix); + return ilix; + // AOCC end + case IL_FCOSH: + #ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("coshf", "f pure", DT_FLOAT, 1, DT_FLOAT); + ilix = ad_func(IL_DFRSP, IL_QJSR, "coshf", 1, op1); + return ad1altili(opc, op1, ilix); + } +#endif if (XBIT_NEW_MATH_NAMES) { fname = make_math(MTH_cosh, &funcsptr, 1, false, DT_FLOAT, 1, DT_FLOAT); ilix = ad_func(IL_spfunc, IL_QJSR, fname, 1, op1); @@ -4619,6 +5804,13 @@ addarth(ILI *ilip) return ilix; case IL_DCOSH: + #ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("cosh", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRSP, IL_QJSR, "cosh", 1, op1); + return ad1altili(opc, op1, ilix); + } +#endif if (XBIT_NEW_MATH_NAMES) { fname = make_math(MTH_cosh, &funcsptr, 1, false, DT_DBLE, 1, DT_DBLE); ilix = ad_func(IL_dpfunc, IL_QJSR, fname, 1, op1); @@ -4643,8 +5835,51 @@ addarth(ILI *ilip) } ilix = ad1altili(opc, op1, ilix); return ilix; + //AOCC Begin + case IL_QCOSH: + (void)mk_prototype("coshq", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, "coshq", 1, op1); + return ad1altili(opc, op1, ilix); + break; + + case IL_QSINH: + (void)mk_prototype("sinhq", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, "sinhq", 1, op1); + return ad1altili(opc, op1, ilix); + break; + case IL_QTANH: + (void)mk_prototype("tanhq", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, "tanhq", 1, op1); + return ad1altili(opc, op1, ilix); + break; + //AOCC End + + //AOCC Begin + case IL_QACOSH: + (void)mk_prototype("acoshq", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, "acoshq", 1, op1); + return ad1altili(opc, op1, ilix); + break; + case IL_QASINH: + (void)mk_prototype("asinhq", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, "asinhq", 1, op1); + return ad1altili(opc, op1, ilix); + break; + case IL_QATANH: + (void)mk_prototype("atanhq", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, "atanhq", 1, op1); + return ad1altili(opc, op1, ilix); + break; + //AOCC End case IL_FTANH: + #ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("tanhf", "f pure", DT_FLOAT, 1, DT_FLOAT); + ilix = ad_func(IL_DFRSP, IL_QJSR, "tanhf", 1, op1); + return ad1altili(opc, op1, ilix); + } +#endif if (XBIT_NEW_MATH_NAMES) { fname = make_math(MTH_tanh, &funcsptr, 1, false, DT_FLOAT, 1, DT_FLOAT); ilix = ad_func(IL_spfunc, IL_QJSR, fname, 1, op1); @@ -4657,6 +5892,13 @@ addarth(ILI *ilip) return ilix; case IL_DTANH: + #ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("tanh", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRSP, IL_QJSR, "tanh", 1, op1); + return ad1altili(opc, op1, ilix); + } +#endif if (XBIT_NEW_MATH_NAMES) { fname = make_math(MTH_tanh, &funcsptr, 1, false, DT_DBLE, 1, DT_DBLE); ilix = ad_func(IL_dpfunc, IL_QJSR, fname, 1, op1); @@ -4902,6 +6144,40 @@ addarth(ILI *ilip) } break; + // AOCC begin + case IL_QCMP: + newili.opnd[2] = ilip->opnd[2]; +#ifdef TM_QCMPZ + if (ncons == 2 && is_quad0(cons2)) + return ad2ili(IL_QCMPZ, op1, (int)ilip->opnd[2]); + if (ncons == 1 && is_quad0(cons1)) + return ad2ili(IL_QCMPZ, op2, commute_cc(ilip->opnd[2])); +#else + if (ncons == 1 && is_quad0(cons1)) + return ad3ili(IL_QCMP, op2, op1, + commute_cc(CCRelationILIOpnd(ilip, 2))); +#endif + if (ncons == 2 && ILI_OPC(op1) == IL_QUAD) { + ilix = QuadIsSingle(cons2); + if (ilix) { + return ad3ili(IL_FCMP, ILI_OPND(op1, 1), ilix, ilip->opnd[2]); + } + } + if (!flg.ieee) { + if (ncons == 3) { + GETVAL128(num1, cons1); + GETVAL128(num2, cons2); + res.numi[1] = + cmp_to_log(xqcmp(num1.numq, num2.numq), (int)ilip->opnd[2]); + goto add_icon; + } + if (op1 == op2 && !func_in(op1)) { + res.numi[1] = cmp_to_log((INT)0, (int)ilip->opnd[2]); + goto add_icon; + } + } + break; + // AOCC end case IL_ACMP: newili.opnd[2] = ilip->opnd[2]; if (ncons == 2 && con2v2 == 0 && con2v1 == 0) { @@ -4967,6 +6243,30 @@ addarth(ILI *ilip) } break; #endif + // AOCC begin + case IL_QMAX: + if (ncons == 3) { + GETVAL128(num1, cons1); + GETVAL128(num2, cons2); + if (xqcmp(num1.numq, num2.numq) > 0) + return op1; + return op2; + } + if (!flg.ieee) + return red_minmax(opc, op1, op2); + break; + case IL_QMIN: + if (ncons == 3) { + GETVAL128(num1, cons1); + GETVAL128(num2, cons2); + if (xqcmp(num1.numq, num2.numq) < 0) + return op1; + return op2; + } + if (!flg.ieee) + return red_minmax(opc, op1, op2); + break; + // AOCC end case IL_AND: if (ncons == 2) { @@ -5280,8 +6580,8 @@ addarth(ILI *ilip) goto add_icon; } } -#ifdef TM_SHIFTAR - opc = IL_LSHIFTA; +#ifdef TM_SHIFTBR + opc = IL_LSHIFTB; op2 = ad1ili(IL_IAMV, op2); #endif break; @@ -5302,13 +6602,13 @@ addarth(ILI *ilip) goto add_icon; } } -#ifdef TM_SHIFTAR - opc = IL_RSHIFTA; +#ifdef TM_SHIFTBR + opc = IL_RSHIFTB; op2 = ad1ili(IL_IAMV, op2); #endif break; -#ifdef TM_SHIFTAR - case IL_SHIFTA: +#ifdef TM_SHIFTBR + case IL_SHIFTB: break; #endif @@ -5328,8 +6628,8 @@ addarth(ILI *ilip) goto add_icon; } } -#ifdef TM_SHIFTAR - opc = IL_ULSHIFTA; +#ifdef TM_SHIFTBR + opc = IL_ULSHIFTB; op2 = ad1ili(IL_IAMV, op2); #endif break; @@ -5354,13 +6654,13 @@ addarth(ILI *ilip) goto add_icon; } } -#ifdef TM_SHIFTAR - opc = IL_URSHIFTA; +#ifdef TM_SHIFTBR + opc = IL_URSHIFTB; op2 = ad1ili(IL_IAMV, op2); #endif break; -#ifdef TM_SHIFTAR - case IL_USHIFTA: +#ifdef TM_SHIFTBR + case IL_USHIFTB: break; #endif case IL_ARSHIFT: @@ -5379,8 +6679,8 @@ addarth(ILI *ilip) goto add_icon; } } -#ifdef TM_SHIFTAR - opc = IL_ARSHIFTA; +#ifdef TM_SHIFTBR + opc = IL_ARSHIFTB; op2 = ad1ili(IL_IAMV, op2); #endif break; @@ -5450,6 +6750,7 @@ addarth(ILI *ilip) case IL_CSEAR: case IL_CSECS: case IL_CSECD: + case IL_CSECQ: // AOCC #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128CSE: #endif @@ -5609,7 +6910,56 @@ addarth(ILI *ilip) #endif break; + /* AOCC begin */ + case IL_FCOTAN: + #ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("cotanf", "f pure", DT_FLOAT, 1, DT_FLOAT); + ilix = ad_func(IL_DFRSP, IL_QJSR, "cotanf", 1, op1); + return ad1altili(opc, op1, ilix); + } +#endif + if (XBIT_NEW_MATH_NAMES) { + fname = make_math(MTH_cotan, &funcsptr, 1, false, DT_FLOAT, 1, DT_FLOAT); + ilix = ad_func(IL_spfunc, IL_QJSR, fname, 1, op1); + ilix = ad1altili(opc, op1, ilix); + return ilix; + } +#if defined(TARGET_X8664) + if (!flg.ieee && TEST_FEATURE(FEATURE_AVX)) { + (void)mk_prototype(relaxed_math("cotan", 's', 's', MTH_I_COTAN), "f pure", + DT_FLOAT, 1, DT_FLOAT); + ilix = ad_func(IL_DFRSP, IL_QJSR, + relaxed_math("cotan", 's', 's', MTH_I_COTAN), 1, op1); + ilix = ad1altili(opc, op1, ilix); + return ilix; + } +#endif +#if defined(TARGET_POWER) + if (flg.ieee) { + (void)mk_prototype(MTH_I_COTAN, "f pure", DT_FLOAT, 1, DT_FLOAT); + ilix = ad_func(IL_DFRSP, IL_QJSR, MTH_I_COTAN, 1, op1); + } else { + (void)mk_prototype(fast_math("cotan", 's', 's', MTH_I_COTAN), "f pure", + DT_FLOAT, 1, DT_FLOAT); + ilix = ad_func(IL_DFRSP, IL_QJSR, fast_math("cotan", 's', 's', MTH_I_COTAN), + 1, op1); + } + return ad1altili(opc, op1, ilix); +#else + (void)mk_prototype(MTH_I_COTAN, "f pure", DT_FLOAT, 1, DT_FLOAT); + ilix = ad_func(IL_spfunc, IL_QJSR, MTH_I_COTAN, 1, op1); + return ad1altili(opc, op1, ilix); +#endif + /* AOCC end */ case IL_FTAN: + #ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("tanf", "f pure", DT_FLOAT, 1, DT_FLOAT); + ilix = ad_func(IL_DFRSP, IL_QJSR, "tanf", 1, op1); + return ad1altili(opc, op1, ilix); + } +#endif if (XBIT_NEW_MATH_NAMES) { fname = make_math(MTH_tan, &funcsptr, 1, false, DT_FLOAT, 1, DT_FLOAT); ilix = ad_func(IL_spfunc, IL_QJSR, fname, 1, op1); @@ -5643,7 +6993,64 @@ addarth(ILI *ilip) return ad1altili(opc, op1, ilix); #endif + /* AOCC begin */ + case IL_DCOTAN: + #ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("cotan", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRSP, IL_QJSR, "cotan", 1, op1); + return ad1altili(opc, op1, ilix); + } +#endif + if (XBIT_NEW_MATH_NAMES) { + fname = make_math(MTH_cotan, &funcsptr, 1, false, DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_dpfunc, IL_QJSR, fname, 1, op1); + ilix = ad1altili(opc, op1, ilix); + return ilix; + } +#if defined(TARGET_X8664) + if (!flg.ieee && TEST_FEATURE(FEATURE_AVX)) { + if (!XBIT(36, 0x04)) { + (void)mk_prototype(fast_math("cotan", 's', 'd', MTH_I_DCOTAN), "f pure", + DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRDP, IL_QJSR, + fast_math("cotan", 's', 'd', MTH_I_DCOTAN), 1, op1); + } else { + (void)mk_prototype(relaxed_math("cotan", 's', 'd', MTH_I_DCOTAN), "f pure", + DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRDP, IL_QJSR, + relaxed_math("cotan", 's', 'd', MTH_I_DCOTAN), 1, op1); + } + ilix = ad1altili(opc, op1, ilix); + return ilix; + } +#endif +#if defined(TARGET_POWER) + if (flg.ieee) { + (void)mk_prototype(MTH_I_DCOTAN, "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRDP, IL_QJSR, MTH_I_DCOTAN, 1, op1); + } else { + (void)mk_prototype(fast_math("cotan", 's', 'd', MTH_I_DCOTAN), "f pure", + DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRDP, IL_QJSR, fast_math("cotan", 's', 'd', MTH_I_DCOTAN), + 1, op1); + } + return ad1altili(opc, op1, ilix); +#else + (void)mk_prototype(MTH_I_DCOTAN, "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_dpfunc, IL_QJSR, MTH_I_DCOTAN, 1, op1); + return ad1altili(opc, op1, ilix); +#endif + /* AOCC end */ + case IL_DTAN: + #ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("tan", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRSP, IL_QJSR, "tan", 1, op1); + return ad1altili(opc, op1, ilix); + } +#endif if (XBIT_NEW_MATH_NAMES) { fname = make_math(MTH_tan, &funcsptr, 1, false, DT_DBLE, 1, DT_DBLE); ilix = ad_func(IL_dpfunc, IL_QJSR, fname, 1, op1); @@ -5683,8 +7090,27 @@ addarth(ILI *ilip) ilix = ad_func(IL_dpfunc, IL_QJSR, MTH_I_DTAN, 1, op1); return ad1altili(opc, op1, ilix); #endif - + //AOCC Begin + case IL_QTAN: + #ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("tan", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, "tan", 1, op1); + return ad1altili(opc, op1, ilix); + } +#endif + (void)mk_prototype("tanq", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, "tanq", 1, op1); + return ad1altili(opc, op1, ilix); + //AOCC End case IL_FATAN: + #ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("atanf", "f pure", DT_FLOAT, 1, DT_FLOAT); + ilix = ad_func(IL_DFRQP, IL_QJSR, "atanf", 1, op1); + return ad1altili(opc, op1, ilix); + } +#endif if (ncons == 1) { xfatan(con1v2, &res.numi[1]); goto add_rcon; @@ -5723,6 +7149,14 @@ addarth(ILI *ilip) break; case IL_DATAN: + #ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && + (gbl.ompaccel_intarget || OMPACCFUNCDEVG(gbl.currsub))) { + (void)mk_prototype("atan", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRQP, IL_QJSR, "atan", 1, op1); + return ad1altili(opc, op1, ilix); + } +#endif if (ncons == 1) { GETVAL64(num1, cons1); xdatan(num1.numd, res.numd); @@ -5763,6 +7197,13 @@ addarth(ILI *ilip) break; case IL_FACOS: + #ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("acosf", "f pure", DT_FLOAT, 1, DT_FLOAT); + ilix = ad_func(IL_DFRQP, IL_QJSR, "acosf", 1, op1); + return ad1altili(opc, op1, ilix); + } +#endif if (XBIT_NEW_MATH_NAMES) { fname = make_math(MTH_acos, &funcsptr, 1, false, DT_FLOAT, 1, DT_FLOAT); ilix = ad_func(IL_spfunc, IL_QJSR, fname, 1, op1); @@ -5775,6 +7216,13 @@ addarth(ILI *ilip) break; case IL_FASIN: + #ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("asinf", "f pure", DT_FLOAT, 1, DT_FLOAT); + ilix = ad_func(IL_DFRQP, IL_QJSR, "asinf", 1, op1); + return ad1altili(opc, op1, ilix); + } +#endif if (XBIT_NEW_MATH_NAMES) { fname = make_math(MTH_asin, &funcsptr, 1, false, DT_FLOAT, 1, DT_FLOAT); ilix = ad_func(IL_spfunc, IL_QJSR, fname, 1, op1); @@ -5787,6 +7235,13 @@ addarth(ILI *ilip) break; case IL_FATAN2: + #ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("atan2f", "f pure", DT_FLOAT, 2, DT_FLOAT, DT_FLOAT); + ilix = ad_func(IL_DFRQP, IL_QJSR, "atan2f", 2, op1, op2); + return ad2altili(opc, op1, op2, ilix); + } +#endif if (XBIT_NEW_MATH_NAMES) { fname = make_math(MTH_atan2, &funcsptr, 1, false, DT_FLOAT, 2, DT_FLOAT, DT_FLOAT); @@ -5800,6 +7255,13 @@ addarth(ILI *ilip) break; case IL_DACOS: + #ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("acos", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRQP, IL_QJSR, "acos", 1, op1); + return ad1altili(opc, op1, ilix); + } +#endif if (XBIT_NEW_MATH_NAMES) { fname = make_math(MTH_acos, &funcsptr, 1, false, DT_DBLE, 1, DT_DBLE); ilix = ad_func(IL_dpfunc, IL_QJSR, fname, 1, op1); @@ -5812,6 +7274,14 @@ addarth(ILI *ilip) break; case IL_DASIN: + #ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && + (gbl.ompaccel_intarget || OMPACCFUNCDEVG(gbl.currsub))) { + (void)mk_prototype("asin", "f pure", DT_DBLE, 1, DT_DBLE); + ilix = ad_func(IL_DFRQP, IL_QJSR, "asin", 1, op1); + return ad1altili(opc, op1, ilix); + } +#endif if (XBIT_NEW_MATH_NAMES) { fname = make_math(MTH_asin, &funcsptr, 1, false, DT_DBLE, 2, DT_DBLE, DT_DBLE); @@ -5825,6 +7295,13 @@ addarth(ILI *ilip) break; case IL_DATAN2: + #ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + (void)mk_prototype("atan2", "f pure", DT_DBLE, 2, DT_DBLE, DT_DBLE); + ilix = ad_func(IL_DFRQP, IL_QJSR, "atan2", 2, op1, op2); + return ad2altili(opc, op1, op2, ilix); + } +#endif if (XBIT_NEW_MATH_NAMES) { fname = make_math(MTH_atan2, &funcsptr, 1, false, DT_DBLE, 2, DT_DBLE, DT_DBLE); @@ -5836,7 +7313,30 @@ addarth(ILI *ilip) ilix = ad_func(IL_DFRDP, IL_QJSR, MTH_I_DATAN2, 2, op1, op2); return ad2altili(opc, op1, op2, ilix); break; + //AOCC Begin + case IL_QACOS: + (void)mk_prototype("acosq", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, "acosq", 1, op1); + return ad1altili(opc, op1, ilix); + break; + case IL_QASIN: + (void)mk_prototype("asinq", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, "asinq", 1, op1); + return ad1altili(opc, op1, ilix); + break; + + case IL_QATAN: + (void)mk_prototype("atanq", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, "atanq", 1, op1); + return ad1altili(opc, op1, ilix); + break; + case IL_QATAN2: + (void)mk_prototype("atan2q", "f pure", DT_QUAD, 2, DT_QUAD, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, "atan2q", 2, op1,op2); + return ad2altili(opc, op1,op2, ilix); + break; + //AOCC End case IL_FLOG: if (XBIT_NEW_MATH_NAMES) { fname = make_math(MTH_log, &funcsptr, 1, false, DT_FLOAT, 1, DT_FLOAT); @@ -6080,6 +7580,62 @@ addarth(ILI *ilip) #endif #endif /*if !defined(PGOCL) && !defined(TARGET_LLVM_ARM) */ break; + // AOCC begin + case IL_QEXP: + if (ncons == 1 && is_quad0(cons1)) { + GETVAL128(res, stb.quad1); + goto add_qcon; + } + if (XBIT_NEW_MATH_NAMES) { + fname = make_math(MTH_exp, &funcsptr, 1, false, DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_qpfunc, IL_QJSR, fname, 1, op1); + ilix = ad1altili(opc, op1, ilix); + return ilix; + } +#if defined(TARGET_X8664) + if (!flg.ieee) { + if (XBIT_NEW_RELAXEDMATH) { + (void)mk_prototype(relaxed_math("exp", 's', 'q', FMTH_I_QEXP), "f pure", + DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, + relaxed_math("exp", 's', 'q', FMTH_I_QEXP), 1, op1); + } else { +/* + * try the new naming convention -- only for exp + */ + (void)mk_prototype(gnr_math("exp", 's', 'q', FMTH_I_QEXP, 0), "f pure", + DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, + gnr_math("exp", 's', 'q', FMTH_I_QEXP, 0), 1, op1); + } + } else { + (void)mk_prototype(MTH_I_QEXP, "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, MTH_I_QEXP, 1, op1); + } + ilix = ad1altili(opc, op1, ilix); + return ilix; +#endif +#if !defined(PGOCL) && !defined(TARGET_LLVM_ARM) +#if defined(TARGET_POWER) + if (flg.ieee) { + (void)mk_prototype(MTH_I_QEXP, "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, MTH_I_QEXP, 1, op1); + } else { + (void)mk_prototype(fast_math("exp", 's', 'q', MTH_I_QEXP), "f pure", + DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, fast_math("exp", 's', 'q', MTH_I_QEXP), + 1, op1); + } + return ad1altili(opc, op1, ilix); +#else + (void)mk_prototype(MTH_I_QEXP, "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_qpfunc, IL_QJSR, MTH_I_QEXP, 1, op1); + ilix = ad1altili(opc, op1, ilix); + return ilix; +#endif +#endif /*if !defined(PGOCL) && !defined(TARGET_LLVM_ARM) */ + break; + // AOCC end /* * getting here for the ensuing cmplex intrinsics means XBIT_NEW_MATH_NAMES @@ -6101,6 +7657,12 @@ addarth(ILI *ilip) ilix = ad1mathfunc_cmplx(MTH_tan, opc, op1, DT_CMPLX, DT_CMPLX); return ilix; + /* AOCC begin */ + case IL_SCMPLXCOTAN: + ilix = ad1mathfunc_cmplx(MTH_cotan, opc, op1, DT_CMPLX, DT_CMPLX); + return ilix; + /* AOCC end */ + case IL_SCMPLXACOS: ilix = ad1mathfunc_cmplx(MTH_acos, opc, op1, DT_CMPLX, DT_CMPLX); return ilix; @@ -6166,6 +7728,12 @@ addarth(ILI *ilip) ilix = ad1mathfunc_cmplx(MTH_tan, opc, op1, DT_DCMPLX, DT_DCMPLX); return ilix; + /* AOCC begin */ + case IL_DCMPLXCOTAN: + ilix = ad1mathfunc_cmplx(MTH_cotan, opc, op1, DT_DCMPLX, DT_DCMPLX); + return ilix; + /* AOCC end */ + case IL_DCMPLXACOS: ilix = ad1mathfunc_cmplx(MTH_acos, opc, op1, DT_DCMPLX, DT_DCMPLX); return ilix; @@ -6221,23 +7789,123 @@ addarth(ILI *ilip) return ilix; break; - case IL_DJN: - (void)mk_prototype(MTH_I_DJN, "f pure", DT_DBLE, 2, DT_INT, DT_DBLE); - ilix = ad_func(IL_dpfunc, IL_QJSR, MTH_I_DJN, 2, op1, op2); + case IL_DJN: + (void)mk_prototype(MTH_I_DJN, "f pure", DT_DBLE, 2, DT_INT, DT_DBLE); + ilix = ad_func(IL_dpfunc, IL_QJSR, MTH_I_DJN, 2, op1, op2); + return ilix; + break; + + case IL_QJN: + (void)mk_prototype(MTH_I_QJN, "f pure", DT_QUAD, 2, DT_INT, DT_QUAD); + ilix = ad_func(IL_dpfunc, IL_QJSR, MTH_I_QJN, 2, op1, op2); + return ilix; + break; + + case IL_YN: + (void)mk_prototype(MTH_I_YN, "f pure", DT_FLOAT, 2, DT_INT, DT_FLOAT); + ilix = ad_func(IL_spfunc, IL_QJSR, MTH_I_YN, 2, op1, op2); + return ilix; + break; + + case IL_DYN: + (void)mk_prototype(MTH_I_DYN, "f pure", DT_DBLE, 2, DT_INT, DT_DBLE); + ilix = ad_func(IL_dpfunc, IL_QJSR, MTH_I_DYN, 2, op1, op2); + return ilix; + break; + case IL_QYN: + (void)mk_prototype(MTH_I_QYN, "f pure", DT_QUAD, 2, DT_INT, DT_QUAD); + ilix = ad_func(IL_dpfunc, IL_QJSR, MTH_I_DYN, 2, op1, op2); + return ilix; + break; + + // AOCC begin + case IL_QCMPLXEXP: + ilix = ad1mathfunc_cmplx(MTH_exp, opc, op1, DT_QCMPLX, DT_QCMPLX); + return ilix; + break; + + case IL_QCMPLXCOS: + ilix = ad1mathfunc_cmplx(MTH_cos, opc, op1, DT_QCMPLX, DT_QCMPLX); + return ilix; + break; + + case IL_QCMPLXSIN: + ilix = ad1mathfunc_cmplx(MTH_sin, opc, op1, DT_QCMPLX, DT_QCMPLX); + return ilix; + break; + + /* AOCC begin */ + case IL_QCMPLXCOTAN: + ilix = ad1mathfunc_cmplx(MTH_cotan, opc, op1, DT_QCMPLX, DT_QCMPLX); + return ilix; + break; + /* AOCC end */ + + case IL_QCMPLXTAN: + ilix = ad1mathfunc_cmplx(MTH_tan, opc, op1, DT_QCMPLX, DT_QCMPLX); + return ilix; + break; + + case IL_QCMPLXACOS: + ilix = ad1mathfunc_cmplx(MTH_acos, opc, op1, DT_QCMPLX, DT_QCMPLX); + return ilix; + break; + + case IL_QCMPLXASIN: + ilix = ad1mathfunc_cmplx(MTH_asin, opc, op1, DT_QCMPLX, DT_QCMPLX); + return ilix; + break; + + case IL_QCMPLXATAN: + ilix = ad1mathfunc_cmplx(MTH_atan, opc, op1, DT_QCMPLX, DT_QCMPLX); + return ilix; + break; + + case IL_QCMPLXCOSH: + ilix = ad1mathfunc_cmplx(MTH_cosh, opc, op1, DT_QCMPLX, DT_QCMPLX); + return ilix; + break; + + case IL_QCMPLXSINH: + ilix = ad1mathfunc_cmplx(MTH_sinh, opc, op1, DT_QCMPLX, DT_QCMPLX); + return ilix; + break; + + case IL_QCMPLXTANH: + ilix = ad1mathfunc_cmplx(MTH_tanh, opc, op1, DT_QCMPLX, DT_QCMPLX); + return ilix; + break; + + case IL_QCMPLXLOG: + ilix = ad1mathfunc_cmplx(MTH_log, opc, op1, DT_QCMPLX, DT_QCMPLX); + return ilix; + break; + + case IL_QCMPLXSQRT: + ilix = ad1mathfunc_cmplx(MTH_sqrt, opc, op1, DT_QCMPLX, DT_QCMPLX); + return ilix; + break; + + case IL_QCMPLXPOW: + ilix = ad2mathfunc_cmplx(MTH_pow, opc, op1, op2, DT_QCMPLX, DT_QCMPLX, + DT_QCMPLX); return ilix; break; - case IL_YN: - (void)mk_prototype(MTH_I_YN, "f pure", DT_FLOAT, 2, DT_INT, DT_FLOAT); - ilix = ad_func(IL_spfunc, IL_QJSR, MTH_I_YN, 2, op1, op2); + case IL_QCMPLXPOWI: + /**** ad2mathfunc_cmplx needs WORK for the integer argument ****/ + ilix = ad2mathfunc_cmplx(MTH_powi, opc, op1, op2, DT_QCMPLX, DT_QCMPLX, + DT_INT); return ilix; break; - case IL_DYN: - (void)mk_prototype(MTH_I_DYN, "f pure", DT_DBLE, 2, DT_INT, DT_DBLE); - ilix = ad_func(IL_dpfunc, IL_QJSR, MTH_I_DYN, 2, op1, op2); + case IL_QCMPLXPOWK: + /**** ad2mathfunc_cmplx needs WORK for the integer argument ****/ + ilix = ad2mathfunc_cmplx(MTH_powk, opc, op1, op2, DT_QCMPLX, DT_QCMPLX, + DT_INT8); return ilix; break; + // AOCC end case IL_IPOWI: if (ncons == 3) { @@ -6246,7 +7914,10 @@ addarth(ILI *ilip) } if (ncons == 1 && con1v2 == 2) { tmp1 = ad_icon(1); - tmp1 = ad2ili(IL_LSHIFT, tmp1, op2); + // AOCC Modification : Using 64 bit shl to be safe. Because 2**32 + // expands to (i32) 1 << 32 which is invalid. + // So using (i64) 1 << 32 + tmp1 = ad2ili(IL_KLSHIFT, tmp1, op2); /* generate ili which computes (((1)<>31)) */ tmp = ad_icon(31); tmp = ad2ili(IL_ARSHIFT, op2, tmp); @@ -6327,11 +7998,49 @@ addarth(ILI *ilip) return ilix; } } + // AOCC Begin + // for constant int exponent values of 1,2,-1,-2 generate llvm intrinsic + // this will help in vectorizatio of few loops + if (flg.use_llvm_math_intrin && (IL_TYPE(ILI_OPC(op2)) == ILTY_CONS)) { + if ((con2v2 == 1) || (con2v2 == 2) || (con2v2 == -1) || (con2v2 == -2)) { + INT tmp[4]; + int newili; + tmp[0] = 0; + if (con2v2 == 1) { + atoxf("1.0", &tmp[1], 3); + } else if (con2v2 == 2) { + atoxf("2.0", &tmp[1], 3); + } else if (con2v2 == -1) { + atoxf("-1.0", &tmp[1], 3); + } else if (con2v2 == -2) { + atoxf("-2.0", &tmp[1], 3); + } + newili=ad1ili(IL_FCON, getcon(tmp, DT_FLOAT)); + (void)mk_prototype("llvm.pow.f32", "f pure", DT_FLOAT, 2, DT_FLOAT, DT_FLOAT); + ilix = ad_func(IL_spfunc, IL_QJSR, "llvm.pow.f32", 2, op1, newili); + ilix = ad2altili(opc, op1,newili , ilix); + return ilix; + } + } + // AOCC End if (XBIT_NEW_MATH_NAMES) { - fname = make_math(MTH_powi, &funcsptr, 1, false, DT_FLOAT, 2, DT_FLOAT, - DT_INT); - ilix = ad_func(IL_spfunc, IL_QJSR, fname, 2, op1, op2); - ilix = ad2altili(opc, op1, op2, ilix); +#ifdef OMP_OFFLOAD_AMD + // Do not generate call to pgmath x86 function + // Use function which is available on the device + if (flg.amdgcn_target && gbl.ompaccel_intarget) { + fname = "powif"; + funcsptr = mk_prototype(fname, "f pure", DT_FLOAT, 2, DT_FLOAT, DT_INT); + ilix = ad_func(IL_spfunc, IL_QJSR, fname, 2, op1, op2); + ilix = ad2altili(opc, op1, op2, ilix); + } + else +#endif + { + fname = make_math(MTH_powi, &funcsptr, 1, false, DT_FLOAT, 2, DT_FLOAT, + DT_INT); + ilix = ad_func(IL_spfunc, IL_QJSR, fname, 2, op1, op2); + ilix = ad2altili(opc, op1, op2, ilix); + } return ilix; } (void)mk_prototype(MTH_I_RPOWI, "f pure", DT_FLOAT, 2, DT_FLOAT, DT_INT); @@ -6470,6 +8179,21 @@ addarth(ILI *ilip) ilix = ad_func(IL_dpfunc, IL_QJSR, MTH_I_DPOWI, 2, op1, op2); ilix = ad2altili(opc, op1, op2, ilix); return ilix; + + case IL_QPOWI: + if ((!flg.ieee || con2v2 == 1 || con2v2 == 2) + && ncons >= 2 && !XBIT(124, 0x200)) { + if (con2v2 == 1) + return op1; + if (con2v2 > 1 && con2v2 <= __MAXPOW) { + ilix = _xpowi(op1, con2v2, IL_QMUL); + return ilix; + } + } + (void)mk_prototype(MTH_I_QPOWI, "f pure", DT_QUAD, 2, DT_QUAD, DT_INT); + ilix = ad_func(IL_qpfunc, IL_QJSR, MTH_I_QPOWI, 2, op1, op2); + ilix = ad2altili(opc, op1, op2, ilix); + return ilix; case IL_DPOWK: if ((!flg.ieee || con2v2 == 1 || con2v2 == 2) && ncons >= 2 && !XBIT(124, 0x200) && con2v1 == 0) { @@ -6641,6 +8365,21 @@ addarth(ILI *ilip) ilix = ad1altili(opc, op1, ilix); return ilix; + // AOCC begin + case IL_ITRAILZI: + op2 = ad_icon(_ipowi(2, op2)); + ilix = ad_func(IL_DFRIR, IL_QJSR, MTH_I_ITRAILZI, 2, op1, op2); + ilix = ad2altili(opc, op1, op2, ilix); + return ilix; + case IL_ITRAILZ: + ilix = ad_func(IL_DFRIR, IL_QJSR, MTH_I_ITRAILZ, 1, op1); + ilix = ad1altili(opc, op1, ilix); + return ilix; + case IL_KTRAILZ: + ilix = ad_func(IL_DFRKR, IL_QJSR, MTH_I_KTRAILZ, 1, op1); + ilix = ad1altili(opc, op1, ilix); + return ilix; + // AOCC end case IL_IPOPCNTI: op2 = ad_icon(_ipowi(2, op2)); ilix = ad_func(IL_DFRIR, IL_QJSR, MTH_I_IPOPCNTI, 2, op1, op2); @@ -7011,6 +8750,7 @@ addarth(ILI *ilip) ilix = ad_func(IL_spfunc, IL_QJSR, MTH_I_FCEIL, 1, op1); return ad1altili(opc, op1, ilix); } + #else else interr("addarth: old math name for ili not handled", @@ -7038,6 +8778,13 @@ addarth(ILI *ilip) #endif break; + // AOCC Begin + case IL_QCEIL: + (void)mk_prototype("ceilq", "f pure", DT_QUAD, 1, DT_QUAD); + ilix = ad_func(IL_DFRQP, IL_QJSR, "ceilq", 1, op1); + return ad1altili(opc, op1, ilix); + // AOCC End + case IL_FFLOOR: if (XBIT_NEW_MATH_NAMES) { fname = make_math(MTH_floor, &funcsptr, 1, false, DT_FLOAT, 1, DT_FLOAT); @@ -7145,6 +8892,11 @@ addarth(ILI *ilip) add_dcon: return ad1ili(IL_DCON, getcon(res.numi, DT_DBLE)); + +// AOCC +add_qcon: + return ad1ili(IL_QCON, getcon(res.numi, DT_QUAD)); + } static int @@ -7791,6 +9543,27 @@ addother(ILI *ilip) ILI_ALT(ilix) = op1; iltb.callfg = 1; return ilix; + // AOCC begin + case IL_QPQP2QCMPLXI0: + op1 = ilip->opnd[0]; + if (ILI_OPC(op1) == IL_QCON) { + INT numi[2]; + numi[0] = ILI_OPND(op1, 1); + numi[1] = stb.quad0; + return ad1ili(IL_QCMPLXCON, getcon(numi, DT_QCMPLX)); + } + break; + case IL_QPQP2QCMPLX: + op1 = ilip->opnd[0]; + op2 = ilip->opnd[1]; + if (ILI_OPC(op1) == IL_QCON && ILI_OPC(op2) == IL_QCON) { + INT numi[2]; + numi[0] = ILI_OPND(op1, 1); + numi[1] = ILI_OPND(op2, 1); + return ad1ili(IL_QCMPLXCON, getcon(numi, DT_QCMPLX)); + } + break; + // AOCC end case IL_DPDP2DCMPLXI0: op1 = ilip->opnd[0]; if (ILI_OPC(op1) == IL_DCON) { @@ -7829,6 +9602,26 @@ addother(ILI *ilip) return ad1ili(IL_SCMPLXCON, getcon(numi, DT_CMPLX)); } break; + // AOCC begin + case IL_QCMPLX2REAL: + op1 = ilip->opnd[0]; + if (ILI_OPC(op1) == IL_QPQP2QCMPLX || ILI_OPC(op1) == IL_QPQP2QCMPLXI0) { + return ILI_OPND(op1, 1); + } else if (ILI_OPC(op1) == IL_QCMPLXCON) { + return ad1ili(IL_QCON, CONVAL1G(ILI_OPND(op1, 1))); + } + break; + case IL_QCMPLX2IMAG: + op1 = ilip->opnd[0]; + if (ILI_OPC(op1) == IL_QPQP2QCMPLX) { + return ILI_OPND(op1, 2); + } else if (ILI_OPC(op1) == IL_QPQP2QCMPLXI0) { + return ad1ili(IL_QCON, stb.quad0); + } else if (ILI_OPC(op1) == IL_QCMPLXCON) { + return ad1ili(IL_QCON, CONVAL2G(ILI_OPND(op1, 1))); + } + break; + // AOCC end case IL_DCMPLX2REAL: op1 = ilip->opnd[0]; if (ILI_OPC(op1) == IL_DPDP2DCMPLX || ILI_OPC(op1) == IL_DPDP2DCMPLXI0) { @@ -7951,9 +9744,11 @@ addbran(ILI *ilip) case IL_FCMPZ: /* ILI, switch to the ILI which does the */ case IL_DCMPZ: /* integer compare with zero and branches */ case IL_ACMPZ: /* if the condition is met */ + case IL_QCMPZ: /* AOCC: intefer compare */ case IL_ICMP: case IL_FCMP: case IL_DCMP: + case IL_QCMP: // AOCC case IL_ACMP: #if defined(TARGET_X8664) case IL_KCMPZ: @@ -8034,6 +9829,14 @@ addbran(ILI *ilip) break; return ad3ili(IL_DCJMPZ, ILI_OPND(op1, 1), new_cond, ilip->opnd[2]); + // AOCC begin + case IL_QCMPZ: + new_cond = combine_int_ccs(CC_ILI_OPND(op1, 2), cc_op2); + if (new_cond == 0) + break; + return ad3ili(IL_QCJMPZ, ILI_OPND(op1, 1), new_cond, ilip->opnd[2]); + // AOCC end + case IL_ACMPZ: new_cond = combine_int_ccs(CC_ILI_OPND(op1, 2), cc_op2); if (new_cond == 0) @@ -8084,6 +9887,16 @@ addbran(ILI *ilip) break; return ad4ili(IL_DCJMP, ILI_OPND(op1, 1), ILI_OPND(op1, 2), new_cond, ilip->opnd[2]); + // AOCC begin + case IL_QCMP: + new_cond = (!IEEE_CMP) + ? combine_int_ccs(CC_ILI_OPND(op1, 3), cc_op2) + : combine_ieee_ccs(CC_ILI_OPND(op1, 3), cc_op2); + if (new_cond == 0) + break; + return ad4ili(IL_QCJMP, ILI_OPND(op1, 1), ILI_OPND(op1, 2), new_cond, + ilip->opnd[2]); + // AOCC end case IL_ACMP: if ((new_cond = combine_int_ccs(CC_ILI_OPND(op1, 3), cc_op2)) == @@ -8463,6 +10276,37 @@ addbran(ILI *ilip) if (!IEEE_CMP) goto cjmp_2; /* check if operands are identical */ break; + // AOCC begin + case IL_QCJMP: +#if defined(TARGET_X86) + if (mach.feature[FEATURE_SCALAR_SSE]) { + /* scalar sse code gen. don't use QCJMPZ; it costs less to + * 'compute' 0.0 rather than fetch from memory + */ + goto nogen_qcjmpz; + } +#endif +#ifdef TM_QCJMPZ + if (ILI_OPC(op1) == IL_QCON && IS_QUAD0(ILI_OPND(op1, 1))) + return ad3ili(IL_QCJMPZ, op2, commute_cc(CCRelationILIOpnd(ilip, 2)), + ilip->opnd[3]); + if (ILI_OPC(op2) == IL_QCON && IS_QUAD0(ILI_OPND(op2, 1))) + return ad3ili(IL_QCJMPZ, op1, ilip->opnd[2], ilip->opnd[3]); +#endif + nogen_qcjmpz: + if (op1 == op2 && (ILI_OPC(op2) == IL_QCON) && + !_is_nand(ILI_SymOPND(op2, 1))) { + cond = CCRelationILIOpnd(ilip, 2); + if (cond == CC_EQ || cond == CC_GE || cond == CC_LE || cond == CC_NOTNE || + cond == CC_NOTLT || cond == CC_NOTGT) + return ad1ili(IL_JMP, (int)ilip->opnd[3]); + RFCNTD(ilip->opnd[3]); + return 0; + } + if (!IEEE_CMP) + goto cjmp_2; /* check if operands are identical */ + break; + // AOCC end case IL_ACJMPZ: if (ILI_OPC(op1) == IL_ACON) { @@ -9973,6 +11817,11 @@ simplified_cmp_ili(int cmp_ili) case IL_DCMP: jump_opc = IL_DCJMP; goto shared_bin_cmp; + // AOCC begin + case IL_QCMP: + jump_opc = IL_QCJMP; + goto shared_bin_cmp; + // AOCC end case IL_ICMP: jump_opc = IL_ICJMP; goto shared_bin_cmp; @@ -10008,6 +11857,11 @@ simplified_cmp_ili(int cmp_ili) case IL_DCMPZ: jump_opc = IL_DCJMPZ; goto shared_una_cmp; + // AOCC begin + case IL_QCMPZ: + jump_opc = IL_QCJMPZ; + goto shared_una_cmp; + // AOCC end case IL_ICMPZ: jump_opc = IL_ICJMPZ; goto shared_una_cmp; @@ -10072,6 +11926,9 @@ dump_msz(MSZ ms) case MSZ_DBLE: msz = "db"; break; + case MSZ_F16: // AOCC + msz = "qd"; + break; #ifdef MSZ_I8 case MSZ_I8: msz = "i8"; @@ -10225,10 +12082,12 @@ dump_ili(FILE *f, int i) case IL_ICMP: case IL_FCMP: case IL_DCMP: + case IL_QCMP: // AOCC case IL_ACMP: case IL_ICMPZ: case IL_FCMPZ: case IL_DCMPZ: + case IL_QCMPZ: // AOCC case IL_ACMPZ: case IL_ICJMP: case IL_FCJMP: @@ -10442,6 +12301,9 @@ dump_ili(FILE *f, int i) case ILIO_DP: fprintf(f, " dp(%2d)", opn); break; + case ILIO_QP: + fprintf(f, " qp(%2d)", opn); + break; case ILIO_CS: fprintf(f, " cs(%2d)", opn); break; @@ -10458,6 +12320,14 @@ dump_ili(FILE *f, int i) fprintf(f, "\n"); } +// AOCC begin +void +dump_ili(int i) +{ + dump_ili(stdout, i); +} +// AOCC end + /* ****************************************************************** */ static void dilitree(int i) @@ -10641,6 +12511,7 @@ optype(ILI_OP opc) case IL_UKNEG: case IL_SCMPLXNEG: case IL_DCMPLXNEG: + case IL_QCMPLXNEG: // AOCC case IL_FNEG: case IL_DNEG: return OT_UNARY; @@ -10650,10 +12521,12 @@ optype(ILI_OP opc) case IL_LDDP: case IL_LDSCMPLX: case IL_LDDCMPLX: + case IL_LDQCMPLX: // AOCC case IL_LDA: case IL_ICON: case IL_KCON: case IL_DCON: + case IL_QCON: // AOCC case IL_FCON: case IL_ACON: return OT_LEAF; @@ -10681,13 +12554,16 @@ prilitree(int i) case IL_UKADD: case IL_FADD: case IL_DADD: + case IL_QADD: case IL_SCMPLXADD: case IL_DCMPLXADD: + case IL_QCMPLXADD: // AOCC case IL_UIADD: case IL_AADD: opval = "+"; goto binop; case IL_DSUB: + case IL_QSUB: opval = "-"; goto binop; case IL_ISUB: @@ -10696,6 +12572,7 @@ prilitree(int i) case IL_FSUB: case IL_SCMPLXSUB: case IL_DCMPLXSUB: + case IL_QCMPLXSUB: // AOCC case IL_UISUB: case IL_ASUB: opval = "-"; @@ -10705,14 +12582,18 @@ prilitree(int i) case IL_UKMUL: case IL_FMUL: case IL_DMUL: + case IL_QMUL: // AOCC case IL_UIMUL: case IL_SCMPLXMUL: case IL_DCMPLXMUL: + case IL_QCMPLXMUL: // AOCC opval = "*"; goto binop; case IL_SCMPLXDIV: case IL_DCMPLXDIV: + case IL_QCMPLXDIV: // AOCC case IL_DDIV: + case IL_QDIV: // AOCC case IL_KDIV: case IL_FDIV: case IL_IDIV: @@ -10786,6 +12667,9 @@ prilitree(int i) opval = ">>"; goto binop; case IL_ARSHIFT: + /* AOCC begin */ + case IL_SHIFTA: + /* AOCC end */ case IL_KARSHIFT: opval = "a>>"; goto binop; @@ -10797,6 +12681,7 @@ prilitree(int i) #ifdef IL_KPOWK case IL_KPOWK: #endif + case IL_QPOWQ: case IL_DPOWK: case IL_DPOWD: case IL_DPOWI: @@ -10819,6 +12704,7 @@ prilitree(int i) case IL_ICMP: case IL_FCMP: case IL_DCMP: + case IL_QCMP: // AOCC case IL_ACMP: case IL_UICMP: #ifdef IL_X87CMP @@ -10849,6 +12735,7 @@ prilitree(int i) case IL_UKNEG: case IL_SCMPLXNEG: case IL_DCMPLXNEG: + case IL_QCMPLXNEG: case IL_DNEG: case IL_UINEG: case IL_FNEG: @@ -10872,6 +12759,7 @@ prilitree(int i) case IL_KCMPZ: case IL_FCMPZ: case IL_DCMPZ: + case IL_QCMPZ: case IL_ACMPZ: case IL_UICMPZ: opval = ccval[ILI_OPND(i, 2)]; @@ -10900,6 +12788,10 @@ prilitree(int i) n = 2; opval = "min"; goto intrinsic; + case IL_QUAD: + n = 1; + opval = "quad"; + goto intrinsic; case IL_DBLE: n = 1; opval = "dble"; @@ -10918,6 +12810,13 @@ prilitree(int i) opval = "dimag"; goto intrinsic; break; + // AOCC begin + case IL_QCMPLX2IMAG: + n = 1; + opval = "qimag"; + goto intrinsic; + break; + // AOCC end case IL_SCMPLX2REAL: n = 1; opval = "real"; @@ -10928,6 +12827,13 @@ prilitree(int i) opval = "dreal"; goto intrinsic; break; + // AOCC begin + case IL_QCMPLX2REAL: + n = 1; + opval = "qreal"; + goto intrinsic; + break; + // AOCC end case IL_SPSP2SCMPLX: n = 2; opval = "cmplx"; @@ -10948,6 +12854,18 @@ prilitree(int i) opval = "dcmplx"; goto intrinsic; break; + // AOCC begin + case IL_QPQP2QCMPLX: + n = 2; + opval = "qcmplx"; + goto intrinsic; + break; + case IL_QPQP2QCMPLXI0: + n = 1; + opval = "qcmplx"; + goto intrinsic; + break; + // AOCC end case IL_SCMPLXCONJG: n = 1; opval = "conjg"; @@ -10958,6 +12876,13 @@ prilitree(int i) opval = "conjg"; goto intrinsic; break; + // AOCC begin + /*case IL_QCMPLXCONJG: + n = 1; + opval = "conjg"; + goto intrinsic; + break;*/ + // AOCC end case IL_SCMPLXEXP: n = 1; opval = "cexp"; @@ -10968,6 +12893,16 @@ prilitree(int i) opval = "cdexp"; goto intrinsic; break; + case IL_SCMPLXABS: + n = 1; + opval = "cabs"; + goto intrinsic; + break; + case IL_DCMPLXABS: + n = 1; + opval = "cdabs"; + goto intrinsic; + break; case IL_SCMPLXCOS: n = 1; opval = "cexp"; @@ -10978,6 +12913,23 @@ prilitree(int i) opval = "cdexp"; goto intrinsic; break; + // AOCC begin + case IL_QCMPLXCOS: + n = 1; + opval = "cqcos"; + goto intrinsic; + break; + case IL_QCMPLXACOS: + n = 1; + opval = "cqacos"; + goto intrinsic; + break; + case IL_QCMPLXACOSH: + n = 1; + opval = "cqacosh"; + goto intrinsic; + break; + // AOCC end case IL_SCMPLXSIN: n = 1; opval = "csin"; @@ -10988,6 +12940,23 @@ prilitree(int i) opval = "cdsin"; goto intrinsic; break; + // AOCC begin + case IL_QCMPLXSIN: + n = 1; + opval = "cqsin"; + goto intrinsic; + break; + case IL_QCMPLXASIN: + n = 1; + opval = "cqasin"; + goto intrinsic; + break; + case IL_QCMPLXASINH: + n = 1; + opval = "cqasinh"; + goto intrinsic; + break; + // AOCC end case IL_SCMPLXTAN: n = 1; opval = "ctan"; @@ -10998,6 +12967,45 @@ prilitree(int i) opval = "cdtan"; goto intrinsic; break; + // AOCC begin + case IL_QCMPLXTAN: + n = 1; + opval = "cqtan"; + goto intrinsic; + break; + /* AOCC begin */ + case IL_SCMPLXCOTAN: + n = 1; + opval = "ccotan"; + goto intrinsic; + break; + case IL_DCMPLXCOTAN: + n = 1; + opval = "cdcotan"; + goto intrinsic; + break; + case IL_QCMPLXCOTAN: + n = 1; + opval = "cqcotan"; + goto intrinsic; + break; + /* AOCC end */ + case IL_QCMPLXATAN: + n = 1; + opval = "cqatan"; + goto intrinsic; + break; + case IL_QCMPLXATAN2: + n = 1; + opval = "cqatan2"; + goto intrinsic; + break; + case IL_QCMPLXATANH: + n = 1; + opval = "cqatanh"; + goto intrinsic; + break; + // AOCC end case IL_SCMPLXACOS: n = 1; opval = "cacos"; @@ -11078,6 +13086,18 @@ prilitree(int i) opval = "cdsqrt"; goto intrinsic; break; + // AOCC begin + case IL_QCMPLXSQRT: + n = 1; + opval = "csqrtq"; + goto intrinsic; + break; + case IL_QCMPLXCONJG: + n = 1; + opval = "conjgq"; + goto intrinsic; + break; + // AOCC end case IL_FIX: case IL_FIXK: case IL_FIXUK: @@ -11098,6 +13118,13 @@ prilitree(int i) n = 1; opval = "dfix"; goto intrinsic; + // AOCC begin + case IL_QFIX: + case IL_QFIXU: + n = 1; + opval = "qfix"; + goto intrinsic; + // AOCC end case IL_FLOAT: n = 1; opval = "float"; @@ -11118,6 +13145,28 @@ prilitree(int i) n = 1; opval = "dexp"; goto intrinsic; + // AOCC begin + case IL_QEXP: + n = 1; + opval = "qexp"; + goto intrinsic; + case IL_QFLOAT: + n = 1; + opval = "qfloat"; + goto intrinsic; + case IL_QFLOATU: + n = 1; + opval = "qfloatu"; + goto intrinsic; + case IL_QFLOATK: + n = 1; + opval = "qfloatk"; + goto intrinsic; + case IL_QFLOATUK: + n = 1; + opval = "qfloatuk"; + goto intrinsic; + // AOCC end case IL_DFLOAT: n = 1; opval = "dfloat"; @@ -11159,6 +13208,12 @@ prilitree(int i) opval = "kidnint"; goto intrinsic; #endif + // AOCC begin + case IL_QABS: + n = 1; + opval = "abs"; + goto intrinsic; + // AOCC end case IL_DABS: n = 1; opval = "abs"; @@ -11195,8 +13250,14 @@ prilitree(int i) n = 1; opval = "dsqrt"; goto intrinsic; - case IL_DSIGN: + // AOCC begin + case IL_QSQRT: + n = 1; + opval = "qsqrt"; + goto intrinsic; n = 2; + // AOCC end + case IL_DSIGN: opval = "dsign"; goto intrinsic; #ifdef IL_FRSQRT @@ -11218,6 +13279,17 @@ prilitree(int i) n = 1; opval = "leadz"; goto intrinsic; + // AOCC begin + case IL_ITRAILZI: + n = 2; + opval = "trailz"; + goto intrinsic; + case IL_ITRAILZ: + case IL_KTRAILZ: + n = 1; + opval = "trailz"; + goto intrinsic; + // AOCC end case IL_IPOPCNTI: n = 2; opval = "popcnt"; @@ -11319,6 +13391,7 @@ prilitree(int i) case IL_DAKR: case IL_DAAR: case IL_DADP: + case IL_DAQP: #ifdef IL_DA128 case IL_DA128: #endif @@ -11345,6 +13418,7 @@ prilitree(int i) case IL_ARGIR: case IL_ARGSP: case IL_ARGDP: + case IL_ARGQP: case IL_ARGAR: #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128ARG: @@ -11379,6 +13453,11 @@ prilitree(int i) case IL_MVDP: opval = "MVDP"; goto mv_reg; + // AOCC begin + case IL_MVQP: + opval = "MVQP"; + goto mv_reg; + // AOCC end case IL_MVAR: opval = "MVAR"; goto mv_reg; @@ -11401,6 +13480,11 @@ prilitree(int i) case IL_DPDF: opval = "DPDF"; goto df_reg; + // AOCC begin + case IL_QPDF: + opval = "QPDF"; + goto df_reg; + // AOCC end case IL_ARDF: opval = "ARDF"; goto df_reg; @@ -11437,6 +13521,7 @@ prilitree(int i) case IL_CSEAR: case IL_CSECS: case IL_CSECD: + case IL_CSECQ: // AOCC #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128CSE: #endif @@ -11483,8 +13568,10 @@ prilitree(int i) case IL_ICON: case IL_FCON: case IL_DCON: + case IL_QCON: // AOCC case IL_SCMPLXCON: case IL_DCMPLXCON: + case IL_QCMPLXCON: // AOCC prcon(ILI_OPND(i, 1)); break; @@ -11501,8 +13588,10 @@ prilitree(int i) case IL_LD: case IL_LDSP: case IL_LDDP: + case IL_LDQP: case IL_LDSCMPLX: case IL_LDDCMPLX: + case IL_LDQCMPLX: // AOCC case IL_LDKR: case IL_LDA: prnme(ILI_OPND(i, 2), ILI_OPND(i, 1)); @@ -11527,8 +13616,10 @@ prilitree(int i) case IL_ST: case IL_STDP: case IL_STSP: + case IL_STQP: // AOCC case IL_STSCMPLX: case IL_STDCMPLX: + case IL_STQCMPLX: // AOCC case IL_DSTS_SCALAR: case IL_SSTS_SCALAR: case IL_STA: @@ -12341,8 +14432,8 @@ mem_size(TY_KIND ty) msz = MSZ_F4; break; case TY_QUAD: - DEBUG_ASSERT(size_of(DT_QUAD) == 8, "TY_QUAD assumed to be 8 bytes"); - msz = MSZ_F8; + //DEBUG_ASSERT(size_of(DT_QUAD) == 8, "TY_QUAD assumed to be 8 bytes"); + msz = MSZ_F16; // AOCC break; case TY_DBLE: msz = MSZ_F8; @@ -12353,6 +14444,11 @@ mem_size(TY_KIND ty) case TY_DCMPLX: msz = MSZ_F16; break; + // AOCC begin + case TY_QCMPLX: + msz = MSZ_F32; + break; + // AOCC end case TY_LOG: msz = MSZ_WORD; break; @@ -12361,6 +14457,16 @@ mem_size(TY_KIND ty) msz = MSZ_WORD; break; + // AOCC Begin + case TY_LOG8: + msz = MSZ_I8; + break; + + case TY_BINT: + msz = MSZ_BYTE; + break; + // AOCC End + case TY_SINT: msz = MSZ_SHWORD; break; @@ -12561,6 +14667,7 @@ is_argili_opcode(ILI_OP opc) case IL_ARGIR: case IL_ARGSP: case IL_ARGDP: + case IL_ARGQP: case IL_ARGAR: case IL_ARGKR: case IL_GARG: @@ -12585,6 +14692,7 @@ is_cseili_opcode(ILI_OP opc) case IL_CSEAR: case IL_CSECS: case IL_CSECD: + case IL_CSECQ: // AOCC case IL_CSEKR: #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128CSE: @@ -12624,6 +14732,7 @@ is_mvili_opcode(ILI_OP opc) case IL_MVIR: case IL_MVSP: case IL_MVDP: + case IL_MVQP: case IL_MVAR: case IL_MVKR: #ifdef IL_MVSPX87 @@ -12665,6 +14774,7 @@ is_daili_opcode(ILI_OP opc) case IL_DAIR: case IL_DASP: case IL_DADP: + case IL_DAQP: #ifdef IL_DA128 case IL_DA128: #endif @@ -12675,6 +14785,7 @@ is_daili_opcode(ILI_OP opc) case IL_DAKR: case IL_DACS: case IL_DACD: + case IL_DACQ: // AOCC #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128ARG: #endif @@ -12703,7 +14814,7 @@ is_dfrili_opcode(ILI_OP opc) case IL_DFRDPX87: case IL_DFRSPX87: #endif - case IL_DFR128: + case IL_DFRQP: // AOCC case IL_DFR256: return 1; default: @@ -12730,8 +14841,11 @@ is_integer_comparison_opcode(ILI_OP opc) case IL_FCMPZ: case IL_DCMP: case IL_DCMPZ: + case IL_QCMP: // AOCC + case IL_QCMPZ: case IL_SCMPLXCMP: case IL_DCMPLXCMP: + case IL_QCMPLXCMP: // AOCC #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128CMP: #endif @@ -12759,8 +14873,11 @@ is_floating_comparison_opcode(ILI_OP opc) case IL_FCMPZ: case IL_DCMP: case IL_DCMPZ: + case IL_QCMP: // AOCC + case IL_QCMPZ: // AOCC case IL_SCMPLXCMP: case IL_DCMPLXCMP: + case IL_QCMPLXCMP: // AOCC #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128CMP: #endif @@ -13102,6 +15219,60 @@ DblIsSingle(SPTR dd) return 0; } +// AOCC begin +static int +QuadIsSingle(SPTR dd) +{ + INT num[4]; + + if (XBIT(15, 0x80)) + return 0; + if (is_quad0(dd)) { + return ad1ili(IL_FCON, stb.flt0); + } + num[0] = CONVAL1G(dd); + num[1] = CONVAL2G(dd); + num[2] = CONVAL3G(dd); + num[3] = CONVAL4G(dd); + if ((num[1] & 0x1fffffff) == 0) { + /* the mantissa does not exceed the mantissa of a single + * precision value + */ + unsigned uu; + int de; /* exponent of quad value */ + uu = num[0]; + de = (int)((uu >> 44) & 0x7fff) - 16382; + if (de >= -16382 && de <= 16383) { + /* + * exponent is within the Emin & Emax for single precision. + */ + unsigned ds, dm; /* sign, mantissa of dble value */ + int se; /* exponent of single value */ + unsigned ss, sm; /* sign, mantissa of single value */ + INT v; + + uu = num[0]; + ds = uu >> 31; + dm = (uu & 0xfffff); + uu = num[1] >> 29; + dm = (dm << 3) | uu; + + xsngl(num, &v); + uu = v; + ss = uu >> 31; + se = (int)((uu >> 23) & 0xfff) - 16383; + sm = uu & 0x7fffff; + + if (ss == ds && se == de && sm == dm) { + static INT numi[2]; + numi[1] = v; + return ad1ili(IL_FCON, getcon(numi, DT_FLOAT)); + } + } + } + return 0; +} +// AOCC end /** \brief Check if the expression is shifting one left; if so, return its the * shift count. */ @@ -13172,8 +15343,10 @@ cmpz_of_cmp(int op1, CC_RELATION cmpz_relation) return ad2ili(ILI_OPC(op1), ILI_OPND(op1, 1), relation); case IL_FCMP: case IL_DCMP: + case IL_QCMP: // AOCC case IL_SCMPLXCMP: case IL_DCMPLXCMP: + case IL_QCMPLXCMP: // AOCC #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128CMP: #endif @@ -13186,6 +15359,7 @@ cmpz_of_cmp(int op1, CC_RELATION cmpz_relation) return ad3ili(ILI_OPC(op1), ILI_OPND(op1, 1), ILI_OPND(op1, 2), relation); case IL_FCMPZ: case IL_DCMPZ: + case IL_QCMPZ: // AOCC if (IEEE_CMP) relation = combine_ieee_ccs(CC_ILI_OPND(op1, 2), cmpz_relation); else @@ -13296,6 +15470,11 @@ genretvalue(int ilix, ILI_OP resultopc) case IL_DFRDP: ilix = ad2ili(resultopc, ilix, DP_RETVAL); break; +//AOCC Begin + case IL_DFRQP: + ilix = ad2ili(resultopc, ilix, QP_RETVAL); + break; +//AOCC End case IL_DFRCS: ilix = ad2ili(resultopc, ilix, CS_RETVAL); break; @@ -13318,14 +15497,17 @@ ilstckind(ILI_OP opc, int opnum) case IL_ICMP: case IL_FCMP: case IL_DCMP: + case IL_QCMP: // AOCC case IL_ACMP: case IL_ICMPZ: case IL_FCMPZ: case IL_DCMPZ: + case IL_QCMPZ: // AOCC case IL_ACMPZ: case IL_ICJMP: case IL_FCJMP: case IL_DCJMP: + case IL_QCJMP: // AOCC case IL_ACJMP: case IL_ICJMPZ: case IL_FCJMPZ: @@ -13355,6 +15537,7 @@ ilstckind(ILI_OP opc, int opnum) case IL_UKCJMPZ: case IL_SCMPLXCMP: case IL_DCMPLXCMP: + case IL_QCMPLXCMP: // AOCC case IL_LCJMPZ: #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128CMP: @@ -13371,8 +15554,10 @@ ilstckind(ILI_OP opc, int opnum) case IL_STDP: case IL_LDSCMPLX: case IL_LDDCMPLX: + case IL_LDQCMPLX: // AOCC case IL_STSCMPLX: case IL_STDCMPLX: + case IL_STQCMPLX: // AOCC case IL_DSTS_SCALAR: #ifdef LONG_DOUBLE_FLOAT128 @@ -13452,12 +15637,16 @@ complement_int_cc(CC_RELATION cc) return CC_NE; case CC_NE: return CC_EQ; + case CC_NOTGE: case CC_LT: return CC_GE; + case CC_NOTLT: case CC_GE: return CC_LT; + case CC_NOTGT: case CC_LE: return CC_GT; + case CC_NOTLE: case CC_GT: return CC_LE; default: @@ -13766,6 +15955,10 @@ dt_to_mthtype(char mtype) return 's'; case DT_DBLE: return 'd'; + // AOCC begin + case DT_QUAD: + return 'q'; + // AOCC end case DT_CMPLX: return 'c'; case DT_DCMPLX: @@ -13797,7 +15990,7 @@ make_math_name(MTH_FN fn, int vectlen, bool mask, DTYPE res_dt) "div", "exp", "log", "log10", "pow", "powi", "powk", "powi1", "powk1", "sin", "sincos", "sinh", "sqrt", "tan", "tanh", "mod", "floor", "ceil", - "aint"}; + "aint", "cotan"}; char *fstr; char ftype = 'f'; if (flg.ieee) diff --git a/tools/flang2/flang2exe/iliutil.h b/tools/flang2/flang2exe/iliutil.h index 936be66c66..2b9ea509ab 100644 --- a/tools/flang2/flang2exe/iliutil.h +++ b/tools/flang2/flang2exe/iliutil.h @@ -589,6 +589,7 @@ void dump_atomic_info(FILE *f, ATOMIC_INFO info); \brief ... */ void dump_ili(FILE *f, int i); +void dump_ili(int i); // AOCC /** \brief ... diff --git a/tools/flang2/flang2exe/ilm.h b/tools/flang2/flang2exe/ilm.h index 431dcc5f61..0ccd230d66 100644 --- a/tools/flang2/flang2exe/ilm.h +++ b/tools/flang2/flang2exe/ilm.h @@ -4,6 +4,15 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + * + */ #ifndef ILM_H_ #define ILM_H_ @@ -70,25 +79,29 @@ typedef struct { #define ILMO_AR 13 #define ILMO_SP 14 #define ILMO_DP 15 -#define ILMO_SZ 16 -#define ILMO_SCZ 17 -#define ILMO_SCF 18 -#define ILMO_ISP 19 -#define ILMO_IDP 20 -#define ILMO_XRSYM 21 -#define ILMO_XDSYM 22 -#define ILMO__ESYM 23 -#define ILMO_LSYM 24 -#define ILMO_LLSYM 25 -#define ILMO_DRRET 26 -#define ILMO_ARRET 27 -#define ILMO_SPRET 28 -#define ILMO_DPRET 29 -#define ILMO_KRRET 30 -#define ILMO_DRPOS 31 -#define ILMO_ARPOS 32 -#define ILMO_SPPOS 33 -#define ILMO_DPPOS 34 +#define ILMO_QP 16 // AOCC +#define ILMO_SZ 17 +#define ILMO_SCZ 18 +#define ILMO_SCF 19 +#define ILMO_ISP 20 +#define ILMO_IDP 21 +#define ILMO_XRSYM 22 +#define ILMO_XDSYM 23 +#define ILMO__ESYM 24 +#define ILMO_LSYM 25 +#define ILMO_LLSYM 26 +#define ILMO_DRRET 27 +#define ILMO_ARRET 28 +#define ILMO_SPRET 29 +#define ILMO_DPRET 30 +#define ILMO_QPRET 31 // AOCC +#define ILMO_KRRET 32 +#define ILMO_DRPOS 33 +#define ILMO_ARPOS 34 +#define ILMO_SPPOS 35 +#define ILMO_DPPOS 36 +#define ILMO_QPPOS 37 // AOCC +#define ILMO_IQP 38 #define ILMO_P 1 #define ILMO_RP 2 @@ -111,6 +124,7 @@ typedef struct { #define IM_NOINLC(i) (ilms[i].oprflag & 0x01000000) #define IM_DOUBLEDOUBLECPLX(i) (ilms[i].oprflag & 0x00800000) #define IM_FLOAT128CPLX(i) (ilms[i].oprflag & 0x00400000) +#define IM_QCPLX(i) (ilms[i].oprflag & 0x00080000) /* *** ILM Template Declarations *****/ diff --git a/tools/flang2/flang2exe/ilmutil.cpp b/tools/flang2/flang2exe/ilmutil.cpp index 07894a5391..514c161fad 100644 --- a/tools/flang2/flang2exe/ilmutil.cpp +++ b/tools/flang2/flang2exe/ilmutil.cpp @@ -1466,6 +1466,7 @@ put_dtype(DTYPE dtype) case TY_CMPLX: case TY_DBLE: case TY_DCMPLX: + case TY_QCMPLX: // AOCC case TY_FLOAT: case TY_INT: case TY_INT8: @@ -1488,7 +1489,7 @@ put_dtype(DTYPE dtype) ad = AD_DPTR(dtype); numdim = AD_NUMDIM(ad); fprintf(xfile, "("); - if (numdim >= 1 && numdim <= 7) { + if (is_legal_numdim(numdim)) { // AOCC int i; for (i = 0; i < numdim; ++i) { if (i) diff --git a/tools/flang2/flang2exe/iltutil.cpp b/tools/flang2/flang2exe/iltutil.cpp index 2ee76e08d7..aea487ea68 100644 --- a/tools/flang2/flang2exe/iltutil.cpp +++ b/tools/flang2/flang2exe/iltutil.cpp @@ -331,6 +331,14 @@ dump_ilt(FILE *ff, int bihx) fprintf(ff, " UJRES"); if (BIH_SIMD(bihx)) fprintf(ff, " SIMD"); + if (BIH_NOSIMD(bihx)) + fprintf(ff, " NOSIMD"); + if (BIH_UNROLL(bihx)) + fprintf(ff, " UNROLL"); + if (BIH_UNROLL_COUNT(bihx)) + fprintf(ff, " UNROLL_COUNT"); + if (BIH_NOUNROLL(bihx)) + fprintf(ff, " NOUNROLL"); if (BIH_LDVOL(bihx)) fprintf(ff, " LDVOL"); if (BIH_STVOL(bihx)) diff --git a/tools/flang2/flang2exe/kmpcutil.cpp b/tools/flang2/flang2exe/kmpcutil.cpp index caa51ead05..72374f6c4d 100644 --- a/tools/flang2/flang2exe/kmpcutil.cpp +++ b/tools/flang2/flang2exe/kmpcutil.cpp @@ -5,6 +5,20 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading + * Last modified: Sep 2019 + * + * Support for x86-64 OpenMP offloading + * Last modified: Apr 2020 + * + * Added code support for openmp schedule clause + * Last modified: March 2021 + */ + /** \file * \brief outliner.c - extract regions into subroutines; add uplevel references * as arguments @@ -39,6 +53,9 @@ #include "llassem.h" #include "ll_ftn.h" #include "symfun.h" +//AOCC Begin +#include "tgtutil.h" +//AOCC End #define MXIDLEN 250 static DTYPE kmpc_ident_dtype; @@ -171,7 +188,19 @@ static class ClassKmpcApiCalls break; case KMPC_API_SPMD_KERNEL_INIT: return {"__kmpc_spmd_kernel_init", IL_NONE, DT_VOID_NONE, 0}; + case KMPC_API_TARGET_INIT: + return {"__kmpc_target_init_v1", IL_NONE, DT_INT, 0}; break; + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + case KMPC_API_TARGET_DEINIT: + return {"__kmpc_target_deinit_v1", IL_NONE, DT_VOID_NONE, 0}; + break; + case KMPC_API_SPMD_KERNEL_DEINIT_V2: + return {"__kmpc_spmd_kernel_deinit_v2", IL_NONE, DT_VOID_NONE, 0}; + break; +#endif + // AOCC End case KMPC_API_PUSH_TARGET_TRIPCOUNT: return {"__kmpc_push_target_tripcount", IL_NONE, DT_VOID_NONE, 0}; break; @@ -184,6 +213,14 @@ static class ClassKmpcApiCalls case KMPC_API_SHUFFLE_I64: return {"__kmpc_shuffle_int64", IL_NONE, DT_INT8, 0}; break; + // AOCC Begin + // Currently emitting intrinsic call as there is no OpenMP API exposed for + // float shuffle. Once OpenMP has float shuffle APIs we can change the + // name to API name. + case KMPC_API_SHUFFLE_F32: + return {"nvvm.shfl.down.f32", IL_NONE, DT_FLOAT, 0}; + break; + // AOCC End case KMPC_API_NVPTX_PARALLEL_REDUCE_NOWAIT_SIMPLE_SPMD: return {"__kmpc_nvptx_parallel_reduce_nowait_simple_spmd", IL_NONE, DT_INT, 0}; @@ -276,12 +313,25 @@ static const struct kmpc_api_entry_t kmpc_api_calls[] = { KMPC_FLAG_STR_FMT}, [KMPC_API_SPMD_KERNEL_INIT] = {"__kmpc_spmd_kernel_init", 0, DT_VOID_NONE, 0}, + [KMPC_API_TARGET_INIT] = {"__kmpc_target_init_v1", 0, DT_INT, + 0}, + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + [KMPC_API_TARGET_DEINIT] = {"__kmpc_target_deinit_v1", 0, DT_VOID_NONE, + 0}, + [KMPC_API_SPMD_KERNEL_DEINIT_V2] = {"__kmpc_spmd_kernel_deinit_v2", 0, DT_VOID_NONE, + 0}, +#endif + // AOCC End [KMPC_API_PUSH_TARGET_TRIPCOUNT] = {"__kmpc_push_target_tripcount", 0, DT_VOID_NONE, 0}, [KMPC_API_KERNEL_INIT_PARAMS] = {"__kmpc_kernel_init_params", 0, DT_VOID_NONE, 0}, [KMPC_API_SHUFFLE_I32] = {"__kmpc_shuffle_int32", 0, DT_INT, 0}, [KMPC_API_SHUFFLE_I64] = {"__kmpc_shuffle_int64", 0, DT_INT8, 0}, + // AOCC Begin + [KMPC_API_SHUFFLE_F32] = {"nvvm.shfl.down.f32", 0, DT_FLOAT, 0}, + // AOCC End [KMPC_API_NVPTX_PARALLEL_REDUCE_NOWAIT_SIMPLE_SPMD] = {"__kmpc_nvptx_parallel_reduce_nowait_simple_spmd", 0, DT_INT, 0}, [KMPC_API_NVPTX_END_REDUCE_NOWAIT] = {"__kmpc_nvptx_end_reduce_nowait", 0, @@ -335,6 +385,7 @@ dump_loop_args(const loop_args_t *args) fprintf(fp, "dtype: %d (%s) \n", args->dtype, stb.tynames[DTY(args->dtype)]); fprintf(fp, "**********\n\n"); +dsym(args->chunk); } /* Return ili (icon/kcon, or a loaded value) for use with mk_kmpc_api_call @@ -462,6 +513,15 @@ ll_make_kmpc_proto(const char *nm, int kmpc_api, int argc, DTYPE *args) if (kmpc_api == KMPC_API_FORK_CALL) { LL_ABI_Info *abi = ll_proto_get_abi(nm); abi->is_varargs = true; + + // AOCC begin + // We want the variadic version of __kmpc_fork_call to have the 4th arg as + // variadic, this won't effect the upstream fork_call for non-target + // parallel region + if (flg.x86_64_omptarget) { + abi->nargs = 3; + } + // AOCC end } /* Update ABI (special case) */ if (kmpc_api == KMPC_API_FORK_TEAMS) { @@ -623,7 +683,9 @@ ll_make_kmpc_generic_ptr_int(int kmpc_api) DTYPE arg_types[2] = {DT_CPTR, DT_INT}; args[1] = gen_null_arg(); #ifdef OMP_OFFLOAD_LLVM - if (gbl.ompaccel_intarget) + // AOCC begin + if (gbl.ompaccel_intarget && !flg.x86_64_omptarget) + // AOCC end args[0] = ompaccel_nvvm_get_gbl_tid(); else #endif @@ -663,7 +725,9 @@ ll_make_kmpc_generic_ptr_2int(int kmpc_api, int argili) DTYPE arg_types[3] = {DT_CPTR, DT_INT, DT_INT}; args[2] = gen_null_arg(); #ifdef OMP_OFFLOAD_LLVM - if (flg.omptarget) + // AOCC begin + if (flg.omptarget && !flg.x86_64_omptarget) + // AOCC end args[1] = ompaccel_nvvm_get_gbl_tid(); else #endif @@ -717,6 +781,70 @@ ll_make_kmpc_fork_call(SPTR sptr, int argc, int *arglist, RegionType rt, return mk_kmpc_api_call(KMPC_API_FORK_CALL, 4, arg_types, args); } +// AOCC begin +int +ll_make_kmpc_fork_call_variadic(SPTR sptr, int argc, SPTR *sptrlist) +{ + int argili, args[argc + 3]; + DTYPE arg_types[argc + 3]; + + args[argc + 2] = gen_null_arg(); /* ident */ + arg_types[0] = DT_CPTR; + + args[argc + 1] = ad_icon(argc); + arg_types[1] = DT_INT; + + args[argc + 0] = ad_acon(sptr, 0); + arg_types[2] = DT_CPTR; + + for (int i = 0; i < argc; i++) { + arg_types[2 + i + 1] = DT_CPTR; + args[argc - i - 1] = ad_acon(sptrlist[i], 0); + } + + return mk_kmpc_api_call(KMPC_API_FORK_CALL, argc + 3, arg_types, args); +} + +int +ll_make_kmpc_fork_call_variadic2(SPTR sptr, int argc, SPTR *sptrlist, int kmpc_api) +{ + int argili, args[argc + 3]; + DTYPE arg_types[argc + 3]; + + args[argc + 2] = gen_null_arg(); /* ident */ + arg_types[0] = DT_CPTR; + + args[argc + 1] = ad_icon(argc); + arg_types[1] = DT_INT; + + args[argc + 0] = ad_acon(sptr, 0); + arg_types[2] = DT_CPTR; + + for (int i = 0; i < argc; i++) { + int nme = addnme(NT_VAR, sptrlist[i], 0, (INT)0); + int ili = mk_address(sptrlist[i]); + if (!PASSBYVALG(sptrlist[i])) + args[argc - i - 1] = ad2ili(IL_LDA, ili, nme); + else { + if (DTY(DTYPEG(sptrlist[i])) == TY_PTR) { + args[argc - i - 1] = ad2ili(IL_LDA, ili, nme); + } else { + if (DTYPEG(sptrlist[i]) == DT_INT8) + args[argc - i - 1] = ad3ili(IL_LDKR, ili, nme, MSZ_I8); + else if (DTYPEG(sptrlist[i]) == DT_DBLE) + args[argc - i - 1] = ad3ili(IL_LDDP, ili, nme, MSZ_F8); + else + args[argc - i - 1] = ad3ili(IL_LD, ili, nme, MSZ_WORD); + } + } + arg_types[2 + i + 1] = DT_CPTR; + } + + return mk_kmpc_api_call(kmpc_api, argc + 3, arg_types, args); +} + +// AOCC end + /* arglist is 1 containing the uplevel pointer */ int ll_make_kmpc_fork_teams(SPTR sptr, int argc, int *arglist) @@ -1000,33 +1128,74 @@ mp_sched_to_kmpc_sched(int sched) if(sched & MP_SCH_ATTR_DEVICEDIST) return KMP_DISTRIBUTE_STATIC_CHUNKED_CHUNKONE; switch (sched) { + case SCHED_PREFIX(AUTO) | MP_MOD_NONMONOTONIC: case SCHED_PREFIX(AUTO): return KMP_SCH_AUTO; case SCHED_PREFIX(DYNAMIC): return KMP_SCH_DYNAMIC_CHUNKED; + case SCHED_PREFIX(GUIDED) | MP_MOD_NONMONOTONIC: case SCHED_PREFIX(GUIDED): return KMP_SCH_GUIDED_CHUNKED; + case SCHED_PREFIX(RUNTIME) | MP_MOD_NONMONOTONIC: case SCHED_PREFIX(RUNTIME): return KMP_SCH_RUNTIME_CHUNKED; + case SCHED_PREFIX(STATIC) | MP_MOD_NONMONOTONIC: case SCHED_PREFIX(STATIC): return KMP_SCH_STATIC; + case SCHED_PREFIX(DIST_STATIC) | MP_MOD_NONMONOTONIC: case SCHED_PREFIX(DIST_STATIC): return KMP_DISTRIBUTE_STATIC; + case SCHED_PREFIX(DYNAMIC) | MP_MOD_NONMONOTONIC: + return KMP_SCH_STATIC_STEAL; + + case SCHED_PREFIX(RUNTIME) | MP_MOD_SIMD: + return KMP_SCH_RUNTIME_SIMD; + case SCHED_PREFIX(GUIDED) | MP_MOD_SIMD: + return KMP_SCH_GUIDED_SIMD; + case SCHED_PREFIX(STATIC) | MP_MOD_SIMD: + case SCHED_PREFIX(STATIC) | MP_SCH_ATTR_CHUNKED | MP_MOD_SIMD: + case SCHED_PREFIX(STATIC) | MP_SCH_ATTR_CHUNKED | MP_SCH_CHUNK_1 | MP_MOD_SIMD: + case SCHED_PREFIX(STATIC) | MP_SCH_CHUNK_1 | MP_MOD_SIMD: + case SCHED_PREFIX(STATIC) | MP_SCH_ATTR_CHUNKED | MP_SCH_BLK_CYC | MP_MOD_SIMD: + case SCHED_PREFIX(STATIC) | MP_SCH_BLK_CYC | MP_MOD_SIMD: + case SCHED_PREFIX(STATIC) | MP_SCH_BLK_ALN | MP_MOD_SIMD: + return KMP_SCH_UPPER; /* Ordered */ + case SCHED_PREFIX(AUTO) | MP_MOD_MONOTONIC: case SCHED_PREFIX(AUTO) | MP_SCH_ATTR_ORDERED: return KMP_ORD_AUTO; + case SCHED_PREFIX(RUNTIME) | MP_MOD_MONOTONIC: case SCHED_PREFIX(RUNTIME) | MP_SCH_ATTR_ORDERED: return KMP_ORD_RUNTIME; + case SCHED_PREFIX(STATIC) | MP_MOD_MONOTONIC: case SCHED_PREFIX(STATIC) | MP_SCH_ATTR_ORDERED: return KMP_ORD_STATIC; + case SCHED_PREFIX(STATIC) | MP_SCH_ATTR_ORDERED | MP_SCH_ATTR_CHUNKED | MP_MOD_MONOTONIC: case SCHED_PREFIX(STATIC) | MP_SCH_ATTR_ORDERED | MP_SCH_ATTR_CHUNKED: return KMP_ORD_STATIC_CHUNKED; + case SCHED_PREFIX(DYNAMIC) | MP_SCH_ATTR_ORDERED | MP_MOD_MONOTONIC: + case SCHED_PREFIX(DYNAMIC) | MP_SCH_ATTR_ORDERED | MP_SCH_ATTR_CHUNKED | MP_MOD_MONOTONIC: case SCHED_PREFIX(DYNAMIC) | MP_SCH_ATTR_ORDERED: case SCHED_PREFIX(DYNAMIC) | MP_SCH_ATTR_ORDERED | MP_SCH_ATTR_CHUNKED: return KMP_ORD_DYNAMIC_CHUNKED; + + case SCHED_PREFIX(STATIC) | MP_SCH_ATTR_CHUNKED | MP_MOD_MONOTONIC: + case SCHED_PREFIX(STATIC) | MP_SCH_ATTR_CHUNKED | MP_SCH_CHUNK_1 | MP_MOD_MONOTONIC: + case SCHED_PREFIX(STATIC) | MP_SCH_CHUNK_1 | MP_MOD_MONOTONIC: + case SCHED_PREFIX(STATIC) | MP_SCH_ATTR_CHUNKED | MP_SCH_BLK_CYC | MP_MOD_MONOTONIC: + case SCHED_PREFIX(STATIC) | MP_SCH_BLK_CYC | MP_MOD_MONOTONIC: + case SCHED_PREFIX(STATIC) | MP_SCH_BLK_ALN | MP_MOD_MONOTONIC: + return KMP_ORD_STATIC_CHUNKED; + /* Special cases of static */ + case SCHED_PREFIX(STATIC) | MP_SCH_ATTR_CHUNKED | MP_MOD_NONMONOTONIC: + case SCHED_PREFIX(STATIC) | MP_SCH_ATTR_CHUNKED | MP_SCH_CHUNK_1 | MP_MOD_NONMONOTONIC: + case SCHED_PREFIX(STATIC) | MP_SCH_CHUNK_1 | MP_MOD_NONMONOTONIC: + case SCHED_PREFIX(STATIC) | MP_SCH_ATTR_CHUNKED | MP_SCH_BLK_CYC | MP_MOD_NONMONOTONIC: + case SCHED_PREFIX(STATIC) | MP_SCH_BLK_CYC | MP_MOD_NONMONOTONIC: + case SCHED_PREFIX(STATIC) | MP_SCH_BLK_ALN | MP_MOD_NONMONOTONIC: case SCHED_PREFIX(STATIC) | MP_SCH_ATTR_CHUNKED: case SCHED_PREFIX(STATIC) | MP_SCH_ATTR_CHUNKED | MP_SCH_CHUNK_1: case SCHED_PREFIX(STATIC) | MP_SCH_CHUNK_1: @@ -1531,6 +1700,19 @@ ll_make_kmpc_shuffle(int ili_val, int ili_delta, int ili_size, bool isint64) return mk_kmpc_api_call(KMPC_API_SHUFFLE_I32, 3, arg_types, args); } +// AOCC Begin +int +ll_make_kmpc_shuffle_f32(int ili_val, int ili_delta, int ili_size) +{ + int args[3]; + DTYPE arg_types[3] = {DT_FLOAT, DT_INT, DT_INT}; + args[2] = ili_val; /* value */ + args[1] = ili_delta; /* delta */ + args[0] = ili_size; /* size */ + return mk_kmpc_api_call(KMPC_API_SHUFFLE_F32, 3, arg_types, args); +} +// AOCC End + int ll_make_kmpc_kernel_init_params(int ReductionScratchpadPtr) { @@ -1542,15 +1724,45 @@ ll_make_kmpc_kernel_init_params(int ReductionScratchpadPtr) } int -ll_make_kmpc_spmd_kernel_init(int sptr) +ll_make_kmpc_target_init(OMP_TARGET_MODE mode) { + DTYPE arg_types[4] = {DT_CPTR, DT_BLOG, DT_BLOG, DT_BLOG}; + int args[4]; + + args[3] = gen_null_arg(); /* ident */ + if (is_SPMD_mode(mode)) { + args[2] = ad_icon(2); /* SPMD Mode */ + args[1] = ad_icon(0); /* UseGenericStateMachine */ + args[0] = ad_icon(0); /* RequiresFullRuntime */ + } else { + args[2] = ad_icon(1); /* Generic mode */ + args[1] = ad_icon(1); /* UseGenericStateMachine */ + args[0] = ad_icon(1); /* RequiresFullRuntime */ + } + return mk_kmpc_api_call(KMPC_API_TARGET_INIT, 4, arg_types, args); +} + +// AOCC Begin +#ifdef OMP_OFFLOAD_AMD + +int +ll_make_kmpc_target_deinit(OMP_TARGET_MODE mode) +{ + DTYPE arg_types[3] = {DT_CPTR, DT_BLOG, DT_BLOG}; int args[3]; - DTYPE arg_types[3] = {DT_INT, DT_SINT, DT_SINT}; - args[2] = sptr; // ld_sptr(sptr); - args[1] = gen_null_arg(); - args[0] = gen_null_arg(); - return mk_kmpc_api_call(KMPC_API_SPMD_KERNEL_INIT, 3, arg_types, args); + + args[2] = gen_null_arg(); /* ident */ + if (is_SPMD_mode(mode)) { + args[1] = ad_icon(2); /* SPMD Mode */ + args[0] = ad_icon(0); /* RequiresFullRuntime */ + } else { + args[1] = ad_icon(1); /* Generic mode */ + args[0] = ad_icon(1); /* RequiresFullRuntime */ + } + return mk_kmpc_api_call(KMPC_API_TARGET_DEINIT, 3, arg_types, args); } +#endif +// AOCC End int ll_make_kmpc_nvptx_parallel_reduce_nowait_simple_spmd(int ili_num_vars, @@ -1605,7 +1817,17 @@ ll_make_kmpc_for_static_init_simple_spmd(const loop_args_t *inargs, int sched) } args[8] = gen_null_arg(); /* ident */ + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + /* + * Passing the first argument as global thread number. + * This is required for bound calculation. + */ + args[7] = ll_make_kmpc_global_thread_num(); +#else args[7] = ad_icon(0); +#endif + // AOCC End args[6] = ad_icon(sched); /* sched */ if (last && STYPEG(last) != ST_CONST @@ -1621,6 +1843,7 @@ ll_make_kmpc_for_static_init_simple_spmd(const loop_args_t *inargs, int sched) args[1] = ld_sptr(stride); /* incr */ args[0] = chunk; /* chunk */ + ADDRTKNP(upper, 1); ADDRTKNP(stride, 1); ADDRTKNP(lower, 1); diff --git a/tools/flang2/flang2exe/kmpcutil.h b/tools/flang2/flang2exe/kmpcutil.h index f131458416..696aaf026b 100644 --- a/tools/flang2/flang2exe/kmpcutil.h +++ b/tools/flang2/flang2exe/kmpcutil.h @@ -5,6 +5,21 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading + * Last modified: Sep 2019 + * + * Support for x86-64 OpenMP offloading + * Last modified: Apr 2020 + * + * Added support for SIMD modifier of schedule clause + * Last modified: March 2021 + * + */ + #ifndef KMPC_RUNTIME_H_ #define KMPC_RUNTIME_H_ @@ -12,7 +27,9 @@ #include "global.h" #include "symtab.h" #include "ili.h" - +//AOCC Begin +#include "llmputil.h" +//AOCC End /** \file * \brief Various definitions for the kmpc runtime */ @@ -62,6 +79,8 @@ typedef enum _kmpc_sched_e { KMP_NM_ORD_STATIC = 194, KMP_NM_ORD_AUTO = 198, KMP_NM_UPPER = 200, + KMP_SCH_GUIDED_SIMD = 46, + KMP_SCH_RUNTIME_SIMD = 47, KMP_SCH_DEFAULT = KMP_SCH_STATIC } kmpc_sched_e; @@ -153,10 +172,20 @@ enum { /* Begin - OpenMP Accelerator RT (libomptarget-nvptx) - non standard - */ KMPC_API_PUSH_TARGET_TRIPCOUNT, KMPC_API_FOR_STATIC_INIT_SIMPLE_SPMD, + KMPC_API_TARGET_INIT, KMPC_API_SPMD_KERNEL_INIT, + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + KMPC_API_TARGET_DEINIT, + KMPC_API_SPMD_KERNEL_DEINIT_V2, +#endif + // AOCC End KMPC_API_KERNEL_INIT_PARAMS, KMPC_API_SHUFFLE_I32, KMPC_API_SHUFFLE_I64, + // AOCC Begin + KMPC_API_SHUFFLE_F32, + // AOCC End KMPC_API_NVPTX_PARALLEL_REDUCE_NOWAIT_SIMPLE_SPMD, KMPC_API_NVPTX_END_REDUCE_NOWAIT, /* End - OpenMP Accelerator RT (libomptarget-nvptx) - non standard - */ @@ -271,6 +300,21 @@ int ll_make_kmpc_flush(void); */ int ll_make_kmpc_fork_call(SPTR sptr, int argc, int *arglist, RegionType rt, int ngangs_ili); +// AOCC begin +/** + * \brief the variadic version of ll_make_kmpc_fork_call which uses \p argc args + * from \p sptrlist. Set refargs to true if they are passed by ref. + */ +int ll_make_kmpc_fork_call_variadic(SPTR sptr, int argc, SPTR *sptrlist); + +/** + * \brief ll_make_kmpc_fork_call_variadic for -Mx,232,0x1 implementing + * functions. \p kmpc_api decides fork_call() or fork_teams() + */ +int ll_make_kmpc_fork_call_variadic2(SPTR sptr, int argc, SPTR *sptrlist, + int kmpc_api = KMPC_API_FORK_CALL); +// AOCC end + /** \brief ... */ @@ -441,15 +485,31 @@ void reset_kmpc_ident_dtype(void); */ int ll_make_kmpc_shuffle(int, int, int, bool); +// AOCC Begin +/** + \brief cuda special register shuffling for int 32 or int 64 + */ +int ll_make_kmpc_shuffle_f32(int, int, int); +// AOCC End + /** \brief SPMD mode - static loop init */ int ll_make_kmpc_for_static_init_simple_spmd(const loop_args_t *, int); /** - \brief SPMD mode - kernel init. + \brief kernel init */ -int ll_make_kmpc_spmd_kernel_init(int); +int ll_make_kmpc_target_init(OMP_TARGET_MODE); + +// AOCC Begin +#ifdef OMP_OFFLOAD_AMD +/** + \brief kernel deinit +*/ +int ll_make_kmpc_target_deinit(OMP_TARGET_MODE); +#endif +// AOCC End /** \brief Push the trip count of the loop that is going to be parallelized. diff --git a/tools/flang2/flang2exe/ll_ftn.cpp b/tools/flang2/flang2exe/ll_ftn.cpp index 5598bdab8b..aa7f05facf 100644 --- a/tools/flang2/flang2exe/ll_ftn.cpp +++ b/tools/flang2/flang2exe/ll_ftn.cpp @@ -4,6 +4,16 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading + * Last modified: Apr 2020 + * + * Added support for quad precision + * Last modified: Feb 2020 + */ /** \file @@ -25,9 +35,9 @@ #include "cgllvm.h" #include "cgmain.h" #include "symfun.h" +#include "lldebug.h" static SPTR create_display_temp_arg(DTYPE ref_dtype); - /* debug switches: -Mq,11,16 dump ili right before ILI -> LLVM translation -Mq,12,16 provides dinit info, ilt trace, and some basic preprocessing info @@ -44,6 +54,7 @@ static SPTR create_display_temp_arg(DTYPE ref_dtype); #define MAXARGLEN 256 #define LLVM_SHORTTERM_AREA 14 +bool is_nvvm_sreg_function(SPTR funcsptr); //AOCC typedef struct char_len { SPTR sptr; struct char_len *next; @@ -103,9 +114,11 @@ is_fastcall(int ilix) switch (ILI_OPC(ILI_OPND(ilix, 2))) { /* mth_i_ .. routines? */ case IL_DADP: /* dplnk dp lnk */ + case IL_DAQP: /* qplnk qp lnk */ // AOCC case IL_DASP: /* splnk sp lnk */ case IL_DACS: /* cslnk cs lnk */ case IL_DACD: /* cdlnk cd lnk */ + case IL_DACQ: /* cdlnk cq lnk */ // AOCC return true; } break; @@ -325,6 +338,9 @@ ll_process_routine_parameters(SPTR func_sptr) /* If an internal function */ if ((gbl.internal > 1 && STYPEG(func_sptr) == ST_ENTRY) && +#ifdef OMP_OFFLOAD_LLVM + !is_nvvm_sreg_function(func_sptr) && // AOCC +#endif !OUTLINEDG(func_sptr)) { /* get the display variable. This will be the last argument. */ display_temp = aux.curr_entry->display; @@ -433,7 +449,8 @@ ll_process_routine_parameters(SPTR func_sptr) } /* For string, need to ut length */ if (!PASSBYVALG(param_sptr) && - (DTYG(param_dtype) == TY_CHAR || DTYG(param_dtype) == TY_NCHAR)) { + (DTYG(param_dtype) == TY_CHAR || DTYG(param_dtype) == TY_NCHAR) && + !OMPACCDEVSYMG(param_sptr)) { SPTR len = CLENG(param_sptr); if ((len <= NOSYM) || (SCG(len) == SC_NONE) || (SCG(len) == SC_LOCAL)) { @@ -632,6 +649,7 @@ get_return_type(SPTR func_sptr) return DT_NONE; case TY_CMPLX: case TY_DCMPLX: + case TY_QCMPLX: // AOCC if (CFUNCG(func_sptr) || CMPLXFUNC_C) break; return DT_NONE; @@ -821,11 +839,49 @@ write_local_overlap(void) if (!equiv_var) return; + // AOCC Begin + bool gpu_cg = false; + int addrspace = -1; +#ifdef OMP_OFFLOAD_LLVM + gpu_cg = gbl.ompaccel_isdevice && flg.amdgcn_target; +#endif +#ifdef OMP_OFFLOAD_AMD + if (gpu_cg) + addrspace = get_alloca_addrspace(gpu_llvm_module); +#endif + // AOCC End + + if (addrspace == -1 || addrspace == 0) { + print_token("\t"); + print_token(equiv_var); + print_token(" = alloca "); + write_type(equiv_type); + print_token(", align 4\n"); + return; + } + + // AOCC Begin + // Print alloca with proper address space + char buf[15]; + sprintf (buf, " addrspace(%d)", addrspace); print_token("\t"); print_token(equiv_var); - print_token(" = alloca "); + print_token(".tmp = alloca "); + write_type(equiv_type); + print_token(", align 4, "); + print_token(buf); + print_token("\n\t"); + print_token(equiv_var); + print_token(" = addrspacecast "); write_type(equiv_type); - print_token(", align 4\n"); + print_token(buf); + print_token("* "); + print_token(equiv_var); + print_token(".tmp to "); + write_type(equiv_type); + print_token("*"); + print_token("\n"); + // AOCC End } void @@ -1114,20 +1170,58 @@ print_entry_subroutine(LL_Module *module) ll_proto_add_sptr(sptr, abi); ll_proto_set_defined_body(ll_proto_key(sptr), true); - +// AOCC Begin + // emit !DISubprogram for every entry routine + lldbg_emit_subprogram(module->debug_info, sptr, get_return_type(sptr), + BIH_FINDEX(gbl.entbih), false, gbl.entries == sptr); +// AOCC End /* * HACK XXX FIXME: We do not call process_formal_arguments() * on any of the routines generated by the print_token commands below. * This means process_sptr will not be called for any CCSYM arguments * and we need to do that so that there exists an SNAME for those. */ + for (i = 1; i <= abi->nargs; ++i) { SPTR arg_sptr = abi->arg[i].sptr; if (!SNAME(arg_sptr) && CCSYMG(arg_sptr)) process_sptr(arg_sptr); hashset_insert(formals, INT2HKEY(arg_sptr)); + +// AOCC Begin + // ignore CCSYM formal arguments + if (!CCSYMG(arg_sptr)) { + // emit parameter variable for each formal argument + LL_MDRef param_md = lldbg_emit_param_variable(module->debug_info, + arg_sptr, BIH_FINDEX(gbl.entbih), i, false); + + // emit llvm.dbg.declare intrinsic for each formal argument + LL_Type *dataloctype = LLTYPE(arg_sptr); + if (dataloctype && dataloctype->data_type == LL_PTR) + dataloctype = dataloctype->sub_types[0]; + insert_llvm_dbg_declare(param_md, arg_sptr, dataloctype, NULL, OPF_NONE); + } +// AOCC End } - build_routine_and_parameter_entries(sptr, abi, NULL); + + build_routine_and_parameter_entries(sptr, abi, module); + +// AOCC Begin + // write the llvm.dbg.declare call instruction + if (abi->nargs) { + INSTR_LIST *instr = llvm_info_last_instr(); + for (int j = 1; ((j <= abi->nargs) && instr); ++j) { + SPTR arg_sptr = abi->arg[j].sptr; + if ((!CCSYMG(arg_sptr)) && (instr->i_name == I_CALL)) { + bool dbg_call_written = write_I_CALL(instr, + ll_feature_emit_func_signature_for_call(&module->ir)); + print_dbg_line(lldbg_cons_line(module->debug_info)); + print_nl(); + instr = instr->prev; + } + } + } +// AOCC End write_dummy_as_local_in_entry(sptr); @@ -1292,9 +1386,11 @@ print_entry_subroutine(LL_Module *module) } pd_len = pd_len->next; } - - print_token(")\n\t"); - +// AOCC Begin + print_token(")"); + print_dbg_line(lldbg_cons_line(module->debug_info)); + print_token("\n\t"); +// AOCC End if (tmp) { /* load return value and return it */ LL_Type *return_ll_type; diff --git a/tools/flang2/flang2exe/ll_structure.cpp b/tools/flang2/flang2exe/ll_structure.cpp index fa31d8ffcf..24cef2256a 100644 --- a/tools/flang2/flang2exe/ll_structure.cpp +++ b/tools/flang2/flang2exe/ll_structure.cpp @@ -4,6 +4,12 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * last modified : April 2020 + */ /** \file @@ -394,10 +400,12 @@ compute_ir_feature_vector(LLVMModuleRef module, enum LL_IRVersion vers) module->ir.dwarf_version = LL_DWARF_Version_2; } else if (XBIT(120, 0x4000)) { module->ir.dwarf_version = LL_DWARF_Version_3; - } else if (true) { // FIXME - need a new bit + } else if (XBIT(120, 0x1000000)) { module->ir.dwarf_version = LL_DWARF_Version_4; - } else { + } else if (XBIT(120, 0x2000000)) { module->ir.dwarf_version = LL_DWARF_Version_5; + } else if (true) { // FIXME - need a new bit + module->ir.dwarf_version = LL_DWARF_Version_4; } if (ll_feature_versioned_dw_tag(&module->ir)) { @@ -434,6 +442,8 @@ ll_feature_dwarf_version(const LL_IRFeatures *feature) return 3; case LL_DWARF_Version_4: return 4; + case LL_DWARF_Version_5: + return 5; } } @@ -457,6 +467,14 @@ static const struct triple_info known_triples[] = { {"armv7-", "e-p:32:32-i64:64-v128:64:128-n32-S64"}, {"aarch64-", "e-m:e-i64:64-i128:128-n32:64-S128"}, {"powerpc64le", "e-p:64:64-i64:64-n32:64"}, + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + {"amdgcn-amd-amdhsa", "e-p:64:64-p1:64:64-p2:32:32-p3:32:32-p4:64:64" + "-p5:32:32-p6:32:32-i64:64-v16:16-v24:32-v32:32" + "-v48:64-v96:128-v192:256-v256:256-v512:512" + "-v1024:1024-v2048:2048-n32:64-S32-A5"}, +#endif + // AOCC End {"", ""}}; /* Compute the data layout for the requested target triple. */ diff --git a/tools/flang2/flang2exe/ll_structure.h b/tools/flang2/flang2exe/ll_structure.h index e3f32d10d4..6151278a1c 100644 --- a/tools/flang2/flang2exe/ll_structure.h +++ b/tools/flang2/flang2exe/ll_structure.h @@ -5,6 +5,16 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights + * reserved. Notified per clause 4(b) of the license. + * + * + * Changes to DISubrange metadata for representing assumed shape arrays. + * Changes to DIModule metadata for representing Fortran modules. + * Date of Modification: July 2020 + */ + #ifndef LL_STRUCTURE_H_ #define LL_STRUCTURE_H_ @@ -20,6 +30,8 @@ /* clang-format off */ +extern size_t get_llvm_ir_version(); + typedef enum LL_Op { LL_ADD, LL_FADD, LL_SUB, LL_FSUB, LL_MUL, LL_FMUL, LL_UDIV, LL_SDIV, LL_UREM, LL_SREM, @@ -146,6 +158,10 @@ typedef enum LL_IRVersion { LL_Version_7_0 = 70, LL_Version_8_0 = 80, LL_Version_9_0 = 90, + LL_Version_10_0 = 100, + LL_Version_11_0 = 110, + LL_Version_12_0 = 120, + LL_Version_13_0 = 130, LL_Version_trunk = 1023 } LL_IRVersion; @@ -385,6 +401,27 @@ ll_feature_debug_info_ver90(const LL_IRFeatures *feature) return feature->version >= LL_Version_9_0; } +/** + \brief Version 11.0 debug metadata + */ +INLINE static bool ll_feature_debug_info_ver11(const LL_IRFeatures *feature) { + return (get_llvm_ir_version() >= LL_Version_11_0); +} + +/** + \brief Version 12.0 debug metadata + */ +INLINE static bool ll_feature_debug_info_ver12(const LL_IRFeatures *feature) { + return (get_llvm_ir_version() >= LL_Version_12_0); +} + +/** + \brief Version 13.0 debug metadata + */ +INLINE static bool ll_feature_debug_info_ver13(const LL_IRFeatures *feature) { + return (get_llvm_ir_version() >= LL_Version_13_0); +} + /** \brief Version 9.0 onwards uses 3 field syntax for constructors and destructors @@ -484,6 +521,11 @@ ll_feature_no_file_in_namespace(const LL_IRFeatures *feature) #define ll_feature_debug_info_ver70(f) ((f)->version >= LL_Version_7_0) #define ll_feature_debug_info_ver80(f) ((f)->version >= LL_Version_8_0) #define ll_feature_debug_info_ver90(f) ((f)->version >= LL_Version_9_0) +#define ll_feature_debug_info_ver11(f) (get_llvm_ir_version() >= LL_Version_11_0) +#define ll_feature_debug_info_ver12(f) \ + (get_llvm_ir_version() >= LL_Version_12_0) +#define ll_feature_debug_info_ver13(f) \ + (get_llvm_ir_version() >= LL_Version_13_0) #define ll_feature_three_argument_ctor_and_dtor(f) \ ((f)->version >= LL_Version_9_0) #define ll_feature_use_distinct_metadata(f) ((f)->version >= LL_Version_3_8) @@ -650,6 +692,7 @@ typedef enum LL_MDClass { LL_DIBasicType_string, /* deprecated */ LL_DIStringType, LL_DICommonBlock, + LL_DIGenericSubRange, LL_MDClass_MAX /**< must be last value and < 64 (6 bits) */ } LL_MDClass; @@ -676,8 +719,13 @@ typedef enum LL_DW_OP_t { LL_DW_OP_xderef, LL_DW_OP_stack_value, LL_DW_OP_constu, + LL_DW_OP_consts, LL_DW_OP_plus_uconst, LL_DW_OP_int, + LL_DW_OP_push_object_address, + LL_DW_OP_mul, + LL_DW_OP_over, + LL_DW_OP_and, LL_DW_OP_MAX /**< must be last value */ } LL_DW_OP_t; diff --git a/tools/flang2/flang2exe/ll_write.cpp b/tools/flang2/flang2exe/ll_write.cpp index b8263c1aa6..46ae80a811 100644 --- a/tools/flang2/flang2exe/ll_write.cpp +++ b/tools/flang2/flang2exe/ll_write.cpp @@ -1,10 +1,30 @@ /* + * * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. * See https://llvm.org/LICENSE.txt for license information. * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changed the metadata name as per llvm trunk. + * Date of Modification: May 2018 + * + */ + +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights + * reserved. Notified per clause 4(b) of the license. + * + * + * Changes to DISubrange metadata for representing assumed shape arrays. + * Changes to DIModule metadata for representing Fortran modules. + * Date of Modification: July 2020 + */ + #include "gbldefs.h" #include "error.h" #include "ll_structure.h" @@ -686,6 +706,28 @@ ll_write_object_dbg_references(FILE *out, LL_Module *m, LL_ObjToDbgList *ods) llObjtodbgFree(ods); } +// AOCC Begin +/* + * \brief Static function to calculte the alloca addrespace from DL string + * + * As per https://llvm.org/docs/AMDGPUUsage.html#address-spaces address space + * for AMDGPU is only single digit number. + * + */ +#ifdef OMP_OFFLOAD_AMD +static int get_alloca_addrspace(LL_Module *module) { + const char *dl = module->datalayout_string; + while ((*dl) != 'A' && (*dl) != '\0') + dl++; + if (dl[0] == '\0') + return -1; + dl++; + return (*dl) - '0'; +} +#endif +// AOCC End + + void ll_write_basicblock(FILE *out, LL_Function *function, LL_BasicBlock *block, LL_Module *module, int no_return) @@ -695,8 +737,16 @@ ll_write_basicblock(FILE *out, LL_Function *function, LL_BasicBlock *block, if (block->name) fprintf(out, "%s:\n", block->name); - if (block == function->first) + if (block == function->first) { + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + int addrspace = get_alloca_addrspace(module); + ll_write_local_objects(out, function, addrspace); +#else ll_write_local_objects(out, function); +#endif + // AOCC End + } while (inst) { ll_write_instruction(out, inst, module, no_return); @@ -712,7 +762,11 @@ ll_write_basicblock(FILE *out, LL_Function *function, LL_BasicBlock *block, once per function. */ void +#ifdef OMP_OFFLOAD_AMD +ll_write_local_objects(FILE *out, LL_Function *function, int alloca_addrspace) +#else ll_write_local_objects(FILE *out, LL_Function *function) +#endif { LL_Object *object; #ifdef TARGET_POWER @@ -721,11 +775,39 @@ ll_write_local_objects(FILE *out, LL_Function *function) const char *name; #endif + int final_addrspace; for (object = function->first_local; object; object = object->next) { +#ifdef OMP_OFFLOAD_AMD + final_addrspace = alloca_addrspace == -1 ? object->type->addrspace : alloca_addrspace; + if (final_addrspace != 0) + fprintf(out, "\t%s.tmp = alloca %s", object->address.data, object->type->str); + else + fprintf(out, "\t%s = alloca %s", object->address.data, object->type->str); + if (object->align_bytes) + fprintf(out, ", align %u", object->align_bytes); + if (final_addrspace != 0) + fprintf(out, ", addrspace(%d)",final_addrspace); + fputc('\n', out); + if (final_addrspace != 0) { + fprintf(out, "\t%s = addrspacecast %s addrspace(%d)* %s.tmp to %s*", + object->address.data, object->type->str, final_addrspace, + object->address.data, object->type->str); + fputc('\n', out); + } + if (object->type->data_type == LL_I32 || object->type->data_type == LL_I64) { + fprintf(out, "\tstore %s 0, %s* %s",object->type->str, object->type->str, object->address.data); + if (object->align_bytes) + fprintf(out, ", align %u", object->align_bytes); + fputc('\n', out); + } +#else fprintf(out, "\t%s = alloca %s", object->address.data, object->type->str); if (object->align_bytes) fprintf(out, ", align %u", object->align_bytes); fputc('\n', out); +#endif + + #ifdef TARGET_LLVM_ARM64 // See process_formal_arguments in cgmain.c for handling on ARM64 of locals @@ -869,7 +951,9 @@ enum FieldType { DWLangField, DWVirtualityField, DWEncodingField, - DWEmissionField + DWEmissionField, + SignedOrMDField, + DebugNameTableKindField }; enum FieldFlags { @@ -961,7 +1045,7 @@ static const MDTemplate Tmpl_DICompileUnit[] = { /* "subprograms" removed from DICompileUnit in LLVM 3.9 */ static const MDTemplate Tmpl_DICompileUnit_ver39[] = { - { "DICompileUnit", TF, 13 }, + { "DICompileUnit", TF, 14 }, { "tag", DWTagField, FlgHidden }, { "file", NodeField }, { "language", DWLangField }, @@ -974,7 +1058,8 @@ static const MDTemplate Tmpl_DICompileUnit_ver39[] = { { "globals", NodeField }, { "emissionKind", DWEmissionField }, { "imports", NodeField }, - { "splitDebugFilename", StringField } + { "splitDebugFilename", StringField }, + { "nameTableKind", DebugNameTableKindField } }; static const MDTemplate Tmpl_DICompileUnit_pre34[] = { @@ -1032,6 +1117,31 @@ static const MDTemplate Tmpl_DIModule[] = { //{ "isysroot", StringField, FlgOptional } }; +static const MDTemplate Tmpl_DIModule_11[] = { + { "DIModule", TF, 5 }, + { "tag", DWTagField, FlgHidden }, + { "scope", NodeField }, + { "name", StringField }, + { "file", NodeField }, + { "line", UnsignedField } + //,{ "configMacros", StringField, FlgOptional }, + //{ "includePath", StringField, FlgOptional }, + //{ "isysroot", StringField, FlgOptional } +}; + +static const MDTemplate Tmpl_DIModule_12[] = { + { "DIModule", TF, 6 }, + { "tag", DWTagField, FlgHidden }, + { "scope", NodeField }, + { "name", StringField }, + { "file", NodeField, FlgOptional }, + { "line", UnsignedField, FlgOptional }, + { "isDecl", BoolField, FlgOptional } + //,{ "configMacros", StringField, FlgOptional }, + //{ "includePath", StringField, FlgOptional }, + //{ "isysroot", StringField, FlgOptional } +}; + static const MDTemplate Tmpl_DISubprogram[] = { { "DISubprogram", TF, 20 }, { "tag", DWTagField, FlgHidden }, @@ -1052,7 +1162,7 @@ static const MDTemplate Tmpl_DISubprogram[] = { { "function", ValueField }, { "templateParams", NodeField }, { "declaration", NodeField }, - { "variables", NodeField }, + { "retainedNodes", NodeField}, { "scopeLine", UnsignedField } }; @@ -1122,7 +1232,7 @@ static const MDTemplate Tmpl_DISubprogram_38[] = { { "function", ValueField, FlgHidden }, { "templateParams", NodeField }, { "declaration", NodeField }, - { "variables", NodeField }, + { "retainedNodes", NodeField }, { "scopeLine", UnsignedField } }; @@ -1148,7 +1258,7 @@ static const MDTemplate Tmpl_DISubprogram_39[] = { { "templateParams", NodeField }, { "declaration", NodeField }, { "unit", NodeField }, - { "variables", NodeField }, + { "retainedNodes", NodeField }, { "scopeLine", UnsignedField } }; @@ -1186,13 +1296,9 @@ static const MDTemplate Tmpl_DIExpression[] = { static const MDTemplate Tmpl_DILocalVariable[] = { { "DILocalVariable", TF, 9 }, - { "tag", DWTagField }, { "scope", NodeField }, - { "name", StringField }, { "arg", UnsignedField }, - { "file", NodeField }, { "line", UnsignedField }, - { "type", NodeField }, { "flags", UnsignedField }, /* TBD: DIFlag... */ { "inlinedAt", UnsignedField } /* TBD: NodeField */ }; @@ -1377,7 +1483,7 @@ static const MDTemplate Tmpl_DICompositeType_pre34[] = { }; static const MDTemplate Tmpl_DICompositeType[] = { - { "DICompositeType", TF, 15 }, + { "DICompositeType", TF, 19 }, { "tag", DWTagField }, { "file", NodeField }, { "scope", NodeField }, @@ -1392,7 +1498,11 @@ static const MDTemplate Tmpl_DICompositeType[] = { { "runtimeLang", DWLangField }, { "vtableHolder", NodeField }, { "templateParams", NodeField }, - { "identifier", StringField } + { "identifier", StringField }, + { "dataLocation", NodeField}, + { "associated", NodeField}, + { "allocated", NodeField}, + { "rank", NodeField} }; static const MDTemplate Tmpl_DIFortranArrayType[] = { @@ -1406,13 +1516,30 @@ static const MDTemplate Tmpl_DIFortranArrayType[] = { { "elements", NodeField } }; -static const MDTemplate Tmpl_DISubrange[] = { +static const MDTemplate Tmpl_DISubrange_pre11[] = { { "DISubrange", TF, 3 }, { "tag", DWTagField, FlgHidden }, { "lowerBound", SignedField }, { "count", SignedField, FlgMandatory } }; +static const MDTemplate Tmpl_DISubrange[] = { + { "DISubrange", TF, 5 }, + { "tag", DWTagField, FlgHidden }, + { "count", SignedOrMDField }, + { "lowerBound", SignedOrMDField }, + { "upperBound", SignedOrMDField }, + { "stride", SignedOrMDField } +}; + +static const MDTemplate Tmpl_DIGenericSubrange[] = { + { "DIGenericSubrange", TF, 4 }, + { "tag", DWTagField, FlgHidden }, + { "lowerBound", SignedOrMDField }, + { "upperBound", SignedOrMDField, FlgMandatory }, + { "stride", SignedOrMDField, FlgMandatory } +}; + static const MDTemplate Tmpl_DISubrange_pre37[] = { { "DISubrange", TF, 3 }, { "tag", DWTagField, FlgHidden }, @@ -1540,6 +1667,24 @@ dwarf_emission_name(int value) } } +/** + \brief generate DWARF table kind + */ +static const char * +dwarf_table_name(int value) +{ + switch (value) { + case 0: + return "Default"; + case 1: + return "GNU"; + case 2: + return "None"; + default: + return "None"; + } +} + /** \brief Write out an an LL_MDRef as a field in a specialised MDNode class \param out file to write to @@ -1568,8 +1713,8 @@ write_mdfield(FILE *out, LL_Module *module, int needs_comma, LL_MDRef mdref, switch (LL_MDREF_kind(mdref)) { case MDRef_Node: if (value) { - assert(tmpl->type == NodeField, "metadata elem should not be a mdnode", - tmpl->type, ERR_Fatal); + assert(tmpl->type == NodeField || tmpl->type == SignedOrMDField, + "metadata elem should not be a mdnode", tmpl->type, ERR_Fatal); fprintf(out, "%s%s: !%u", prefix, tmpl->name, value); } else if (mandatory) { fprintf(out, "%s%s: null", prefix, tmpl->name); @@ -1619,6 +1764,7 @@ write_mdfield(FILE *out, LL_Module *module, int needs_comma, LL_MDRef mdref, } break; + case SignedOrMDField: case SignedField: { bool doOutput = true; const char *dv = module->constants[value]->data; @@ -1646,6 +1792,7 @@ write_mdfield(FILE *out, LL_Module *module, int needs_comma, LL_MDRef mdref, switch (tmpl->type) { case UnsignedField: case SignedField: + case SignedOrMDField: fprintf(out, "%s%s: %u", prefix, tmpl->name, value); break; @@ -1676,6 +1823,10 @@ write_mdfield(FILE *out, LL_Module *module, int needs_comma, LL_MDRef mdref, fprintf(out, "%s%s: %s", prefix, tmpl->name, dwarf_emission_name(value)); break; + case DebugNameTableKindField: + fprintf(out, "%s%s: %s", prefix, tmpl->name, dwarf_table_name(value)); + break; + default: interr("metadata elem should not be an int", tmpl->type, ERR_unused); } @@ -1795,6 +1946,7 @@ static void emitDIGlobalVariableExpression(FILE *, LLVMModuleRef, MDNodeRef, unsigned); static void emitDIImportedEntity(FILE *, LLVMModuleRef, MDNodeRef, unsigned); static void emitDICommonBlock(FILE *, LLVMModuleRef, MDNodeRef, unsigned); +static void emitDIGenericSubRange(FILE *, LLVMModuleRef, MDNodeRef, unsigned); typedef void (*MDDispatchMethod)(FILE *out, LLVMModuleRef mod, MDNodeRef mdnode, unsigned mdi); @@ -1832,6 +1984,7 @@ static MDDispatch mdDispTable[LL_MDClass_MAX] = { {emitDIBasicStringType}, // LL_DIBasicType_string - deprecated {emitDIStringType}, // LL_DIStringType {emitDICommonBlock}, // LL_DICommonBlock + {emitDIGenericSubRange}, // LL_DIGenericSubRange }; INLINE static void @@ -1977,11 +2130,20 @@ static void emitDISubRange(FILE *out, LLVMModuleRef mod, const LL_MDNode *mdnode, unsigned mdi) { + if (ll_feature_debug_info_ver11(&mod->ir)) { + emitTmpl(out, mod, mdnode, mdi, Tmpl_DISubrange); + return; + } if (!ll_feature_debug_info_subrange_needs_count(&mod->ir)) { emitTmpl(out, mod, mdnode, mdi, Tmpl_DISubrange_pre37); return; } - emitTmpl(out, mod, mdnode, mdi, Tmpl_DISubrange); + emitTmpl(out, mod, mdnode, mdi, Tmpl_DISubrange_pre11); +} + +static void emitDIGenericSubRange(FILE *out, LLVMModuleRef mod, + const LL_MDNode *mdnode, unsigned mdi) { + emitTmpl(out, mod, mdnode, mdi, Tmpl_DIGenericSubrange); } static void @@ -2016,6 +2178,14 @@ emitDINamespace(FILE *out, LLVMModuleRef mod, const LL_MDNode *mdnode, static void emitDIModule(FILE *out, LLVMModuleRef mod, const LL_MDNode *mdnd, unsigned mdi) { + if (ll_feature_debug_info_ver12(&mod->ir)) { + emitTmpl(out, mod, mdnd, mdi, Tmpl_DIModule_12); + return; + } + if (ll_feature_debug_info_ver11(&mod->ir)) { + emitTmpl(out, mod, mdnd, mdi, Tmpl_DIModule_11); + return; + } emitTmpl(out, mod, mdnd, mdi, Tmpl_DIModule); } @@ -2146,8 +2316,18 @@ ll_dw_op_to_name(LL_DW_OP_t op) return "DW_OP_stack_value"; case LL_DW_OP_constu: return "DW_OP_constu"; + case LL_DW_OP_consts: + return "DW_OP_consts"; case LL_DW_OP_plus_uconst: return "DW_OP_plus_uconst"; + case LL_DW_OP_push_object_address: + return "DW_OP_push_object_address"; + case LL_DW_OP_mul: + return "DW_OP_mul"; + case LL_DW_OP_over: + return "DW_OP_over"; + case LL_DW_OP_and: + return "DW_OP_and"; default: break; } @@ -2162,7 +2342,9 @@ decode_expression_op(LLVMModuleRef mod, LL_MDRef md, char *buff) bool isLiteralOp; if (LL_MDREF_kind(md) == MDRef_Constant) { - strcpy(buff, mod->constants[LL_MDREF_value(md)]->data); + // Emit the constant as an unsigned value. + char *ptr; + sprintf(buff, "%lu", strtoul( mod->constants[LL_MDREF_value(md)]->data, &ptr, 10)); return buff; } DEBUG_ASSERT(LL_MDREF_kind(md) == MDRef_SmallInt32, "not int"); @@ -2487,6 +2669,7 @@ ll_write_module(FILE *out, LL_Module *module, int generate_no_return_variants, c case LL_I64: case LL_FLOAT: case LL_DOUBLE: + case LL_FP128: // AOCC case LL_PTR: if (module->module_vars.values[i]->flags & VAL_IS_TEXTURE) linkage_string = ""; diff --git a/tools/flang2/flang2exe/ll_write.h b/tools/flang2/flang2exe/ll_write.h index f977db162a..5520eec71c 100644 --- a/tools/flang2/flang2exe/ll_write.h +++ b/tools/flang2/flang2exe/ll_write.h @@ -52,7 +52,14 @@ void ll_write_llvm_used(FILE *out, LLVMModuleRef module); /** \brief ... */ +// AOCC Begin +#ifdef OMP_OFFLOAD_AMD +void ll_write_local_objects(FILE *out, LL_Function *function, + int alloca_addrspace); +#else void ll_write_local_objects(FILE *out, LL_Function *function); +#endif +// AOCC End /** \brief ... diff --git a/tools/flang2/flang2exe/llassem.cpp b/tools/flang2/flang2exe/llassem.cpp index e7a706c935..fc1b204f71 100644 --- a/tools/flang2/flang2exe/llassem.cpp +++ b/tools/flang2/flang2exe/llassem.cpp @@ -5,6 +5,22 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Support for x86-64 OpenMP offloading + * Last modified: Oct 2019 + * + * Changes to support AMDGPU OpenMP offloading. + * Last modified: Nov 2019 + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ + + /** \file LLVM backend routines. This backend is Fortran-specific. @@ -74,7 +90,7 @@ static class ClassSections { case NVIDIA_OLDFATBIN_SEC: return {".nv_fatbin", DoubleAlign}; case OMP_OFFLOAD_SEC: - return {".omp_offloading.entries", OneAlign}; + return {"omp_offloading_entries", OneAlign}; // AOCC default: return {NULL, 0}; } @@ -611,8 +627,9 @@ get_struct_from_dsrt2(SPTR sptr, DSRT *dsrtp, ISZ_T size, int *align8, addr = dsrtp->offset; first_data = 0; } else if (addr > dsrtp->offset) { - error(S_0164_Overlapping_data_initializations_of_OP1, ERR_Warning, 0, - SYMNAME(dsrtp->sptr), CNULL); + if (!(CFUNCG(dsrtp->sptr) && STYPEG(dsrtp->sptr) == ST_VAR)) // AOCC + error(S_0164_Overlapping_data_initializations_of_OP1, ERR_Warning, 0, + SYMNAME(dsrtp->sptr), CNULL); continue; } } @@ -789,7 +806,7 @@ get_struct_from_dsrt2(SPTR sptr, DSRT *dsrtp, ISZ_T size, int *align8, } if (!first_data) strcat(buf, ", "); - strcat(buf, "i8* "); + strcat(buf, "i64 "); ptrcnt++; } else if (size_of_item) { if (ptrcnt || !i8cnt) { @@ -1048,10 +1065,27 @@ ompaccel_write_sharedvars(void) for (gblsym = ag_other; gblsym; gblsym = AG_SYMLK(gblsym)) { name = AG_NAME(gblsym); typed = AG_TYPENAME(gblsym); + // AOCC begin +#ifdef OMP_OFFLOAD_AMD + fprintf(gbl.ompaccfile, + "@%s = weak addrspace(3) externally_initialized global %s ", name, + typed); + fprintf(gbl.ompaccfile, " undef\n"); +#else + // AOCC End fprintf(gbl.ompaccfile, "@%s = common addrspace(3) global %s ", name, typed); fprintf(gbl.ompaccfile, " zeroinitializer\n"); + + // AOCC Begin +#endif + // AOCC end } + + // AOCC Begin + // Reset after global are dumped to file + ag_other = 0; + // AOCC End } static void @@ -1095,13 +1129,41 @@ write_libomtparget(void) if (!isOmptargetInitialized) { if(!strcmp(SYMNAME(gbl.currsub), "ompaccel.register")) { - fprintf(ASMFIL, "\n; OpenMP GPU Offload Init\n\ -@.omp_offloading.img_end.nvptx64-nvidia-cuda = external constant i8 \n\ -@.omp_offloading.img_start.nvptx64-nvidia-cuda = external constant i8 \n\ -@.omp_offloading.entries_end = external constant %%struct.__tgt_offload_entry_ \n\ -@.omp_offloading.entries_begin = external constant %%struct.__tgt_offload_entry_ \n\ -@.omp_offloading.device_images = internal unnamed_addr constant [1 x %%struct.__tgt_device_image] [%%struct.__tgt_device_image { i8* @.omp_offloading.img_start.nvptx64-nvidia-cuda, i8* @.omp_offloading.img_end.nvptx64-nvidia-cuda, %%struct.__tgt_offload_entry_* @.omp_offloading.entries_begin, %%struct.__tgt_offload_entry_* @.omp_offloading.entries_end }], align 8\n\ -@.omp_offloading.descriptor_ = internal constant %%struct.__tgt_bin_desc { i64 1, %%struct.__tgt_device_image* getelementptr inbounds ([1 x %%struct.__tgt_device_image], [1 x %%struct.__tgt_device_image]* @.omp_offloading.device_images, i32 0, i32 0), %%struct.__tgt_offload_entry_* @.omp_offloading.entries_begin, %%struct.__tgt_offload_entry_* @.omp_offloading.entries_end }, align 8\n\n"); + + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + if (flg.amdgcn_target) { +//FIXME: Is this descriptor still needed? + fprintf(ASMFIL, "\n; OpenMP GPU Offload Init\n\ + @__stop_omp_offloading_entries = external constant %%struct.__tgt_offload_entry_ \n\ + @__start_omp_offloading_entries = external constant %%struct.__tgt_offload_entry_ \n\ + @.omp_offloading.device_images = internal unnamed_addr constant [1 x %%struct.__tgt_device_image] [%%struct.__tgt_device_image { i8* null, i8* null, %%struct.__tgt_offload_entry_* @__start_omp_offloading_entries, %%struct.__tgt_offload_entry_* @__stop_omp_offloading_entries }], align 8\n\ + @.omp_offloading.descriptor_ = internal constant %%struct.__tgt_bin_desc { i64 1, %%struct.__tgt_device_image* getelementptr inbounds ([1 x %%struct.__tgt_device_image], [1 x %%struct.__tgt_device_image]* @.omp_offloading.device_images, i32 0, i32 0), %%struct.__tgt_offload_entry_* @__start_omp_offloading_entries, %%struct.__tgt_offload_entry_* @__stop_omp_offloading_entries }, align 8\n\n"); + } + + else if (flg.x86_64_omptarget) { + fprintf(ASMFIL, "\n; OpenMP GPU Offload Init\n\ + @.omp_offloading.img_end.x86_64-pc-linux-gnu = internal constant i8 0\n\ + @.omp_offloading.img_start.x86_64-pc-linux-gnu = internal constant i8 0\n\ + @__stop_omp_offloading_entries = internal constant %%struct.__tgt_offload_entry_ zeroinitializer\n\ + @__start_omp_offloading_entries = internal constant %%struct.__tgt_offload_entry_ zeroinitializer\n\ + @.omp_offloading.device_images = internal unnamed_addr constant [1 x %%struct.__tgt_device_image] [%%struct.__tgt_device_image { i8* @.omp_offloading.img_start.x86_64-pc-linux-gnu, i8* @.omp_offloading.img_end.x86_64-pc-linux-gnu, %%struct.__tgt_offload_entry_* @__start_omp_offloading_entries, %%struct.__tgt_offload_entry_* @__stop_omp_offloading_entries }], align 8\n\ + @.omp_offloading.descriptor_ = internal constant %%struct.__tgt_bin_desc { i64 1, %%struct.__tgt_device_image* getelementptr inbounds ([1 x %%struct.__tgt_device_image], [1 x %%struct.__tgt_device_image]* @.omp_offloading.device_images, i32 0, i32 0), %%struct.__tgt_offload_entry_* @__start_omp_offloading_entries , %%struct.__tgt_offload_entry_* @__stop_omp_offloading_entries }, align 8\n\n"); + } else { +#endif + // AOCC End + fprintf(ASMFIL, "\n; OpenMP GPU Offload Init\n\ + @.omp_offloading.img_end.nvptx64-nvidia-cuda = external constant i8 \n\ + @.omp_offloading.img_start.nvptx64-nvidia-cuda = external constant i8 \n\ + @.omp_offloading.entries_end = external constant %%struct.__tgt_offload_entry_ \n\ + @.omp_offloading.entries_begin = external constant %%struct.__tgt_offload_entry_ \n\ + @.omp_offloading.device_images = internal unnamed_addr constant [1 x %%struct.__tgt_device_image] [%%struct.__tgt_device_image { i8* @.omp_offloading.img_start.nvptx64-nvidia-cuda, i8* @.omp_offloading.img_end.nvptx64-nvidia-cuda, %%struct.__tgt_offload_entry_* @.omp_offloading.entries_begin, %%struct.__tgt_offload_entry_* @.omp_offloading.entries_end }], align 8\n\ + @.omp_offloading.descriptor_ = internal constant %%struct.__tgt_bin_desc { i64 1, %%struct.__tgt_device_image* getelementptr inbounds ([1 x %%struct.__tgt_device_image], [1 x %%struct.__tgt_device_image]* @.omp_offloading.device_images, i32 0, i32 0), %%struct.__tgt_offload_entry_* @.omp_offloading.entries_begin, %%struct.__tgt_offload_entry_* @.omp_offloading.entries_end }, align 8\n\n"); + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + } +#endif + // AOCC End isOmptargetInitialized = true; } } @@ -1109,6 +1171,18 @@ write_libomtparget(void) #endif +#ifdef OMP_OFFLOAD_LLVM + +// AOCC Begin + +/* AMDGPU offload support + * Removed multiple definition ompaccel_write_sharedvars + * + * Removed multiple definition of write_libomtparget + */ + +// AOCC end +#endif /** \brief Complete assem for the source file @@ -1170,12 +1244,22 @@ assemble_end(void) AG_ISMOD(gblsym) ? "external" : "common", name); fprintf(ASMFIL, "%s, align %d", AG_ISMOD(gblsym) ? "" : " zeroinitializer", align_value); + if (flg.omptarget && gbl.ompaccfile) { + fprintf(gbl.ompaccfile, "%%struct%s = type < { %s } > \n", name, typed); + fprintf(gbl.ompaccfile, "@%s = %s global %%struct%s ", name, + AG_ISMOD(gblsym) ? "external" : "common", name); + fprintf(gbl.ompaccfile, "%s, align %d", + AG_ISMOD(gblsym) ? "" : " zeroinitializer", align_value); + } for (llObjtodbgFirst(listp, &i); !llObjtodbgAtEnd(&i); llObjtodbgNext(&i)) { print_dbg_line(llObjtodbgGet(&i)); } llObjtodbgFree(listp); fprintf(ASMFIL, "\n"); + if (flg.omptarget && gbl.ompaccfile) { + fprintf(gbl.ompaccfile, "\n"); + } AG_DSIZE(gblsym) = 1; } } @@ -1222,6 +1306,21 @@ assemble_end(void) static void write_consts(void) { + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + FILE *llvmfile; + FILE *asmfile; + + if ((flg.amdgcn_target || flg.x86_64_omptarget) && gbl.ompaccel_isdevice) { + //printf("Setting GPU file\n"); + llvmfile = get_llasm_output_file(); + asmfile = ASMFIL; + use_gpu_output_file(); + ASMFIL = gbl.ompaccfile; + } +#endif + // AOCC End + if (gbl.consts > NOSYM) { SPTR sptr; for (sptr = gbl.consts; sptr > NOSYM; sptr = SYMLKG(sptr)) { @@ -1233,7 +1332,7 @@ write_consts(void) put_kstr(sptr, XBIT(124, 0x8000)); fputc('\n', ASMFIL); } else if (DTY(dtype) != TY_PTR) { - const char *tyName = char_type(dtype, sptr); + const char *tyName = char_type(dtype, sptr); if (OMPACCRTG(sptr)) { fprintf(ASMFIL, "@%s = external constant %s ", getsname(sptr), tyName); @@ -1245,7 +1344,9 @@ write_consts(void) fprintf(ASMFIL, "@%s = internal constant %s ", getsname(sptr), tyName); } - write_constant_value(sptr, 0, CONVAL1G(sptr), CONVAL2G(sptr), false); + // AOCC Parameters :CONVAL3G(sptr), CONVAL4G(sptr) + write_constant_value(sptr, 0, CONVAL1G(sptr), CONVAL2G(sptr), + CONVAL3G(sptr), CONVAL4G(sptr), false); } fputc('\n', ASMFIL); } @@ -1261,6 +1362,15 @@ write_consts(void) SYMLKP(tsptr, SPTR_NULL); } } + + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + if ((flg.amdgcn_target || flg.x86_64_omptarget) && gbl.ompaccel_isdevice) { + ASMFIL = asmfile; + set_llasm_output_file(llvmfile); + } +#endif + // AOCC End gbl.consts = NOSYM; } @@ -1310,8 +1420,9 @@ process_dsrt(DSRT *dsrtp, ISZ_T size, char *cptr, bool stop_at_sect, ISZ_T addr) first_data = 0; addr = dsrtp->offset; } else if (addr > dsrtp->offset) { - error(S_0164_Overlapping_data_initializations_of_OP1, ERR_Warning, 0, - SYMNAME(dsrtp->sptr), CNULL); + if (!(CFUNCG(dsrtp->sptr) && STYPEG(dsrtp->sptr) == ST_VAR)) // AOCC + error(S_0164_Overlapping_data_initializations_of_OP1, ERR_Warning, 0, + SYMNAME(dsrtp->sptr), CNULL); continue; } } @@ -1343,6 +1454,13 @@ process_dsrt(DSRT *dsrtp, ISZ_T size, char *cptr, bool stop_at_sect, ISZ_T addr) emit_init(p->dtype, p->conval, &addr, &repeat_cnt, loc_base, &i8cnt, &ptrcnt, &ptr); } + + // AOCC begin + // If this is a bind(C) variable then we stop processing `dsrt`s since each + // bind(C) variable must be a separate symbol. + if (CFUNCG(dsrtp->sptr) && STYPEG(dsrtp->sptr) == ST_VAR) + break; + // AOCC end } if (size >= 0) { @@ -1350,7 +1468,7 @@ process_dsrt(DSRT *dsrtp, ISZ_T size, char *cptr, bool stop_at_sect, ISZ_T addr) if (skip_size > 0) { if (ptrcnt) { if (!first_data && skip_size) - fprintf(ASMFIL, ", "); + fprintf(ASMFIL, ", "); if (!i8cnt) { ptr = put_next_member(ptr); fprintf(ASMFIL, "zeroinitializer "); @@ -1374,9 +1492,16 @@ process_dsrt(DSRT *dsrtp, ISZ_T size, char *cptr, bool stop_at_sect, ISZ_T addr) i8cnt = skip_size; } free(cptrCopy); - if (i8cnt) + // AOCC Begin + // i8cnt can be negattive + if (flg.amdgcn_target || flg.x86_64_omptarget) { + if (i8cnt > 0) + fprintf(ASMFIL, "] "); + } else if (i8cnt) + // AOCC End fprintf(ASMFIL, "] "); + return dsrtp; } @@ -1474,6 +1599,7 @@ write_extern_inits(void) free(typed); } } +static bool bss_written_through_ctor = false; static void write_bss(void) @@ -1490,7 +1616,16 @@ write_bss(void) int gblsym; char *type_str = "internal global"; char *bss_nm = bss_name; - + // AOCC Begin + // For offload target, write_bss function is called for first function + // through ompaccel_create_globalctor function. dont process for first + // function if it is processed already + if (flg.omptarget && gbl.bss_addr && (gbl.multi_func_count == 0)) { + if (bss_written_through_ctor) return; + bss_written_through_ctor = true; + } + if (flg.omptarget && ASMFIL == gbl.ompaccfile) return; + // AOCC end if (gbl.bss_addr) { fprintf(ASMFIL, "%%struct%s = type <{[%" ISZ_PF "d x i8]}>\n", bss_nm, gbl.bss_addr); @@ -2048,7 +2183,7 @@ write_parent_pointers(int parent, int level) /* final table size is max dimensions plus 2. The 0th element holds the * scalar subroutine and the last element holds the elemental subroutine. */ -#define FINAL_TABLE_SZ 9 +#define FINAL_TABLE_SZ MAXSUBS + 2 static int build_final_table(DTYPE dtype, SPTR ft[FINAL_TABLE_SZ]) @@ -2173,7 +2308,7 @@ has_pending_final_procedures(SPTR sptr) dtype = DTyArgType(dtype); for (mem = DTyAlgTyMember(dtype); mem > NOSYM; mem = SYMLKG(mem)) { - if (CLASSG(mem) && FINALG(mem) < 0) + if (CLASSG(mem) && FINALG(mem)) // AOCC : Changed from (FINALG(mem) < 0) return 1; } return 0; @@ -5048,6 +5183,11 @@ get_llvm_name(SPTR sptr) } if (stype != ST_ENTRY || gbl.rutype != RU_PROG) { q = SYMNAME(sptr); + // AOCC Begin + } else if (CONSTRUCTORG(sptr) && + (flg.amdgcn_target || flg.x86_64_omptarget)) { + q = SYMNAME(sptr); + // AOCC End } else if ((flg.smp || XBIT(34, 0x200) || gbl.usekmpc) && OUTLINEDG(sptr)) { q = SYMNAME(sptr); } else { @@ -5500,7 +5640,7 @@ find_funcptr_name(SPTR sptr) goto Continue; } while (*sp); if (np - sptrnm != len) - continue; + goto Continue; goto Found; Continue: if (gblsym == FPTR_HASHLK(gblsym)) @@ -5932,6 +6072,7 @@ get_sptr_uplevel_address(int sptr) { int i, gblsym; gblsym = find_ag(get_ag_searchnm(gbl.currsub)); + if (!gblsym) return 0; // AOCC for (i = 0; i < AG_UPLEVEL_AVL(gblsym); i++) { if (sptr == AG_UPLEVEL_NEW(gblsym, i)) { return AG_UPLEVEL_MEM(gblsym, i); diff --git a/tools/flang2/flang2exe/llassem_common.cpp b/tools/flang2/flang2exe/llassem_common.cpp index 64a749c77e..7447caed72 100644 --- a/tools/flang2/flang2exe/llassem_common.cpp +++ b/tools/flang2/flang2exe/llassem_common.cpp @@ -4,6 +4,17 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes for AMD GPU OpenMP offloading and bug fixes. + * Last modified: November 2019 + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ /** \file llassem_common.c @@ -68,14 +79,17 @@ static void put_ncharstring_n(char *, ISZ_T, int); static void put_zeroes(ISZ_T); static void put_cmplx_n(int, int); static void put_dcmplx_n(int, int); +static void put_qcmplx_n(int, int); static void put_i8(int); static void put_i16(int); static void put_r4(INT); static void put_r8(int, int); +static void put_r16(int, int); // AOCC static void put_int(INT); static void put_int8(INT); static void put_float(INT); static void put_double(int); +static void put_quad(int); // AOCC static void put_cmplx_n(int, int); static void put_float_cmplx(int, int); static void put_double_cmplx(int, int); @@ -139,7 +153,8 @@ put_skip(ISZ_T old, ISZ_T New) } } } else { - assert(amt == 0, "assem.c-put_skip old,new not in sync", New, ERR_Severe); + if (!flg.amdgcn_target && !flg.x86_64_omptarget) // AOCC + assert(amt == 0, "assem.c-put_skip old,new not in sync", New, ERR_Severe); } return amt; } @@ -292,8 +307,22 @@ emit_init(DTYPE tdtype, ISZ_T tconval, ISZ_T *addr, ISZ_T *repeat_cnt, fprintf(ASMFIL, ", "); #ifdef OMP_OFFLOAD_LLVM // TODO ompaccel. Hackery for TGT structs. It must be fixed later. - if (flg.omptarget) + if (flg.omptarget) { fprintf(ASMFIL, " i8* "); + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + if (flg.amdgcn_target || flg.x86_64_omptarget) { + char *temp_ptr = *cptr; + if (*temp_ptr == ',') + temp_ptr++; + while (*temp_ptr != ',' && *temp_ptr != '\0') { + temp_ptr++; + } + *cptr = temp_ptr; + } +#endif + // AOCC End + } else #endif *cptr = put_next_member(*cptr); @@ -427,6 +456,12 @@ emit_init(DTYPE tdtype, ISZ_T tconval, ISZ_T *addr, ISZ_T *repeat_cnt, if (tconval == stb.dbl0) goto do_zeroes; break; + // AOCC begin + case TY_QUAD: + if (tconval == stb.quad0) + goto do_zeroes; + break; + // AOCC end case TY_CMPLX: if (CONVAL1G(tconval) == 0 && CONVAL2G(tconval) == 0) goto do_zeroes; @@ -435,6 +470,13 @@ emit_init(DTYPE tdtype, ISZ_T tconval, ISZ_T *addr, ISZ_T *repeat_cnt, if (CONVAL1G(tconval) == stb.dbl0 && CONVAL2G(tconval) == stb.dbl0) goto do_zeroes; break; + // AOCC begin + case TY_QCMPLX: + if (CONVAL1G(tconval) == stb.quad0 && CONVAL2G(tconval) == stb.quad0 + && CONVAL4G(tconval) == stb.quad0 && CONVAL4G(tconval) == stb.quad0) + goto do_zeroes; + break; + // AOCC end #ifdef LONG_DOUBLE_FLOAT128 case TY_FLOAT128: if (tconval == stb.float128_0) @@ -458,6 +500,7 @@ emit_init(DTYPE tdtype, ISZ_T tconval, ISZ_T *addr, ISZ_T *repeat_cnt, break; } do { + bool initptrwithnull = true; if (DTY(tdtype) != TY_PTR && DTY(tdtype) != TY_STRUCT) { if (*ptrcnt) { if (!first_data) @@ -546,6 +589,17 @@ emit_init(DTYPE tdtype, ISZ_T tconval, ISZ_T *addr, ISZ_T *repeat_cnt, put_r8((int)tconval, putval); break; + // AOCC begin + case TY_QUAD: + if (DBGBIT(5, 32)) { + fprintf(gbl.dbgfil, + "emit_init:put_r16 first_data:%d i8cnt:%ld ptrcnt:%d\n", + first_data, *i8cnt, *ptrcnt); + } + put_r16((int)tconval, putval); + break; + // AOCC end + case TY_CMPLX: if (DBGBIT(5, 32)) { fprintf(gbl.dbgfil, @@ -564,6 +618,17 @@ emit_init(DTYPE tdtype, ISZ_T tconval, ISZ_T *addr, ISZ_T *repeat_cnt, put_dcmplx_n((int)tconval, putval); break; + // AOCC begin + case TY_QCMPLX: + if (DBGBIT(5, 32)) { + fprintf(gbl.dbgfil, + "emit_init:put_qcmplx_n first_data:%d i8cnt:%ld ptrcnt:%d\n", + first_data, *i8cnt, *ptrcnt); + } + put_qcmplx_n((int)tconval, putval); + break; + // AOCC end + case TY_PTR: if (*i8cnt) { fprintf(ASMFIL, /*[*/ "], "); @@ -571,8 +636,13 @@ emit_init(DTYPE tdtype, ISZ_T tconval, ISZ_T *addr, ISZ_T *repeat_cnt, fprintf(ASMFIL, ", "); *ptrcnt = *ptrcnt + 1; *i8cnt = 0; - *cptr = put_next_member(*cptr); + initptrwithnull = true; + // AOCC: if a f77 pointer is initialized with int value,we mark it as i64 type + // null pointer initialization need to be changed to 0 initialization + if (*cptr && (!strncmp(*cptr,"i64",3) || (!strncmp(*cptr,", i64",5)))) + initptrwithnull = false; + *cptr = put_next_member(*cptr); if (DBGBIT(5, 32)) { fprintf(gbl.dbgfil, "emit_init:put_addr first_data:%d i8cnt:%ld ptrcnt:%d\n", @@ -582,7 +652,7 @@ emit_init(DTYPE tdtype, ISZ_T tconval, ISZ_T *addr, ISZ_T *repeat_cnt, put_addr(SPTR_NULL, tconval, DT_NONE); } else { put_addr(SymConval1((SPTR)tconval), CONVAL2G(tconval), - DT_NONE); // ??? + DT_NONE,initptrwithnull); // ??? } break; @@ -897,6 +967,53 @@ put_double(int sptr) } } +// AOCC begin +static void +put_quad(int sptr) +{ + INT num[4]; + num[0] = CONVAL1G(sptr); + num[1] = CONVAL2G(sptr); + num[2] = CONVAL3G(sptr); + num[3] = CONVAL4G(sptr); + fprintf(ASMFIL, "fp128 "); + + if ((num[0] & 0x7ff00000) == 0x7ff00000) /* exponent == 2047 */ + fprintf(ASMFIL, "0x%08x00000000", num[0]); + else { + fprintf(ASMFIL, "0xL%.8X%.8X%.8X%.8X", num[0], num[1], num[2], num[3]); + } +} + +static void +put_r16(int sptr, int putval) +{ + INT num[4]; + + num[0] = CONVAL1G(sptr); + num[1] = CONVAL2G(sptr); + num[2] = CONVAL3G(sptr); + num[3] = CONVAL4G(sptr); + if (flg.endian) { + put_r4(num[0]); + fprintf(ASMFIL, ","); + put_r4(num[1]); + fprintf(ASMFIL, ","); + put_r4(num[2]); + fprintf(ASMFIL, ","); + put_r4(num[3]); + } else { + put_r4(num[3]); + fprintf(ASMFIL, ","); + put_r4(num[2]); + fprintf(ASMFIL, ","); + put_r4(num[1]); + fprintf(ASMFIL, ","); + put_r4(num[0]); + } +} +// AOCC end + static void put_r8(int sptr, int putval) { @@ -951,6 +1068,16 @@ put_dcmplx_n(int sptr, int putval) put_r8((int)CONVAL2G(sptr), putval); } +// AOCC begin +static void +put_qcmplx_n(int sptr, int putval) +{ + put_r16((int)CONVAL1G(sptr), putval); + fprintf(ASMFIL, ","); + put_r16((int)CONVAL2G(sptr), putval); +} +// AOCC end + /** \brief Generate an expression to add an offset to a ptr \param offset the addend @@ -992,7 +1119,7 @@ gen_ptr_offset_val(int offset, LL_Type *ret_type, char *ptr_nm) \endverbatim */ void -put_addr(SPTR sptr, ISZ_T off, DTYPE dtype) +put_addr(SPTR sptr, ISZ_T off, DTYPE dtype, bool initptrwithnull) { const char *name, *elem_type; bool is_static_or_common_block_var, in_fortran; @@ -1052,11 +1179,16 @@ put_addr(SPTR sptr, ISZ_T off, DTYPE dtype) LL_Value *ll_offset = gen_ptr_offset_val(off, ll_type, SNAME(sptr)); fprintf(ASMFIL, "%s", ll_offset->data); } - } else - fprintf(ASMFIL, "null"); - } else if (off == 0) - fprintf(ASMFIL, "null"); - else + } else { + // AOCC: if a f77 pointer is initialized with int value,we mark it as i64 type + // null pointer initialization need to be changed to 0 initialization + initptrwithnull?fprintf(ASMFIL, "null"):fprintf(ASMFIL, "0"); + } + } else if (off == 0) { + // AOCC: if a f77 pointer is initialized with int value,we mark it as i64 type + // null pointer initialization need to be changed to 0 initialization + initptrwithnull?fprintf(ASMFIL, "null"):fprintf(ASMFIL, "0"); + } else fprintf(ASMFIL, "%ld", (long)off); } diff --git a/tools/flang2/flang2exe/llassem_common.h b/tools/flang2/flang2exe/llassem_common.h index 0ad80e4573..8066b52db3 100644 --- a/tools/flang2/flang2exe/llassem_common.h +++ b/tools/flang2/flang2exe/llassem_common.h @@ -4,6 +4,15 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Bug fixes. + * Date of Modification: November 2018 + * + */ + #ifndef LLASSEM_COMMON_H_ #define LLASSEM_COMMON_H_ @@ -77,7 +86,7 @@ void init_Mcuda_compiled(void); /** \brief ... */ -void put_addr(SPTR sptr, ISZ_T off, DTYPE dtype); +void put_addr(SPTR sptr, ISZ_T off, DTYPE dtype, bool initptrwithzero=false); /** \brief ... diff --git a/tools/flang2/flang2exe/lldebug.cpp b/tools/flang2/flang2exe/lldebug.cpp index 994ead5bf0..84422551e6 100644 --- a/tools/flang2/flang2exe/lldebug.cpp +++ b/tools/flang2/flang2exe/lldebug.cpp @@ -5,6 +5,16 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights + * reserved. Notified per clause 4(b) of the license. + * + * + * Changes to DISubrange metadata for representing assumed shape arrays. + * Changes to DIModule metadata for representing Fortran modules. + * Date of Modification: July 2020 + */ + /** \file \brief Main module to generate LLVM debug informations using metadata @@ -25,6 +35,9 @@ #include "cgmain.h" #include "flang/ADT/hash.h" #include "symfun.h" +#define RTE_C +#include "rte.h" +#undef RTE_C #include #include @@ -70,6 +83,7 @@ const int DIFLAG_ISMAINPGM = 1 << 21; // removed in release_90 static int DIFLAG_PURE; // removed in release_80 static int DIFLAG_ELEMENTAL; // removed in release_80 static int DIFLAG_RECURSIVE; // removed in release_80 +const int DIFLAG_ALLCALLSDESCRIBED = 1 << 29; // added in release_80 const int DISPFLAG_LOCALTOUNIT = 1 << 2; // added in release_80 const int DISPFLAG_DEFINITION = 1 << 3; // added in release_80 @@ -129,6 +143,7 @@ struct LL_DebugInfo { LL_MDRef cur_module_mdnode; LL_MDRef cur_cmnblk_mdnode; int cur_subprogram_lineno; + LL_MDRef cur_subprogram_line_mdnode; LL_MDRef cur_subprogram_null_loc; LL_MDRef cur_line_mdnode; PARAMINFO param_stack[PARAM_STACK_SIZE]; @@ -168,11 +183,32 @@ static LL_MDRef lldbg_create_file_mdnode(LL_DebugInfo *db, char *filename, static LL_MDRef lldbg_emit_type(LL_DebugInfo *db, DTYPE dtype, SPTR sptr, int findex, bool is_reference, bool skip_first_dim, - bool skipDataDependentTypes); + bool skipDataDependentTypes, + SPTR data_sptr = SPTR_NULL); static LL_MDRef lldbg_fwd_local_variable(LL_DebugInfo *db, int sptr, int findex, int emit_dummy_as_local); static void lldbg_emit_imported_entity(LL_DebugInfo *db, SPTR entity_sptr, SPTR func_sptr, IMPORT_TYPE entity_type); +static LL_MDRef lldbg_create_subrange_mdnode(LL_DebugInfo *db, LL_MDRef count, + LL_MDRef lb, LL_MDRef ub, + LL_MDRef st); +static LL_MDRef lldbg_create_generic_subrange_mdnode(LL_DebugInfo *db, + LL_MDRef lb, LL_MDRef ub, + LL_MDRef st); +static LL_MDRef lldbg_create_subrange_via_sdsc(LL_DebugInfo *db, int findex, + SPTR sptr, int rank); +static void lldbg_get_bounds_for_sdsc(LL_DebugInfo *db, int findex, SPTR sptr, + int rank, LL_MDRef *count_expr_mdnode, + LL_MDRef *lbnd_expr_mdnode, + LL_MDRef *ubnd_expr_mdnode, + LL_MDRef *stride_expr_mdnode); + +static void lldbg_get_bounds_for_assumed_rank_sdsc( + LL_DebugInfo *db, SPTR sptr, LL_MDRef *lbnd_expr_mdnode, + LL_MDRef *ubnd_expr_mdnode, LL_MDRef *stride_expr_mdnode); +static void lldbg_register_param_mdnode(LL_DebugInfo *db, LL_MDRef mdnode, + int sptr); +INLINE static int set_dilocalvariable_flags(int sptr); /* ---------------------------------------------------------------------- */ void @@ -263,7 +299,7 @@ get_filedesc_mdnode(LL_DebugInfo *db, int index) static LL_MDRef lldbg_create_compile_unit_mdnode(LL_DebugInfo *db, int lang_tag, char *filename, char *sourcedir, char *producer, int main, - int optimized, char *compflags, int vruntime, + bool optimized, char *compflags, int vruntime, LL_MDRef *enum_types_list, LL_MDRef *retained_types_list, LL_MDRef *subprograms_list, LL_MDRef *gv_list, @@ -320,6 +356,8 @@ lldbg_create_compile_unit_mdnode(LL_DebugInfo *db, int lang_tag, char *filename, llmd_add_i32(mdb, 1); /* emissionMode: FullDebug */ llmd_add_md(mdb, *imported_entity_list); llmd_add_string(mdb, ""); + if (!XBIT(120, 0x40000000)) + llmd_add_i32(mdb, 2); /* nameTableKind: None */ } llmd_set_distinct(mdb); @@ -331,12 +369,15 @@ lldbg_create_compile_unit_mdnode(LL_DebugInfo *db, int lang_tag, char *filename, static LL_MDRef lldbg_create_module_mdnode(LL_DebugInfo *db, LL_MDRef _, char *name, - LL_MDRef scope, int lineno) + LL_MDRef scope, LL_MDRef file, int lineno) { LLMD_Builder mdb; char *module_name, *pname, *pmname; unsigned tag = ll_feature_debug_info_pre34(&db->module->ir) ? DW_TAG_namespace : DW_TAG_module; + bool is_decl = false; + if (!lineno) + is_decl = true; if (name && db->cur_module_name && !strcmp(name, db->cur_module_name)) return db->cur_module_mdnode; @@ -358,6 +399,13 @@ lldbg_create_module_mdnode(LL_DebugInfo *db, LL_MDRef _, char *name, llmd_add_i32(mdb, make_dwtag(db, DW_TAG_module)); // tag llmd_add_md(mdb, scope); // scope llmd_add_string(mdb, module_name); // name + if (ll_feature_debug_info_ver11(&db->module->ir)) { + // If it's a declaration, pass `0` as file node. + llmd_add_md(mdb, is_decl ? 0 : file); // file + llmd_add_i32(mdb, lineno); // lineno + } + if (ll_feature_debug_info_ver12(&db->module->ir) && is_decl) + llmd_add_i1(mdb, is_decl); // isDecl } else { llmd_set_class(mdb, LL_DINamespace); llmd_add_i32(mdb, make_dwtag(db, tag)); @@ -424,7 +472,7 @@ lldbg_create_subprogram_mdnode( LL_DebugInfo *db, LL_MDRef context, const char *routine, const char *mips_linkage_name, LL_MDRef def_context, int line, LL_MDRef type_mdnode, int is_local, int is_definition, int virtuality, - int vindex, int spFlags, int flags, int is_optimized, + int vindex, int spFlags, int flags, bool is_optimized, LL_MDRef template_param_mdnode, LL_MDRef decl_desc_mdnode, LL_MDRef lv_list_mdnode, int scope) { @@ -561,20 +609,36 @@ lldbg_create_global_variable_mdnode(LL_DebugInfo *db, LL_MDRef context, LLMD_Builder mdb2 = llmd_init(db->module); llmd_set_class(mdb2, LL_DIGlobalVariableExpression); llmd_add_md(mdb2, cur_mdnode); - /* Handle the Fortran allocatable array cases. Emit expression mdnode with a - * sigle argument of DW_OP_deref because of using sptr array$p instead of - * sptr array for debugging purpose. - */ - if (ftn_array_need_debug_info(sptr)) { + if (!ll_feature_debug_info_ver11(&cpu_llvm_module->ir) && + ftn_array_need_debug_info(sptr)) { + /* Handle the Fortran allocatable array cases. Emit expression mdnode with + * a single argument of DW_OP_deref because of using sptr array$p instead + * of sptr array for debugging purpose. + */ const unsigned deref = lldbg_encode_expression_arg(LL_DW_OP_deref, 0); expr_mdnode = lldbg_emit_expression_mdnode(db, 1, deref); - } else - if (ll_feature_use_5_diexpression(&db->module->ir)) { - const unsigned add = lldbg_encode_expression_arg(LL_DW_OP_plus_uconst, 0); - expr_mdnode = lldbg_emit_expression_mdnode(db, cnt, add, v); + } else if(SCOPEG(sptr) && STYPEG(sptr) == ST_PARAM) { + /* Store the constant value as an unsigned 64 bit value, + * This will help in dealing with -ve values. */ + char buffer[64]; + int convalue = CONVAL1G(sptr); + sprintf(buffer, "%d", convalue); + char *ptr; + ISZ_T uvalue = strtoul(buffer, &ptr, 10); + const unsigned value = lldbg_encode_expression_arg(LL_DW_OP_int, + CONVAL1G(sptr)); + const unsigned consts_op = lldbg_encode_expression_arg(LL_DW_OP_consts, + 0); + const unsigned stack_op = lldbg_encode_expression_arg( + LL_DW_OP_stack_value, 0); + expr_mdnode = lldbg_emit_expression_mdnode(db, 3/*Count of operands*/, + consts_op, convalue >= 0 ? value : uvalue, stack_op); + } else if (ll_feature_use_5_diexpression(&db->module->ir)) { + const unsigned add = lldbg_encode_expression_arg(LL_DW_OP_plus_uconst, 0); + expr_mdnode = lldbg_emit_expression_mdnode(db, cnt, add, v); } else { - const unsigned add = lldbg_encode_expression_arg(LL_DW_OP_plus, 0); - expr_mdnode = lldbg_emit_expression_mdnode(db, cnt, add, v); + const unsigned add = lldbg_encode_expression_arg(LL_DW_OP_plus, 0); + expr_mdnode = lldbg_emit_expression_mdnode(db, cnt, add, v); } llmd_add_md(mdb2, expr_mdnode); cur_mdnode = llmd_finish(mdb2); @@ -720,12 +784,15 @@ lldbg_create_ftn_array_type_mdnode(LL_DebugInfo *db, LL_MDRef context, int line, \param alignment alignment of array \param pts_to \param subscripts + \param data_location + \param associated + \param allocated + \param rank */ -static LL_MDRef -lldbg_create_array_type_mdnode(LL_DebugInfo *db, LL_MDRef context, int line, - ISZ_T sz, DBLINT64 alignment, LL_MDRef pts_to, - LL_MDRef subscripts) -{ +static LL_MDRef lldbg_create_array_type_mdnode( + LL_DebugInfo *db, LL_MDRef context, int line, ISZ_T sz, DBLINT64 alignment, + LL_MDRef pts_to, LL_MDRef subscripts, LL_MDRef data_location, + LL_MDRef associated, LL_MDRef allocated, LL_MDRef rank) { DBLINT64 size; LLMD_Builder mdb = llmd_init(db->module); @@ -756,6 +823,27 @@ lldbg_create_array_type_mdnode(LL_DebugInfo *db, LL_MDRef context, int line, llmd_add_null(mdb); llmd_add_null(mdb); } + if (ll_feature_debug_info_ver11(&db->module->ir)) { + if (!LL_MDREF_IS_NULL(data_location)) { + llmd_add_null(mdb); + llmd_add_md(mdb, data_location); + } else { + llmd_add_null(mdb); + llmd_add_null(mdb); + } + if (!LL_MDREF_IS_NULL(associated)) + llmd_add_md(mdb, associated); + else + llmd_add_null(mdb); + if (!LL_MDREF_IS_NULL(allocated)) + llmd_add_md(mdb, allocated); + else + llmd_add_null(mdb); + if (!LL_MDREF_IS_NULL(rank)) + llmd_add_md(mdb, rank); + else + llmd_add_null(mdb); + } return llmd_finish(mdb); } @@ -890,17 +978,20 @@ lldbg_create_aggregate_members_type(LL_DebugInfo *db, SPTR first, int findex, */ base_sptr = element; if (ALLOCATTRG(element) && SDSCG(element)) { - if (db->gbl_var_sptr) { + if (!ll_feature_debug_info_ver11(&db->module->ir) && db->gbl_var_sptr) { contains_allocatable = true; db->need_dup_composite_type |= true; } } else { - element = SYMLKG(element); - assert(element > NOSYM, + if (!SDSCG(element)) + element = SYMLKG(element); + assert(element > NOSYM, "lldbg_create_aggregate_members_type: element not exists", element, ERR_Fatal); is_desc_member = true; - db->need_dup_composite_type = false; + if (!ll_feature_debug_info_ver11(&db->module->ir)) { + db->need_dup_composite_type = false; + } } } elem_dtype = DTYPEG(element); @@ -922,7 +1013,7 @@ lldbg_create_aggregate_members_type(LL_DebugInfo *db, SPTR first, int findex, member = base_sptr; is_desc_member = false; } - if (contains_allocatable) { + if (!ll_feature_debug_info_ver11(&db->module->ir) && contains_allocatable) { db->need_dup_composite_type |= true; } if (base_sptr && SDSCG(element)) { @@ -1231,9 +1322,145 @@ lldbg_create_ftn_subrange_via_sdsc(LL_DebugInfo *db, int findex, SPTR sptr, return llmd_finish(mdb); } -static LL_MDRef -lldbg_create_subrange_mdnode(LL_DebugInfo *db, ISZ_T lb, ISZ_T ub) +static void lldbg_get_bounds_for_sdsc(LL_DebugInfo *db, int findex, SPTR sptr, + int rank, LL_MDRef *count_expr_mdnode, + LL_MDRef *lbnd_expr_mdnode, + LL_MDRef *ubnd_expr_mdnode, + LL_MDRef *stride_expr_mdnode) { + + /* + * Please consider below derived type, which has allocatable array as member. + * type dt + * integer :: var1 + * integer :: var2 + * integer, allocatable :: arr (:,:) + * end type dt + * Below should be its datalayout, + *o0=0 o1 o2 o3 + * |--------|--------|--------------------|---------------------| + * |<-var1->|<-var2->|<--address of arr-->|<-Descriptor of arr->| + * + * for allocatable array 'arr' DW_OP_push_object_address produces 'o2' to get + * to the descriptor start we need 'o3-o2' which we are calling here + * 'descr_offset_wrt_array'. + */ + const int descr_offset_wrt_array = + (SCG(SDSCG(sptr)) == SC_CMBLK || STYPEG(SDSCG(sptr)) == ST_MEMBER) + ? ADDRESSG(SDSCG(sptr)) - ADDRESSG(sptr) + : 0; + + const int F90_Desc_byte_len = 8 * (DESC_HDR_BYTE_LEN - DESC_HDR_TAG); + const int F90_DescDim_size = 8 * DESC_DIM_LEN; /* sizeof(F90_DescDim)*/ + const int F90_Desc_dim_offset = 8 * DESC_HDR_LEN; /* offsetof(F90_Desc, dim)*/ + const int count_offset_wrt_lbound = + 8 * (DESC_DIM_EXTENT - DESC_DIM_LOWER); /* offsetof(F90_DescDim, extent)*/ + const int ubound_offset_wrt_lbound = + 8 * (DESC_DIM_UPPER - DESC_DIM_LOWER); /* offsetof(F90_DescDim, ubound)*/ + const int lstride_offset_wrt_lbound = + 8 * + (DESC_DIM_LMULT - DESC_DIM_LOWER); /* offsetof(F90_DescDim, lstride)*/ + + const int target_size_offset = descr_offset_wrt_array + F90_Desc_byte_len; + const int lower_offset = + descr_offset_wrt_array + F90_Desc_dim_offset + (rank * F90_DescDim_size); + const int count_offset = lower_offset + count_offset_wrt_lbound; + const int upper_offset = lower_offset + ubound_offset_wrt_lbound; + const int stride_offset = lower_offset + lstride_offset_wrt_lbound; + + const unsigned v0 = lldbg_encode_expression_arg(LL_DW_OP_int, count_offset); + const unsigned v1 = lldbg_encode_expression_arg(LL_DW_OP_int, lower_offset); + const unsigned v2 = lldbg_encode_expression_arg(LL_DW_OP_int, upper_offset); + const unsigned v3 = lldbg_encode_expression_arg(LL_DW_OP_int, stride_offset); + const unsigned v4 = + lldbg_encode_expression_arg(LL_DW_OP_int, target_size_offset); + + const unsigned add = lldbg_encode_expression_arg(LL_DW_OP_plus_uconst, 0); + const unsigned mul = lldbg_encode_expression_arg(LL_DW_OP_mul, 0); + const unsigned deref = lldbg_encode_expression_arg(LL_DW_OP_deref, 0); + const unsigned pushobj = + lldbg_encode_expression_arg(LL_DW_OP_push_object_address, 0); + + if (count_expr_mdnode) + *count_expr_mdnode = + lldbg_emit_expression_mdnode(db, 4, pushobj, add, v0, deref); + if (lbnd_expr_mdnode) + *lbnd_expr_mdnode = + lldbg_emit_expression_mdnode(db, 4, pushobj, add, v1, deref); + if (ubnd_expr_mdnode) + *ubnd_expr_mdnode = + lldbg_emit_expression_mdnode(db, 4, pushobj, add, v2, deref); + if (stride_expr_mdnode) { + if (zsize_of(DTYPEG(sptr)) > 0) + *stride_expr_mdnode = lldbg_emit_expression_mdnode( + db, 9, pushobj, add, v3, deref, pushobj, add, v4, deref, mul); + else + *stride_expr_mdnode = ll_get_md_null(); + } +} + +static void lldbg_get_bounds_for_assumed_rank_sdsc( + LL_DebugInfo *db, SPTR sptr, LL_MDRef *lbnd_expr_mdnode, + LL_MDRef *ubnd_expr_mdnode, LL_MDRef *stride_expr_mdnode) { + + const int F90_Desc_byte_len = 8 * (DESC_HDR_BYTE_LEN - DESC_HDR_TAG); + const int F90_DescDim_size = 8 * DESC_DIM_LEN; /* sizeof(F90_DescDim)*/ + const int F90_Desc_dim_offset = 8 * DESC_HDR_LEN; /* offsetof(F90_Desc, dim)*/ + const int ubound_offset_wrt_lbound = + 8 * (DESC_DIM_UPPER - DESC_DIM_LOWER); /* offsetof(F90_DescDim, ubound)*/ + const int lstride_offset_wrt_lbound = + 8 * (DESC_DIM_LMULT - DESC_DIM_LOWER); /* offsetof(F90_DescDim, lstride)*/ + + const int target_size_offset = F90_Desc_byte_len; + const int lower_offset = F90_Desc_dim_offset; + const int upper_offset = lower_offset + ubound_offset_wrt_lbound; + const int stride_offset = lower_offset + lstride_offset_wrt_lbound; + + const unsigned v0 = + lldbg_encode_expression_arg(LL_DW_OP_int, F90_DescDim_size); + const unsigned v1 = lldbg_encode_expression_arg(LL_DW_OP_int, lower_offset); + const unsigned v2 = lldbg_encode_expression_arg(LL_DW_OP_int, upper_offset); + const unsigned v3 = lldbg_encode_expression_arg(LL_DW_OP_int, stride_offset); + const unsigned v4 = + lldbg_encode_expression_arg(LL_DW_OP_int, target_size_offset); + + const unsigned add = lldbg_encode_expression_arg(LL_DW_OP_plus_uconst, 0); + const unsigned mul = lldbg_encode_expression_arg(LL_DW_OP_mul, 0); + const unsigned plus = lldbg_encode_expression_arg(LL_DW_OP_plus, 0); + const unsigned constu = lldbg_encode_expression_arg(LL_DW_OP_constu, 0); + const unsigned deref = lldbg_encode_expression_arg(LL_DW_OP_deref, 0); + const unsigned pushobj = + lldbg_encode_expression_arg(LL_DW_OP_push_object_address, 0); + const unsigned over = lldbg_encode_expression_arg(LL_DW_OP_over, 0); + + if (lbnd_expr_mdnode) + *lbnd_expr_mdnode = lldbg_emit_expression_mdnode( + db, 9, pushobj, over, constu, v0, mul, add, v1, plus, deref); + if (ubnd_expr_mdnode) + *ubnd_expr_mdnode = lldbg_emit_expression_mdnode( + db, 9, pushobj, over, constu, v0, mul, add, v2, plus, deref); + if (stride_expr_mdnode) { + if (zsize_of(DTYPEG(sptr)) > 0) + *stride_expr_mdnode = lldbg_emit_expression_mdnode( + db, 14, pushobj, over, constu, v0, mul, add, v3, plus, deref, pushobj, + add, v4, deref, mul); + else + *stride_expr_mdnode = ll_get_md_null(); + } +} + +static LL_MDRef lldbg_create_subrange_via_sdsc(LL_DebugInfo *db, int findex, + SPTR sptr, int rank) { + LL_MDRef lbnd_expr_mdnode, ubnd_expr_mdnode, stride_expr_mdnode; + lldbg_get_bounds_for_sdsc(db, findex, sptr, rank, NULL, &lbnd_expr_mdnode, + &ubnd_expr_mdnode, &stride_expr_mdnode); + + return lldbg_create_subrange_mdnode(db, ll_get_md_null(), lbnd_expr_mdnode, + ubnd_expr_mdnode, stride_expr_mdnode); +} + +static LL_MDRef lldbg_create_subrange_mdnode_pre11(LL_DebugInfo *db, ISZ_T lb, + ISZ_T ub) { DBLINT64 count, low, high; DBLINT64 one; LLMD_Builder mdb = llmd_init(db->module); @@ -1261,6 +1488,50 @@ lldbg_create_subrange_mdnode(LL_DebugInfo *db, ISZ_T lb, ISZ_T ub) return llmd_finish(mdb); } +static LL_MDRef lldbg_create_subrange_mdnode(LL_DebugInfo *db, LL_MDRef count, + LL_MDRef lb, LL_MDRef ub, + LL_MDRef st) { + LLMD_Builder mdb = llmd_init(db->module); + + llmd_set_class(mdb, LL_DISubRange); + llmd_add_i32(mdb, make_dwtag(db, DW_TAG_subrange_type)); + if (count != ll_get_md_null()) + llmd_add_md(mdb, count); + else + llmd_add_null(mdb); + llmd_add_md(mdb, lb); + if (ub != ll_get_md_null()) + llmd_add_md(mdb, ub); + else + llmd_add_null(mdb); + if (st != ll_get_md_null()) + llmd_add_md(mdb, st); + else + llmd_add_null(mdb); + + return llmd_finish(mdb); +} + +static LL_MDRef lldbg_create_generic_subrange_mdnode(LL_DebugInfo *db, + LL_MDRef lb, LL_MDRef ub, + LL_MDRef st) { + LLMD_Builder mdb = llmd_init(db->module); + + llmd_set_class(mdb, LL_DIGenericSubRange); + llmd_add_i32(mdb, make_dwtag(db, DW_TAG_subrange_type)); + llmd_add_md(mdb, lb); + if (ub != ll_get_md_null()) + llmd_add_md(mdb, ub); + else + llmd_add_null(mdb); + if (st != ll_get_md_null()) + llmd_add_md(mdb, st); + else + llmd_add_null(mdb); + + return llmd_finish(mdb); +} + static LL_MDRef lldbg_create_unspecified_mdnode(LL_DebugInfo *db, int dw_tag) { @@ -1321,7 +1592,7 @@ lldbg_create_local_variable_mdnode(LL_DebugInfo *db, int dw_tag, LL_MDRef context, char *name, LL_MDRef fileref, int line, int argnum, LL_MDRef type_mdnode, int flags, - LL_MDRef fwd) + LL_MDRef fwd, int sptr = 0) // AOCC { LLMD_Builder mdb = llmd_init(db->module); @@ -1343,6 +1614,28 @@ lldbg_create_local_variable_mdnode(LL_DebugInfo *db, int dw_tag, llmd_add_md(mdb, type_mdnode); llmd_add_i32(mdb, flags); llmd_add_i32(mdb, 0); + + // AOCC begin + if (sptr && (flags & DIFLAG_ARTIFICIAL)) { + /* + * Mark every anonymous DILocalVariable metadata as distinct + * to avoid merging of metadata nodes having similar contents for + * a local/compiler generated variable. So that even if + * SROA happens on these variables later, they still have a + * unique metadata node. Avoiding "Overlapping fragments". + * + * Incorrect case: Overlapping fragments: + * call void @llvm.dbg.declare(metadata i64* %tmp.sroa.0, metadata !19, metadata !DIExpression(DW_OP_LLVM_fragment, 0, 64)).. + * call void @llvm.dbg.declare(metadata i64* %tmp.sroa.5, metadata !19, metadata !DIExpression(DW_OP_LLVM_fragment, 0 64)).. + * + * Corected case: No-Overlapping fragments: + * call void @llvm.dbg.declare(metadata i64* %tmp.sroa.0, metadata !19, metadata !DIExpression(DW_OP_LLVM_fragment, 0, 64)).. + * call void @llvm.dbg.declare(metadata i64* %tmp.sroa.5, metadata !20, metadata !DIExpression(DW_OP_LLVM_fragment, 0 64)).. + * */ + llmd_set_distinct(mdb); + } + // AOCC end + if (fwd) return ll_finish_variable(mdb, fwd); return llmd_finish(mdb); @@ -1555,9 +1848,31 @@ lldbg_emit_compile_unit(LL_DebugInfo *db) int lang_tag; assert(db, "Debug info not enabled", 0, ERR_Fatal); if (LL_MDREF_IS_NULL(db->comp_unit_mdnode)) { - lang_tag = DW_LANG_Fortran90; + // AOCC begin + const unsigned dwarfVers = ll_feature_dwarf_version(&db->module->ir); + switch (flg.std) { + case F77: + lang_tag = DW_LANG_Fortran77; + break; + case F90: + lang_tag = DW_LANG_Fortran90; + break; + case F95: + lang_tag = DW_LANG_Fortran95; + break; + case F2003: + lang_tag = dwarfVers > 4 ? DW_LANG_Fortran03 : DW_LANG_Fortran90; + break; + case F2008: + lang_tag = dwarfVers > 4 ? DW_LANG_Fortran08 : DW_LANG_Fortran90; + break; + default: + lang_tag = DW_LANG_Fortran90; + } + // AOCC end db->comp_unit_mdnode = lldbg_create_compile_unit_mdnode( - db, lang_tag, get_filename(1), get_currentdir(), db->producer, 1, 0, "", + db, lang_tag, get_filename(1), get_currentdir(), db->producer, 1, + flg.opt >= 1, "", 0, &db->llvm_dbg_enum, &db->llvm_dbg_retained, &db->llvm_dbg_sp, &db->llvm_dbg_gv, &db->llvm_dbg_imported); } @@ -1575,7 +1890,34 @@ lldbg_emit_file(LL_DebugInfo *db, int findex) lldbg_create_file_mdnode(db, get_filename(findex), get_currentdir(), cu_mnode, findex); } - return get_file_mdnode(db, findex); + return ll_feature_debug_info_need_file_descriptions(&db->module->ir) + ? get_filedesc_mdnode(db, 1) : get_file_mdnode(db, findex); +} + +static LOGICAL +is_procedure_dtype(DTYPE dtype) { + return dtype > DT_NONE && DTY(dtype) == TY_PROC; +} + +static LOGICAL +is_procedure_ptr_dtype(DTYPE dtype) { + return ((dtype > DT_NONE) && (DTY(dtype) == TY_PTR) && + is_procedure_dtype(DTySeqTyElement(dtype))); +} + +LOGICAL +is_procedure_ptr(SPTR sptr) { + if (sptr > NOSYM && (POINTERG(sptr))) { + switch (STYPEG(sptr)) { + case ST_PROC: + case ST_ENTRY: + /* subprograms aren't considered to be procedure pointers */ + break; + default: + return is_procedure_ptr_dtype(DTYPEG(sptr)); + } + } + return FALSE; } static LL_MDRef @@ -1606,8 +1948,12 @@ lldbg_emit_parameter_list(LL_DebugInfo *db, DTYPE dtype, DTYPE ret_dtype, lldbg_emit_modified_type(db, ret_dtype, SPTR_NULL, findex); else #endif - retval_mdnode = - lldbg_emit_type(db, ret_dtype, SPTR_NULL, findex, true, false, true); + if (DT_ISBASIC(ret_dtype)) + retval_mdnode = + lldbg_emit_type(db, ret_dtype, SPTR_NULL, findex, false, false, true); + else + retval_mdnode = + lldbg_emit_type(db, ret_dtype, SPTR_NULL, findex, true, false, true); } else { if (ll_feature_debug_info_pre34(&db->module->ir)) retval_mdnode = ll_get_md_null(); @@ -1623,7 +1969,7 @@ lldbg_emit_parameter_list(LL_DebugInfo *db, DTYPE dtype, DTYPE ret_dtype, /* do the return value, if it appears in the argument list */ num_args = 0; - if (fval && SCG(fval) == SC_DUMMY) { + if (!ret_dtype && fval && SCG(fval) == SC_DUMMY) { is_reference = ((SCG(fval) == SC_DUMMY) && HOMEDG(fval) && !PASSBYVALG(fval)); parameter_mdnode = lldbg_emit_type(db, DTYPEG(fval), fval, findex, @@ -1810,7 +2156,11 @@ lldbg_emit_lexical_block(LL_DebugInfo *db, int sptr, int lineno, int findex, NEEDB((db->blk_idx + 1), db->blk_tab, BLKINFO, db->blk_tab_size, (db->blk_tab_size + 64)); db->blk_tab[db->blk_idx].mdnode = - lldbg_create_block_mdnode(db, parent_blk_mdnode, lineno, 1, findex, ID++); + // AOCC Begin + STYPEG(sptr) == ST_BLOCK ? lldbg_create_block_mdnode(db, + parent_blk_mdnode, lineno, 1, findex, ID++) + : parent_blk_mdnode; + // AOCC End db->blk_tab[db->blk_idx].sptr = sptr; db->blk_tab[db->blk_idx].startline = startline; db->blk_tab[db->blk_idx].endline = endline; @@ -1965,14 +2315,20 @@ INLINE static int set_disubprogram_flags(LL_DebugInfo *db, int sptr) { int flags = 0; - if (CCSYMG(sptr)) - flags |= DIFLAG_ARTIFICIAL; - if (!ll_feature_debug_info_ver90(&db->module->ir)) - if (gbl.rutype == RU_PROG) - flags |= DIFLAG_ISMAINPGM; - if (!ll_feature_debug_info_ver80(&db->module->ir)) - if (PUREG(sptr)) - flags |= DIFLAG_PURE; + if (ll_feature_has_diextensions(&db->module->ir)) { + if (CCSYMG(sptr)) + flags |= DIFLAG_ARTIFICIAL; + if (!ll_feature_debug_info_ver90(&db->module->ir)) + if (gbl.rutype == RU_PROG) + flags |= DIFLAG_ISMAINPGM; + if (!ll_feature_debug_info_ver80(&db->module->ir)) + if (PUREG(sptr)) + flags |= DIFLAG_PURE; + } + + if (db->module->ir.dwarf_version >= LL_DWARF_Version_4) + flags |= DIFLAG_ALLCALLSDESCRIBED; + return flags; } @@ -2023,8 +2379,7 @@ lldbg_emit_outlined_subprogram(LL_DebugInfo *db, int sptr, int findex, file_mdnode = lldbg_emit_file(db, findex); type_mdnode = lldbg_emit_outlined_subroutine( db, sptr, DTyReturnType(DTYPEG(sptr)), findex, file_mdnode); - if (ll_feature_has_diextensions(&db->module->ir)) - flags = set_disubprogram_flags(db, sptr); + flags = set_disubprogram_flags(db, sptr); db->cur_line_mdnode = ll_get_md_null(); lv_list_mdnode = ll_create_flexible_md_node(db->module); if (db->routine_idx >= db->routine_count) @@ -2075,18 +2430,20 @@ lldbg_emit_module_mdnode(LL_DebugInfo *db, int sptr) { LL_MDRef module_mdnode; - lldbg_emit_file(db, 1); + LL_MDRef file_mdnode = lldbg_emit_file(db, 1); module_mdnode = ll_get_module_debug(db->module->module_debug_map, SYMNAME(sptr)); if (!LL_MDREF_IS_NULL(module_mdnode)) return module_mdnode; + return lldbg_create_module_mdnode(db, ll_get_md_null(), SYMNAME(sptr), - lldbg_emit_compile_unit(db), 1); + lldbg_emit_compile_unit(db), + file_mdnode, FUNCLINEG(sptr)); } void lldbg_emit_subprogram(LL_DebugInfo *db, SPTR sptr, DTYPE ret_dtype, int findex, - bool targetNVVM) + bool targetNVVM, bool entryfunc) { LL_MDRef file_mdnode; LL_MDRef type_mdnode; @@ -2099,7 +2456,7 @@ lldbg_emit_subprogram(LL_DebugInfo *db, SPTR sptr, DTYPE ret_dtype, int findex, int vindex = 0; int spFlags = 0; int flags = 0; - int is_optimized = 0; + bool is_optimized = flg.opt >= 1; int sc = SCG(sptr); int is_def; int is_local = (sc == SC_STATIC); @@ -2122,10 +2479,14 @@ lldbg_emit_subprogram(LL_DebugInfo *db, SPTR sptr, DTYPE ret_dtype, int findex, db->llvm_dbg_lv_array[db->routine_idx++] = lv_list_mdnode; lineno = FUNCLINEG(sptr); - if (ll_feature_has_diextensions(&db->module->ir)) - flags = set_disubprogram_flags(db, sptr); + flags = set_disubprogram_flags(db, sptr); get_extra_info_for_sptr(&func_name, &context_mdnode, NULL /* pmk: &type_mdnode */, db, sptr); +// AOCC Begin + // set the scope of first entry routine to compile unit + if (entryfunc) + context_mdnode = lldbg_emit_compile_unit(db); +// AOCC End is_def = DEFDG(sptr); is_def |= (STYPEG(sptr) == ST_ENTRY); if (INMODULEG(sptr) && ll_feature_create_dimodule(&db->module->ir)) { @@ -2158,8 +2519,16 @@ lldbg_emit_subprogram(LL_DebugInfo *db, SPTR sptr, DTYPE ret_dtype, int findex, db->import_entity_list->entity_type); db->import_entity_list = db->import_entity_list->next; } +// AOCC Begin + if (has_multiple_entries(gbl.currsub)) + db->cur_subprogram_null_loc = + lldbg_create_location_mdnode(db, lineno, 1, db->cur_subprogram_mdnode); + else +// AOCC End db->cur_subprogram_null_loc = - lldbg_create_location_mdnode(db, 0, 0, db->cur_subprogram_mdnode); + lldbg_create_location_mdnode(db, 0, 0, db->cur_subprogram_mdnode); + db->cur_subprogram_lineno = lineno; + db->cur_subprogram_line_mdnode = ll_get_md_null(); db->param_idx = 0; memset(db->param_stack, 0, sizeof(PARAMINFO) * PARAM_STACK_SIZE); lldbg_emit_lexical_blocks(db, sptr, findex, targetNVVM); @@ -2303,6 +2672,10 @@ lldbg_emit_line(LL_DebugInfo *db, int lineno) db->cur_line_mdnode = lldbg_create_location_mdnode(db, lineno, 1, db->blk_tab[idx].mdnode); } + // it is not yet column aware so comparing only line + if (lineno == db->cur_subprogram_lineno) + db->cur_subprogram_line_mdnode = db->cur_line_mdnode; + last_line = lineno; } } @@ -2348,6 +2721,7 @@ dwarf_encoding(DTYPE dtype) return DW_ATE_float; case TY_CMPLX: case TY_DCMPLX: + case TY_QCMPLX: // AOCC return DW_ATE_complex_float; default: break; @@ -2463,6 +2837,12 @@ is_assumed_char(DTYPE dtype) return (DTY(dtype) == TY_CHAR) && (dtype == DT_ASSCHAR); } +INLINE static bool +is_deferred_char(DTYPE dtype) +{ + return (DTY(dtype) == TY_CHAR) && (dtype == DT_DEFERCHAR); +} + INLINE static char * next_assumed_len_character_name(void) { @@ -2504,6 +2884,66 @@ lldbg_create_assumed_len_string_type_mdnode(LL_DebugInfo *db, SPTR sptr, return llmd_finish(mdb); } +INLINE static LL_MDRef +lldbg_create_deferred_len_string_type_mdnode(LL_DebugInfo *db, SPTR sptr, + int findex) +{ + LL_MDRef mdLen = ll_get_md_null(); + LL_MDRef mdLenExp = ll_get_md_null(); + LLMD_Builder mdb = llmd_init(db->module); + const char *name = "character(*)"; + const long long size = 32; + const long long alignment = 0; + const int encoding = 0; + + if (SDSCG(REVMIDLNKG(sptr)) && (DTY(DTYPEG(sptr)) == TY_PTR)) { + /* get the array descriptor */ + SPTR sdscsptr = SDSCG(REVMIDLNKG(sptr)); + LL_Type *dataloctype = LLTYPE(sdscsptr); + BLKINFO *blk_info = get_lexical_block_info(db, sdscsptr, true); + LL_MDRef file_mdnode; + if (ll_feature_debug_info_need_file_descriptions(&db->module->ir)) + file_mdnode = get_filedesc_mdnode(db, findex); + else + file_mdnode = lldbg_emit_file(db, findex); + + LL_MDRef type_mdnode = + lldbg_emit_type(db, DT_INT, sdscsptr, findex, false, false, false); + + /* create a local variable to hold the string length */ + mdLen = lldbg_create_local_variable_mdnode( + db, DW_TAG_auto_variable, blk_info->mdnode, NULL, + file_mdnode, 0, 0, type_mdnode, DIFLAG_ARTIFICIAL, + ll_get_md_null(), 1 /*distinct*/); + + /* string length is preserved in DESC_HDR_BYTE_LEN or len field of Fortran + * descriptor. i.e. offsetof(F90_Desc, len), extract it using !DIExpression + */ + const int F90_Desc_byte_len = 8 * (DESC_HDR_BYTE_LEN - DESC_HDR_TAG); + const int target_size_offset = F90_Desc_byte_len; + const unsigned v1 = + lldbg_encode_expression_arg(LL_DW_OP_int, target_size_offset); + const unsigned add = lldbg_encode_expression_arg(LL_DW_OP_plus_uconst, 0); + + /* emit an @llvm.dbg.declare with required !DIExpression */ + LL_MDRef expr_mdnode = lldbg_emit_expression_mdnode(db, 2, add, v1); + insert_llvm_dbg_declare(mdLen, sdscsptr, dataloctype, + make_mdref_op(expr_mdnode), OPF_NONE); + + mdLenExp = lldbg_emit_empty_expression_mdnode(db); + } + + llmd_set_class(mdb, LL_DIStringType); + llmd_add_i32(mdb, make_dwtag(db, DW_TAG_string_type)); + llmd_add_string(mdb, name); + llmd_add_i64(mdb, size); + llmd_add_i64(mdb, alignment); + llmd_add_i32(mdb, encoding); + llmd_add_md(mdb, mdLen); + llmd_add_md(mdb, mdLenExp); + return llmd_finish(mdb); +} + static LL_MDRef lldbg_fwd_local_variable(LL_DebugInfo *db, int sptr, int findex, int emit_dummy_as_local) @@ -2530,10 +2970,9 @@ lldbg_fwd_local_variable(LL_DebugInfo *db, int sptr, int findex, \param findex Pass through argument for creating forward reference \param db The debug info */ -INLINE static void -init_subrange_bound(LL_DebugInfo *db, ISZ_T *cb, LL_MDRef *bound_sptr, - SPTR sptr, ISZ_T defVal, int findex) -{ +INLINE static void init_subrange_bound_pre11(LL_DebugInfo *db, ISZ_T *cb, + LL_MDRef *bound_sptr, SPTR sptr, + ISZ_T defVal, int findex) { if (sptr) { switch (STYPEG(sptr)) { case ST_CONST: @@ -2555,10 +2994,30 @@ init_subrange_bound(LL_DebugInfo *db, ISZ_T *cb, LL_MDRef *bound_sptr, *cb = defVal; } -static LL_MDRef -lldbg_emit_type(LL_DebugInfo *db, DTYPE dtype, SPTR sptr, int findex, - bool is_reference, bool skip_first_dim, - bool skipDataDependentTypes) +INLINE static void init_subrange_bound(LL_DebugInfo *db, LL_MDRef *bound_sptr, + SPTR sptr, ISZ_T defVal, int findex) { + if (sptr) { + switch (STYPEG(sptr)) { + case ST_CONST: + *bound_sptr = ll_get_md_i64(db->module, ad_val_of(sptr)); + return; + case ST_VAR: + if (!db->scope_is_global) { + *bound_sptr = lldbg_fwd_local_variable(db, sptr, findex, false); + return; + } + break; + default: + break; + } + } + *bound_sptr = ll_get_md_i64(db->module, defVal); +} + +static LL_MDRef lldbg_emit_type(LL_DebugInfo *db, DTYPE dtype, SPTR sptr, + int findex, bool is_reference, + bool skip_first_dim, + bool skipDataDependentTypes, SPTR data_sptr) { LL_MDRef cu_mdnode, file_mdnode, type_mdnode; LL_MDRef subscripts_mdnode, subscript_mdnode; @@ -2583,23 +3042,36 @@ lldbg_emit_type(LL_DebugInfo *db, DTYPE dtype, SPTR sptr, int findex, type_mdnode = db->dtype_array[dtype]; if (LL_MDREF_IS_NULL(type_mdnode)) { if (is_assumed_char(dtype)) { +// AOCC Begin + /* For assumed length string type, emit !DIStringType metadata node + * if LLVM version is 11 and above. Here compiler created + * local variable holds the string length. + */ +// AOCC End + if (ll_feature_debug_info_ver11(&db->module->ir)) + type_mdnode = + lldbg_create_assumed_len_string_type_mdnode(db, sptr, findex); + else { + type_mdnode = + lldbg_emit_type(db, DT_CPTR, sptr, findex, false, false, false); #if defined(FLANG_LLVM_EXTENSIONS) - if ((!skipDataDependentTypes) && - ll_feature_has_diextensions(&db->module->ir)) { - type_mdnode = - lldbg_create_assumed_len_string_type_mdnode(db, sptr, findex); - } else { + if (!skipDataDependentTypes) { #endif - type_mdnode = - lldbg_emit_type(db, DT_CPTR, sptr, findex, false, false, false); + dtype_array_check_set(db, dtype, type_mdnode); #if defined(FLANG_LLVM_EXTENSIONS) - if (!skipDataDependentTypes) { + } #endif - dtype_array_check_set(db, dtype, type_mdnode); -#if defined(FLANG_LLVM_EXTENSIONS) } - } -#endif + } else if (is_deferred_char(dtype)) { +// AOCC Begin + /* For deferred length string type, emit !DIStringType metadata node + * if LLVM version is 11 and above. Here Fortran descriptor contains + * the string length. + */ +// AOCC End + if (ll_feature_debug_info_ver11(&db->module->ir)) + type_mdnode = + lldbg_create_deferred_len_string_type_mdnode(db, sptr, findex); } else if (DT_ISBASIC(dtype) && (DTY(dtype) != TY_PTR)) { @@ -2612,13 +3084,16 @@ lldbg_emit_type(LL_DebugInfo *db, DTYPE dtype, SPTR sptr, int findex, offset[0] = 0; offset[1] = 0; cu_mdnode = ll_get_md_null(); -#if defined(FLANG_LLVM_EXTENSIONS) + /* + * In case of character metadata node with tag DW_TAG_string_type + * should always be generated, it helps debuggers to differentiate + * fortran character type over fortran integer(kind=1) type. + */ if (ll_feature_from_global_to_md(&db->module->ir) && (DTY(dtype) == TY_CHAR)) type_mdnode = lldbg_create_string_type_mdnode( db, sz, align, stb.tynames[DTY(dtype)], dwarf_encoding(dtype)); else -#endif type_mdnode = lldbg_create_basic_type_mdnode( db, cu_mdnode, stb.tynames[DTY(dtype)], ll_get_md_null(), 0, sz, align, offset, 0, dwarf_encoding(dtype)); @@ -2659,23 +3134,28 @@ lldbg_emit_type(LL_DebugInfo *db, DTYPE dtype, SPTR sptr, int findex, /* Fortran arrays with SDSC and MIDNUM attributes have the type of either * Pointer to FortranArrayType or FortranArrayType. */ - if (ftn_array_need_debug_info(sptr)) { - SPTR array_sptr = (SPTR)REVMIDLNKG(sptr); - type_mdnode = lldbg_emit_type(db, DTYPEG(array_sptr), array_sptr, findex, - false, false, false); - /* Emit FortranArrayType instead of pointer to FortranArrayType - * to workaround a known gdb bug not able to debug array bounds. - * i.e. - * 1) On POWER, gdb 7.x fails to read array bounds either w/ or - * w/o the pointer type layer; gdb 8.x only works w/o the pointer - * type layer. - * 2) On X86, gdb 7.x works either w/ or w/o the pointer type layer, - * however, gdb 8.x only works w/o the pointer type layer. - */ - return type_mdnode; + if (!ll_feature_debug_info_ver11(&cpu_llvm_module->ir)) { + if (ftn_array_need_debug_info(sptr)) { + SPTR array_sptr = (SPTR)REVMIDLNKG(sptr); + type_mdnode = lldbg_emit_type(db, DTYPEG(array_sptr), array_sptr, + findex, false, false, false); + /* Emit FortranArrayType instead of pointer to FortranArrayType + * to workaround a known gdb bug not able to debug array bounds. + * i.e. + * 1) On POWER, gdb 7.x fails to read array bounds either w/ or + * w/o the pointer type layer; gdb 8.x only works w/o the pointer + * type layer. + * 2) On X86, gdb 7.x works either w/ or w/o the pointer type layer, + * however, gdb 8.x only works w/o the pointer type layer. + */ + return type_mdnode; + } } - type_mdnode = lldbg_emit_type(db, DTySeqTyElement(dtype), sptr, findex, - false, false, false); + type_mdnode = lldbg_emit_type(db, DTySeqTyElement(dtype), + is_procedure_ptr(sptr) + ? DTyInterface(DTySeqTyElement(dtype)) + : sptr, + findex, false, false, false); sz = (ZSIZEOF(dtype) * 8); align[1] = ((alignment(dtype) + 1) * 8); align[0] = 0; @@ -2700,6 +3180,11 @@ lldbg_emit_type(LL_DebugInfo *db, DTYPE dtype, SPTR sptr, int findex, case TY_ARRAY: { LLMD_Builder mdb = llmd_init(db->module); + LL_MDRef dataloc = ll_get_md_null(); + LL_MDRef is_live = ll_get_md_null(); + LL_MDRef associated = ll_get_md_null(); + LL_MDRef allocated = ll_get_md_null(); + LL_MDRef rank = ll_get_md_null(); ADSC *ad; int i, numdim; elem_dtype = DTySeqTyElement(dtype); @@ -2710,42 +3195,237 @@ lldbg_emit_type(LL_DebugInfo *db, DTYPE dtype, SPTR sptr, int findex, align[1] = (alignment(dtype) + 1) * 8; ad = AD_DPTR(dtype); numdim = AD_NUMDIM(ad); - if (numdim >= 1 && numdim <= 7) { - for (i = 0; i < numdim; ++i) { - SPTR lower_bnd = AD_LWBD(ad, i); - SPTR upper_bnd = AD_UPBD(ad, i); - if (ll_feature_has_diextensions(&db->module->ir)) { - // use PGI metadata extensions - LL_MDRef lbv; - LL_MDRef ubv; - if (SDSCG(sptr) && MIDNUMG(sptr) && - !(lower_bnd && STYPEG(lower_bnd) == ST_CONST && - upper_bnd && STYPEG(upper_bnd) == ST_CONST)) { - /* Create subrange mdnode based on array descriptor */ - subscript_mdnode = - lldbg_create_ftn_subrange_via_sdsc(db, findex, sptr, i); + if ((!ll_feature_debug_info_ver12(&db->module->ir) || + db->module->ir.dwarf_version < LL_DWARF_Version_5) && + data_sptr && ASSUMRANKG(data_sptr)) { + // Set dimension of array to maximum for DWARF version lower than5 + numdim = get_legal_maxdim(); + } + if (is_legal_numdim(numdim)) { /* AOCC */ + // Generate dataLocation field DW_TAG_array_type for assumed shape + // arrays, pointers and allocatables. For pointers and allocatables + // generate allocated / associated. + if (ll_feature_debug_info_ver11(&db->module->ir)) { + if ((SCG(sptr) == SC_DUMMY) && data_sptr && + db->cur_subprogram_mdnode) { + // Assumed shape array + LL_Type *dataloctype = LLTYPE(data_sptr); + /* make_lltype_from_sptr() should have added a pointer to + * the type of this local variable. Remove it */ + if (!dataloctype) + dataloctype = make_lltype_from_sptr(data_sptr); + if (dataloctype->data_type == LL_PTR) + dataloctype = dataloctype->sub_types[0]; + if (SCG(data_sptr) == SC_DUMMY) { + LL_MDRef type_mdnode = lldbg_emit_type( + db, __POINT_T, data_sptr, findex, false, false, false); + dataloc = lldbg_create_local_variable_mdnode( + db, DW_TAG_arg_variable, db->cur_subprogram_mdnode, NULL, + file_mdnode, db->cur_subprogram_lineno, + get_parnum(data_sptr), type_mdnode, + set_dilocalvariable_flags(data_sptr), ll_get_md_null()); + lldbg_register_param_mdnode(db, dataloc, data_sptr); + + } else + dataloc = + lldbg_emit_local_variable(db, data_sptr, findex, true); + + OPERAND *ld = make_operand(); + ld->ot_type = OT_MDNODE; + ld->val.sptr = data_sptr; + + /* lets generate llvm.dbg.value intrinsic for it.*/ + insert_llvm_dbg_value(ld, dataloc, data_sptr, dataloctype); + } else if (ALLOCATTRG(sptr) || POINTERG(sptr)) { + // Variables with allocatable/pointer attribute. + if (SCG(SDSCG(sptr)) == SC_CMBLK || + STYPEG(SDSCG(sptr)) == ST_MEMBER) { + const unsigned deref = + lldbg_encode_expression_arg(LL_DW_OP_deref, 0); + const unsigned pushobj = lldbg_encode_expression_arg( + LL_DW_OP_push_object_address, 0); + dataloc = lldbg_emit_expression_mdnode(db, 2, pushobj, deref); + if (ll_feature_debug_info_ver12(&db->module->ir)) { + is_live = lldbg_emit_expression_mdnode(db, 2, pushobj, deref); + if (ALLOCATTRG(sptr)) + allocated = is_live; + else + associated = is_live; + } } else { - const ISZ_T M = 1ul << ((sizeof(ISZ_T) * 8) - 1); - init_subrange_bound(db, &lb, &lbv, lower_bnd, 1, findex); - init_subrange_bound(db, &ub, &ubv, upper_bnd, M, findex); - subscript_mdnode = - lldbg_create_ftn_subrange_mdnode(db, lb, lbv, ub, ubv); + SPTR datasptr = MIDNUMG(sptr); + if (datasptr == NOSYM) + datasptr = SYMLKG(sptr); + if ((SCG(sptr) == SC_DUMMY) || ((SCG(datasptr) == SC_DUMMY) && + !db->cur_subprogram_mdnode)) { + const unsigned zero = + lldbg_encode_expression_arg(LL_DW_OP_int, 0); + const unsigned constu = + lldbg_encode_expression_arg(LL_DW_OP_constu, 0); + dataloc = lldbg_emit_expression_mdnode(db, 2, constu, zero); + if (ll_feature_debug_info_ver12(&db->module->ir)) { + is_live = lldbg_emit_expression_mdnode(db, 2, constu, zero); + if (ALLOCATTRG(sptr)) + allocated = is_live; + else + associated = is_live; + } + // If cur_subprogram_md is not yet ready, we are interested + // only in type. datalocation is about value than type. So + } else { + LL_Type *dataloctype = LLTYPE(datasptr); + /* make_lltype_from_sptr() should have added a pointer to + * the type of this local variable. Remove it */ + if (!dataloctype) + dataloctype = make_lltype_from_sptr(datasptr); + if (dataloctype->data_type == LL_PTR) + dataloctype = dataloctype->sub_types[0]; + if (SCG(datasptr) == SC_DUMMY) { + LL_MDRef type_mdnode = lldbg_emit_type( + db, __POINT_T, datasptr, findex, false, false, false); + dataloc = lldbg_create_local_variable_mdnode( + db, DW_TAG_arg_variable, db->cur_subprogram_mdnode, + NULL, file_mdnode, db->cur_subprogram_lineno, + get_parnum(sptr), type_mdnode, + set_dilocalvariable_flags(datasptr), ll_get_md_null()); + lldbg_register_param_mdnode(db, dataloc, datasptr); + } else + dataloc = + lldbg_emit_local_variable(db, datasptr, findex, true); + insert_llvm_dbg_declare(dataloc, datasptr, dataloctype, NULL, + OPF_NONE); + if (ll_feature_debug_info_ver12(&db->module->ir)) { + BLKINFO *blk_info = get_lexical_block_info(db, sptr, true); + LL_MDRef type_mdnode = lldbg_emit_type( + db, DT_LOG, sptr, findex, false, false, false); + is_live = lldbg_create_local_variable_mdnode( + db, DW_TAG_auto_variable, blk_info->mdnode, NULL, + file_mdnode, LINENOG(sptr), 0, type_mdnode, DIFLAG_ARTIFICIAL, + ll_get_md_null(), 1 /*distinct*/); + + if (ALLOCATTRG(sptr)) + allocated = is_live; + else + associated = is_live; + + insert_llvm_dbg_declare(is_live, datasptr, dataloctype, + NULL, OPF_NONE); + } + } } - llmd_add_md(mdb, subscript_mdnode); - } else { - // cons the old debug metadata - if (lower_bnd && STYPEG(lower_bnd) == ST_CONST && upper_bnd && - STYPEG(upper_bnd) == ST_CONST) { - lb = ad_val_of(lower_bnd); /* or get_isz_cval() */ - if (upper_bnd) - ub = ad_val_of(upper_bnd); /* or get_isz_cval() */ - else - ub = 0; /* error or zero-size */ - subscript_mdnode = lldbg_create_subrange_mdnode(db, lb, ub); + } + } + // For DWARF version 5 and greater make use of DW_OP_rank and + // DW_TAG_generic_subrange for assumed rank array. + if (ll_feature_debug_info_ver12(&db->module->ir) && + db->module->ir.dwarf_version >= LL_DWARF_Version_5 && data_sptr && + ASSUMRANKG(data_sptr)) { + LL_MDRef lbnd_expr_mdnode, ubnd_expr_mdnode, stride_expr_mdnode; + + const unsigned pushobj = + lldbg_encode_expression_arg(LL_DW_OP_push_object_address, 0); + const unsigned v1 = lldbg_encode_expression_arg(LL_DW_OP_int, 8); + const unsigned v2 = + lldbg_encode_expression_arg(LL_DW_OP_int, get_legal_maxdim()); + const unsigned add = + lldbg_encode_expression_arg(LL_DW_OP_plus_uconst, 0); + const unsigned deref = + lldbg_encode_expression_arg(LL_DW_OP_deref, 0); + const unsigned constu = + lldbg_encode_expression_arg(LL_DW_OP_constu, 0); + const unsigned op_and = + lldbg_encode_expression_arg(LL_DW_OP_and, 0); + // Get rank of assumed rank array from descriptor + rank = lldbg_emit_expression_mdnode(db, 7, pushobj, add, v1, deref, + constu, v2, op_and); + // Generate generic subrange + lldbg_get_bounds_for_assumed_rank_sdsc( + db, data_sptr, &lbnd_expr_mdnode, &ubnd_expr_mdnode, + &stride_expr_mdnode); + subscript_mdnode = lldbg_create_generic_subrange_mdnode( + db, lbnd_expr_mdnode, ubnd_expr_mdnode, stride_expr_mdnode); + llmd_add_md(mdb, subscript_mdnode); + } else { + + for (i = 0; i < numdim; ++i) { + SPTR lower_bnd = AD_LWBD(ad, i); + SPTR upper_bnd = AD_UPBD(ad, i); + if (ll_feature_has_diextensions(&db->module->ir)) { + // use PGI metadata extensions + LL_MDRef lbv; + LL_MDRef ubv; + if (SDSCG(sptr) && MIDNUMG(sptr) && + !(lower_bnd && STYPEG(lower_bnd) == ST_CONST && upper_bnd && + STYPEG(upper_bnd) == ST_CONST)) { + /* Create subrange mdnode based on array descriptor */ + subscript_mdnode = + lldbg_create_ftn_subrange_via_sdsc(db, findex, sptr, i); + } else { + const ISZ_T M = 1ul << ((sizeof(ISZ_T) * 8) - 1); + init_subrange_bound_pre11(db, &lb, &lbv, lower_bnd, 1, + findex); + init_subrange_bound_pre11(db, &ub, &ubv, upper_bnd, M, + findex); + subscript_mdnode = + lldbg_create_ftn_subrange_mdnode(db, lb, lbv, ub, ubv); + } llmd_add_md(mdb, subscript_mdnode); - } else { - subscript_mdnode = lldbg_create_subrange_mdnode(db, 1, 1); + } else if (ll_feature_debug_info_ver11(&db->module->ir)) { + LL_MDRef lbv = ll_get_md_null(); + LL_MDRef ubv = ll_get_md_null(); + LL_MDRef st = ll_get_md_null(); + if ((ll_feature_debug_info_ver12(&db->module->ir) && + db->module->ir.dwarf_version < LL_DWARF_Version_5 && + data_sptr && ASSUMRANKG(data_sptr)) || + ALLOCATTRG(sptr) || POINTERG(sptr)) { + /* Create subrange mdnode based on array descriptor */ + subscript_mdnode = lldbg_create_subrange_via_sdsc( + db, findex, + (data_sptr && ASSUMRANKG(data_sptr)) ? data_sptr : sptr, + i); + } else if ((SCG(sptr) == SC_DUMMY) && data_sptr && + db->cur_subprogram_mdnode) { + // assumed shape array + LL_MDRef count, s_bnd; + init_subrange_bound(db, &lbv, lower_bnd, 1, findex); + init_subrange_bound(db, &ubv, upper_bnd, 0, findex); + lldbg_get_bounds_for_sdsc(db, findex, data_sptr, i, &count, + NULL, NULL, &s_bnd); + + if (ll_feature_debug_info_ver13(&db->module->ir)) + subscript_mdnode = lldbg_create_subrange_mdnode( + db, count, lbv, ll_get_md_null(), s_bnd); + else + subscript_mdnode = lldbg_create_subrange_mdnode( + db, ll_get_md_null(), lbv, ubv, s_bnd); + } else { + // explicit shape array, assumed size array + init_subrange_bound(db, &lbv, lower_bnd, 1, findex); + if (!ll_feature_debug_info_ver12(&db->module->ir) || + (upper_bnd != SPTR_NULL)) // assumed size + init_subrange_bound(db, &ubv, upper_bnd, 0, findex); + + subscript_mdnode = + lldbg_create_subrange_mdnode(db, NULL, lbv, ubv, st); + } llmd_add_md(mdb, subscript_mdnode); + } else { + // cons the old debug metadata + if (lower_bnd && STYPEG(lower_bnd) == ST_CONST && upper_bnd && + STYPEG(upper_bnd) == ST_CONST) { + lb = ad_val_of(lower_bnd); /* or get_isz_cval() */ + if (upper_bnd) + ub = ad_val_of(upper_bnd); /* or get_isz_cval() */ + else + ub = 0; /* error or zero-size */ + subscript_mdnode = + lldbg_create_subrange_mdnode_pre11(db, lb, ub); + llmd_add_md(mdb, subscript_mdnode); + } else { + subscript_mdnode = + lldbg_create_subrange_mdnode_pre11(db, 1, 1); + llmd_add_md(mdb, subscript_mdnode); + } } } } @@ -2754,12 +3434,17 @@ lldbg_emit_type(LL_DebugInfo *db, DTYPE dtype, SPTR sptr, int findex, lldbg_emit_type(db, elem_dtype, sptr, findex, false, false, false); cu_mdnode = ll_get_md_null(); subscripts_mdnode = llmd_finish(mdb); - if (ll_feature_has_diextensions(&db->module->ir)) { + if (ll_feature_debug_info_ver11(&db->module->ir)) { + type_mdnode = lldbg_create_array_type_mdnode( + db, cu_mdnode, 0, sz, align, elem_type_mdnode, subscripts_mdnode, + dataloc, associated, allocated, rank); + } else if (ll_feature_has_diextensions(&db->module->ir)) { type_mdnode = lldbg_create_ftn_array_type_mdnode( db, cu_mdnode, 0, sz, align, elem_type_mdnode, subscripts_mdnode); } else type_mdnode = lldbg_create_array_type_mdnode( - db, cu_mdnode, 0, sz, align, elem_type_mdnode, subscripts_mdnode); + db, cu_mdnode, 0, sz, align, elem_type_mdnode, subscripts_mdnode, + dataloc, associated, allocated, rank); dtype_array_check_set(db, dtype, type_mdnode); break; } @@ -2795,7 +3480,14 @@ lldbg_emit_type(LL_DebugInfo *db, DTYPE dtype, SPTR sptr, int findex, /* TODO: Check that vector datatype is what's expected by LLVM */ lb = 0; ub = DTyVecLength(dtype) - 1; - subscript_mdnode = lldbg_create_subrange_mdnode(db, lb, ub); + if (ll_feature_debug_info_ver11(&db->module->ir)) + subscript_mdnode = lldbg_create_subrange_mdnode( + db, ll_get_md_null(), ll_get_md_i64(db->module, lb), + ll_get_md_i64(db->module, ub), ll_get_md_null()); + else + subscript_mdnode = + lldbg_create_subrange_mdnode_pre11(db, lb, DTyVecLength(dtype)); + llmd_add_md(ssmdb, subscript_mdnode); subscripts_mdnode = llmd_finish(ssmdb); sz = (ZSIZEOF(dtype) * 8); @@ -2864,16 +3556,32 @@ lldbg_emit_global_variable(LL_DebugInfo *db, SPTR sptr, ISZ_T off, int findex, bool savedScopeIsGlobal; hash_data_t val; + // Dont emit if it is uplevel variable + if (sptr && UPLEVELG(sptr)) + return; + assert(db, "Debug info not enabled", 0, ERR_Fatal); if ((!sptr) || (!DTYPEG(sptr))) return; savedScopeIsGlobal = db->scope_is_global; db->scope_is_global = true; db->gbl_var_sptr = sptr; - type_mdnode = - lldbg_emit_type(db, DTYPEG(sptr), sptr, findex, false, false, false); + SPTR new_sptr = (SPTR)REVMIDLNKG(sptr); get_extra_info_for_sptr(&display_name, &scope_mdnode, &type_mdnode, db, sptr); - display_name = SYMNAME(sptr); + if (ll_feature_debug_info_ver11(&cpu_llvm_module->ir) && CCSYMG(sptr) && + new_sptr && + (is_procedure_ptr(new_sptr) || + ((STYPEG(new_sptr) == ST_ARRAY) && + (POINTERG(new_sptr) || ALLOCATTRG(new_sptr)) && SDSCG(new_sptr)))) { + type_mdnode = lldbg_emit_type(db, DTYPEG(new_sptr), new_sptr, findex, false, + false, false); + display_name = SYMNAME(new_sptr); + flags = CCSYMG(new_sptr) ? DIFLAG_ARTIFICIAL : 0; + } else { + type_mdnode = + lldbg_emit_type(db, DTYPEG(sptr), sptr, findex, false, false, false); + flags = CCSYMG(sptr) ? DIFLAG_ARTIFICIAL : 0; + } file_mdnode = ll_feature_debug_info_need_file_descriptions(&db->module->ir) ? get_filedesc_mdnode(db, findex) : lldbg_emit_file(db, findex); @@ -2888,35 +3596,38 @@ lldbg_emit_global_variable(LL_DebugInfo *db, SPTR sptr, ISZ_T off, int findex, } else { fwd = ll_get_md_null(); } - flags = CCSYMG(sptr) ? DIFLAG_ARTIFICIAL : 0; - if (ftn_array_need_debug_info(sptr)) { - SPTR array_sptr =(SPTR)REVMIDLNKG(sptr); - /* Overwrite the display_name and flags to represent the user defined - * array instead of a compiler generated symbol of array pointer. - */ - display_name = SYMNAME(array_sptr); - flags = 0; + if (!ll_feature_debug_info_ver11(&db->module->ir)) { + if (ftn_array_need_debug_info(sptr)) { + SPTR array_sptr = (SPTR)REVMIDLNKG(sptr); + /* Overwrite the display_name and flags to represent the user defined + * array instead of a compiler generated symbol of array pointer. + */ + display_name = SYMNAME(array_sptr); + flags = 0; + } } mdref = lldbg_create_global_variable_mdnode( db, scope_mdnode, display_name, SYMNAME(sptr), "", file_mdnode, decl_line, type_mdnode, is_local, DEFDG(sptr) || (sc != SC_EXTERN), value, -1, flags, off, sptr, fwd); - if (!LL_MDREF_IS_NULL(db->gbl_obj_mdnode)) { - if (LL_MDREF_IS_NULL(db->gbl_obj_exp_mdnode)) { - /* Create a dummy global var expression mdnode to be associated to - * the global static object. - */ - db->gbl_obj_exp_mdnode = lldbg_create_global_variable_mdnode( - db, scope_mdnode, "", "", "", file_mdnode, 0, type_mdnode, 0, 0, - NULL, -1, DIFLAG_ARTIFICIAL, 0, SPTR_NULL, db->gbl_obj_mdnode); - } - if (db->need_dup_composite_type) { - /* erase dtype record to allow duplication for allocatable array type within - * derived type. - */ - dtype_array_check_set(db, DTYPEG(sptr), ll_get_md_null()); - db->need_dup_composite_type = false; + if (!ll_feature_debug_info_ver11(&db->module->ir)) { + if (!LL_MDREF_IS_NULL(db->gbl_obj_mdnode)) { + if (LL_MDREF_IS_NULL(db->gbl_obj_exp_mdnode)) { + /* Create a dummy global var expression mdnode to be associated to + * the global static object. + */ + db->gbl_obj_exp_mdnode = lldbg_create_global_variable_mdnode( + db, scope_mdnode, "", "", "", file_mdnode, 0, type_mdnode, 0, 0, + NULL, -1, DIFLAG_ARTIFICIAL, 0, SPTR_NULL, db->gbl_obj_mdnode); + } + if (db->need_dup_composite_type) { + /* erase dtype record to allow duplication for allocatable array type + * within derived type. + */ + dtype_array_check_set(db, DTYPEG(sptr), ll_get_md_null()); + db->need_dup_composite_type = false; + } } } db->gbl_var_sptr = SPTR_NULL; @@ -2932,7 +3643,8 @@ lldbg_emit_global_variable(LL_DebugInfo *db, SPTR sptr, ISZ_T off, int findex, llObjtodbgAddUnique(*listp, db->gbl_obj_exp_mdnode); } ll_add_global_debug(db->module, sptr, mdref); - if (gbl.rutype == RU_BDATA && sc == SC_CMBLK) { + // `RU_SUBR` is set for modules imported from different CompileUnits. + if ((gbl.rutype == RU_SUBR || gbl.rutype == RU_BDATA) && sc == SC_CMBLK) { const char *modvar_name; if (CCSYMG(MIDNUMG(sptr))) { modvar_name = new_debug_name(SYMNAME(ENCLFUNCG(sptr)), @@ -2997,7 +3709,7 @@ lldbg_register_value_call(LL_DebugInfo *db, INSTR_LIST *instr, int sptr) db->param_idx++; } -static LL_MDRef +LL_MDRef get_param_mdnode(LL_DebugInfo *db, int sptr) { int i; @@ -3057,7 +3769,16 @@ set_dilocalvariable_flags(int sptr) return DIFLAG_ARTIFICIAL; } #endif - return CCSYMG(sptr) ? DIFLAG_ARTIFICIAL : 0; + /* Mark the variable as artificial if (Compiler Created Symbol) + * flag is set except in the case of function result variable. + * This is done because Function result variable is available + * in source. So user expect it to be visible in debugger. + */ + if (CCSYMG(sptr) && (FVALG(GBL_CURRFUNC) != sptr)) { + return DIFLAG_ARTIFICIAL; + } else { + return 0; + } } LL_MDRef @@ -3072,8 +3793,34 @@ lldbg_emit_local_variable(LL_DebugInfo *db, SPTR sptr, int findex, file_mdnode = get_filedesc_mdnode(db, findex); else file_mdnode = lldbg_emit_file(db, findex); - type_mdnode = - lldbg_emit_type(db, DTYPEG(sptr), sptr, findex, false, false, false); + + SPTR new_sptr = (SPTR)REVMIDLNKG(sptr); + /* If it's an associate statement, associating another variable + * take the pointer to type of associated variable.*/ + if (new_sptr && CCSYMG(sptr) && !SDSCG(new_sptr) && + (ADDRTKNG(new_sptr) || is_procedure_ptr(new_sptr))) { + if (is_procedure_ptr(new_sptr)) + type_mdnode = + lldbg_emit_type(db, DTySeqTyElement(DTYPEG(new_sptr)), + DTyInterface(DTySeqTyElement(DTYPEG(new_sptr))), + findex, false, false, false); + else + type_mdnode = lldbg_emit_type(db, DTYPEG(new_sptr), sptr, findex, false, + false, false); + DBLINT64 align = {0}; + DBLINT64 offset = {0}; + offset[0] = offset[1] = 0; + align[1] = ((alignment(DT_CPTR) + 1) * 8); + type_mdnode = lldbg_create_pointer_type_mdnode( + db, lldbg_emit_compile_unit(db), "", ll_get_md_null(), 0, + (ZSIZEOF(DT_CPTR) * 8), align, offset, 0, type_mdnode); + + } else if ((ASSUMRANKG(sptr) || ASSUMSHPG(sptr)) && SDSCG(sptr)) + type_mdnode = + lldbg_emit_type(db, __POINT_T, sptr, findex, false, false, false); + else + type_mdnode = + lldbg_emit_type(db, DTYPEG(sptr), sptr, findex, false, false, false); #ifdef THISG if (ENCLFUNCG(sptr) && THISG(ENCLFUNCG(sptr)) == sptr) { symname = "this"; @@ -3091,6 +3838,12 @@ lldbg_emit_local_variable(LL_DebugInfo *db, SPTR sptr, int findex, sptr, ERR_Fatal); } else { int flags = set_dilocalvariable_flags(sptr); + + // This is base address of Assumed shape array, need to be used as + // dataLocation field of DW_TAG_array_type. Make it artificial. + if (ASSUMSHPG(sptr) && SDSCG(sptr)) + flags = DIFLAG_ARTIFICIAL; + BLKINFO *blk_info = get_lexical_block_info(db, sptr, true); LL_MDRef fwd; hash_data_t val; @@ -3100,18 +3853,25 @@ lldbg_emit_local_variable(LL_DebugInfo *db, SPTR sptr, int findex, } else { fwd = ll_get_md_null(); } - if (ftn_array_need_debug_info(sptr)) { + if (ll_feature_debug_info_ver11(&db->module->ir) && + !pointer_scalar_need_debug_info(sptr)) { + if (SDSCG(sptr)) + sptr = SDSCG(sptr); + } else if (ftn_array_need_debug_info(sptr) || + pointer_scalar_need_debug_info(sptr)) { SPTR array_sptr =(SPTR)REVMIDLNKG(sptr); - /* Overwrite the symname and flags to represent the user defined array - * instead of a compiler generated symbol of array pointer. + /* Overwrite the symname and flags to represent the user defined array or + * scalar, instead of a compiler generated symbol of array or scalar pointer */ symname = (char *)lldbg_alloc(strlen(SYMNAME(array_sptr)) + 1); strcpy(symname, SYMNAME(array_sptr)); flags = 0; } + var_mdnode = lldbg_create_local_variable_mdnode( - db, DW_TAG_auto_variable, blk_info->mdnode, symname, file_mdnode, 0, 0, - type_mdnode, flags, fwd); + db, DW_TAG_auto_variable, blk_info->mdnode, PASSBYVALG(sptr) + ? SYMNAME(MIDNUMG(sptr)) : symname, file_mdnode, LINENOG(sptr), 0, + type_mdnode, flags, fwd, sptr); } return var_mdnode; } @@ -3160,8 +3920,24 @@ lldbg_emit_param_variable(LL_DebugInfo *db, SPTR sptr, int findex, int parnum, file_mdnode = lldbg_emit_file(db, findex); is_reference = ((SCG(sptr) == SC_DUMMY) && HOMEDG(sptr) && !PASSBYVALG(sptr)); dtype = DTYPEG(sptr) ? DTYPEG(sptr) : DT_ADDR; - type_mdnode = - lldbg_emit_type(db, dtype, sptr, findex, is_reference, true, false); + if (ll_feature_debug_info_ver11(&db->module->ir)) { + if ((ASSUMRANKG(sptr) || ASSUMSHPG(sptr)) && SDSCG(sptr)) { + type_mdnode = lldbg_emit_type(db, dtype, SDSCG(sptr), findex, + is_reference, true, false, sptr); + parnum = get_parnum(SDSCG(sptr)); + } else if (STYPEG(sptr) == ST_ARRAY && + (ALLOCATTRG(sptr) || POINTERG(sptr)) && SDSCG(sptr)) { + type_mdnode = lldbg_emit_type(db, dtype, sptr, findex, is_reference, true, + false, MIDNUMG(sptr)); + parnum = get_parnum(SDSCG(sptr)); + } else { + type_mdnode = + lldbg_emit_type(db, dtype, sptr, findex, is_reference, true, false); + } + } else { + type_mdnode = + lldbg_emit_type(db, dtype, sptr, findex, is_reference, true, false); + } if (unnamed) { symname = NULL; #ifdef THISG @@ -3170,13 +3946,25 @@ lldbg_emit_param_variable(LL_DebugInfo *db, SPTR sptr, int findex, int parnum, #endif } else { symname = (char *)lldbg_alloc(sizeof(char) * (strlen(SYMNAME(sptr)) + 1)); - strcpy(symname, SYMNAME(sptr)); + /* In pass by value case flang creates a dummy variable with name + * prefixed with "_V_". For debug info creation we are using the + * absolute name. */ + if (PASSBYVALG(sptr)) + strcpy(symname, SYMNAME(MIDNUMG(sptr))); + else + strcpy(symname, SYMNAME(sptr)); } flags = set_dilocalvariable_flags(sptr); var_mdnode = lldbg_create_local_variable_mdnode( db, DW_TAG_arg_variable, db->cur_subprogram_mdnode, symname, file_mdnode, db->cur_subprogram_lineno, parnum, type_mdnode, flags, ll_get_md_null()); - lldbg_register_param_mdnode(db, var_mdnode, sptr); + if (ll_feature_debug_info_ver11(&db->module->ir) && + ((STYPEG(sptr) == ST_ARRAY && (ALLOCATTRG(sptr) || POINTERG(sptr))) || + ASSUMRANKG(sptr) || ASSUMSHPG(sptr)) && + SDSCG(sptr)) { + lldbg_register_param_mdnode(db, var_mdnode, SDSCG(sptr)); + } else + lldbg_register_param_mdnode(db, var_mdnode, sptr); return var_mdnode; } @@ -3389,18 +4177,24 @@ lldbg_create_cmblk_gv_mdnode(LL_DebugInfo *db, LL_MDRef cmnblk_mdnode, ub = dim_ele; align[1] = ((alignment(elem_dtype) + 1) * 8); align[0] = 0; - subscript_mdnode = lldbg_create_subrange_mdnode(db, lb, ub); + if (ll_feature_debug_info_ver11(&db->module->ir)) + subscript_mdnode = lldbg_create_subrange_mdnode( + db, ll_get_md_null(), ll_get_md_i64(db->module, lb), + ll_get_md_i64(db->module, ub), ll_get_md_null()); + else + subscript_mdnode = lldbg_create_subrange_mdnode_pre11(db, lb, sz); llmd_add_md(mdb, subscript_mdnode); sz *= ZSIZEOF(elem_dtype) * 8; elem_type_mdnode = lldbg_emit_type(db, elem_dtype, sptr, 1, false, false, false); subscripts_mdnode = llmd_finish(mdb); type_mdnode = lldbg_create_array_type_mdnode( - db, ll_get_md_null(), 0, sz, align, elem_type_mdnode, subscripts_mdnode); + db, ll_get_md_null(), 0, sz, align, elem_type_mdnode, subscripts_mdnode, + ll_get_md_null(), ll_get_md_null(), ll_get_md_null(), ll_get_md_null()); display_name = SYMNAME(sptr); mdref = lldbg_create_global_variable_mdnode( db, cmnblk_mdnode, display_name, SYMNAME(sptr), "", ll_get_md_null(), - DECLLINEG(sptr), type_mdnode, 0, 1, NULL, -1, DIFLAG_ARTIFICIAL, 0, + LINENOG(sptr), type_mdnode, 0, 1, NULL, -1, DIFLAG_ARTIFICIAL, 0, SPTR_NULL, ll_get_md_null()); ll_add_global_debug(db->module, sptr, mdref); return mdref; @@ -3436,7 +4230,7 @@ lldbg_create_common_block_mdnode(LL_DebugInfo *db, LL_MDRef scope, LL_MDRef lldbg_emit_common_block_mdnode(LL_DebugInfo *db, SPTR sptr) { - LL_MDRef scope_modnode, cmnblk_mdnode, cmnblk_gv_mdnode; + LL_MDRef scope_modnode, cmnblk_mdnode; SPTR scope = SCOPEG(sptr), var; const char *cmnblk_name = new_debug_name(SYMNAME(scope), SYMNAME(sptr), NULL); LL_MDNode *node; @@ -3451,11 +4245,6 @@ lldbg_emit_common_block_mdnode(LL_DebugInfo *db, SPTR sptr) cmnblk_mdnode = lldbg_create_common_block_mdnode( db, scope_modnode, ll_get_md_null(), SYMNAME(sptr)); db->cur_cmnblk_mdnode = cmnblk_mdnode; - cmnblk_gv_mdnode = lldbg_create_cmblk_gv_mdnode(db, cmnblk_mdnode, sptr); - slot = LL_MDREF_value(cmnblk_gv_mdnode) - 1; - node = db->module->mdnodes[slot]; - cmnblk_gv_mdnode = node->elem[0]; - ll_update_md_node(db->module, cmnblk_mdnode, 1, cmnblk_gv_mdnode); ll_add_module_debug(db->module->common_debug_map, cmnblk_name, cmnblk_mdnode); if (db->cur_subprogram_mdnode) add_debug_cmnblk_variables(db, sptr); @@ -3513,3 +4302,6 @@ new_debug_name(const char *str1, const char *str2, const char *str3) return (const char *)new_name; } +LL_MDRef lldbg_get_subprogram_line(LL_DebugInfo *db) { + return db->cur_subprogram_line_mdnode; +} diff --git a/tools/flang2/flang2exe/lldebug.h b/tools/flang2/flang2exe/lldebug.h index 9d680f4d4d..47508f6d09 100644 --- a/tools/flang2/flang2exe/lldebug.h +++ b/tools/flang2/flang2exe/lldebug.h @@ -23,6 +23,10 @@ \param sptr \param ret_dtype \param findex + \param targetNVVM +// AOCC Begin + \param entryfunc +// AOCC End Side-effect: stores the metadata node in the LL_DebugInfo struct. @@ -30,7 +34,7 @@ lldbg_set_func_ptr(). */ void lldbg_emit_subprogram(LL_DebugInfo *db, SPTR sptr, DTYPE ret_dtype, - int findex, bool targetNVVM); + int findex, bool targetNVVM, bool entryfunc); /** \brief Create a metadata node for the outlined subprogram \p sptr @@ -273,4 +277,12 @@ void InitializeDIFlags(const LL_IRFeatures *feature); void lldbg_reset_module(LL_DebugInfo *db); +/// \brief Get the debug location mdnode of the current procedure. +LL_MDRef lldbg_get_subprogram_line(LL_DebugInfo *db); + +/// \brief Return TRUE if SPTR is pointer to procedure. +LOGICAL is_procedure_ptr(SPTR sptr); + +/// \brief Get parameter mdnode for SPTR +LL_MDRef get_param_mdnode(LL_DebugInfo *db, int sptr); #endif /* LLDEBUG_H_ */ diff --git a/tools/flang2/flang2exe/llopt.cpp b/tools/flang2/flang2exe/llopt.cpp index bd8e2c3749..796ec59bc5 100644 --- a/tools/flang2/flang2exe/llopt.cpp +++ b/tools/flang2/flang2exe/llopt.cpp @@ -5,6 +5,15 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ + /** \file \brief optimization/peephole/inst simplification routines for LLVM Code @@ -199,6 +208,10 @@ is_recip(OPERAND *cand) return sptr == stb.flt1; case IL_DCON: return sptr == stb.dbl1; + // AOCC begin + case IL_QCON: + return sptr == stb.quad1; + // AOCC end #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128CON: return sptr == stb.float128_1; @@ -246,6 +259,10 @@ convert_mul_to_div(ILI_OP opc) return IL_FDIV; case IL_DMUL: return IL_DDIV; + // AOCC begin + case IL_QMUL: + return IL_QDIV; + // AOCC end #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128MUL: return IL_FLOAT128DIV; diff --git a/tools/flang2/flang2exe/llutil.cpp b/tools/flang2/flang2exe/llutil.cpp index 84b9b63841..5f6ce53756 100644 --- a/tools/flang2/flang2exe/llutil.cpp +++ b/tools/flang2/flang2exe/llutil.cpp @@ -4,6 +4,24 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights + * reserved. Notified per clause 4(b) of the license. + * + * Changes for AMD GPU OpenMP offloading and bug fixes. + * Last Modified : Dec 2020 + * + * Added support for quad precision + * Last modified: Feb 2020 + * + * Real128 support for math intrinsics + * Date of Modification : 24 Feb 2020 + * + * Last modified: June 2020 + * + * Support for comparing quad complex + * Date of Modification : 10 July 2020 + */ /** \file llutil.c @@ -36,6 +54,54 @@ typedef struct LLDEF { struct LLDEF *next; } LLDEF; +static const char *openmp_functions[] = { + "omp_set_dynamic", + "omp_get_dynamic", + "omp_set_num_threads", + "omp_get_max_threads", + "omp_get_level", + "omp_get_active_level", + "omp_in_parallel", + "omp_get_schedule", + "omp_set_schedule", + "omp_get_ancestor_thread_num", + "omp_get_thread_num", + "omp_get_team_size", + "omp_get_num_threads", + "omp_get_thread_limit", + "omp_get_num_procs", + "omp_set_nested", + "omp_get_nested", + "omp_set_max_active_levels", + "omp_get_max_active_levels", + "omp_get_proc_bind", + "omp_get_num_places", + "omp_get_place_num_procs", + "omp_get_place_proc_ids", + "omp_get_place_num", + "omp_get_partition_num_places", + "omp_get_partition_place_nums", + "omp_get_cancellation", + "omp_set_default_device", + "omp_get_default_device", + "omp_get_num_devices", + "omp_get_device_num", + "omp_get_num_teams", + "omp_get_team_num", + "omp_get_initial_device", + "omp_is_initial_device", + "omp_get_num_threads" +}; + +static bool is_openmp_function(const char *name) { + const int num_items = sizeof(openmp_functions)/sizeof(char *); + for (int i = 0; i < num_items; ++i) { + if (!strcmp(name, openmp_functions[i])) { + return true; + } + } + return false; +} #if DEBUG static const char *ot_names[OT_LAST] = { "OT_NONE", "OT_CONSTSPTR", "OT_VAR", "OT_TMP", "OT_LABEL", @@ -110,6 +176,7 @@ static LL_ABI_Info *ll_abi_for_missing_prototype(LL_Module *module, static bool LLTYPE_equiv(LL_Type *ty1, LL_Type *ty2); static int is_gpu_module = false; +static int tgt_offload_entry_count = 0; void llvm_set_acc_module(void) @@ -263,7 +330,10 @@ LL_InstrListFlags ldst_instr_flags_from_dtype_nme(DTYPE dtype, int nme) { unsigned flags = ldst_instr_flags_from_dtype(dtype); - if (nme == NME_VOL) + // AOCC Begin + // Adding NME_VOLATILE condition + if (nme == NME_VOL || NME_VOLATILE(nme)) + // AOCC End flags |= VOLATILE_FLAG; return (LL_InstrListFlags)flags; } @@ -287,11 +357,13 @@ ll_convert_basic_dtype_with_addrspace(LL_Module *module, DTYPE dtype, int addrsp break; case TY_DBLE: case TY_DCMPLX: - case TY_QUAD: - /* TY_QUAD represents a long double on systems that map long - * double to IEEE64. */ basetype = LL_DOUBLE; break; + // AOCC + case TY_QUAD: + case TY_QCMPLX: + /* TY_QUAD represents a float128 on systems that map long + * double to IEEE128. */ case TY_FLOAT128: case TY_CMPLX128: /* TY_FLOAT128 represents a long double (or __float128) on @@ -351,6 +423,13 @@ ll_convert_simd_dtype(LL_Module *module, DTYPE dtype) case DT_256D: base = LL_DOUBLE; break; + // AOCC begin + case DT_QUAD: + case DT_128Q: + case DT_256Q: + base = LL_FP128; + break; + // AOCC end default: interr("ll_convert_simd_dtype: unhandled dtype", dtype, ERR_Fatal); return NULL; @@ -619,7 +698,7 @@ ll_convert_array_dtype(LL_Module *module, DTYPE dtype, int addrspace) type = ll_convert_dtype(module, ddtype); - if (numdim >= 1 && numdim <= 7) { + if (is_legal_numdim(numdim)) { // AOCC /* Create nested LLVM arrays. */ int i; for (i = 0; i < numdim; i++) @@ -803,6 +882,7 @@ llis_struct_kind(DTYPE dtype) case TY_CMPLX128: case TY_CMPLX: case TY_DCMPLX: + case TY_QCMPLX: // AOCC case TY_STRUCT: case TY_UNION: return true; @@ -837,6 +917,7 @@ is_struct_kind(DTYPE dtype, bool check_return, case TY_CMPLX: return check_return; case TY_DCMPLX: + case TY_QCMPLX: // AOCC case TY_CMPLX128: return true; } @@ -987,6 +1068,11 @@ get_dtype_from_arg_opc(ILI_OP opc) case IL_ARGDP: case IL_DADP: return DT_DBLE; + // AOCC begin + case IL_ARGQP: + case IL_DAQP: + return DT_QUAD; + // AOCC end case IL_ARGAR: case IL_DAAR: return DT_CPTR; @@ -1046,6 +1132,10 @@ get_dtype_from_tytype(TY_KIND ty) return DT_CMPLX; case TY_DCMPLX: return DT_DCMPLX; + // AOCC begin + case TY_QCMPLX: + return DT_QCMPLX; + // AOCC end case TY_INT8: return DT_INT8; case TY_UINT8: @@ -1126,6 +1216,10 @@ get_dtype_for_vect_type_nme(int nme) { case DT_DBLE: dtype = DT_128D; break; + // AOCC + case DT_QUAD: + dtype = DT_128Q; + break; default: dtype = DT_128; } @@ -1138,6 +1232,10 @@ get_dtype_for_vect_type_nme(int nme) { case DT_DBLE: dtype = DT_256D; break; + // AOCC + case DT_QUAD: + dtype = DT_128Q; + break; default: dtype = DT_256; } @@ -1172,6 +1270,10 @@ dtype_from_return_type(ILI_OP ret_opc) #endif case IL_DFRDP: return DT_DBLE; + //AOCC Begin + case IL_DFRQP: + return DT_QUAD; + //AOCC End case IL_DFRIR: return DT_INT; case IL_DFRKR: @@ -1227,7 +1329,7 @@ make_lltype_from_sptr(SPTR sptr) SPTR iface; int len; int stype = 0, sc = 0; - LL_Type *llt, *llt2; + LL_Type *llt = 0, *llt2; int addrspace = LL_AddrSp_Default; ADSC *ad; INT d; @@ -1256,7 +1358,7 @@ make_lltype_from_sptr(SPTR sptr) return make_ptr_lltype(get_ftn_static_lltype(sptr)); } else if (CFUNCG(sptr) && SCG(sptr) == SC_EXTERN) { return make_ptr_lltype(get_ftn_cbind_lltype(sptr)); - } else if (SCG(sptr) == SC_LOCAL && SOCPTRG(sptr)) { + } else if (SCG(sptr) == SC_LOCAL && SOCPTRG(sptr) && STYPEG(sptr) != ST_PARAM) { return make_ptr_lltype(get_local_overlap_vartype()); } @@ -1267,20 +1369,25 @@ make_lltype_from_sptr(SPTR sptr) /* Labels */ if (stype == ST_LABEL) { - return ll_create_basic_type(llvm_get_current_module(), LL_LABEL, 0); + llt = ll_create_basic_type(llvm_get_current_module(), LL_LABEL, 0); + goto return_llt; } /* Functions */ if (is_function(sptr)) { LL_ABI_Info *abi; if (IS_FTN_PROC_PTR(sptr)) { - if ((iface = get_iface_sptr(sptr))) - return make_ptr_lltype(make_ptr_lltype(make_lltype_from_iface(iface))); - return make_ptr_lltype(make_lltype_from_dtype(DT_CPTR)); + if ((iface = get_iface_sptr(sptr))) { + llt = make_ptr_lltype(make_ptr_lltype(make_lltype_from_iface(iface))); + goto return_llt; + } + llt = make_ptr_lltype(make_lltype_from_dtype(DT_CPTR)); + goto return_llt; } abi = ll_abi_for_func_sptr(llvm_get_current_module(), sptr, DT_NONE); llt = ll_abi_function_type(abi); - return make_ptr_lltype(llt); + llt = make_ptr_lltype(llt); + goto return_llt; } /* Volatiles */ @@ -1311,8 +1418,10 @@ make_lltype_from_sptr(SPTR sptr) } } else if (llis_array_kind(sdtype)) { /* all dummy argument are i32* or i64* */ - if (SCG(sptr) == SC_DUMMY) - return make_generic_dummy_lltype(); + if (SCG(sptr) == SC_DUMMY) { + llt = make_generic_dummy_lltype(); + goto return_llt; + } /* Make all arrays to be * */ if (DTY(sdtype) == TY_CHAR) atype = DT_BINT; @@ -1396,6 +1505,10 @@ make_lltype_from_sptr(SPTR sptr) add_def(def, &llarray_def_list); } return llt; +return_llt: + DBGDUMPLLTYPE("returned type is ", llt) + DBGTRACEOUT1(" return type address %p", llt) + return llt; } /* make_lltype_from_sptr */ /* Create an OT_CONSTSPTR operand for the constant sptr. */ @@ -1416,57 +1529,16 @@ make_constsptr_op(SPTR sptr) static char * ll_get_string_buf(int string_len, char *base, int skip_quotes) { - char *name = ""; + char *name; char *from, *to; - int c, len, newlen; - - len = string_len; - from = base; - newlen = 3; - while (len--) { - c = *from++ & 0xff; - if (c == '\"' || c == '\\') { - newlen += 3; - } else if (c >= ' ' && c <= '~') { - newlen++; - } else if (c == '\n' || c == '\r') { - newlen += 3; - } else { - newlen += 3; - } - } - name = (char *)llutil_alloc((newlen + 3) * sizeof(char)); + int len; + name = (char *)llutil_alloc(string_len * sizeof(char)); to = name; - if (!skip_quotes) { - *name = '\"'; - to++; - } - from = base; len = string_len; while (len--) { - c = *from++ & 0xff; - if (c == '\"' || c == '\\') { - *to++ = '\\'; - sprintf(to, "%02X", c); - to += 2; - } else if (c >= ' ' && c <= '~') { - *to++ = c; - } else if (c == '\n' || c == '\r') { - *to++ = '\\'; - sprintf(to, "%02X", c); - to += 2; - } else { - *to++ = '\\'; - sprintf(to, "%02X", c); - to += 3; - } + *to++ = *from++; } - - if (!skip_quotes) { - *to++ = '\"'; - } - *to = '\0'; return name; } @@ -1740,12 +1812,29 @@ make_operand(void) return op; } +// AOCC Begin +#ifdef OMP_OFFLOAD_AMD +void +#else +// AOCC End static void +// AOCC Begin +#endif +// AOCC End set_llasm_output_file(FILE *fd) { LLVMFIL = fd; } +// AOCC Begin +#ifdef OMP_OFFLOAD_LLVM +FILE *get_llasm_output_file() { + return LLVMFIL; +} + +#endif // OMP_OFFLOAD_LLVM +// AOCC End + void init_output_file(void) { @@ -1756,6 +1845,17 @@ init_output_file(void) ll_write_module_header(gbl.asmfil, llvm_get_current_module()); } +//AOCC Begin +static void init_openmp_constants() +{ + //Define OpenMP constants + fprintf(gbl.ompaccfile, "@__omp_rtl_debug_kind = weak_odr hidden addrspace(1) constant i32 0\n"); + fprintf(gbl.ompaccfile, "@__omp_rtl_assume_teams_oversubscription = weak_odr hidden addrspace(1) constant i32 0\n"); + fprintf(gbl.ompaccfile, "@__omp_rtl_assume_threads_oversubscription = weak_odr hidden addrspace(1) constant i32 0\n"); + fprintf(gbl.ompaccfile, "@__omp_rtl_assume_no_thread_state = weak_odr hidden addrspace(1) constant i32 0\n"); +} +//AOCC End + void init_gpu_output_file(void) { @@ -1763,8 +1863,10 @@ init_gpu_output_file(void) return; FTN_GPU_INIT() = 1; #ifdef OMP_OFFLOAD_LLVM - if(flg.omptarget) + if(flg.omptarget) { ll_write_module_header(gbl.ompaccfile, gpu_llvm_module); + init_openmp_constants(); + } #endif } @@ -1856,7 +1958,12 @@ void print_token(const char *tk) { assert(tk, "print_token(): missing token", 0, ERR_Fatal); - fprintf(LLVMFIL, "%s", tk); + if (flg.omptarget && LLVMFIL == gbl.ompaccfile && !strncmp(tk,"@fort_ptr_assn",14)) { + fprintf(LLVMFIL, "@__tgt_"); + fprintf(LLVMFIL, tk+1); + } + else + fprintf(LLVMFIL, "%s", tk); } /** @@ -1945,8 +2052,9 @@ write_vconstant_value(int sptr, LL_Type *type, unsigned long long undef_bitmask) undef_bitmask >>= 1; switch (vtype->data_type) { + case LL_FP128: // AOCC case LL_DOUBLE: - write_constant_value(VCON_CONVAL(edtype + i), 0, 0, 0, false); + write_constant_value(VCON_CONVAL(edtype + i), 0, 0, 0,0,0, false); break; case LL_I40: case LL_I48: @@ -1954,12 +2062,12 @@ write_vconstant_value(int sptr, LL_Type *type, unsigned long long undef_bitmask) case LL_I64: case LL_I128: case LL_I256: { - write_constant_value(VCON_CONVAL(edtype + i), 0, 0, 0, false); + write_constant_value(VCON_CONVAL(edtype + i), 0, 0, 0,0,0, false); break; } /* Fall through. */ default: - write_constant_value(0, vtype, VCON_CONVAL(edtype + i), 0, false); + write_constant_value(0, vtype, VCON_CONVAL(edtype + i), 0,0,0, false); } } fputc('>', LLVMFIL); @@ -1968,12 +2076,13 @@ write_vconstant_value(int sptr, LL_Type *type, unsigned long long undef_bitmask) /** \brief Write a constant value to the output llvm file */ +// AOCC parameter: conval3, conval4 void -write_constant_value(int sptr, LL_Type *type, INT conval0, INT conval1, +write_constant_value(int sptr, LL_Type *type, INT conval0, INT conval1, INT conval2, INT conval3, bool uns) { const char *ctype; - INT num[2] = {0, 0}; + INT num[4] = {0, 0, 0, 0}; // AOCC union xx_u xx; union { double d; @@ -2022,7 +2131,7 @@ write_constant_value(int sptr, LL_Type *type, INT conval0, INT conval1, if (sptr && DTY(DTYPEG(sptr)) == TY_NCHAR) { fprintf(LLVMFIL, "%s ", ctype); } - write_constant_value(0, type->sub_types[0], conval0, conval1, uns); + write_constant_value(0, type->sub_types[0], conval0, conval1, conval2, conval3, uns); elems--; if (elems > 0) fprintf(LLVMFIL, ", "); @@ -2041,16 +2150,17 @@ write_constant_value(int sptr, LL_Type *type, INT conval0, INT conval1, LL_Type *float_type = make_lltype_from_dtype(DT_FLOAT); ctype = llvm_fc_type(DT_FLOAT); fprintf(LLVMFIL, "<{ %s ", ctype); - write_constant_value(0, float_type, CONVAL1G(sptr), 0, uns); + write_constant_value(0, float_type, CONVAL1G(sptr), 0,0,0, uns); fprintf(LLVMFIL, ", %s ", ctype); - write_constant_value(0, float_type, CONVAL2G(sptr), 0, uns); + write_constant_value(0, float_type, CONVAL2G(sptr), 0,0,0, uns); fprintf(LLVMFIL, "}>"); - } else { + } else if (DTY(DTYPEG(sptr)) == TY_DCMPLX || + DTY(DTYPEG(sptr)) == TY_QCMPLX) { //AOCC ctype = llvm_fc_type(DTYPEG(CONVAL1G(sptr))); fprintf(LLVMFIL, "<{ %s ", ctype); - write_constant_value(CONVAL1G(sptr), 0, 0, 0, uns); + write_constant_value(CONVAL1G(sptr), 0, 0, 0,0,0, uns); fprintf(LLVMFIL, ", %s ", ctype); - write_constant_value(CONVAL2G(sptr), 0, 0, 0, uns); + write_constant_value(CONVAL2G(sptr), 0, 0, 0,0,0, uns); fprintf(LLVMFIL, "}>"); } } else { @@ -2144,12 +2254,42 @@ write_constant_value(int sptr, LL_Type *type, INT conval0, INT conval1, (unsigned short)(CONVAL3G(sptr) >> 16)); return; +#ifdef LONG_DOUBLE_FLOAT128 case LL_FP128: assert(sptr, "write_constant_value(): fp128 constant without sptr", 0, ERR_Fatal); fprintf(LLVMFIL, "0xL%08x%08x%08x%08x", CONVAL1G(sptr), CONVAL2G(sptr), CONVAL3G(sptr), CONVAL4G(sptr)); return; +#endif + case LL_FP128: + if (sptr) { + num[0] = CONVAL1G(sptr); + num[1] = CONVAL2G(sptr); + num[2] = CONVAL3G(sptr); + num[3] = CONVAL4G(sptr); + } else { + num[0] = conval0; + num[1] = conval1; + num[2] = conval2; + num[3] = conval3; + } + cprintf(d, "%.37lF", num); + /* Check for `+/-Infinity` and 'NaN' based on the IEEE bit patterns */ + if ((num[0] & 0x7ff00000) == 0x7ff00000) /* exponent == 2047 */ + sprintf(d, "0x%08x%08x%08x%08x", num[0], num[1], num[2], num[3]); + /* also check for -0 */ + else if (num[0] == 0x80000000 && num[1] == 0x00000000) + sprintf(d, "-0.00000000e+00"); + fprintf(LLVMFIL, "0xL%08x%08x%08x%08x", CONVAL3G(sptr), CONVAL4G(sptr), + CONVAL1G(sptr), CONVAL2G(sptr)); + return; +#if 0 + assert(sptr, "write_constant_value(): fp128 constant without sptr", 0, ERR_Fatal); + fprintf(LLVMFIL, "0xL%08x%08x%08x%08x", CONVAL3G(sptr), CONVAL4G(sptr), + CONVAL1G(sptr), CONVAL2G(sptr)); + return; +#endif case LL_PPC_FP128: assert(sptr, "write_constant_value(): double-double constant without sptr", 0, ERR_Fatal); @@ -2194,6 +2334,88 @@ metadata_args_need_struct(void) return ll_feature_metadata_args_struct(&llvm_get_current_module()->ir); } +/** + * This function returns true for the types supported + * in function make_param_op + */ +bool should_preserve_param(const DTYPE dtype) { + switch (DTY(dtype)) { + // handled cases + case TY_ARRAY: + case TY_STRUCT: + case TY_BLOG: + case TY_SLOG: + case TY_LOG: + case TY_BINT: + case TY_SINT: + case TY_INT: + case TY_REAL: + case TY_INT8: + case TY_LOG8: + case TY_DBLE: + case TY_QUAD: + case TY_CMPLX: + case TY_DCMPLX: + case TY_QCMPLX: + case TY_CHAR: + return true; + // unsupported cases + case TY_WORD: + case TY_DWORD: + case TY_HOLL: + case TY_NCHAR: + return false; + default: + assert(0, "should_preserve_param(dtype): unexpected DTYPE", 0, ERR_Fatal); + return false; + } +} + +OPERAND *make_param_op(SPTR sptr) { + OPERAND *oper; + DTYPE dtype = DTYPEG(sptr); + + switch (DTY(dtype)) { + case TY_BLOG: + case TY_SLOG: + case TY_LOG: + case TY_BINT: + case TY_SINT: + case TY_INT: + case TY_REAL: + oper = make_constval_op(make_lltype_from_dtype(dtype), CONVAL1G(sptr), + CONVAL2G(sptr)); + break; + case TY_INT8: + case TY_LOG8: + oper = make_constval_op(make_lltype_from_dtype(dtype), + CONVAL2G(CONVAL1G(sptr)), CONVAL1G(CONVAL1G(sptr))); + break; + case TY_DBLE: + oper = make_constval_op(make_lltype_from_dtype(dtype), + CONVAL1G(CONVAL1G(sptr)), CONVAL2G(CONVAL1G(sptr))); + break; + case TY_QUAD: + oper = make_constval_opL(make_lltype_from_dtype(dtype), + CONVAL1G(CONVAL1G(sptr)), CONVAL2G(CONVAL1G(sptr)), + CONVAL3G(CONVAL1G(sptr)), CONVAL4G(CONVAL1G(sptr))); + break; + case TY_CMPLX: + case TY_DCMPLX: + case TY_QCMPLX: // AOCC + oper = make_constsptr_op((SPTR)CONVAL1G(sptr)); + break; + case TY_CHAR: + oper = make_conststring_op((SPTR)CONVAL1G(sptr)); + break; + // TODO: to add support for other types + default: + break; + } + + return oper; +} + /** \brief Write a single operand */ @@ -2224,15 +2446,20 @@ write_operand(OPERAND *p, const char *punc_string, int flags) if (p->flags & OPF_NULL_TYPE) { if (!(flags & FLG_OMIT_OP_TYPE)) write_type(p->ll_type); - print_token(" null"); + // AOCC: when pointer is initialized with a value, it is made as i64 type + // initialize it with 0 + if (!(strcmp(p->ll_type->str,"i64"))) + print_token(" 0"); + else + print_token(" null"); } else { assert(p->ll_type, "write_operand(): no type when expected", 0, ERR_Fatal); if (!(flags & FLG_OMIT_OP_TYPE)) { write_type(p->ll_type); print_space(1); } - write_constant_value(0, p->ll_type, p->val.conval[0], p->val.conval[1], - uns); + write_constant_value(0, p->ll_type, p->val.conval[0], p->val.conval[1], p->val.conval[2], + p->val.conval[3], uns); } break; case OT_UNDEF: @@ -2254,9 +2481,17 @@ write_operand(OPERAND *p, const char *punc_string, int flags) if (p->ll_type->sub_types[0]->data_type == LL_I16) { print_token(p->string); } else { - print_token("c\""); - print_token(p->string); - print_token("\""); + char buffer[6]; + print_token("["); + for (int i = 0; i < p->ll_type->sub_elements; i++) { + if (i) + print_token(", "); + print_token("i8 "); + char c = p->string[i]; + sprintf(buffer, "%d", c); + print_token(buffer); + } + print_token(" ] "); } } break; @@ -2275,7 +2510,7 @@ write_operand(OPERAND *p, const char *punc_string, int flags) if (p->flags & OPF_CONTAINS_UNDEF) { write_vconstant_value(sptr, sptrType, p->val.sptr_undef.undef_mask); } else { - write_constant_value(sptr, sptrType, 0, 0, uns); + write_constant_value(sptr, sptrType, 0, 0, 0, 0, uns); } } break; @@ -2298,8 +2533,16 @@ write_operand(OPERAND *p, const char *punc_string, int flags) write_type(pllt); if (p->flags & OPF_SRET_TYPE) print_token(" sret"); - if (p->flags & OPF_SRARG_TYPE) + if (p->flags & OPF_SRARG_TYPE) { print_token(" byval"); + print_token("("); + if (p->ll_type->data_type == LL_PTR) + write_type(p->ll_type->sub_types[0]); + else + write_type(p->ll_type); + print_token(") "); + } + print_space(1); print_token(name); break; @@ -2320,8 +2563,15 @@ write_operand(OPERAND *p, const char *punc_string, int flags) } if (p->flags & OPF_SRET_TYPE) print_token(" sret "); - if (p->flags & OPF_SRARG_TYPE) + if (p->flags & OPF_SRARG_TYPE) { print_token(" byval "); + print_token(" ( "); + if (p->ll_type->data_type == LL_PTR) + write_type(p->ll_type->sub_types[0]); + else + write_type(p->ll_type); + print_token(" ) "); + } if (p->tmps) print_tmp_name(p->tmps); else @@ -2376,11 +2626,14 @@ write_operand(OPERAND *p, const char *punc_string, int flags) new_op = make_arg_op(p->val.sptr); if (p->ll_type) new_op->ll_type = p->ll_type; + } else if (STYPEG(p->val.sptr) == ST_PARAM) { + new_op = make_param_op(p->val.sptr); } else { new_op = make_var_op(p->val.sptr); if (p->ll_type) new_op->ll_type = ll_get_pointer_type(p->ll_type); } + new_op->flags = p->flags; write_operand(new_op, "", 0); if (metadata_args_need_struct()) @@ -2611,13 +2864,14 @@ llvm_fc_type(DTYPE dtype) retc = "float"; break; case TY_DBLE: - case TY_QUAD: retc = "double"; break; + case TY_QUAD: case TY_FLOAT128: case TY_128: retc = "fp128"; break; + case TY_QCMPLX: case TY_CMPLX128: retc = "{fp128, fp128}"; break; @@ -3211,6 +3465,11 @@ process_dtype_struct(DTYPE dtype) /* if empty (extended) type - don't call process_symlinked_sptr -> oop508 */ if (is_empty_typedef(dtype)) def->values = 0; + if (!strcmp(d_name,"%struct.__tgt_offload_entry_")) { + if (tgt_offload_entry_count > 0) + def->printed=1; + tgt_offload_entry_count++; + } def->values = process_symlinked_sptr( DTyAlgTyMember(dtype), ZSIZEOF(dtype), (dty == TY_UNION), (DTyAlgTyAlign(dtype) + 1) * 8); @@ -3356,6 +3615,15 @@ add_init_const_op(DTYPE dtype, OPERAND *cur_op, ISZ_T conval, ISZ_T *repeat_cnt, cur_op = cur_op->next; address += 8; break; + // AOCC begin + case TY_QUAD: + cur_op->next = make_constval_opL(make_lltype_from_dtype(dtype), + CONVAL1G(conval), CONVAL2G(conval), + CONVAL3G(conval), CONVAL4G(conval)); + cur_op = cur_op->next; + address += 16; + break; + // AOCC end case TY_CMPLX: cur_op->next = make_constval_op(make_lltype_from_dtype(DT_FLOAT), CONVAL1G(conval), 0); @@ -3383,6 +3651,22 @@ add_init_const_op(DTYPE dtype, OPERAND *cur_op, ISZ_T conval, ISZ_T *repeat_cnt, cur_op = cur_op->next->next; address += 16; break; + // AOCC begin + case TY_QCMPLX: + cur_op->next = make_constval_opL(make_lltype_from_dtype(DT_QUAD), + CONVAL4G(CONVAL1G(conval)), + CONVAL3G(CONVAL1G(conval)), + CONVAL2G(CONVAL1G(conval)), + CONVAL1G(CONVAL1G(conval))); + cur_op->next->next = make_constval_opL(make_lltype_from_dtype(DT_QUAD), + CONVAL4G(CONVAL2G(conval)), + CONVAL3G(CONVAL2G(conval)), + CONVAL2G(CONVAL2G(conval)), + CONVAL1G(CONVAL2G(conval))); + cur_op = cur_op->next->next; + address += 32; + break; + // AOCC end case TY_CHAR: address += DTyCharLength(DTYPEG(conval)); if (STYPEG(conval) == ST_CONST) @@ -3817,7 +4101,18 @@ ll_abi_for_missing_prototype(LL_Module *module, DTYPE return_dtype, LL_ABI_Info * ll_abi_for_func_sptr(LL_Module *module, SPTR func_sptr, DTYPE dtype) { - return process_ll_abi_func_ftn_mod(module, func_sptr, false); + LL_ABI_Info *abi; + abi = process_ll_abi_func_ftn_mod(module, func_sptr, false); + // AOCC Begin + // Do not mark OpenMP API functions as variadic + // If we mark them as variadic we will have + // undefined references if we want to build the code with -O0 flag + if (is_openmp_function(SYMNAME(func_sptr))) { + abi->missing_prototype = false; + abi->call_as_varargs = false; + } + // AOCC End + return abi; } LL_ABI_Info * @@ -4000,6 +4295,15 @@ get_ftn_static_lltype(SPTR sptr) if (DESCARRAYG(sptr) && CLASSG(sptr)) return make_ptr_lltype(get_ftn_typedesc_lltype(sptr)); + // AOCC Begin +#ifdef OMP_OFFLOAD_LLVM + if (flg.amdgcn_target && gbl.ompaccel_isdevice && + OMPACCFUNCKERNELG(gbl.currsub)) { + return make_lltype_from_dtype(DTYPEG(sptr)); + } +#endif + // AOCC End + name = get_llvm_name(sptr); sprintf(tname, "struct%s", name); @@ -4174,7 +4478,7 @@ get_ftn_cbind_lltype(SPTR sptr) ad = AD_DPTR(dtype); numdim = AD_NUMDIM(ad); d = AD_NUMELM(ad); - if (numdim >= 1 && numdim <= 7) { + if (is_legal_numdim(numdim)) { // AOCC if (d == 0 || STYPEG(d) != ST_CONST) { if (XBIT(68, 0x1)) d = AD_NUMELM(ad) = stb.k1; @@ -4327,3 +4631,39 @@ ll_coercion_type(LL_Module *module, DTYPE dtype, ISZ_T size, ISZ_T reg_size) return parts[0] ? parts[0] : parts[1]; } +// AOCC Begin +char *get_flang_version() +{ +#if defined(FLANG_VERSION) + return FLANG_VERSION; +#else + return "INVALID\.VERSION"; +#endif +} + +size_t +get_flang_major_version() +{ +#if defined(FLANG_VERSION_MAJOR) + return atoi(FLANG_VERSION_MAJOR); +#else + return 10; // default llvm version +#endif +} + +size_t +get_flang_minor_version() +{ +#if defined(FLANG_VERSION_MINOR) + return atoi(FLANG_VERSION_MINOR); +#else + return 0; // default llvm version +#endif +} + +size_t +get_llvm_ir_version() +{ + return (10 * get_flang_major_version()); +} +// AOCC End diff --git a/tools/flang2/flang2exe/llutil.h b/tools/flang2/flang2exe/llutil.h index be18604801..785bebabff 100644 --- a/tools/flang2/flang2exe/llutil.h +++ b/tools/flang2/flang2exe/llutil.h @@ -4,6 +4,13 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights + * reserved. Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: June 2020 + */ #ifndef LLUTIL_H_ #define LLUTIL_H_ @@ -265,7 +272,7 @@ typedef enum LL_InstrListFlags { CALL_FUNC_PTR_FLAG = (1 << 1), CALL_INTRINSIC_FLAG = (1 << 2), HIDDEN_ARG_FLAG = (1 << 3), - SIMD_BACKEDGE_FLAG = (1 << 4), /**< I_BR only */ + LOOP_BACKEDGE_FLAG = (1 << 4), /**< I_BR only */ FAST_MATH_FLAG = (1 << 4), /**< I_CALL only */ VOLATILE_FLAG = (1 << 4), /**< I_LOAD, I_STORE, I_ATOMICRMW, I_CMPXCHG only */ @@ -1548,7 +1555,7 @@ void set_metadata_string(TMPS *t, char *string); /** \brief ... */ -void write_constant_value(int sptr, LL_Type *type, INT conval0, INT conval1, +void write_constant_value(int sptr, LL_Type *type, INT conval0, INT conval1, INT conval2, INT conval3, bool uns); /** @@ -1592,6 +1599,11 @@ bool llis_vector_kind(DTYPE dtype); bool llis_struct_kind(DTYPE dtype); bool llis_function_kind(DTYPE dtype); +/** + \brief return whether param debug info should be preserved + */ +bool should_preserve_param(const DTYPE dtype); + #ifdef OMP_OFFLOAD_LLVM /** \brief Create a file to write the device code if it has not already been created, @@ -1607,5 +1619,24 @@ void use_cpu_output_file(void); \brief Assign the gpu file to LLVMFIL */ void use_gpu_output_file(void); -#endif + + +// AOCC Begin +/** + \brief Return the current output file + */ +FILE *get_llasm_output_file(); + +#ifdef OMP_OFFLOAD_AMD +/** + \brief Set the output file to \p file + */ +void set_llasm_output_file(FILE *file); +#endif // OMP_OFFLOAD_AMD +// AOCC End +#endif // OMP_OFFLOAD_LLVM +char* get_flang_version(); +size_t get_flang_major_version(); +size_t get_flang_minor_version(); +size_t get_llvm_ir_version(); #endif diff --git a/tools/flang2/flang2exe/main.cpp b/tools/flang2/flang2exe/main.cpp index a02db8b27a..c20b4e62a7 100644 --- a/tools/flang2/flang2exe/main.cpp +++ b/tools/flang2/flang2exe/main.cpp @@ -5,6 +5,18 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading + * Last modified: 02nd June 2020 + * + * Support for x86-64 OpenMP offloading + * Last modified: Apr 2020 + */ + + /** \file \brief Fortran backend main program and initialization routines. @@ -46,6 +58,12 @@ #include #include "flang/ArgParser/arg_parser.h" #include "dtypeutl.h" +#include +// AOCC BEGIN +#ifdef DEBUG +#include "debug.h" +#endif // DEBUG +// AOCC END static bool process_input(char *argv0, bool *need_cuda_constructor); @@ -54,6 +72,7 @@ static bool process_input(char *argv0, bool *need_cuda_constructor); extern int errno; #endif #endif +extern int HasRequiresUnifiedSharedMemory; #define IS_COFF (flg.astype == 1) #define IS_ELF (flg.astype == 0) @@ -92,6 +111,8 @@ static char *who[] = {"init", "import", "expand", "", "", static INT xtimes[_N_WHO]; static char *cmdline = NULL; static char *ccff_filename = NULL; +char *flang_version_sha = {FLANG_SHA}; + #include "ccffinfo.h" #if DEBUG @@ -242,8 +263,18 @@ process_input(char *argv0, bool *need_cuda_constructor) #ifdef OMP_OFFLOAD_LLVM if (flg.omptarget) { init_test(); - ompaccel_initsyms(); - ompaccel_create_reduction_wrappers(); + if (!flg.x86_64_omptarget) { // AOCC + ompaccel_initsyms(); + // AOCC Begin + // ompaccel_create_reduction_wrappers() emits reduction wrappers + // for current tinfo. But current tinfo doesn't always point to + // current subroutines tinfo. + if (flg.amdgcn_target) + ompaccel_create_amd_reduction_wrappers(); + else + // AOCC End + ompaccel_create_reduction_wrappers(); + } } #endif if (gbl.cuda_constructor) { @@ -317,11 +348,37 @@ process_input(char *argv0, bool *need_cuda_constructor) #if defined(OMP_OFFLOAD_LLVM) if (flg.omptarget && ompaccel_tinfo_has(gbl.currsub)) gbl.ompaccel_isdevice = true; + // AOCC begin + // We do a late type modification. Doing this during + // ompaccel_create_device_symbol() can end up lowering incorrect code. + // And, in some scenarios there are assertion failures as well. + // So doing it right before the final schedule. + if (flg.omptarget) { + // TODO: maybe rename this if we're sure that all -fopenmp-targets + // require this ? + ompaccel_x86_fix_arg_types(gbl.currsub); + } + // AOCC end #endif TR("F90 SCHEDULER begins\n"); DUMP("before-schedule"); + // AOCC Begin +#if defined(OMP_OFFLOAD_LLVM) + if (OMPACCFUNCDEVG(gbl.currsub)) { + bool orig = gbl.ompaccel_isdevice; + gbl.ompaccel_isdevice = true; + schedule(); + gbl.ompaccel_isdevice = orig; + if (flg.omptarget && !gbl.ompaccel_isdevice) { + schedule(); + } + } else { + schedule(); + } +#else schedule(); +#endif xtimes[5] += get_rutime(); DUMP("schedule"); } /* CUDAG(GBL_CURRFUNC) & CUDA_HOST */ @@ -331,6 +388,18 @@ process_input(char *argv0, bool *need_cuda_constructor) xtimes[6] += get_rutime(); upper_save_syminfo(); } + + // AOCC begin +#if defined(OMP_OFFLOAD_LLVM) + if (flg.x86_64_omptarget && !XBIT(232, 0x1)) { + bool orig = gbl.ompaccel_isdevice; + gbl.ompaccel_isdevice = true; + ompaccel_x86_gen_fork_wrapper(gbl.currsub); + gbl.ompaccel_isdevice = orig; + } +#endif + // AOCC end + if (DBGBIT(5, 4)) symdmp(gbl.dbgfil, DBGBIT(5, 8)); if (DBGBIT(5, 16)) @@ -418,7 +487,7 @@ main(int argc, char *argv[]) #ifdef OMP_OFFLOAD_LLVM if (flg.omptarget) { init_test(); - ompaccel_create_globalctor(); + // ompaccel_create_globalctor(); gbl.func_count--; gbl.multi_func_count = gbl.func_count; } @@ -431,6 +500,9 @@ main(int argc, char *argv[]) } while (!gbl.eof_flag); cg_llvm_end(); + if (flg.march) { + ompaccel_create_globalctor(); + } if (flg.smp) { ll_unlink_parfiles(); @@ -547,6 +619,12 @@ init(int argc, char *argv[]) char *idfname; time_t now; + // Display version sha and exit + if (argv[1] && strcmp(argv[1],"--version") == 0) { + fprintf(stderr, "%s\n", flang_version_sha); + exit(0); + } + file_suffix = FTNFILE; /* default suffix for source files */ /* * initialize error and symbol table modules in case error messages are @@ -648,19 +726,43 @@ init(int argc, char *argv[]) register_string_arg(arg_parser, "fopenmp-targets", &omptp, NULL); register_string_arg(arg_parser, "fopenmp-targets-asm", &ompfile, NULL); register_boolean_arg(arg_parser, "reentrant", &arg_reentrant, false); - register_integer_arg(arg_parser, "terse", &flg.terse, 1); - register_boolean_arg(arg_parser, "quad", &flg.quad, false); - register_boolean_arg(arg_parser, "save", &flg.save, false); + + register_integer_arg(arg_parser, "terse", &(flg.terse), 1); + register_boolean_arg(arg_parser, "quad", (bool *)&(flg.quad), false); + register_boolean_arg(arg_parser, "save", (bool *)&(flg.save), false); + register_boolean_arg(arg_parser, "func_args_alias", (bool *)&(flg.func_args_alias), false); // AOCC register_string_arg(arg_parser, "tp", &tp, NULL); - register_integer_arg(arg_parser, "astype", &flg.astype, 0); - register_boolean_arg(arg_parser, "recursive", &flg.recursive, false); - register_integer_arg(arg_parser, "vect", &vect_val, 0); - register_string_arg(arg_parser, "cmdline", &cmdline, NULL); - register_boolean_arg(arg_parser, "debug", &flg.debug, false); + register_integer_arg(arg_parser, "astype", &(flg.astype), 0); + register_boolean_arg(arg_parser, "recursive", (bool *)&(flg.recursive), + false); + register_integer_arg(arg_parser, "vect", &(vect_val), 0); + register_string_arg(arg_parser, "cmdline", &(cmdline), NULL); + register_boolean_arg(arg_parser, "debug", (bool *)&(flg.debug), false); + // AOCC Begin + register_boolean_arg(arg_parser, "use_llvm_math_intrin", + (bool *)&(flg.use_llvm_math_intrin), true); + register_string_arg(arg_parser, "std", &flg.std_string, "unknown"); + register_boolean_arg(arg_parser, "disable-vectorize-pragmas", + (bool *)&(flg.disable_loop_vectorize_pragmas), false); + register_integer_arg(arg_parser, "warp_size", &(flg.warp_size), 64); + register_string_arg(arg_parser, "march", &flg.march, NULL); + + // Debug Logs +#ifdef DEBUG + register_boolean_arg(arg_parser, "debug-log", (bool *)&(flg.debug_log), 0); + register_string_arg(arg_parser, "debug-only", &(flg.debug_only_strs), NULL); +#endif // DEBUG + // AOCC End /* Run argument parser */ parse_arguments(arg_parser, argc, argv); + // AOCC Begin +#ifdef DEBUG + DEBUG_LOG_INIT(flg.debug_log, flg.debug_only_strs); +#endif // DEBUG + // AOCC End + /* Process debug output settings */ if (was_value_set(arg_parser, &(flg.dbg)) || was_value_set(arg_parser, phase_dump_map)) { @@ -702,6 +804,27 @@ init(int argc, char *argv[]) flg.recursive = false; } } + // AOCC begin + /* setting the fortran standard */ + if (strcmp(flg.std_string, "f2008") == 0) { + flg.std = F2008; + } else if (strcmp(flg.std_string, "f2003") == 0) { + flg.std = F2003; + } else if (strcmp(flg.std_string, "f90") == 0) { + flg.std = F90; + } else if (strcmp(flg.std_string, "f77") == 0) { + flg.std = F77; + } else if (strcmp(flg.std_string, "f95") == 0) { + flg.std = F95; + } else if (strcmp(flg.std_string, "unknown") == 0) { + flg.std = STD_UNKNOWN; + } else { + interr("Erroneous -std option", 0, ERR_Fatal); + } + // AOCC end + + warp_size_log2 = log2(flg.warp_size); + warp_size_log2_mask = flg.warp_size - 1; /* Free memory */ destroy_arg_parser(&arg_parser); @@ -719,6 +842,10 @@ init(int argc, char *argv[]) } #if defined(OMP_OFFLOAD_LLVM) || defined(OMP_OFFLOAD_PGI) flg.omptarget = false; + // AOCC begin + flg.amdgcn_target = false; + flg.x86_64_omptarget = false; + // AOCC end gbl.ompaccfilename = NULL; #endif #ifdef OMP_OFFLOAD_LLVM @@ -727,6 +854,25 @@ init(int argc, char *argv[]) flg.omptarget = true; gbl.ompaccfilename = ompfile; } + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + if (omptp && !strcmp(omptp, "amdgcn-amd-amdhsa")) + flg.amdgcn_target = true; + else if (omptp && strcmp(omptp, "x86_64-pc-linux-gnu") == 0) + flg.x86_64_omptarget = true; +#endif + // Force -Mx,232,0x40 for amdgcn offloading + if (flg.amdgcn_target) { + flg.x[232] |= 0x40; + } + + // alias settings + flg.x[53] |= 0x800000; + + // aggressive gep folding + // flg.x[2] |= 0x2000000; + // AOCC End + #endif /* Vectorizer settings */ flg.vect |= vect_val; @@ -959,6 +1105,17 @@ finish() if (flg.smp) { ll_unlink_parfiles(); } + // AOCC Begin + #ifdef OMP_OFFLOAD_LLVM + if (gbl.ompaccfile != NULL && gbl.ompaccfile != stdout) { + fclose(gbl.ompaccfile); + gbl.ompaccfile = NULL; + } + #endif +#ifdef DEBUG + DEBUG_LOG_DEINIT(); +#endif // DEBUG + // AOCC End if (ccff_filename) ccff_close(); @@ -1051,12 +1208,21 @@ static void ompaccel_create_globalctor() { if (!XBIT(232, 0x10) && !ompaccel_is_tgt_registered()) { + // AOCC Begin + // This is a constructor and will not contain any subprograms + int temp_internal = gbl.internal; + gbl.internal = 0; + // AOCC End SPTR cur_func_sptr = gbl.currsub; ompaccel_emit_tgt_register(); schedule(); assemble(); ompaccel_register_tgt(); gbl.currsub = cur_func_sptr; + // AOCC Begin + llutil_struct_def_reset(); + gbl.internal = temp_internal; + // AOCC End } } @@ -1069,25 +1235,62 @@ ompaccel_create_reduction_wrappers() { if (gbl.ompaccel_intarget && gbl.currsub != NULL) { int nreds = ompaccel_tinfo_current_get()->n_reduction_symbols; + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + /* + * Adding suffix to reduction function names. This is to avoid duplicate + * function names in the case of multi kernel applications + * + */ + char suffix[300]; + sprintf(suffix, "%s", SYMNAME(gbl.currsub)); +#endif + // AOCC End if (nreds != 0) { SPTR cur_func_sptr = gbl.currsub; OMPACCEL_RED_SYM *redlist = ompaccel_tinfo_current_get()->reduction_symbols; gbl.outlined = false; gbl.ompaccel_isdevice = true; + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + SPTR sptr_reduce = ompaccel_nvvm_emit_reduce(redlist, nreds, suffix); +#else + // AOCC End SPTR sptr_reduce = ompaccel_nvvm_emit_reduce(redlist, nreds); + // AOCC Begin +#endif + // AOCC End schedule(); assemble(); gbl.func_count++; gbl.multi_func_count = gbl.func_count; + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + ompaccel_tinfo_current_get()->reduction_funcs.shuffleFn = + ompaccel_nvvm_emit_shuffle_reduce(redlist, nreds, sptr_reduce, suffix); +#else + // AOCC End ompaccel_tinfo_current_get()->reduction_funcs.shuffleFn = ompaccel_nvvm_emit_shuffle_reduce(redlist, nreds, sptr_reduce); + // AOCC Begin +#endif + // AOCC End schedule(); assemble(); gbl.func_count++; gbl.multi_func_count = gbl.func_count; + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + ompaccel_tinfo_current_get()->reduction_funcs.interWarpCopy = + ompaccel_nvvm_emit_inter_warp_copy(redlist, nreds, suffix); +#else + // AOCC End ompaccel_tinfo_current_get()->reduction_funcs.interWarpCopy = ompaccel_nvvm_emit_inter_warp_copy(redlist, nreds); + // AOCC Begin +#endif + // AOCC End schedule(); assemble(); ompaccel_write_sharedvars(); diff --git a/tools/flang2/flang2exe/mth.h b/tools/flang2/flang2exe/mth.h index 0f7207f237..9b65e1667d 100644 --- a/tools/flang2/flang2exe/mth.h +++ b/tools/flang2/flang2exe/mth.h @@ -5,6 +5,20 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last modified: March 2020 + * Added support for QFLOAT + * + * Support for TRAILZ intrinsic. + * Month of Modification: July 2019 + * + * Support for COTAN intrinsic + * Modified on Oct 2020 + */ + #ifndef MTH_H_ #define MTH_H_ @@ -79,7 +93,8 @@ typedef enum MTH_FN { MTH_mod, MTH_floor, MTH_ceil, - MTH_aint + MTH_aint, + MTH_cotan //AOCC } MTH_FN; #define MTH_I_DFIXK "__mth_i_dfixk" @@ -114,27 +129,32 @@ typedef enum MTH_FN { #define MTH_I_SIN "__mth_i_sin" #define MTH_I_COS "__mth_i_cos" #define MTH_I_SINCOS "__mth_i_sincos" +#define MTH_I_COTAN "__mth_i_cotan" // AOCC #define MTH_I_TAN "__mth_i_tan" #define MTH_I_DSIN "__mth_i_dsin" #define MTH_I_DCOS "__mth_i_dcos" #define MTH_I_DSINCOS "__mth_i_dsincos" #define MTH_I_DTAN "__mth_i_dtan" +#define MTH_I_DCOTAN "__mth_i_dcotan" // AOCC #define MTH_I_RPOWI "__mth_i_rpowi" #define MTH_I_RPOWK "__mth_i_rpowk" #define MTH_I_RPOWF "__mth_i_rpowr" #define MTH_I_DPOWI "__mth_i_dpowi" #define MTH_I_DPOWK "__mth_i_dpowk" #define MTH_I_DPOWD "__mth_i_dpowd" +#define MTH_I_QPOWI "__mth_i_qpowi" //AOCC #define MTH_I_FSIGN "__mth_i_sign" #define MTH_I_DSIGN "__mth_i_dsign" #define MTH_I_EXP "__mth_i_exp" #define MTH_I_DEXP "__mth_i_dexp" +#define MTH_I_QEXP "__mth_i_qexp" // AOCC #define MTH_I_ALOG "__mth_i_alog" #define MTH_I_DLOG "__mth_i_dlog" #define MTH_I_ALOG10 "__mth_i_alog10" #define MTH_I_DLOG10 "__mth_i_dlog10" #define MTH_I_AMOD "__mth_i_amod" #define MTH_I_DMOD "__mth_i_dmod" +#define MTH_I_QMOD "__mth_i_qmod" // AOCC #define MTH_I_SINH "__mth_i_sinh" #define MTH_I_COSH "__mth_i_cosh" #define MTH_I_TANH "__mth_i_tanh" @@ -150,13 +170,16 @@ typedef enum MTH_FN { #define MTH_I_JN "__mth_i_bessel_jn" #define MTH_I_DJN "__mth_i_dbessel_jn" +#define MTH_I_QJN "__mth_i_qbessel_jn" #define MTH_I_YN "__mth_i_bessel_yn" #define MTH_I_DYN "__mth_i_dbessel_yn" +#define MTH_I_QYN "__mth_i_qbessel_yn" #define FMTH_I_RPOWF "__fmth_i_rpowr" #define FMTH_I_DPOWD "__fmth_i_dpowd" #define FMTH_I_EXP "__fmth_i_exp" #define FMTH_I_DEXP "__fmth_i_dexp" +#define FMTH_I_QEXP "__fmth_i_qexp" // AOCC #define FMTH_I_ALOG "__fmth_i_alog" #define FMTH_I_DLOG "__fmth_i_dlog" #define FMTH_I_ALOG10 "__fmth_i_alog10" @@ -164,6 +187,7 @@ typedef enum MTH_FN { #define FMTH_I_CBRT "__fmth_i_cbrt" #define FMTH_I_AMOD "__fmth_i_amod" #define FMTH_I_DMOD "__fmth_i_dmod" +#define FMTH_I_QMOD "__fmth_i_qmod" // AOCC #define FMTH_I_SIN "__fmth_i_sin" #define FMTH_I_DSIN "__fmth_i_dsin" #define FMTH_I_COS "__fmth_i_cos" @@ -178,6 +202,7 @@ typedef enum MTH_FN { #define FMTH_I_DTAN "__fmth_i_dtan" #define FMTH_I_CSDIV "__fsc_div" #define FMTH_I_CDDIV "__fsz_div" +#define FMTH_I_CQDIV "__fsq_div" // AOCC #define MTH_I_ACOS "__mth_i_acos" #define MTH_I_ASIN "__mth_i_asin" @@ -196,8 +221,12 @@ typedef enum MTH_FN { #define MTH_I_DFLOAT "__mth_i_dfloat" #define MTH_I_DFLOATK "__mth_i_dfloatk" #define MTH_I_DFLOATUK "__mth_i_dfloatuk" +#define MTH_I_QDIV "__mth_i_qdiv" +#define MTH_I_QFLOAT "__mth_i_qfloat" // AOCC +#define MTH_I_QFLOATK "__mth_i_qfloatk" // AOCC #define MTH_I_DMUL "__mth_i_dmul" #define MTH_I_DSQRT "__mth_i_dsqrt" +#define MTH_I_QSQRT "__mth_i_qsqrt" // AOCC #define MTH_I_DSUB "__mth_i_dsub" #define MTH_I_FADD "__mth_i_fadd" #define MTH_I_FCMP "__mth_i_fcmp" @@ -236,6 +265,11 @@ typedef enum MTH_FN { #define MTH_I_ILEADZI "__mth_i_ileadzi" #define MTH_I_ILEADZ "__mth_i_ileadz" #define MTH_I_KLEADZ "__mth_i_kleadz" +// AOCC begin +#define MTH_I_ITRAILZI "__mth_i_itrailzi" +#define MTH_I_ITRAILZ "__mth_i_itrailz" +#define MTH_I_KTRAILZ "__mth_i_ktrailz" +// AOCC end #define MTH_I_IPOPCNTI "__mth_i_ipopcnti" #define MTH_I_IPOPCNT "__mth_i_ipopcnt" #define MTH_I_KPOPCNT "__mth_i_kpopcnt" diff --git a/tools/flang2/flang2exe/mwd.cpp b/tools/flang2/flang2exe/mwd.cpp index bfd7f7d6f5..9635dd66db 100644 --- a/tools/flang2/flang2exe/mwd.cpp +++ b/tools/flang2/flang2exe/mwd.cpp @@ -4,6 +4,14 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ /** \file * \brief mw's dump routines @@ -13,6 +21,7 @@ #include "error.h" #include "machar.h" #include "global.h" +#include "gbldefs.h" #include "symtab.h" #include "ilm.h" #include "fih.h" @@ -1839,10 +1848,6 @@ dsym(int sptr) GINTP(0, 0); putnsym("gint8", GINT8G(0)); GINT8P(0, 0); -#ifdef GQCMPLXG - putnsym("gqcmplx", GQCMPLXG(0)); - GQCMPLXP(0, 0); -#endif #ifdef GQUADG putnsym("gquad", GQUADG(0)); GQUADP(0, 0); @@ -2806,6 +2811,11 @@ putdty(TY_KIND dty) case TY_DCMPLX: r = appendstring1("double complex"); break; + // AOCC begin + case TY_QCMPLX: + r = appendstring1("quad complex"); + break; + // AOCC end case TY_CMPLX128: r = appendstring1("cmplx128"); break; @@ -2896,7 +2906,7 @@ _putdtype(DTYPE dtype, int structdepth) ad = AD_DPTR(dtype); numdim = AD_NUMDIM(ad); appendstring1("("); - if (numdim >= 1 && numdim <= 7) { + if (is_legal_numdim(numdim)) { // AOCC int i; for (i = 0; i < numdim; ++i) { if (i) @@ -3010,7 +3020,7 @@ putdtypex(DTYPE dtype, int len) ad = AD_DPTR(dtype); numdim = AD_NUMDIM(ad); r += appendstring1("("); - if (numdim >= 1 && numdim <= 7) { + if (is_legal_numdim(numdim)) { // AOCC int i; for (i = 0; i < numdim && r < len; ++i) { if (i) @@ -3113,7 +3123,7 @@ dumpdtype(DTYPE dtype) putnsym("zbase", (SPTR) AD_ZBASE(ad)); // ??? putnsym("numelm", AD_NUMELM(ad)); putnsym("sdsc", AD_SDSC(ad)); - if (numdim >= 1 && numdim <= 7) { + if (is_legal_numdim(numdim)) { // AOCC int i; for (i = 0; i < numdim; ++i) { putline(); @@ -3231,6 +3241,10 @@ smsz(int m) case MSZ_F8: msz = "db"; break; + // AOCC + case MSZ_F16: + msz = "qd"; + break; #ifdef MSZ_I8 case MSZ_I8: msz = "i8"; @@ -3284,7 +3298,9 @@ optype(int opc) case IL_UKNEG: case IL_SCMPLXNEG: case IL_DCMPLXNEG: + case IL_QCMPLXNEG: // AOCC case IL_FNEG: + case IL_QNEG: // AOCC case IL_DNEG: return OT_UNARY; @@ -3296,6 +3312,7 @@ optype(int opc) case IL_ICON: case IL_KCON: case IL_DCON: + case IL_QCON: // AOCC case IL_FCON: case IL_ACON: return OT_LEAF; @@ -3469,6 +3486,7 @@ _printili(int i) case IL_UKADD: case IL_FADD: case IL_DADD: + case IL_QADD: // AOCC case IL_UIADD: case IL_AADD: opval = "+"; @@ -3479,6 +3497,7 @@ _printili(int i) case IL_UKSUB: case IL_FSUB: case IL_DSUB: + case IL_QSUB: // AOCC case IL_UISUB: case IL_ASUB: opval = "-"; @@ -3489,11 +3508,13 @@ _printili(int i) case IL_UKMUL: case IL_FMUL: case IL_DMUL: + case IL_QMUL: // AOCC case IL_UIMUL: opval = "*"; typ = BINOP; break; case IL_DDIV: + case IL_QDIV: // AOCC case IL_KDIV: case IL_UKDIV: case IL_FDIV: @@ -3544,6 +3565,8 @@ _printili(int i) case IL_FCMP: case IL_SCMPLXCMP: case IL_DCMPLXCMP: + case IL_QCMPLXCMP: // AOCC + case IL_QCMP: // AOCC case IL_DCMP: case IL_ACMP: case IL_UICMP: @@ -3554,11 +3577,13 @@ _printili(int i) case IL_INEG: case IL_KNEG: case IL_UKNEG: + case IL_QNEG: case IL_DNEG: case IL_UINEG: case IL_FNEG: case IL_SCMPLXNEG: case IL_DCMPLXNEG: + case IL_QCMPLXNEG: // AOCC opval = "-"; typ = UNOP; break; @@ -3574,6 +3599,7 @@ _printili(int i) case IL_UKCMPZ: case IL_FCMPZ: case IL_DCMPZ: + case IL_QCMPZ: // AOCC case IL_ACMPZ: case IL_UICMPZ: opval = ccvalzero[ILI_OPND(i, 2)]; @@ -3598,6 +3624,13 @@ _printili(int i) opval = "min"; typ = INTRINSIC; break; + // AOCC begin + case IL_QUAD: + n = 1; + opval = "quad"; + typ = INTRINSIC; + break; + // AOCC end case IL_DBLE: n = 1; opval = "dble"; @@ -3645,12 +3678,33 @@ _printili(int i) opval = "dfloat"; typ = INTRINSIC; break; + // AOCC begin + case IL_QFIX: + case IL_QFIXU: + n = 1; + opval = "qfix"; + typ = INTRINSIC; + break; + case IL_QFLOAT: + case IL_QFLOATU: + n = 1; + opval = "qfloat"; + typ = INTRINSIC; + break; + // AOCC end case IL_DNEWT: case IL_FNEWT: n = 1; opval = "recip"; typ = INTRINSIC; break; + // AOCC begin + case IL_QABS: + n = 1; + opval = "abs"; + typ = INTRINSIC; + break; + // AOCC end case IL_DABS: n = 1; opval = "abs"; @@ -3681,6 +3735,13 @@ _printili(int i) opval = "dsqrt"; typ = INTRINSIC; break; + // AOCC begin + case IL_QSQRT: + n = 1; + opval = "qsqrt"; + typ = INTRINSIC; + break; + // AOCC end case IL_KCJMP: case IL_UKCJMP: @@ -3755,6 +3816,7 @@ _printili(int i) case IL_DAKR: case IL_DAAR: case IL_DADP: + case IL_DAQP: // AOCC #ifdef IL_DA128 case IL_DA128: #endif @@ -3770,6 +3832,7 @@ _printili(int i) case IL_ARGIR: case IL_ARGSP: case IL_ARGDP: + case IL_ARGQP: case IL_ARGAR: _printili(ILI_OPND(j, 1)); j = ILI_OPND(j, 2); @@ -3813,6 +3876,12 @@ _printili(int i) opval = "MVDP"; typ = MVREG; break; + // AOCC begin + case IL_MVQP: + opval = "MVQP"; + typ = MVREG; + break; + // AOCC end case IL_MVAR: opval = "MVAR"; typ = MVREG; @@ -3838,6 +3907,12 @@ _printili(int i) opval = "DPDF"; typ = DFREG; break; + // AOCC begin + case IL_QPDF: + opval = "QPDF"; + typ = DFREG; + break; + // AOCC end case IL_ARDF: opval = "ARDF"; typ = DFREG; @@ -3872,6 +3947,7 @@ _printili(int i) case IL_CSEAR: case IL_CSECS: case IL_CSECD: + case IL_CSECQ: // AOCC #ifdef LONG_DOUBLE_FLOAT128 case IL_FLOAT128CSE: #endif @@ -3883,6 +3959,12 @@ _printili(int i) opval = "FREEKR"; typ = PSCOMM; break; + // AOCC begin + case IL_FREEQP: + opval = "FREEQP"; + typ = PSCOMM; + break; + // AOCC end case IL_FREEDP: opval = "FREEDP"; typ = PSCOMM; @@ -3918,6 +4000,7 @@ _printili(int i) case IL_ICON: case IL_FCON: case IL_DCON: + case IL_QCON: // AOCC appendstring1(printname(ILI_OPND(i, 1))); break; @@ -3949,6 +4032,7 @@ _printili(int i) case IL_LD: case IL_LDSP: case IL_LDDP: + case IL_LDQP: // AOCC case IL_LDKR: case IL_LDA: _printnme(ILI_OPND(i, 2)); @@ -3962,6 +4046,7 @@ _printili(int i) case IL_STKR: case IL_ST: case IL_STDP: + case IL_STQP: // AOCC case IL_STSP: case IL_SSTS_SCALAR: case IL_DSTS_SCALAR: @@ -4608,6 +4693,11 @@ dili(int ilix) case ILIO_DP: putint("dp", opnd); break; + // AOCC begin + case ILIO_QP: + putint("qp", opnd); + break; + // AOCC end default: put2int("Unknown", IL_OPRFLAG(opc, j), opnd); break; @@ -4669,6 +4759,7 @@ dilitreex(int ilix, int l, int notlast) case IL_CSEDP: case IL_CSECS: case IL_CSECD: + case IL_CSECQ: // AOCC case IL_CSEAR: case IL_CSEKR: case IL_CSE: @@ -4893,6 +4984,10 @@ db(int block) putbit("resid", BIH_RESID(block)); putbit("ujres", BIH_UJRES(block)); putbit("simd", BIH_SIMD(block)); + putbit("nosimd", BIH_NOSIMD(block)); + putbit("unroll", BIH_UNROLL(block)); + putbit("unroll_count", BIH_UNROLL_COUNT(block)); + putbit("nounroll", BIH_NOUNROLL(block)); putbit("ldvol", BIH_LDVOL(block)); putbit("stvol", BIH_STVOL(block)); putbit("task", BIH_TASK(block)); @@ -5349,7 +5444,7 @@ printname(int sptr) } if (STYPEG(sptr) == ST_CONST) { - INT num[2], cons1, cons2; + INT num[4], cons1, cons2, cons3, cons4; int pointee; char *bb, *ee; switch (DTY(DTYPEG(sptr))) { @@ -5444,10 +5539,55 @@ printname(int sptr) break; case TY_QUAD: - num[0] = CONVAL1G(sptr); + /*num[0] = CONVAL1G(sptr); num[1] = CONVAL2G(sptr); - cprintf(b, "%.17le", num); + // AOCC begin + num[2] = CONVAL3G(sptr); + num[3] = CONVAL4G(sptr); + cprintf(b, "%.37Lf", num);*/ + sprintf(b, "%08x %08x %08x %08x", CONVAL1G(sptr), CONVAL2G(sptr), + CONVAL3G(sptr), CONVAL4G(sptr)); + // AOCC end + break; + + #if 0 + case TY_QCMPLX: + cons1 = CONVAL1G(sptr); + cons2 = CONVAL2G(sptr); + cons3 = CONVAL3G(sptr); + cons4 = CONVAL4G(sptr); + num[0] = CONVAL1G(cons1); + num[1] = CONVAL2G(cons1); + num[2] = CONVAL3G(cons1); + num[3] = CONVAL4G(cons1); + if ((num[0] & 0x7ff00000) == 0x7ff00000) { + /* Infinity or NaN */ + int len; + len = snprintf(b, 200, "(0x%8.8x%8.8x%8.8x%8.8xLL, ", num[0], num[1]); + bb = b + len; + + } else { + b[0] = '('; + cprintf(&b[1], "%44.37Lf", num); + b[25] = ','; + b[26] = ' '; + bb = &b[27]; + } + + num[0] = CONVAL1G(cons2); + num[1] = CONVAL2G(cons2); + if ((num[0] & 0x7ff00000) == 0x7ff00000) { + /* Infinity or NaN */ + snprintf(bb, 200, "0x%8.8x%8.8xLL", num[0], num[1]); + } else { + cprintf(bb, "%24.17le", num); + bb += 24; + *bb++ = ')'; + *bb = '\0'; + } + break; + #endif case TY_PTR: pointee = CONVAL1G(sptr); diff --git a/tools/flang2/flang2exe/ompaccel.cpp b/tools/flang2/flang2exe/ompaccel.cpp index 39480c4e75..26c8c6b336 100644 --- a/tools/flang2/flang2exe/ompaccel.cpp +++ b/tools/flang2/flang2exe/ompaccel.cpp @@ -4,7 +4,23 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ - +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes made to create single team for omp target parallel block as well + * Date of Modification: 26th June 2019 + * + * Changes to support AMDGPU OpenMP offloading + * Last Modified : Nov 2020 + * + * Support for x86-64 OpenMP offloading + * Last modified: Apr 2020 + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ /** * \file * \brief ompaccel.c - OpenMP GPU Offload for NVVM Targets. It uses @@ -40,6 +56,17 @@ #include "llassem.h" #include "ll_ftn.h" #include "symfun.h" +// AOCC Begin +#include +#include +#include +#include +#include "expreg.h" + +// Should be in sync with clang::GPU::AMDGPUGpuGridValues in clang +int warp_size_log2; +int warp_size_log2_mask; +// AOCC End #include "../../flang1/flang1exe/global.h" #define NOT_IMPLEMENTED(_pragma) \ @@ -52,11 +79,30 @@ /* Initial Max target region */ #define INC_EXP 2 int tinfo_size = 50; -int tinfo_size_reductions = 10; +int tinfo_size_reductions = 20; // AOCC + int num_tinfos = 0; OMPACCEL_TINFO **tinfos; OMPACCEL_TINFO *current_tinfo = nullptr; + +// AOCC Begin +// Keeping target data tinfos in a stack. Array wont work for nested cases. +std::vector targetDataTinfos; +// AOCC End + +// AOCC Begin +// This is used for target update. Since target update can appear anywhere in +// source and there is too much dependency on current_tinfo I don't see any +// other way to avoid overlapping of tinfo of target update with others. +OMPACCEL_TINFO *old_tinfo = nullptr; + +// Store index of last emited tifno +int last_tinfo_index = 0; +int next_default_map_type = 0; +SPTR curr_teams_outlined_sptr = (SPTR)0; // AOCC +// AOCC End + OMP_TARGET_MODE NextTargetMode = mode_none_target; const char *nvvm_target_triple; @@ -89,6 +135,14 @@ _long_unsigned(int lilix, int *dt, bool *punsigned, DTYPE dtype) *dt = 2; } else if (dty == TY_DBLE) { *dt = 4; + // AOCC begin + } else if (dty == TY_CMPLX) { + *dt = 5; + } else if (dty == TY_DCMPLX) { + *dt = 6; + } else if (dty == TY_QUAD) { + *dt = 7; + // AOCC end } // todo ompaccel I don't know how to handle others @@ -141,6 +195,12 @@ mk_ompaccel_ldsptr(SPTR sptr) nme = ILI_OPND(ili, 2); if (_pointer_type(dtype) || DTY(dtype) == TY_ARRAY) { return ad3ili(IL_LDA, ili, nme, MSZ_PTR); + // AOCC Begin + } else if (dtype == DT_CMPLX) { + return ad3ili(IL_LDSCMPLX, ili, nme, MSZ_F8); + } else if (dtype == DT_DCMPLX) { + return ad3ili(IL_LDDCMPLX, ili, nme, MSZ_F16); + // AOCC End } else { if (sz == 8) return ad3ili(IL_LDKR, ili, nme, MSZ_I8); @@ -163,6 +223,11 @@ mk_ompaccel_load(int ili, DTYPE dtype, int nme) return ad3ili(IL_LDKR, ili, nme, MSZ_WORD); else return ad3ili(IL_LD, ili, nme, MSZ_WORD); + // AOCC Begin + case DT_INT8: + case DT_LOG: + return ad3ili(IL_LDKR, ili, nme, MSZ_I8); + // AOCC End case DT_REAL: if (size_of(dtype) > 4) return ad3ili(IL_LDKR, ili, nme, MSZ_F8); @@ -172,6 +237,11 @@ mk_ompaccel_load(int ili, DTYPE dtype, int nme) case DT_DBLE: return ad3ili(IL_LDDP, ili, nme, MSZ_DBLE); break; + // AOCC begin + case DT_QUAD: + return ad3ili(IL_LDQP, ili, nme, MSZ_F16); + break; + // AOCC end case DT_CMPLX: return ad3ili(IL_LDDCMPLX, ili, nme, MSZ_F16); break; @@ -204,12 +274,31 @@ mk_ompaccel_store(int ili_value, DTYPE dtype, int nme, int ili_address) case DT_INT: return ad4ili(IL_ST, ili_value, ili_address, nme, MSZ_WORD); break; + // AOCC Begin + case DT_LOG8: + return ad4ili(IL_STKR, ili_value, ili_address, nme, MSZ_I8); + case DT_BINT: + return ad4ili(IL_ST, ili_value, ili_address, nme, MSZ_BYTE); + break; + case DT_SINT: + return ad4ili(IL_ST, ili_value, ili_address, nme, MSZ_SHWORD); + break; + case DT_CMPLX: + return ad4ili(IL_STSCMPLX, ili_value, ili_address, nme, MSZ_F8); + // AOCC End + case DT_DCMPLX: + return ad4ili(IL_STDCMPLX, ili_value, ili_address, nme, MSZ_F16); case DT_REAL: return ad4ili(IL_STSP, ili_value, ili_address, nme, MSZ_F4); break; case DT_DBLE: return ad4ili(IL_STDP, ili_value, ili_address, nme, MSZ_DBLE); break; + // AOCC begin + case DT_QUAD: + return ad4ili(IL_STQP, ili_value, ili_address, nme, MSZ_F16); + break; + // AOCC end case DT_INT8: return ad4ili(IL_STKR, ili_value, ili_address, nme, MSZ_I8); break; @@ -268,11 +357,41 @@ mk_ompaccel_and(int ili1, DTYPE dtype1, int ili2, DTYPE dtype2) return ad2ili(opc, ili1, ili2); } +static int +mk_ompaccel_or(int ili1, DTYPE dtype1, int ili2, DTYPE dtype2) +{ + ILI_OP opc; + int dt = 0; + bool uu = FALSE; + if (!ili1) + return ili2; + if (!ili2) + return ili1; + if (_pointer_type(dtype1) || _pointer_type(dtype2)) { + return ad3ili(IL_AADD, ili1, ili2, 0); + } else { + _long_unsigned(ili1, &dt, &uu, dtype1); + _long_unsigned(ili2, &dt, &uu, dtype2); + /* signed */ + if (!uu) { + opc = IL_OR; + } else { + opc = IL_KOR; + } + } + return ad2ili(opc, ili1, ili2); +} + static int mk_ompaccel_iand(int ili1, int ili2) { return mk_ompaccel_and(ili1, DT_INT, ili2, DT_INT); } +static int +mk_ompaccel_ior(int ili1, int ili2) +{ + return mk_ompaccel_or(ili1, DT_INT, ili2, DT_INT); +} static int mk_ompaccel_shift(int ili1, DTYPE dtype1, int ili2, DTYPE dtype2) @@ -357,6 +476,10 @@ mk_ompaccel_add(int ili1, DTYPE dtype1, int ili2, DTYPE dtype2) opc = IL_FADD; else if (dt == 4) opc = IL_DADD; + // AOCC begin + else if (dt == 7) + opc = IL_QADD; + // AOCC end else if (dt == 5) opc = IL_SCMPLXADD; else if (dt == 6) @@ -372,6 +495,92 @@ mk_ompaccel_add(int ili1, DTYPE dtype1, int ili2, DTYPE dtype2) return ad2ili(opc, ili1, ili2); } /* mk_ompaccel_add */ +// AOCC Begin + +/* + * Returning max + */ +int +mk_ompaccel_max(int ili1, DTYPE dtype1, int ili2, DTYPE dtype2) { + + ILI_OP opc = IL_NONE; + int dt = 0; + bool uu = FALSE; + if (!ili1) + return ili2; + if (!ili2) + return ili1; + if (_pointer_type(dtype1) || _pointer_type(dtype2)) { + assert(0, "Max reduction of this type not handled.", 0, ERR_Fatal); + } else { + _long_unsigned(ili1, &dt, &uu, dtype1); + _long_unsigned(ili2, &dt, &uu, dtype2); + /* signed */ + if (!uu) { + if (dt == 1) + opc = IL_IMAX; + else if (dt == 2) + opc = IL_KMAX; + else if (dt == 3) + opc = IL_FMAX; + else if (dt == 4) + opc = IL_DMAX; + else if (dt == 5 || dt == 6) + assert(0, "Max reduction of this type not handled.", 0, ERR_Fatal); + } else { + if (dt == 1) + opc = IL_UIMAX; + else if (dt == 2) + opc = IL_UKMAX; + } + } + assert(opc != IL_NONE, "Max reduction of this type not handled.", 0, + ERR_Fatal); + return ad2ili(opc, ili1, ili2); +} + +/* + * Returning min + */ +int +mk_ompaccel_min(int ili1, DTYPE dtype1, int ili2, DTYPE dtype2) { + + ILI_OP opc = IL_NONE; + int dt = 0; + bool uu = FALSE; + if (!ili1) + return ili2; + if (!ili2) + return ili1; + if (_pointer_type(dtype1) || _pointer_type(dtype2)) { + assert(0, "Min reduction of this type not handled.", 0, ERR_Fatal); + } else { + _long_unsigned(ili1, &dt, &uu, dtype1); + _long_unsigned(ili2, &dt, &uu, dtype2); + /* signed */ + if (!uu) { + if (dt == 1) + opc = IL_IMIN; + else if (dt == 2) + opc = IL_KMIN; + else if (dt == 3) + opc = IL_FMIN; + else if (dt == 4) + opc = IL_DMIN; + else if (dt == 5 || dt == 6) + assert(0, "Min reduction of this type not handled.", 0, ERR_Fatal); + } else { + if (dt == 1) + opc = IL_UIMIN; + else if (dt == 2) + opc = IL_UKMIN; + } + } + assert(opc != IL_NONE, "Min reduction of this type not handled.", 0, ERR_Fatal); + return ad2ili(opc, ili1, ili2); +} +// AOCC End + int mk_ompaccel_mul(int ili1, DTYPE dtype1, int ili2, DTYPE dtype2) { @@ -402,6 +611,10 @@ mk_ompaccel_mul(int ili1, DTYPE dtype1, int ili2, DTYPE dtype2) opc = IL_SCMPLXMUL; else if (dt == 6) opc = IL_DCMPLXMUL; + // AOCC begin + else if (dt == 7) + opc = IL_QMUL; + // AOCC end } else { if (dt == 1) opc = IL_UIMUL; @@ -436,7 +649,9 @@ mk_ompaccel_addsymbol(const char *name, DTYPE dtype, SC_KIND SCkind, return sptr; } -static void +// AOCC begin +void +// AOCC end mk_ompaccel_function_end(SPTR func_sptr) { int bihx, endlab; @@ -455,7 +670,9 @@ mk_ompaccel_function_end(SPTR func_sptr) BIH_LABEL(bihx) = SPTR(endlab); } -static SPTR +// AOCC begin +SPTR +// AOCC end mk_ompaccel_function(char *name, int n_params, const SPTR *param_sptrs, bool isDeviceFunc) { @@ -512,7 +729,7 @@ mk_ompaccel_function(char *name, int n_params, const SPTR *param_sptrs, return func_sptr; } -static int +int // AOCC (made non-static) mk_reduction_op(int redop, int lili, DTYPE dtype1, int rili, DTYPE dtype2) { switch (redop) { @@ -521,7 +738,18 @@ mk_reduction_op(int redop, int lili, DTYPE dtype1, int rili, DTYPE dtype2) return mk_ompaccel_add(lili, dtype1, rili, dtype2); case 3: return mk_ompaccel_mul(lili, dtype1, rili, dtype2); + case 17: // OP_LOR + return mk_ompaccel_or(lili, dtype1, rili, dtype2); + case 18: // OP_LAND + return mk_ompaccel_and(lili, dtype1, rili, dtype2); + //AOCC Begin + case 373: + return mk_ompaccel_max(lili, dtype1, rili, dtype2); + case 374: + return mk_ompaccel_min(lili, dtype1, rili, dtype2); + // AOCC End default: + ompaccelInternalFail("Unknown red op type"); // AOCC static_assert(true, "Rest of reduction operators are not implemented yet."); break; } @@ -573,6 +801,28 @@ create_nvvm_sym(const char *name, DTYPE dtype) return sptr; } +// AOCC Begin +INLINE static SPTR +create_amdgcn_sym(const char *name, DTYPE dtype) +{ + SPTR sptr = getsymbol(name); + DEFDP(sptr, 1); + DTYPEP(sptr, dtype); + CFUNCP(sptr, 1); + STYPEP(sptr, ST_ENTRY); + SCP(sptr, SC_STATIC); + ADDRTKNP(sptr, 1); + PARAMCTP(sptr, 1); + return sptr; +} + +INLINE static SPTR +create_amdgcn_sregs(const char *name) +{ + return create_amdgcn_sym(name, DT_INT); +} +// AOCC End + INLINE static SPTR create_sregs(const char *name) { @@ -601,13 +851,25 @@ ompaccel_initsyms() create_sregs(NVVM_SREG[blockIdY]); create_sregs(NVVM_SREG[blockIdZ]); /* Create block id sreg symbols */ - create_sregs(NVVM_SREG[blockDimX]); - create_sregs(NVVM_SREG[blockDimY]); - create_sregs(NVVM_SREG[blockDimZ]); - /* Create block id sreg symbols */ - create_sregs(NVVM_SREG[gridDimX]); - create_sregs(NVVM_SREG[gridDimY]); - create_sregs(NVVM_SREG[gridDimZ]); + // AOCC Begin + if (flg.amdgcn_target) { + create_amdgcn_sregs(NVVM_SREG[blockDimX]); + create_amdgcn_sregs(NVVM_SREG[blockDimY]); + create_amdgcn_sregs(NVVM_SREG[blockDimZ]); + /* Create block id sreg symbols */ + create_amdgcn_sregs(NVVM_SREG[gridDimX]); + create_amdgcn_sregs(NVVM_SREG[gridDimY]); + create_amdgcn_sregs(NVVM_SREG[gridDimZ]); + } else { + // AOCC End + create_sregs(NVVM_SREG[blockDimX]); + create_sregs(NVVM_SREG[blockDimY]); + create_sregs(NVVM_SREG[blockDimZ]); + /* Create block id sreg symbols */ + create_sregs(NVVM_SREG[gridDimX]); + create_sregs(NVVM_SREG[gridDimY]); + create_sregs(NVVM_SREG[gridDimZ]); + } // todo create others nvvm things too create_sregs(NVVM_SREG[warpSize]); @@ -619,11 +881,78 @@ ompaccel_initsyms() int ompaccel_nvvm_get(nvvm_sregs sreg) { - SPTR sptr = SPTR(init_nvvm_syms + sreg); - ll_make_ftn_outlined_params(sptr, 0, nullptr); + SPTR sptr; + if (!flg.amdgcn_target) { + sptr = SPTR(init_nvvm_syms + sreg); + sptr = SPTR(init_nvvm_syms + sreg); + ll_make_ftn_outlined_params(sptr, 0, nullptr); + ll_process_routine_parameters(sptr); + return ll_ad_outlined_func2(IL_DFRIR, IL_JSR, sptr, 0, nullptr); + } + + // AOCC Begin + int dim = -1; + switch(sreg) { + case threadIdX: + case threadIdY: + case threadIdZ: + case blockIdX: + case blockIdY: + case blockIdZ: + sptr = SPTR(init_nvvm_syms + sreg); + ll_make_ftn_outlined_params(sptr, 0, nullptr); + ll_process_routine_parameters(sptr); + return ll_ad_outlined_func2(IL_DFRIR, IL_JSR, sptr, 0, nullptr); + case warpSize: + return ad_icon(flg.warp_size); + case blockDimX: + case gridDimX: + dim = 0; + break; + case blockDimY: + case gridDimY: + dim = 1; + break; + case blockDimZ: + case gridDimZ: + dim = 2; + break; + default: + ompaccelInternalFail("Unknown sreg type"); + } + + sptr = create_amdgcn_sregs(NVVM_SREG[sreg]); + DTYPE arg_types[] = {DT_INT}; + int args[1]; + args[0] = ad_icon(dim); + ll_make_ftn_outlined_params(sptr, 1, arg_types); + ll_process_routine_parameters(sptr); + return ll_ad_outlined_func2(IL_DFRIR, IL_JSR, sptr, 1, args); + // AOCC End +} + +// AOCC Begin +int +ompaccel_nvvm_mk_barrier(nvvm_barriers btype, int ili) +{ + SPTR sptr; + DTYPE arg_types[2] = {DT_INT, DT_INT}; + int args[2]; + args[1] = ad_icon(1); + args[0] = ili; + if (btype != PARTIAL_BARRIER) { + ompaccelInternalFail("Barrier type not supported "); + } + + if (flg.amdgcn_target) + ompaccelInternalFail("Barrier type not supported "); + + sptr = (SPTR)(init_nvvm_intrinsics + barrier); + ll_make_ftn_outlined_params(sptr, 2, arg_types); ll_process_routine_parameters(sptr); - return ll_ad_outlined_func2(IL_DFRIR, IL_JSR, sptr, 0, nullptr); + return ll_ad_outlined_func2(IL_NONE, IL_JSR, sptr, 2, args); } +// AOCC End int ompaccel_nvvm_mk_barrier(nvvm_barriers btype) @@ -635,13 +964,29 @@ ompaccel_nvvm_mk_barrier(nvvm_barriers btype) ll_process_routine_parameters(sptr); return ll_ad_outlined_func2(IL_NONE, IL_JSR, sptr, 0, nullptr); } + + // AOCC Begin + if (btype == PARTIAL_BARRIER && flg.amdgcn_target) { + sptr = (SPTR)(init_nvvm_intrinsics + barrier); + ll_make_ftn_outlined_params(sptr, 0, 0); + ll_process_routine_parameters(sptr); + return ll_ad_outlined_func2(IL_NONE, IL_JSR, sptr, 0, nullptr); + } + // AOCC End static_assert(true, "Other nvvm intrinsics are not implemented yet."); + return -1; } int ompaccel_nvvm_get_gbl_tid() { int ilix, iliy, iliz; + + // AOCC Begin + if (flg.amdgcn_target) + return ll_make_kmpc_global_thread_num(); + // AOCC End + ilix = ad2ili(IL_ISUB, ompaccel_nvvm_get(blockDimX), ad_icon(32)); ilix = ad2ili(IL_IMUL, ompaccel_nvvm_get(blockIdX), ilix); @@ -684,10 +1029,18 @@ ompaccel_tinfo_create(SPTR func_sptr, int max_nargs) NEW(info, OMPACCEL_TINFO, 1); info->func_sptr = func_sptr; + // AOCC Begin + // Add function name also. It is possible that the different + // functions get same sptr (they are in diferent scope). + NEW(info->func_name,char,strlen(SYMNAME(func_sptr))+1); + strcpy(info->func_name,SYMNAME(func_sptr)); + // AOCC End info->n_symbols = 0; if (max_nargs != 0) { NEW(info->symbols, OMPACCEL_SYM, max_nargs); + BZERO(info->symbols, OMPACCEL_SYM, max_nargs); NEW(info->quiet_symbols, OMPACCEL_SYM, max_nargs); + BZERO(info->quiet_symbols, OMPACCEL_SYM, max_nargs); } else { info->symbols = nullptr; info->quiet_symbols = nullptr; @@ -698,7 +1051,14 @@ ompaccel_tinfo_create(SPTR func_sptr, int max_nargs) info->nowait = false; info->n_quiet_symbols = 0; NEW(info->reduction_symbols, OMPACCEL_RED_SYM, tinfo_size_reductions); + info->sz_reduction_symbols = tinfo_size_reductions; // AOCC info->n_reduction_symbols = 0; + // AOCC Begin + info->num_teams = SPTR_NULL; + info->num_threads = SPTR_NULL; + info->default_map = next_default_map_type; + next_default_map_type = 0; + // AOCC End /* add ot to array */ NEED(num_tinfos + 1, tinfos, OMPACCEL_TINFO *, tinfo_size, @@ -718,7 +1078,8 @@ bool ompaccel_tinfo_has(int func_sptr) { for (int i = 0; i < num_tinfos; ++i) { - if (tinfos[i]->func_sptr == func_sptr) { + // AOCC added additional check to check function name + if (tinfos[i]->func_sptr == func_sptr && !(strcmp(tinfos[i]->func_name,SYMNAME(func_sptr)))) { return true; } } @@ -730,7 +1091,8 @@ ompaccel_tinfo_get(int func_sptr) { int i; for (i = 0; i < num_tinfos; ++i) { - if (tinfos[i]->func_sptr == func_sptr) { + // AOCC added additional check to check function name + if (tinfos[i]->func_sptr == func_sptr && !(strcmp(tinfos[i]->func_name,SYMNAME(func_sptr)))) { return tinfos[i]; } } @@ -744,10 +1106,41 @@ ompaccel_create_device_symbol(SPTR sptr, int count) char name[252]; DTYPE dtype = DTYPEG(sptr); bool byval; - if (DTYPEG(sptr) == DT_ADDR || DTY(DTYPEG(sptr)) == TY_ARRAY) - byval = false; - else - byval = true; + + // AOCC begin + bool isPointer = false; + if (flg.x86_64_omptarget || flg.amdgcn_target) { + for (int j = 0; j < current_tinfo->n_quiet_symbols; ++j) { + if (MIDNUMG(current_tinfo->quiet_symbols[j].host_sym) == sptr) + if (POINTERG(current_tinfo->quiet_symbols[j].host_sym)) + isPointer = true; + } + if (DTYPEG(sptr) == DT_ADDR || DTY(DTYPEG(sptr)) == TY_ARRAY || isPointer) + byval = false; + else + byval = true; + if (flg.omptarget && DTY(DTYPEG(sptr)) == TY_PTR) + byval = false; + + for (int j = 0; j < current_tinfo->n_symbols; ++j) { + if (current_tinfo->symbols[j].host_sym == sptr) { + int map_type = current_tinfo->symbols[j].map_type; + if (TY_ISSCALAR(DTY(DTYPEG(sptr))) && + map_type & OMP_TGT_MAPTYPE_FROM) { + byval = false; + break; + } + } + } + + } else { + // AOCC end + if (DTYPEG(sptr) == DT_ADDR || DTY(DTYPEG(sptr)) == TY_ARRAY) + byval = false; + else + byval = true; + } + if (byval) { sprintf(name, "Arg_%s_%d", SYMNAME(sptr), count); } else { @@ -763,6 +1156,18 @@ ompaccel_create_device_symbol(SPTR sptr, int count) if (dtype == DT_CPTR) { dtype = DT_INT8; } + + // AOCC Begin + // Interpreting all int args as int64 values +#ifdef OMP_OFFLOAD_AMD + if (dtype == DT_INT || dtype == DT_BINT || dtype == DT_SINT) { + dtype = DT_INT8; + } + + if (dtype == DT_LOG) { + dtype = DT_LOG8; + } +#endif // assume it's base of allocatable descriptor if (strncmp(SYMNAME(sptr), ".Z", 2) == 0) { for (int j = 0; j < current_tinfo->n_quiet_symbols; ++j) @@ -778,21 +1183,59 @@ ompaccel_create_device_symbol(SPTR sptr, int count) STYPEP(sym, ST_VAR); PASSBYVALP(sym, byval); + // AOCC begin + if (flg.x86_64_omptarget || flg.amdgcn_target) { + for (int j = 0; j < current_tinfo->n_quiet_symbols; ++j) { + if (MIDNUMG(current_tinfo->quiet_symbols[j].host_sym) == sptr) { + POINTERP(sym, POINTERG(current_tinfo->quiet_symbols[j].host_sym)); + DTYPEP(sym, DTYPE(DTYPEG(current_tinfo->quiet_symbols[j].host_sym) + 1)); + } + } + } + // AOCC end + OMPACCDEVSYMP(sym, TRUE); + return sym; } -INLINE static SPTR +// AOCC BEGIN +/* + * This function doesn't return anything. + * Changed return type from SPTR to void + * + */ +INLINE static void +// AOCC END add_symbol_to_function(SPTR func, SPTR sym) { int dpdscp, paramct; paramct = PARAMCTG(func); paramct += 1; + + // AOCC begin +#ifdef OMP_OFFLOAD_AMD + /* + * NODIFICATION Changed the following line from + * aux.dpdsc_base[paramct] = sym + * This is how other arguments are also added. Arg count and offset are not same. + */ + aux.dpdsc_base[aux.dpdsc_avl] = sym; +#else + // AOCC End aux.dpdsc_base[paramct] = sym; + // AOCC Begin +#endif + // AOCC End + PARAMCTP(func, paramct); aux.dpdsc_avl += 1; } +// AOCC Begin +std::vector tinfo_vector; +// AOCC End + INLINE static SPTR get_devsptr(OMPACCEL_TINFO *tinfo, SPTR host_symbol) { @@ -800,6 +1243,20 @@ get_devsptr(OMPACCEL_TINFO *tinfo, SPTR host_symbol) if (tinfo == nullptr) return host_symbol; + // AOCC Begin + if (std::find(tinfo_vector.begin(), tinfo_vector.end(), tinfo) + == tinfo_vector.end()) { + tinfo_vector.push_back(tinfo); + for (i = 0; i < tinfo->n_symbols; ++i) { + if (tinfo->symbols[i].device_sym == NOSYM) { + tinfo->symbols[i].device_sym = + ompaccel_create_device_symbol(tinfo->symbols[i].host_sym, i); + add_symbol_to_function(tinfo->func_sptr, tinfo->symbols[i].device_sym); + } + } + } + // AOCC End + for (i = 0; i < tinfo->n_symbols; ++i) { if (tinfo->symbols[i].host_sym == host_symbol) { if (tinfo->symbols[i].device_sym == NOSYM) { @@ -807,8 +1264,18 @@ get_devsptr(OMPACCEL_TINFO *tinfo, SPTR host_symbol) * ILM. In case there is a symbol that has no device symbol created, we * should create device symbol for it also we should add it function * parameter. */ + + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + tinfo->symbols[i].device_sym = + ompaccel_create_device_symbol(tinfo->symbols[i].host_sym, i); +#else + // AOCC End tinfo->symbols[i].device_sym = ompaccel_create_device_symbol(tinfo->symbols[i].host_sym, 1); + // AOCC Begin +#endif + // AOCC End add_symbol_to_function(tinfo->func_sptr, tinfo->symbols[i].device_sym); } return tinfo->symbols[i].device_sym; @@ -832,6 +1299,13 @@ get_devsptr2(OMPACCEL_TINFO *tinfo, SPTR host_symbol) OMPACCEL_TINFO * ompaccel_tinfo_current_get_targetdata() { + // AOCC Begin + if (flg.amdgcn_target) { + OMPACCEL_TINFO* tinfo = targetDataTinfos.back(); + targetDataTinfos.pop_back(); + return tinfo; + } + // AOCC End OMPACCEL_TINFO *tinfo = current_tinfo; while (tinfo != nullptr) { if (tinfo->mode == mode_target_data_region) @@ -917,7 +1391,12 @@ ompaccel_tinfo_current_get_devsptr(SPTR host_symbol) device_symbol = get_devsptr(current_tinfo, host_symbol); - if (device_symbol == host_symbol && current_tinfo->parent_tinfo != nullptr) + // AOCC Modification: Added condition !flg.amdgcn_target. + // parent_tinfo is not set correctly. Sometimes it points + // to tinfo of another kernel. This leads to use of + // undefined symbols. + if (!(flg.amdgcn_target || flg.x86_64_omptarget) && device_symbol == host_symbol && + current_tinfo->parent_tinfo != nullptr) device_symbol = get_devsptr2(current_tinfo->parent_tinfo, host_symbol); if ((DBGBIT(61, 2)) && gbl.dbgfil != nullptr && @@ -932,6 +1411,21 @@ ompaccel_tinfo_current_get_devsptr(SPTR host_symbol) return device_symbol; } +// AOCC begin +SPTR +ompaccel_tinfo_current_get_hostsptr(SPTR dev_symbol) +{ + int i; + for (i = 0; i < current_tinfo->n_symbols; ++i) { + if (current_tinfo->symbols[i].device_sym == dev_symbol) { + return current_tinfo->symbols[i].host_sym; + } + } + + return NOSYM; +} +// AOCC end + static bool tinfo_update_maptype(OMPACCEL_SYM *tsyms, int nargs, SPTR host_symbol, int map_type) @@ -959,6 +1453,15 @@ ompaccel_tinfo_current_add_reductionitem(SPTR private_sym, SPTR shared_sym, if (current_tinfo == nullptr) ompaccel_msg_interr("XXX", "Current target info is not found.\n"); + // AOCC begin + // Dynamically allocate reduction symbols + if (current_tinfo->sz_reduction_symbols <= current_tinfo->n_reduction_symbols) { + NEED((current_tinfo->n_reduction_symbols + 1), current_tinfo->reduction_symbols, + OMPACCEL_RED_SYM, current_tinfo->sz_reduction_symbols, + current_tinfo->sz_reduction_symbols * INC_EXP); + } + // AOCC end + current_tinfo->reduction_symbols[current_tinfo->n_reduction_symbols] .private_sym = private_sym; current_tinfo->reduction_symbols[current_tinfo->n_reduction_symbols] @@ -994,11 +1497,15 @@ ompaccel_tinfo_current_addupdate_mapitem(SPTR host_symbol, int map_type) ompaccel_msg_interr("XXX", "Current target info is not found\n"); // check whether it is allocatable or not - if (SCG(host_symbol) == SC_BASED) { + if (SCG(host_symbol) == SC_BASED && + STYPEG(host_symbol) != ST_MEMBER) { // AOCC /* if it is in data mode, we should keep midnum at active symbols*/ if (current_tinfo->mode == mode_target_data_enter_region || current_tinfo->mode == mode_target_data_exit_region || - current_tinfo->mode == mode_target_data_region) { + current_tinfo->mode == mode_target_data_region || + // AOCC Begin + current_tinfo->mode == mode_target_update) { + // AOCC End midsptr = (SPTR)MIDNUMG(host_symbol); if (!tinfo_update_maptype(current_tinfo->symbols, current_tinfo->n_symbols, midsptr, map_type)) @@ -1020,7 +1527,15 @@ void ompaccel_tinfo_current_add_sym(SPTR host_symbol, SPTR device_symbol, int map_type) { - if ((MIDNUMG(host_symbol) && SCG(host_symbol) == SC_BASED)) { + // AOCC Begin + if (map_type == 0 && current_tinfo->default_map != 0) { + if (TY_ISSCALAR(DTY(DTYPEG(host_symbol)))) { + map_type = current_tinfo->default_map; + } + } + // AOCC End + if (MIDNUMG(host_symbol) && (SCG(host_symbol) == SC_BASED) + && STYPEG(host_symbol) != ST_MEMBER) { // AOCC NEED((current_tinfo->n_quiet_symbols + 1), current_tinfo->quiet_symbols, OMPACCEL_SYM, current_tinfo->sz_quiet_symbols, current_tinfo->sz_quiet_symbols * INC_EXP); @@ -1037,8 +1552,30 @@ ompaccel_tinfo_current_add_sym(SPTR host_symbol, SPTR device_symbol, current_tinfo->symbols[current_tinfo->n_symbols].host_sym = host_symbol; current_tinfo->symbols[current_tinfo->n_symbols].device_sym = device_symbol; current_tinfo->symbols[current_tinfo->n_symbols].map_type = map_type; + current_tinfo->symbols[current_tinfo->n_symbols].in_map = 0; // AOCC current_tinfo->n_symbols++; } + + // AOCC Begin + // For pointer arrays copy array descripor to device +#ifdef OMP_OFFLOAD_AMD + if (SDSCG(host_symbol) && ((MIDNUMG(host_symbol) > NOSYM) + && POINTERG(host_symbol)) + && STYPEG(host_symbol) != ST_MEMBER) { + ompaccel_tinfo_current_add_sym(SDSCG(host_symbol), NOSYM, + OMP_TGT_MAPTYPE_TARGET_PARAM | + OMP_TGT_MAPTYPE_TO | + OMP_TGT_MAPTYPE_FROM); + } + else if (!XBIT(201,0x02) &&SDSCG(host_symbol) && ASSUMSHPG(host_symbol) + && STYPEG(host_symbol) != ST_MEMBER) { + ompaccel_tinfo_current_add_sym(SDSCG(host_symbol), NOSYM, + OMP_TGT_MAPTYPE_TARGET_PARAM | + OMP_TGT_MAPTYPE_TO | + OMP_TGT_MAPTYPE_FROM); + } +#endif + // AOCC End } INLINE static void @@ -1099,10 +1636,10 @@ dumptargetreduction(OMPACCEL_RED_SYM targetred) case 3: fprintf(gbl.dbgfil, "*: "); break; - case 346: + case 373: fprintf(gbl.dbgfil, "max:"); break; - case 347: + case 374: fprintf(gbl.dbgfil, "min:"); break; case 327: @@ -1160,6 +1697,11 @@ dumpomptarget(OMPACCEL_TINFO *tinfo) case mode_target_teams_distribute: fprintf(gbl.dbgfil, " "); break; + // AOCC Begin + case mode_target_update: + fprintf(gbl.dbgfil, " "); + break; + // AOCC End case mode_target_data_region: fprintf(gbl.dbgfil, " "); break; @@ -1274,22 +1816,47 @@ ompaccel_emit_tgt_register() TEXTSTARTUPP(sptrFn, 1); PRIORITYP(sptrFn, 65535 /* LLVM_DEFAULT_PRIORITY */); cr_block(); - ilix = ll_make_tgt_register_lib(); + // AOCC Begin + if (flg.omptarget) { + ilix = ll_make_tgt_register_lib(); + iltb.callfg = 1; + chk_block(ilix); + wr_block(); + } + ilix = ll_make_tgt_register_requires(); iltb.callfg = 1; chk_block(ilix); wr_block(); + // AOCC End mk_ompaccel_function_end(sptrFn); } SPTR +// AOCC Begin +#ifdef OMP_OFFLOAD_AMD +ompaccel_nvvm_emit_reduce(OMPACCEL_RED_SYM *ReductionItems, int NumReductions, + const char *suffix) +#else +// AOCC End ompaccel_nvvm_emit_reduce(OMPACCEL_RED_SYM *ReductionItems, int NumReductions) +// AOCC Begin +#endif +// AOCC End { int ili, bili, rili; SPTR sptrFn, sptrRhs, sptrReduceData, func_params[2]; DTYPE dtypeReductionItem, dtypeReduceData; int nmeReduceData, nmeRhs; int params_dtypes[2] = {DT_ADDR, DT_ADDR}; + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + char name[300]; +#else + // AOCC End char name[30]; + // AOCC Begin +#endif + // AOCC End /* Generate function parameters */ dtypeReduceData = get_type(2, TY_PTR, DT_ANY); @@ -1299,13 +1866,27 @@ ompaccel_nvvm_emit_reduce(OMPACCEL_RED_SYM *ReductionItems, int NumReductions) mk_ompaccel_addsymbol(".rhs", dtypeReduceData, SC_DUMMY, ST_VAR); /* Generate function symbol */ + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + sprintf(name, "%s_%s_%d", "ompaccel_reduction", suffix, reductionFunctionCounter++); +#else + // AOCC End sprintf(name, "%s%d", "ompaccel_reduction", reductionFunctionCounter++); + // AOCC Begin +#endif + // AOCC End sptrFn = mk_ompaccel_function(name, 2, func_params, true); cr_block(); for (int i = 0; i < NumReductions; ++i) { dtypeReductionItem = DTYPEG(ReductionItems[i].shared_sym); + // AOCC Begin + if (DTY(dtypeReductionItem) == TY_ARRAY) { + dtypeReductionItem = DDTG(dtypeReductionItem); + } + // AOCC End + bili = mk_ompaccel_ldsptr(sptrReduceData); rili = mk_ompaccel_ldsptr(sptrRhs); @@ -1342,16 +1923,106 @@ ompaccel_nvvm_emit_reduce(OMPACCEL_RED_SYM *ReductionItems, int NumReductions) return sptrFn; } +// AOCC Begin +/// Copied from CLANG +/// Emit a helper that reduces data across two OpenMP threads (lanes) +/// in the same warp. It uses shuffle instructions to copy over data from +/// a remote lane's stack. The reduction algorithm performed is specified +/// by the fourth parameter. +/// +/// Algorithm Versions. +/// Full Warp Reduce (argument value 0): +/// This algorithm assumes that all 32 lanes are active and gathers +/// data from these 32 lanes, producing a single resultant value. +/// Contiguous Partial Warp Reduce (argument value 1): +/// This algorithm assumes that only a *contiguous* subset of lanes +/// are active. This happens for the last warp in a parallel region +/// when the user specified num_threads is not an integer multiple of +/// 32. This contiguous subset always starts with the zeroth lane. +/// Partial Warp Reduce (argument value 2): +/// This algorithm gathers data from any number of lanes at any position. +/// All reduced values are stored in the lowest possible lane. The set +/// of problems every algorithm addresses is a super set of those +/// addressable by algorithms with a lower version number. Overhead +/// increases as algorithm version increases. +/// +/// Terminology +/// Reduce element: +/// Reduce element refers to the individual data field with primitive +/// data types to be combined and reduced across threads. +/// Reduce list: +/// Reduce list refers to a collection of local, thread-private +/// reduce elements. +/// Remote Reduce list: +/// Remote Reduce list refers to a collection of remote (relative to +/// the current thread) reduce elements. +/// +/// We distinguish between three states of threads that are important to +/// the implementation of this function. +/// Alive threads: +/// Threads in a warp executing the SIMT instruction, as distinguished from +/// threads that are inactive due to divergent control flow. +/// Active threads: +/// The minimal set of threads that has to be alive upon entry to this +/// function. The computation is correct iff active threads are alive. +/// Some threads are alive but they are not active because they do not +/// contribute to the computation in any useful manner. Turning them off +/// may introduce control flow overheads without any tangible benefits. +/// Effective threads: +/// In order to comply with the argument requirements of the shuffle +/// function, we must keep all lanes holding data alive. But at most +/// half of them perform value aggregation; we refer to this half of +/// threads as effective. The other half is simply handing off their +/// data. +/// +/// Procedure +/// Value shuffle: +/// In this step active threads transfer data from higher lane positions +/// in the warp to lower lane positions, creating Remote Reduce list. +/// Value aggregation: +/// In this step, effective threads combine their thread local Reduce list +/// with Remote Reduce list and store the result in the thread local +/// Reduce list. +/// Value copy: +/// In this step, we deal with the assumption made by algorithm 2 +/// (i.e. contiguity assumption). When we have an odd number of lanes +/// active, say 2k+1, only k threads will be effective and therefore k +/// new values will be produced. However, the Reduce list owned by the +/// (2k+1)th thread is ignored in the value aggregation. Therefore +/// we copy the Reduce list from the (2k+1)th lane to (k+1)th lane so +/// that the contiguity assumption still holds. +// AOCC End SPTR +//AOCC Begin +#ifdef OMP_OFFLOAD_AMD +ompaccel_nvvm_emit_shuffle_reduce(OMPACCEL_RED_SYM *ReductionItems, + int NumReductions, SPTR sptrFnReduce, + const char *suffix) +#else +// AOCC End ompaccel_nvvm_emit_shuffle_reduce(OMPACCEL_RED_SYM *ReductionItems, int NumReductions, SPTR sptrFnReduce) +// AOCC Begin +#endif +// AOCC End { int ili, rili, bili; SPTR sptrFn, sptrRhs, sptrReduceData, sptrShuffleReturn, sptrLaneOffset, func_params[4]; DTYPE dtypeReductionItem, dtypeReduceData, dtypeRHS; int nmeReduceData, nmeRhs, params[2]; + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + char name[300]; + int arg1, arg2, arg3; + int lili; + SPTR lThen1, lIf1, lElseIf1, lElseIf2, lElse1, lThen2, lElseIf3, lElse2; +#else + // AOCC End char name[30]; + // AOCC Begin +#endif + // AOCC End DTYPE params_dtypes[2] = {DT_ADDR, DT_ADDR}; /* Generate function parameters */ @@ -1368,7 +2039,16 @@ ompaccel_nvvm_emit_shuffle_reduce(OMPACCEL_RED_SYM *ReductionItems, PASSBYVALP(func_params[3], 1); /* Generate function symbol */ + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + sprintf(name, "%s_%s_%d", "ompaccel_shufflereduce", suffix, reductionFunctionCounter++); +#else + // AOCC End sprintf(name, "%s%d", "ompaccel_shufflereduce", reductionFunctionCounter++); + // AOCC Begin +#endif + // AOCC End + sptrFn = mk_ompaccel_function(name, 4, func_params, true); cr_block(); @@ -1378,6 +2058,13 @@ ompaccel_nvvm_emit_shuffle_reduce(OMPACCEL_RED_SYM *ReductionItems, for (int i = 0; i < NumReductions; ++i) { dtypeReductionItem = DTYPEG(ReductionItems[i].shared_sym); + + // AOCC Begin + if (DTY(dtypeReductionItem) == TY_ARRAY) { + dtypeReductionItem = DDTG(dtypeReductionItem); + } + // AOCC End + sptrShuffleReturn = mk_ompaccel_getnewccsym('r', i, dtypeReductionItem, SC_LOCAL, ST_VAR); @@ -1396,7 +2083,17 @@ ompaccel_nvvm_emit_shuffle_reduce(OMPACCEL_RED_SYM *ReductionItems, } ili = mk_ompaccel_load(bili, DT_ADDR, nmeReduceData); - ili = mk_ompaccel_load(ili, dtypeReductionItem, nmeReduceData); + + // AOCC Begin + if (flg.amdgcn_target) { + if (dtypeReductionItem == DT_DBLE) + ili = mk_ompaccel_load(ili, DT_INT8, nmeReduceData); + else + ili = mk_ompaccel_load(ili, DT_INT, nmeReduceData); + } else { + // AOCC End + ili = mk_ompaccel_load(ili, dtypeReductionItem, nmeReduceData); + } if (dtypeReductionItem == DT_DBLE) ili = @@ -1420,20 +2117,193 @@ ompaccel_nvvm_emit_shuffle_reduce(OMPACCEL_RED_SYM *ReductionItems, chk_block(ili); } - params[0] = mk_address(sptrRhs); - params[1] = mk_address(sptrReduceData); + // AOCC Begin + // Arg0 ---> ReductionList + // Arg1 ---> LaneID/ThreadID + // Arg2 ---> LaneOffset + // Arg3 ---> AlgoVersion + // + // The actions to be performed on the Remote Reduce list is dependent + // on the algorithm version. + // + // if (AlgoVer==0) || (AlgoVer==1 && (LaneId < Offset)) || (AlgoVer==2 && + // LaneId % 2 == 0 && Offset > 0): + // do the reduction value aggregation + // + // The thread local variable Reduce list is mutated in place to host the + // reduced data, which is the aggregated value produced from local and + // remote lanes. + // + // Note that AlgoVer is expected to be a constant integer known at compile + // time. + // When AlgoVer==0, the first conjunction evaluates to true, making + // the entire predicate true during compile time. + // When AlgoVer==1, the second conjunction has only the second part to be + // evaluated during runtime. Other conjunctions evaluates to false + // during compile time. + // When AlgoVer==2, the third conjunction has only the second part to be + // evaluated during runtime. Other conjunctions evaluates to false + // during compile time. +#ifdef OMP_OFFLOAD_AMD + lThen1 = getlab(); + lIf1 = getlab(); + lElseIf1 = getlab(); + lElseIf2 = getlab(); + lElse1 = getlab(); + + arg3 = mk_ompaccel_ldsptr(func_params[3]); + ili = ad4ili(IL_ICJMP, arg3, ad_icon(0), CC_EQ, lThen1); + + RFCNTI(lIf1); + chk_block(ili); + iltb.callfg = 1; + wr_block(); + cr_block(); + exp_label(lIf1); - /* Call reduce function */ - ili = mk_function_call(DT_NONE, 2, params_dtypes, params, sptrFnReduce); + arg3 = mk_ompaccel_ldsptr(func_params[3]); + arg1 = mk_ompaccel_ldsptr(func_params[1]); + arg2 = mk_ompaccel_ldsptr(func_params[2]); + ili = ad3ili(IL_ICMP, arg3, ad_icon(1), CC_EQ); + lili = ad3ili(IL_ICMP, arg1, arg2, CC_LT); + ili = ad2ili(IL_AND, ili, lili); + ili = ad4ili(IL_ICJMP, ili, ad_icon(0), CC_NE, lThen1); - /* Write to block */ + chk_block(ili); iltb.callfg = 1; + wr_block(); + cr_block(); + + RFCNTI(lElseIf1); + exp_label(lElseIf1); + arg3 = mk_ompaccel_ldsptr(func_params[3]); + arg1 = mk_ompaccel_ldsptr(func_params[1]); + arg2 = mk_ompaccel_ldsptr(func_params[2]); + ili = ad3ili(IL_ICMP, arg3, ad_icon(2), CC_EQ); + lili = ad3ili(IL_ICMP, arg2, ad_icon(0), CC_GT); + rili = ad2ili(IL_AND, arg1, ad_icon(1)); + rili = ad3ili(IL_ICMP, rili, ad_icon(0), CC_EQ); + ili = ad2ili(IL_AND, ili, lili); + ili = ad2ili(IL_AND, ili, rili); + ili = ad4ili(IL_ICJMP, ili, ad_icon(0), CC_NE, lThen1); + chk_block(ili); + iltb.callfg = 1; + wr_block(); + cr_block(); + RFCNTI(lElseIf2); + exp_label(lElseIf2); + ili = ad1ili(IL_JMP, lElse1); + chk_block(ili); + iltb.callfg = 1; wr_block(); - mk_ompaccel_function_end(sptrFn); + cr_block(); - return sptrFn; + + RFCNTI(lThen1); + exp_label(lThen1); +#endif + // AOCC End + + params[0] = mk_address(sptrRhs); + params[1] = mk_address(sptrReduceData); + + /* Call reduce function */ + ili = mk_function_call(DT_NONE, 2, params_dtypes, params, sptrFnReduce); + + /* Write to block */ + iltb.callfg = 1; + chk_block(ili); + + // AOCC Begin + // if (AlgoVer==1 && (LaneId >= Offset)) copy Remote Reduce list to local + // Reduce list. +#ifdef OMP_OFFLOAD_AMD + wr_block(); + cr_block(); + + + RFCNTI(lElse1); + exp_label(lElse1); + ili = mk_ompaccel_ldsptr(func_params[3]); + lili = mk_ompaccel_compare(ili, DT_INT, ad_icon(1), DT_INT, CC_EQ); + ili = mk_ompaccel_ldsptr(func_params[1]); + rili = mk_ompaccel_ldsptr(func_params[2]); + rili = mk_ompaccel_compare(ili, DT_INT, rili, DT_INT, CC_GE); + ili = ad2ili(IL_AND, lili, rili); + lThen2 = getlab(); + lElseIf3 = getlab(); + lElse2 = getlab(); + ili = ad4ili(IL_ICJMP, ili, ad_icon(0), CC_NE, lThen2); + chk_block(ili); + iltb.callfg = 1; + wr_block(); + cr_block(); + + RFCNTI(lElseIf3); + exp_label(lElseIf3); + ili = ad1ili(IL_JMP, lElse2); + chk_block(ili); + iltb.callfg = 1; + wr_block(); + cr_block(); + + RFCNTI(lThen2); + exp_label(lThen2); + + for (int i = 0; i < NumReductions; ++i) { + + cr_block(); + dtypeReductionItem = DTYPEG(ReductionItems[i].shared_sym); + + // AOCC Begin + if (DTY(dtypeReductionItem) == TY_ARRAY) { + dtypeReductionItem = DDTG(dtypeReductionItem); + } + // AOCC End + + sptrShuffleReturn = + mk_ompaccel_getnewccsym('r', i, dtypeReductionItem, SC_LOCAL, ST_VAR); + + bili = mk_ompaccel_ldsptr(sptrReduceData); + rili = mk_address(sptrRhs); + + nmeReduceData = + add_arrnme(NT_IND, SPTR_NULL, addnme(NT_VAR, sptrReduceData, 0, 0), i, + ad_icon(i), FALSE); + + if (i != 0) { + rili = mk_ompaccel_add(rili, DT_ADDR, ad_aconi(i * size_of(DT_ADDR)), + DT_ADDR); + bili = mk_ompaccel_add(bili, DT_ADDR, ad_aconi(i * size_of(DT_ADDR)), + DT_ADDR); + } + + ili = mk_ompaccel_load(bili, DT_ADDR, nmeReduceData); + + nmeRhs = add_arrnme(NT_ARR, NME_NULL, addnme(NT_VAR, sptrRhs, 0, 0), i, + ad_icon(i), FALSE); + bili = mk_ompaccel_load(rili, DT_ADDR, nmeRhs); + bili = mk_ompaccel_load(bili, dtypeReductionItem, nmeRhs); + + ili = mk_ompaccel_store(bili, dtypeReductionItem, + nmeReduceData, + ili); + chk_block(ili); + + wr_block(); + } + + cr_block(); + RFCNTI(lElse2); + exp_label(lElse2); +#endif + // AOCC End + + mk_ompaccel_function_end(sptrFn); + + return sptrFn; } /** @@ -1441,8 +2311,18 @@ ompaccel_nvvm_emit_shuffle_reduce(OMPACCEL_RED_SYM *ReductionItems, of every active warp to lanes in the first warp. */ SPTR +// AOCC Begin +#ifdef OMP_OFFLOAD_AMD +ompaccel_nvvm_emit_inter_warp_copy(OMPACCEL_RED_SYM *ReductionItems, + int NumReductions, + const char *suffix) +#else +// AOCC End ompaccel_nvvm_emit_inter_warp_copy(OMPACCEL_RED_SYM *ReductionItems, int NumReductions) +// AOCC Begin +#endif +// AOCC End { int ili, rili; SPTR sptrFn, sptrReduceData, sptrWarpNum, sptrShmem, sptrWarpId, @@ -1450,9 +2330,18 @@ ompaccel_nvvm_emit_inter_warp_copy(OMPACCEL_RED_SYM *ReductionItems, SPTR lFirstLane, lBarrier, lFirstWarp, lFinalBarrier; int nmeShmem; DTYPE dtypeReductionItem; + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + char name[300]; + sprintf(name, "%s_%s_%d", "ompaccel_InterWarpCopy", suffix, reductionFunctionCounter++); +#else + // AOCC End char name[30]; - sprintf(name, "%s%d", "ompaccel_InterWarpCopy", reductionFunctionCounter++); + // AOCC Begin +#endif + // AOCC End + sptrReduceData = func_params[0] = mk_ompaccel_addsymbol( ".reduceData", mk_ompaccel_array_dtype(DT_INT8, NumReductions), SC_DUMMY, ST_ARRAY); @@ -1463,9 +2352,22 @@ ompaccel_nvvm_emit_inter_warp_copy(OMPACCEL_RED_SYM *ReductionItems, sptrFn = mk_ompaccel_function(name, 2, func_params, true); cr_block(); - sptrShmem = mk_ompaccel_addsymbol( - "ompaccelshmem", mk_ompaccel_array_dtype(DT_INT8, NVVM_WARPSIZE), - SC_EXTERN, ST_ARRAY); + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + sprintf(name, "%s_%s_%d", "ompaccelshmem", suffix, reductionFunctionCounter++); +#else + sprintf(name, "%s_%d", "ompaccelshmem", reductionFunctionCounter++); +#endif + if (flg.amdgcn_target) { + sptrShmem = mk_ompaccel_addsymbol( + name, mk_ompaccel_array_dtype(DT_INT8, flg.warp_size), + SC_EXTERN, ST_ARRAY); + } else { + // AOCC End + sptrShmem = mk_ompaccel_addsymbol( + name, mk_ompaccel_array_dtype(DT_INT8, NVVM_WARPSIZE), + SC_EXTERN, ST_ARRAY); + } OMPACCSHMEMP(sptrShmem, true); SYMLKP(sptrShmem, gbl.externs); gbl.externs = sptrShmem; @@ -1474,7 +2376,12 @@ ompaccel_nvvm_emit_inter_warp_copy(OMPACCEL_RED_SYM *ReductionItems, sptrMasterWarp = mk_ompaccel_addsymbol(".masterwarp", DT_INT, SC_LOCAL, ST_VAR); ili = ompaccel_nvvm_get(threadIdX); - ili = mk_ompaccel_iand(ili, ad_icon(31)); + // AOCC Begin + if (flg.amdgcn_target) + ili = mk_ompaccel_iand(ili, ad_icon(warp_size_log2_mask)); + else + // AOCC End + ili = mk_ompaccel_iand(ili, ad_icon(31)); ili = mk_ompaccel_stsptr(ili, sptrMasterWarp); chk_block(ili); @@ -1482,7 +2389,12 @@ ompaccel_nvvm_emit_inter_warp_copy(OMPACCEL_RED_SYM *ReductionItems, /* MasterWarp */ sptrWarpId = mk_ompaccel_addsymbol(".warpid", DT_INT, SC_LOCAL, ST_VAR); ili = ompaccel_nvvm_get(threadIdX); - ili = mk_ompaccel_shift(ili, DT_UINT, ad_icon(5), DT_UINT); + // AOCC Begin + if (flg.amdgcn_target) + ili = mk_ompaccel_shift(ili, DT_UINT, ad_icon(warp_size_log2), DT_UINT); + else + // AOCC End + ili = mk_ompaccel_shift(ili, DT_UINT, ad_icon(5), DT_UINT); ili = mk_ompaccel_stsptr(ili, sptrWarpId); chk_block(ili); @@ -1497,6 +2409,10 @@ ompaccel_nvvm_emit_inter_warp_copy(OMPACCEL_RED_SYM *ReductionItems, for (int i = 0; i < NumReductions; ++i) { cr_block(); dtypeReductionItem = DTYPEG(ReductionItems[i].shared_sym); + + if (DTY(dtypeReductionItem) == TY_ARRAY) { + dtypeReductionItem = DDTG(dtypeReductionItem); + } rili = mk_ompaccel_ldsptr(sptrReduceData); if (i != 0) { rili = mk_ompaccel_add(rili, DT_ADDR, ad_aconi(i * size_of(DT_ADDR)), @@ -1532,12 +2448,14 @@ ompaccel_nvvm_emit_inter_warp_copy(OMPACCEL_RED_SYM *ReductionItems, ili = mk_ompaccel_add(mk_address(sptrShmem), DT_ADDR, ili, DT_ADDR); nmeShmem = add_arrnme(NT_ARR, NME_NULL, addnme(NT_VAR, sptrShmem, 0, 0), 0, rili, FALSE); - + // AOCC Begin + NME_VOLATILE(nmeShmem) = 1; + // AOCC End rili = mk_ompaccel_ldsptr(sptrRedItem); // todo ompaccel more if (dtypeReductionItem == DT_DBLE) { rili = mk_ompaccel_load(rili, DT_DBLE, addnme(NT_VAR, sptrRedItem, 0, 0)); - } else if (dtypeReductionItem == DT_INT) { + } else if (dtypeReductionItem == DT_INT || dtypeReductionItem == DT_LOG) { rili = mk_ompaccel_ld(rili, addnme(NT_IND, SPTR_NULL, addnme(NT_VAR, sptrRedItem, 0, 0), 0)); rili = ad1ili(IL_FLOAT, rili); @@ -1545,6 +2463,12 @@ ompaccel_nvvm_emit_inter_warp_copy(OMPACCEL_RED_SYM *ReductionItems, rili = mk_ompaccel_load(rili, DT_FLOAT, addnme(NT_VAR, sptrRedItem, 0, 0)); rili = ad1ili(IL_DBLE, rili); + // AOCC Begin + } else if (dtypeReductionItem == DT_INT8 || dtypeReductionItem == DT_LOG8) { + rili = mk_ompaccel_ld(rili, addnme(NT_IND, SPTR_NULL, + addnme(NT_VAR, sptrRedItem, 0, 0), 0)); + rili = ad1ili(IL_DBLE, rili); + // AOCC End } ili = mk_ompaccel_store(rili, DT_DBLE, nmeShmem, ili); chk_block(ili); @@ -1581,6 +2505,9 @@ ompaccel_nvvm_emit_inter_warp_copy(OMPACCEL_RED_SYM *ReductionItems, nmeShmem = add_arrnme(NT_ARR, NME_NULL, addnme(NT_VAR, sptrShmem, 0, 0), 0, rili, FALSE); + // AOCC Begin + NME_VOLATILE(nmeShmem) = 1; + // AOCC End ili = mk_ompaccel_load(ili, DT_DBLE, nmeShmem); rili = mk_ompaccel_ldsptr(sptrRedItemAddress); @@ -1601,6 +2528,14 @@ ompaccel_nvvm_emit_inter_warp_copy(OMPACCEL_RED_SYM *ReductionItems, ili, DT_FLOAT, addnme(NT_IND, NME_NULL, addnme(NT_VAR, sptrRedItemAddress, 0, 0), 0), rili); + // AOCC Begin + } else if (dtypeReductionItem == DT_INT8) { + ili = ad1ili(IL_DFIXK, ili); + ili = mk_ompaccel_store( + ili, DT_NONE, + addnme(NT_IND, NME_NULL, addnme(NT_VAR, sptrRedItemAddress, 0, 0), 0), + rili); + // AOCC End } chk_block(ili); iltb.callfg = 1; @@ -1635,6 +2570,22 @@ exp_ompaccel_bpar(ILM *ilmp, int curilm, SPTR uplevel_sptr, SPTR scopeSptr, ll_rewrite_ilms(-1, curilm, 0); return; } + + // AOCC begin + // + // Force the parallel codegen on the outlined function of teams for now. + if (flg.x86_64_omptarget && gbl.currsub == curr_teams_outlined_sptr) { + outlinedCnt = incrOutlinedCnt(); + BIH_FT(expb.curbih) = TRUE; + BIH_QJSR(expb.curbih) = TRUE; + BIH_NOMERGE(expb.curbih) = TRUE; + if (gbl.outlined) + expb.sc = SC_PRIVATE; + + ll_rewrite_ilms(-1, curilm, 0); + return; + } + // AOCC end outlinedCnt = incrOutlinedCnt(); BIH_FT(expb.curbih) = TRUE; BIH_QJSR(expb.curbih) = TRUE; @@ -1642,18 +2593,26 @@ exp_ompaccel_bpar(ILM *ilmp, int curilm, SPTR uplevel_sptr, SPTR scopeSptr, if (gbl.outlined) expb.sc = SC_PRIVATE; if (outlinedCnt == 1) { - sptr = ll_make_outlined_ompaccel_func(uplevel_sptr, scopeSptr, FALSE); + sptr = ll_make_outlined_ompaccel_func2(uplevel_sptr, + scopeSptr, FALSE); // AOCC if (!PARENCLFUNCG(scopeSptr)) PARENCLFUNCP(scopeSptr, sptr); ll_write_ilm_header(sptr, curilm); - ili = ompaccel_nvvm_get(threadIdX); - ili = ll_make_kmpc_spmd_kernel_init(ili); - iltb.callfg = 1; - chk_block(ili); + // AOCC begin + if (!flg.x86_64_omptarget) { + ili = ll_make_kmpc_target_init(ompaccel_tinfo_get(gbl.currsub)->mode); + iltb.callfg = 1; + chk_block(ili); + } + + if (flg.x86_64_omptarget) + ili = ompaccel_x86_fork_call(sptr); + else + ili = ll_make_outlined_ompaccel_call(gbl.ompoutlinedfunc, sptr); + // AOCC end - ili = ll_make_outlined_ompaccel_call(gbl.ompoutlinedfunc, sptr); iltb.callfg = 1; chk_block(ili); gbl.ompoutlinedfunc = sptr; @@ -1767,6 +2726,20 @@ exp_ompaccel_mploop(ILM *ilmp, int curilm) loop_args.last = ILM_SymOPND(ilmp, 5); loop_args.dtype = (DTYPE)ILM_OPND(ilmp, 6); // ??? loop_args.sched = (kmpc_sched_e)ILM_OPND(ilmp, 7); + + // AOCC begin + // For -Mx,232,0x1 on x86 offloading we emit the teams distribute code + // just like a parallel region (ie. only one invocation of for_static_init). + // The codegen for emitting the fork_teams with a callback to fork_call (ie. + // the one with 2 for_static_inits like -fopenmp) has lots of issues (like the + // bounds are not properly propagated from the teams callback to the fork_call + // callback etc.) + if (flg.x86_64_omptarget && XBIT(232, 0x1) && + mp_sched_to_kmpc_sched(loop_args.sched) == KMP_DISTRIBUTE_STATIC) { + loop_args.sched = (kmpc_sched_e) MP_SCH_STATIC; + } + // AOCC end + sched = mp_sched_to_kmpc_sched(loop_args.sched); switch (sched) { case KMP_SCH_STATIC: @@ -1779,7 +2752,14 @@ exp_ompaccel_mploop(ILM *ilmp, int curilm) } case KMP_DISTRIBUTE_STATIC_CHUNKED: case KMP_DISTRIBUTE_STATIC: - ili = ll_make_kmpc_for_static_init_simple_spmd(&loop_args, sched); + case KMP_DISTRIBUTE_STATIC_CHUNKED_CHUNKONE: // AOCC + // AOCC begin + if (flg.x86_64_omptarget || OMPACCFUNCDEVG(gbl.currsub)) { + ili = ll_make_kmpc_for_static_init(&loop_args); + // AOCC end + } else { + ili = ll_make_kmpc_for_static_init_simple_spmd(&loop_args, sched); + } break; default: ili = ll_make_kmpc_dispatch_init(&loop_args); @@ -1864,11 +2844,15 @@ exp_ompaccel_etarget(ILM *ilmp, int curilm, SPTR targetfunc_sptr, if (outlinedCnt == 1) { ilm_outlined_pad_ilm(curilm); } + // AOCC Begin. rewrite_ilms already executed in callee + /* outlinedCnt = decrOutlinedCnt(); if (outlinedCnt >= 1) { ll_rewrite_ilms(-1, curilm, 0); return; } + */ + // AOCC End if (gbl.outlined) expb.sc = SC_AUTO; @@ -1876,11 +2860,21 @@ exp_ompaccel_etarget(ILM *ilmp, int curilm, SPTR targetfunc_sptr, ili = ll_make_tgt_target(gbl.ompoutlinedfunc, OMPACCEL_DEFAULT_DEVICEID, uplevel_sptr); } else if (ompaccel_tinfo_current_target_mode() == mode_target_parallel_for || - ompaccel_tinfo_current_target_mode() == - mode_target_parallel_for_simd) { + // AOCC Begin + // Need to create a single team for target parallel mode as well. + // Loops can be present inside omp target parallel block + ompaccel_tinfo_current_target_mode() == mode_target_parallel || + // AOCC End + ompaccel_tinfo_current_target_mode() == mode_target_parallel_for_simd) { // Create kernel with single team. ili = ll_make_tgt_target_teams( gbl.ompoutlinedfunc, OMPACCEL_DEFAULT_DEVICEID, uplevel_sptr, 1, 0); + // AOCC Begin + // target simd (without parallel clause) need to be executed on single thread. + } else if (ompaccel_tinfo_current_target_mode() == mode_target_simd) { + ili = ll_make_tgt_target_teams( + gbl.ompoutlinedfunc, OMPACCEL_DEFAULT_DEVICEID, uplevel_sptr, 1, 1); + // AOCC End } else { ili = ll_make_tgt_target_teams( gbl.ompoutlinedfunc, OMPACCEL_DEFAULT_DEVICEID, uplevel_sptr, 0, 0); @@ -1895,37 +2889,95 @@ exp_ompaccel_etarget(ILM *ilmp, int curilm, SPTR targetfunc_sptr, "Target region terminated", NULL); } -void -exp_ompaccel_reduction(ILM *ilmp, int curilm) -{ +// AOCC Begin +// Reducing arrays by reducing each element of array. +static void emit_array_reduction(SPTR sptrReduceData) { + int ili, bili, nmeReduceData, sizeRed = 0; - SPTR lAssignReduction, sptrReduceData, sptrReductionItem; - DTYPE dtypeReduceData, dtypeReductionItem; - dtypeReduceData = mk_ompaccel_array_dtype( - get_type(2, TY_PTR, DT_ANY), - ompaccel_tinfo_current_get()->n_reduction_symbols); - sptrReduceData = - mk_ompaccel_addsymbol(".reduceData", dtypeReduceData, SC_LOCAL, ST_ARRAY); + SPTR lAssignReduction = (SPTR)0, sptrReductionItem; + DTYPE dtypeReductionItem; - cr_block(); - for (int i = 0; i < ompaccel_tinfo_current_get()->n_reduction_symbols; ++i) { - sptrReductionItem = - ompaccel_tinfo_current_get()->reduction_symbols[i].shared_sym; - dtypeReductionItem = DTYPEG(sptrReductionItem); + sptrReductionItem = + ompaccel_tinfo_current_get()->reduction_symbols[0].shared_sym; + dtypeReductionItem = DTYPEG(sptrReductionItem); + nmeReduceData = + add_arrnme(NT_ARR, NME_NULL, addnme(NT_VAR, sptrReduceData, 0, 0), 0, + ad_icon(0), FALSE); - ili = mk_address(sptrReductionItem); - nmeReduceData = - add_arrnme(NT_ARR, NME_NULL, addnme(NT_VAR, sptrReduceData, 0, 0), i, - ad_icon(i), FALSE); + if (DTY(dtypeReductionItem) != TY_ARRAY) { + ompaccelInternalFail("Only handling arrays here"); + } - bili = mk_address(sptrReduceData); - if (i != 0) - bili = mk_ompaccel_add(bili, DT_ADDR, ad_aconi(i * size_of(DT_ADDR)), - DT_ADDR); + std::string name; + name = SYMNAME(sptrReductionItem); - ili = mk_ompaccel_store(ili, DT_ADDR, nmeReduceData, bili); - chk_block(ili); + // Alloca to store size of array + name += "_size"; + SPTR array_size = mk_ompaccel_addsymbol(name.c_str(), DT_INT, + SC_LOCAL, ST_VAR); + + // Alloca for IV of loop + name = SYMNAME(sptrReductionItem); + name += "_iv"; + SPTR array_iv = mk_ompaccel_addsymbol(name.c_str(), DT_INT, + SC_LOCAL, ST_VAR); + + int nme_size = addnme(NT_VAR, array_size, 0, (INT)0); + int nme_iv = addnme(NT_VAR, array_iv, 0, (INT)0); + + ADSC *ad = AD_DPTR(dtypeReductionItem); + int numdim = AD_NUMDIM(ad); + int j; + int ilix, rilix; + ilix = ad_kconi(1); + + for (j = 0; j < numdim; ++j) { + if (AD_UPBD(ad, j) != 0) { + SPTR ub = (SPTR) AD_UPBD(ad, j); + SPTR lb = (SPTR) AD_LWBD(ad, j); + rilix = ad2ili(IL_KSUB, mk_ompaccel_ldsptr(ub), mk_ompaccel_ldsptr(lb)); + rilix = ad2ili(IL_KADD, rilix, ad_kconi(1)); + } else + rilix = ad2ili(IL_KADD, ad_kconi(0), ad_kconi(1)); + ilix = ad2ili(IL_KMUL, ilix, rilix); } + + ilix = mk_ompaccel_store(ilix, DT_INT, nme_size, mk_address(array_size)); + chk_block(ilix); + ilix = mk_ompaccel_store(ad_icon(0), DT_INT, nme_iv, mk_address(array_iv)); + chk_block(ilix); + + ilix = mk_ompaccel_ldsptr(array_iv); + int size_ili = mk_ompaccel_ldsptr(array_size); + int comp_ili = mk_ompaccel_compare(ilix, DT_INT, size_ili, DT_INT, CC_EQ); + + // loop body + SPTR array_cpy_body = getlab(); + + // loop exit + SPTR array_cpy_done = getlab(); + ilix = ad3ili(IL_ICJMPZ, comp_ili, CC_NE, array_cpy_done); + chk_block(ilix); + wr_block(); + + RFCNTI(array_cpy_body); + exp_label(array_cpy_body); + + ilix = mk_ompaccel_ldsptr(array_iv); + ilix = mk_ompaccel_mul(ilix, DT_INT, + ad_icon(size_of(DDTG(dtypeReductionItem))), DT_INT); + + if (SCG(sptrReductionItem) == SC_BASED && MIDNUMG(sptrReductionItem)) { + sptrReductionItem = MIDNUMG(sptrReductionItem); + } + + ili = mk_address(sptrReductionItem); + ili = mk_ompaccel_add(ili, DT_ADDR, ilix, DT_ADDR); + + bili = mk_address(sptrReduceData); + + ili = mk_ompaccel_store(ili, DT_ADDR, nmeReduceData, bili); + chk_block(ili); wr_block(); cr_block(); @@ -1935,51 +2987,252 @@ exp_ompaccel_reduction(ILM *ilmp, int curilm) ompaccel_tinfo_current_get()->reduction_funcs.shuffleFn, ompaccel_tinfo_current_get()->reduction_funcs.interWarpCopy); iltb.callfg = 1; - chk_block(ili); wr_block(); - exp_ompaccel_ereduction(ilmp, curilm); - lAssignReduction = getlab(); RFCNTI(lAssignReduction); - ili = ompaccel_nvvm_get(threadIdX); - ili = mk_ompaccel_compare(ili, DT_INT, ad_icon(0), DT_INT, CC_NE); - ili = ad3ili(IL_ICJMPZ, ili, CC_NE, lAssignReduction); + if (flg.amdgcn_target) + ili = mk_ompaccel_compare(ili, DT_INT, ad_icon(1), DT_INT, CC_NE); + else { + ili = ompaccel_nvvm_get(threadIdX); + ili = mk_ompaccel_compare(ili, DT_INT, ad_icon(0), DT_INT, CC_NE); + } + + SPTR loop_latch = getlab(); + ili = ad3ili(IL_ICJMPZ, ili, CC_NE, loop_latch); chk_block(ili); - // Load reduced items to the origina laddress - for (int i = 0; i < ompaccel_tinfo_current_get()->n_reduction_symbols; ++i) { - bili = mk_address(sptrReduceData); - sptrReductionItem = - ompaccel_tinfo_current_get()->reduction_symbols[i].private_sym; - dtypeReductionItem = DTYPEG(sptrReductionItem); + bili = mk_address(sptrReduceData); + sptrReductionItem = + ompaccel_tinfo_current_get()->reduction_symbols[0].private_sym; + dtypeReductionItem = DDTG(DTYPEG(sptrReductionItem)); - if (i != 0) { - bili = mk_ompaccel_add(bili, DT_ADDR, ad_aconi(i * size_of(DT_ADDR)), - DT_ADDR); - } + if (SCG(sptrReductionItem) == SC_BASED && MIDNUMG(sptrReductionItem)) { + sptrReductionItem = MIDNUMG(sptrReductionItem); + } - bili = mk_ompaccel_load(bili, DT_ADDR, nmeReduceData); - bili = mk_ompaccel_load(bili, dtypeReductionItem, nmeReduceData); + bili = mk_ompaccel_load(bili, DT_ADDR, nmeReduceData); + bili = mk_ompaccel_load(bili, dtypeReductionItem, nmeReduceData); - ili = mk_ompaccel_ldsptr(sptrReductionItem); + ilix = mk_ompaccel_ldsptr(array_iv); + ilix = mk_ompaccel_mul(ilix, DT_INT, + ad_icon(size_of(dtypeReductionItem)), DT_INT); + ili = mk_address(sptrReductionItem); + ili = mk_ompaccel_add(ili, DT_ADDR, ilix, DT_ADDR); + int store_addr = ili; + ili = mk_ompaccel_load(ili, dtypeReductionItem, nmeReduceData); - switch (ompaccel_tinfo_current_get()->reduction_symbols[i].redop) { - case 1: - case 2: - ili = mk_ompaccel_add(ili, dtypeReductionItem, bili, dtypeReductionItem); - ili = mk_ompaccel_store(ili, dtypeReductionItem, - addnme(NT_VAR, sptrReductionItem, 0, 0), - mk_address(sptrReductionItem)); - break; + switch (ompaccel_tinfo_current_get()->reduction_symbols[0].redop) { + case 1: + case 2: + ili = mk_ompaccel_add(ili, dtypeReductionItem, bili, dtypeReductionItem); + ili = mk_ompaccel_store(ili, dtypeReductionItem, + addnme(NT_VAR, sptrReductionItem, 0, 0), + store_addr); + break; + case 3: + ili = mk_ompaccel_mul(ili, dtypeReductionItem, bili, dtypeReductionItem); + ili = mk_ompaccel_store(ili, dtypeReductionItem, + addnme(NT_VAR, sptrReductionItem, 0, 0), + store_addr); + break; + case 17: // OP_LOR + ili = mk_ompaccel_or(ili, dtypeReductionItem, bili, dtypeReductionItem); + ili = mk_ompaccel_store(ili, dtypeReductionItem, + addnme(NT_VAR, sptrReductionItem, 0, 0), + store_addr); + break; + case 18: // OP_LAND + ili = mk_ompaccel_and(ili, dtypeReductionItem, bili, dtypeReductionItem); + ili = mk_ompaccel_store(ili, dtypeReductionItem, + addnme(NT_VAR, sptrReductionItem, 0, 0), + store_addr); + break; + case 373: + ili = mk_ompaccel_max(ili, dtypeReductionItem, bili, dtypeReductionItem); + ili = mk_ompaccel_store(ili, dtypeReductionItem, + addnme(NT_VAR, sptrReductionItem, 0, 0), + mk_address(sptrReductionItem)); + break; + case 374: + ili = mk_ompaccel_min(ili, dtypeReductionItem, bili, dtypeReductionItem); + ili = mk_ompaccel_store(ili, dtypeReductionItem, + addnme(NT_VAR, sptrReductionItem, 0, 0), + store_addr); + break; + default: + ompaccelInternalFail("Unhanled reduction type"); + break; + } + + chk_block(ili); + wr_block(); + cr_block(); + + // Looop latch + // Increment part + RFCNTI(loop_latch); + exp_label(loop_latch); + ilix = mk_ompaccel_ldsptr(array_iv); + ilix = mk_ompaccel_add(ilix, DT_INT, ad_icon(1), DT_INT); + ilix = mk_ompaccel_store(ilix, DT_INT, nme_iv, mk_address(array_iv)); + chk_block(ilix); + + // comparision + ilix = mk_ompaccel_ldsptr(array_iv); + size_ili = mk_ompaccel_ldsptr(array_size); + comp_ili = mk_ompaccel_compare(ilix, DT_INT, size_ili, DT_INT, CC_NE); + ilix = ad3ili(IL_ICJMPZ, comp_ili, CC_NE, array_cpy_body); + chk_block(ilix); + wr_block(); + + // Exit BB + RFCNTI(array_cpy_done); + exp_label(array_cpy_done); +} +// AOCC End + +void +exp_ompaccel_reduction(ILM *ilmp, int curilm) +{ + int ili, bili, nmeReduceData, sizeRed = 0; + SPTR lAssignReduction = (SPTR)0, sptrReduceData, sptrReductionItem; + DTYPE dtypeReduceData, dtypeReductionItem; + dtypeReduceData = mk_ompaccel_array_dtype( + get_type(2, TY_PTR, DT_ANY), + ompaccel_tinfo_current_get()->n_reduction_symbols); + sptrReduceData = + mk_ompaccel_addsymbol(".reduceData", dtypeReduceData, SC_LOCAL, ST_ARRAY); + + cr_block(); + + // AOCC Begin + if (ompaccel_tinfo_current_get()->n_reduction_symbols == 1 && + DTY(DTYPEG( + ompaccel_tinfo_current_get()->reduction_symbols[0].shared_sym)) == + TY_ARRAY) { + emit_array_reduction(sptrReduceData); + } else { + // AOCC End + for (int i = 0; i < ompaccel_tinfo_current_get()->n_reduction_symbols; ++i) { + sptrReductionItem = + ompaccel_tinfo_current_get()->reduction_symbols[i].shared_sym; + dtypeReductionItem = DTYPEG(sptrReductionItem); + + ili = mk_address(sptrReductionItem); + nmeReduceData = + add_arrnme(NT_ARR, NME_NULL, addnme(NT_VAR, sptrReduceData, 0, 0), i, + ad_icon(i), FALSE); + + bili = mk_address(sptrReduceData); + if (i != 0) + bili = mk_ompaccel_add(bili, DT_ADDR, ad_aconi(i * size_of(DT_ADDR)), + DT_ADDR); + + ili = mk_ompaccel_store(ili, DT_ADDR, nmeReduceData, bili); + chk_block(ili); } + wr_block(); + + cr_block(); + ili = ll_make_kmpc_nvptx_parallel_reduce_nowait_simple_spmd( + ad_icon(ompaccel_tinfo_current_get()->n_reduction_symbols), + ad_icon(sizeRed), mk_address(sptrReduceData), + ompaccel_tinfo_current_get()->reduction_funcs.shuffleFn, + ompaccel_tinfo_current_get()->reduction_funcs.interWarpCopy); + iltb.callfg = 1; + wr_block(); + + + lAssignReduction = getlab(); + RFCNTI(lAssignReduction); + + // AOCC Begin + if (flg.amdgcn_target) + ili = mk_ompaccel_compare(ili, DT_INT, ad_icon(1), DT_INT, CC_NE); + // AOCC End + else { + ili = ompaccel_nvvm_get(threadIdX); + ili = mk_ompaccel_compare(ili, DT_INT, ad_icon(0), DT_INT, CC_NE); + } + ili = ad3ili(IL_ICJMPZ, ili, CC_NE, lAssignReduction); chk_block(ili); + + // Load reduced items to the origina laddress + for (int i = 0; i < ompaccel_tinfo_current_get()->n_reduction_symbols; ++i) { + bili = mk_address(sptrReduceData); + sptrReductionItem = + ompaccel_tinfo_current_get()->reduction_symbols[i].private_sym; + dtypeReductionItem = DTYPEG(sptrReductionItem); + + if (i != 0) { + bili = mk_ompaccel_add(bili, DT_ADDR, ad_aconi(i * size_of(DT_ADDR)), + DT_ADDR); + } + + bili = mk_ompaccel_load(bili, DT_ADDR, nmeReduceData); + bili = mk_ompaccel_load(bili, dtypeReductionItem, nmeReduceData); + + ili = mk_ompaccel_ldsptr(sptrReductionItem); + + switch (ompaccel_tinfo_current_get()->reduction_symbols[i].redop) { + case 1: + case 2: + ili = mk_ompaccel_add(ili, dtypeReductionItem, bili, dtypeReductionItem); + ili = mk_ompaccel_store(ili, dtypeReductionItem, + addnme(NT_VAR, sptrReductionItem, 0, 0), + mk_address(sptrReductionItem)); + break; + // AOCC Begin + case 3: + ili = mk_ompaccel_mul(ili, dtypeReductionItem, bili, dtypeReductionItem); + ili = mk_ompaccel_store(ili, dtypeReductionItem, + addnme(NT_VAR, sptrReductionItem, 0, 0), + mk_address(sptrReductionItem)); + break; + case 17: // OP_LOR + ili = mk_ompaccel_or(ili, dtypeReductionItem, bili, dtypeReductionItem); + ili = mk_ompaccel_store(ili, dtypeReductionItem, + addnme(NT_VAR, sptrReductionItem, 0, 0), + mk_address(sptrReductionItem)); + break; + case 18: // OP_LAND + ili = mk_ompaccel_and(ili, dtypeReductionItem, bili, dtypeReductionItem); + ili = mk_ompaccel_store(ili, dtypeReductionItem, + addnme(NT_VAR, sptrReductionItem, 0, 0), + mk_address(sptrReductionItem)); + break; + case 373: + ili = mk_ompaccel_max(ili, dtypeReductionItem, bili, dtypeReductionItem); + ili = mk_ompaccel_store(ili, dtypeReductionItem, + addnme(NT_VAR, sptrReductionItem, 0, 0), + mk_address(sptrReductionItem)); + break; + case 374: + ili = mk_ompaccel_min(ili, dtypeReductionItem, bili, dtypeReductionItem); + ili = mk_ompaccel_store(ili, dtypeReductionItem, + addnme(NT_VAR, sptrReductionItem, 0, 0), + mk_address(sptrReductionItem)); + break; + default: + ompaccelInternalFail("Unknown red op type"); + // AOCC End + } + + chk_block(ili); + // AOCC Begin + wr_block(); + cr_block(); + // AOCC End + } } + exp_ompaccel_ereduction(ilmp, curilm); wr_block(); cr_block(); - exp_label(lAssignReduction); + if (lAssignReduction) + exp_label(lAssignReduction); } void @@ -1993,7 +3246,7 @@ exp_ompaccel_bteams(ILM *ilmp, int curilm, int outlinedCnt, SPTR uplevel_sptr, cr_block(); } - if (flg.omptarget) { + if (flg.omptarget && !XBIT(232, 0x1)) { // AOCC ll_rewrite_ilms(-1, curilm, 0); return; } @@ -2008,18 +3261,28 @@ exp_ompaccel_bteams(ILM *ilmp, int curilm, int outlinedCnt, SPTR uplevel_sptr, expb.sc = SC_PRIVATE; if (outlinedCnt == 1) { if (flg.omptarget) - sptr = ll_make_outlined_ompaccel_func(uplevel_sptr, scopeSptr, FALSE); + sptr = ll_make_outlined_ompaccel_func2(uplevel_sptr, + scopeSptr, FALSE); // AOCC else sptr = ll_make_outlined_func(uplevel_sptr, scopeSptr); + curr_teams_outlined_sptr = sptr; // AOCC if (!PARENCLFUNCG(scopeSptr)) PARENCLFUNCP(scopeSptr, sptr); ll_write_ilm_header(sptr, curilm); if (flg.omptarget) { - ili = ompaccel_nvvm_get(threadIdX); - ili = ll_make_kmpc_spmd_kernel_init(ili); - iltb.callfg = 1; - chk_block(ili); - ili = ll_make_outlined_ompaccel_call(gbl.ompoutlinedfunc, sptr); + // AOCC begin + if (!flg.x86_64_omptarget) { + ili = ll_make_kmpc_target_init(ompaccel_tinfo_get(gbl.currsub)->mode); + iltb.callfg = 1; + chk_block(ili); + } + + if (flg.x86_64_omptarget) + ili = ompaccel_x86_fork_call(sptr); + else + ili = ll_make_outlined_ompaccel_call(gbl.ompoutlinedfunc, sptr); + + // AOCC end iltb.callfg = 1; chk_block(ili); gbl.ompoutlinedfunc = sptr; @@ -2036,6 +3299,8 @@ void exp_ompaccel_map(ILM *ilmp, int curilm, int outlinedCnt) { int label, argilm; + int base = 0, ili_sptr = 0; // AOCC + SPTR lwb_sptr = SPTR_NULL, length_sptr = SPTR_NULL; // AOCC SPTR sptr; if (outlinedCnt >= 2) return; @@ -2047,9 +3312,128 @@ exp_ompaccel_map(ILM *ilmp, int curilm, int outlinedCnt) } else if (ILM_OPC(mapop) == IM_PLD) { sptr = ILM_SymOPND(mapop, 2); // make 2 label = ILM_OPND(ilmp, 2); /* map type */ + // AOCC Begin + // sptr for lower bound and length for assumed shape array + } else if (ILM_OPC(mapop) == IM_ELEMENT) { + sptr = ILM_SymOPND((ILM *)(ilmb.ilm_base + ILM_SymOPND(mapop, 2)), 1); + ILM *tmp = (ILM *)(ilmb.ilm_base + ILM_SymOPND(mapop, 4)); + if(ILM_OPC(tmp) == IM_BASE) + lwb_sptr = ILM_SymOPND(tmp, 1); + else if(ILM_OPC(tmp) == IM_KCON) + lwb_sptr = ILM_SymOPND(tmp, 1); + else if(ILM_OPC(tmp) == IM_KLD){ + lwb_sptr = ILM_SymOPND((ILM *)(ilmb.ilm_base + ILM_SymOPND(tmp, 1)), 1); + } + lwb_sptr = ILM_SymOPND((ILM *)(ilmb.ilm_base + ILM_SymOPND(mapop, 4)), 1); + if(ilms[ILM_OPC(ilmp)].oprs == 3) + length_sptr = ILM_SymOPND((ILM *) + (ilmb.ilm_base + ILM_SymOPND(ilmp, 3)), 1); + label = ILM_OPND(ilmp, 2); /* map type */ + } else if (ILM_OPC(mapop) == IM_MEMBER) { + return; // no need to map non-pointer members explicitly + } + // AOCC End + + // AOCC Begin + if (STYPEG(sptr) == ST_MEMBER && ILM_OPC(ilmp) == IM_MP_MAP_MEM) { + int baseilix = 0; + int nmex = 0; + ISZ_T val; + int ilix, ili1, op1, nme, addr, load; + + base = ILM_OPND(ilmp, 3); + baseilix = ILI_OF(base); + // baseilix and ili_sptr need to be computed for pointer type member + // of structure for constructs which enclose a target region + if(!baseilix) { + SPTR sym = ILM_SymOPND((ILM *)(ilmb.ilm_base + base), 1); + baseilix = mk_address(sym); + nmex = addnme(NT_VAR, sym, 0, (INT)0); + ILM_RESULT(base) = baseilix; + ILM_NME(base) = nmex; + } + + ili_sptr = ILI_OF(argilm); + if(!ili_sptr) { + val = ADDRESSG(sptr); + ili1 = ad_aconi(val); + if(baseilix) { + ilix = ad3ili(IL_AADD, baseilix, ili1, 0); + nmex = addnme(NT_MEM, PSMEMG(sptr), NME_OF(base), 0); + } else { + ilix = ili1; + nmex = NME_UNK; + } + ILM_RESULT(ILM_OPND(mapop, 1)) = ilix; + ILM_NME(ILM_OPND(mapop, 1)) = nmex; + op1 = ILM_OPND(mapop, 1); + addr = op1; + nme = NME_OF(addr); + addr = ILI_OF(addr); + load = ad2ili(IL_LDA, addr, nme); + ADDRCAND(load, nme); + ILM_RESULT(argilm) = load; + ILM_NME(argilm) = addnme(NT_IND, SPTR_NULL, nme, 0); + ili_sptr = load; + } + base = baseilix; + } + // AOCC End + + // AOCC Begin + for (int i = 0; i < current_tinfo->n_symbols; ++i) { + if (SDSCG(current_tinfo->symbols[i].host_sym)){ + if(current_tinfo->symbols[i].host_sym == sptr) { + if(lwb_sptr != SPTR_NULL && length_sptr != SPTR_NULL){ + current_tinfo->symbols[i].in_map = 1; + current_tinfo->symbols[i].sptr_lowerbound = lwb_sptr; + current_tinfo->symbols[i].sptr_length = length_sptr; + } + } + } + } + // AOCC End + + ompaccel_tinfo_current_addupdate_mapitem(sptr, label); + + // AOCC Begin + assert(current_tinfo->n_symbols, "Expecting atleast one symbol", 0, + ERR_Fatal); + current_tinfo->symbols[current_tinfo->n_symbols-1].ili_base = base; + current_tinfo->symbols[current_tinfo->n_symbols-1].ili_sptr = ili_sptr; + // AOCC End +} + +void +exp_ompaccel_use_device_ptr(ILM *ilmp, int curilm, int outlinedCnt) +{ + exp_ompaccel_map(ilmp, curilm, outlinedCnt); +} + +// AOCC Begin +void +exp_ompaccel_use_device_addr(ILM *ilmp, int curilm, int outlinedCnt) +{ + exp_ompaccel_map(ilmp, curilm, outlinedCnt); +} +// AOCC End + +// AOCC Begin +void +exp_ompaccel_is_device_ptr(ILM *ilmp, int curilm) +{ + int label, argilm; + SPTR sptr; + argilm = ILM_OPND(ilmp, 1); + ILM *mapop = (ILM *)(ilmb.ilm_base + argilm); + if (ILM_OPC(mapop) == IM_BASE) { + sptr = ILM_SymOPND(mapop, 1); + label = ILM_OPND(ilmp, 2); } + ompaccel_tinfo_current_addupdate_mapitem(sptr, label); } +// AOCC End void exp_ompaccel_emap(ILM *ilmp, int curilm) @@ -2060,6 +3444,19 @@ exp_ompaccel_emap(ILM *ilmp, int curilm) return; ompaccel_symreplacer(true); targetinfo = ompaccel_tinfo_current_get(); + // AOCC Begin + // A struct variable not mapped using map clause but used in target region + // need to be mapped by reference. + // TODO : add other constructs also which enclose a target region + if(targetinfo && + (targetinfo->mode == mode_target || + targetinfo->mode == mode_target_parallel_for)) + for(int i=0; i < targetinfo->n_symbols; ++i) { + if(STYPEG(targetinfo->symbols[i].host_sym) == ST_STRUCT) + tinfo_update_maptype(targetinfo->symbols, targetinfo->n_symbols, + targetinfo->symbols[i].host_sym, targetinfo->symbols[i].map_type); + } + // AOCC End if (targetinfo != NULL) { if (ompaccel_tinfo_current_target_mode() == mode_target_data_enter_region || ompaccel_tinfo_current_target_mode() == mode_target_data_region) { @@ -2076,6 +3473,15 @@ exp_ompaccel_emap(ILM *ilmp, int curilm) ili = ll_make_tgt_target_data_end(OMPACCEL_DEFAULT_DEVICEID, targetinfo); iltb.callfg = 1; chk_block(ili); + // AOCC Begin + } else if (ompaccel_tinfo_current_target_mode() == mode_target_update) { + wr_block(); + cr_block(); + ili = ll_make_tgt_target_update(OMPACCEL_DEFAULT_DEVICEID, targetinfo); + iltb.callfg = 1; + chk_block(ili); + current_tinfo = old_tinfo; + // AOCC End } } } @@ -2103,6 +3509,36 @@ exp_ompaccel_reductionitem(ILM *ilmp, int curilm) ILM_SymOPND(ilmp, 1), ILM_SymOPND(ilmp, 2), ILM_SymOPND(ilmp, 3)); } +// AOCC Begin +void +exp_ompaccel_target_update(ILM *ilmp, int curilm, ILM_OP opc) +{ + + int dotarget; + + // Store current_tinfo to avoid overlapping with other tinfo. + // Overlapping happends moslty for reduction kernels. + old_tinfo = current_tinfo; + + SPTR beg_label, end_label; + ompaccel_symreplacer(false); + ompaccel_tinfo_create(OMPACCEL_DATA_FUNCTION, OMPACCEL_DATA_MAX_SYM); + ompaccel_tinfo_current_set_mode(mode_target_update); + dotarget = ILI_OF(ILM_OPND(ilmp, 1)); + beg_label = getlab(); + end_label = getlab(); + + dotarget = ad3ili(IL_ICJMPZ, dotarget, CC_EQ, end_label); + RFCNTI(end_label); + chk_block(dotarget); + wr_block(); + cr_block(); + exp_label(beg_label); + + exp_label(end_label); +} +// AOCC End + void exp_ompaccel_targetdata(ILM *ilmp, int curilm, ILM_OP opc) { @@ -2114,8 +3550,10 @@ exp_ompaccel_targetdata(ILM *ilmp, int curilm, ILM_OP opc) ompaccel_tinfo_current_set_mode(mode_target_data_exit_region); else if (opc == IM_TARGETENTERDATA) ompaccel_tinfo_current_set_mode(mode_target_data_enter_region); - else if (opc == IM_BTARGETDATA) + else if (opc == IM_BTARGETDATA) { ompaccel_tinfo_current_set_mode(mode_target_data_region); + targetDataTinfos.push_back(current_tinfo); // AOCC + } dotarget = ILI_OF(ILM_OPND(ilmp, 1)); beg_label = getlab(); end_label = getlab(); @@ -2154,5 +3592,147 @@ init_test() init_tgtutil(); } +// AOCC Begin +/** + \brief Creates necessary reduction helper functions for the runtime. + Compiler passes their address to the runtime. + This function is used only for AMFGPU targets. Unkike to original + function, this function emits wrappers for all avaiable tinfos. + */ +void +ompaccel_create_amd_reduction_wrappers() +{ + if (!flg.amdgcn_target) { + assert(0, "AMDGCN specific function called for another target.", + 0, ERR_Fatal); + } + int i; + for (i = last_tinfo_index; i < num_tinfos; ++i) { + if (gbl.ompaccel_intarget && gbl.currsub != NULL) { + int nreds = tinfos[i]->n_reduction_symbols; +#ifdef OMP_OFFLOAD_AMD + /* + * Adding suffix to reduction function names. This is to avoid duplicate + * function names in the case of multi kernel applications + * + */ + char suffix[300]; + sprintf(suffix, "%s", SYMNAME(gbl.currsub)); +#endif + if (nreds != 0) { + SPTR cur_func_sptr = gbl.currsub; + OMPACCEL_RED_SYM *redlist = + tinfos[i]->reduction_symbols; + gbl.outlined = false; + gbl.ompaccel_isdevice = true; +#ifdef OMP_OFFLOAD_AMD + SPTR sptr_reduce = ompaccel_nvvm_emit_reduce(redlist, nreds, suffix); +#else + SPTR sptr_reduce = ompaccel_nvvm_emit_reduce(redlist, nreds); +#endif + schedule(); + assemble(); + gbl.func_count++; + gbl.multi_func_count = gbl.func_count; +#ifdef OMP_OFFLOAD_AMD + tinfos[i]->reduction_funcs.shuffleFn = + ompaccel_nvvm_emit_shuffle_reduce(redlist, nreds, sptr_reduce, suffix); +#else + tinfos[i]->reduction_funcs.shuffleFn = + ompaccel_nvvm_emit_shuffle_reduce(redlist, nreds, sptr_reduce); +#endif + schedule(); + assemble(); + gbl.func_count++; + gbl.multi_func_count = gbl.func_count; +#ifdef OMP_OFFLOAD_AMD + tinfos[i]->reduction_funcs.interWarpCopy = + ompaccel_nvvm_emit_inter_warp_copy(redlist, nreds, suffix); +#else + tinfos[i]->reduction_funcs.interWarpCopy = + ompaccel_nvvm_emit_inter_warp_copy(redlist, nreds); +#endif + schedule(); + assemble(); + ompaccel_write_sharedvars(); + gbl.func_count++; + gbl.multi_func_count = gbl.func_count; + gbl.outlined = false; + gbl.ompaccel_isdevice = false; + gbl.currsub = cur_func_sptr; + } + } + } + last_tinfo_index = num_tinfos; +} + +/// \brief Update map type for device symbols \p dev_symbol +void +ompaccel_update_devsym_maptype(SPTR dev_symbol, int map_type) +{ + if (!current_tinfo) // AOCC + return; + int i; + for (i = 0; i < current_tinfo->n_symbols; ++i) { + if (current_tinfo->symbols[i].device_sym == dev_symbol) { + current_tinfo->symbols[i].map_type |= map_type; + PASSBYVALP(dev_symbol, 0); + } + } +} + +void +ompaccel_tinfo_current_set(OMPACCEL_TINFO *tinfo) +{ + current_tinfo = tinfo; +} +// AOCC Begin +bool +is_nvvm_sreg_function(SPTR func_sptr) +{ + const char* fname = get_llvm_name(func_sptr); +#ifdef OMP_OFFLOAD_AMD + if (strncmp(fname,"llvm.amdgcn.workitem.id",23) == 0) return true; + if (strncmp(fname,"llvm.amdgcn.workgroup.id",24) == 0) return true; + if (strncmp(fname,"__ockl_get_local_size",21) == 0) return true; + if (strncmp(fname,"__ockl_get_num_groups",21) == 0) return true; +#else + if (strncmp(fname,"llvm.nvvm.read.ptx.sreg",23)) return false; +#endif + for (int i=0; i<(sizeof(NVVM_SREG)/sizeof(char *)); i++) + if (!strcmp(NVVM_SREG[i], fname)) return true; + return false; +} + +void +ompaccel_set_numteams_sptr(SPTR num_teams) { + current_tinfo->num_teams = num_teams; +} + +void +ompaccel_set_numthreads_sptr(SPTR num_threads) { + current_tinfo->num_threads = num_threads; +} + +void +ompaccel_set_default_map(int maptype) { + next_default_map_type = maptype; +} + +void +ompaccel_set_target_declare() { + OMPACCFUNCDEVP(gbl.currsub, 1); + gbl.ompaccel_intarget = true; +} + +bool is_SPMD_mode(OMP_TARGET_MODE mode) { + if (mode >= mode_target_teams_distribute_parallel_for + && mode <= mode_target_parallel_for_simd) { + return true; + } + return false; +} + +// AOCC End #endif /* Expander - OpenMP Accelerator Model */ diff --git a/tools/flang2/flang2exe/ompaccel.h b/tools/flang2/flang2exe/ompaccel.h index 46d568b355..f9173b7487 100644 --- a/tools/flang2/flang2exe/ompaccel.h +++ b/tools/flang2/flang2exe/ompaccel.h @@ -4,6 +4,16 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading + * Last modified: August 2020 + * + * Support for x86-64 OpenMP offloading + * Last modified: Apr 2020 + */ /** * \file @@ -16,6 +26,8 @@ #include "llmputil.h" #include "expand.h" +#include "kmpcutil.h" // AOCC +#include // AOCC /* Find if the func_sptr whether it is a kernel or not. */ #define IS_OMP_DEVICE_KERNEL(func_sptr) (OMPACCFUNCKERNELG(func_sptr)) @@ -49,7 +61,12 @@ typedef struct { bool in_map; /* set if it occurs in map */ int ili_base; /* symbol base */ int ili_lowerbound; /* lower bound */ + SPTR sptr_lowerbound; /* lower bound sptr */ int ili_length; /* length */ + SPTR sptr_length; /* length sptr*/ + int ili_sptr; /* ili for sptr, // AOCC + ili_base represents base of struct, + this represets offsetted pointer */ } OMPACCEL_SYM; /* Target Info is the main struct which keeps all the information about target @@ -70,14 +87,27 @@ struct _OMPACCEL_TARGET{ OMPACCEL_TINFO* parent_tinfo; /* Parent tinfo is used for nested outlining in device. */ bool nowait; /* async */ int n_reduction_symbols; /* Number of reduction symbols */ + int sz_reduction_symbols; /* Size of reduction symbols */ // AOCC OMPACCEL_RED_SYM *reduction_symbols; /* Reduction symbols along with the reduction operator */ OMPACCEL_RED_FUNCS reduction_funcs; /* Auxiliary functions for reduction */ + char *func_name; /* Function name */ // AOCC + SPTR num_teams; /* Number of teams */ // AOCC + SPTR num_threads; /* Number of threads */ // AOCC + int default_map; /* Default map type for current kernel */ //AOCC }; static bool isOmpaccelRegistered = false; +// AOCC Begin +// Keeping target data tinfos in a stack. Array wont work for nested cases. +extern std::vector targetDataTinfos; +// AOCC End + extern OMPACCEL_TINFO **tinfos; +extern int warp_size_log2; +extern int warp_size_log2_mask; + #define NVVM_WARPSIZE 32 typedef enum NVVM_SREG_ENUM { @@ -96,6 +126,20 @@ typedef enum NVVM_SREG_ENUM { warpSize } nvvm_sregs; +// AOCC Begin +// Eventhough warpSize intrinsic is listed as nvvm.read.ptx.sreg.warpsize, +// it's not being used anymore, constant value 64 is used instead. +#ifdef OMP_OFFLOAD_AMD +static const char *NVVM_SREG[] = { + "llvm.amdgcn.workitem.id.x", "llvm.amdgcn.workitem.id.y", + "llvm.amdgcn.workitem.id.z", "llvm.amdgcn.workgroup.id.x", + "llvm.amdgcn.workgroup.id.y", "llvm.amdgcn.workgroup.id.z", + "__ockl_get_local_size", "__ockl_get_local_size", + "__ockl_get_local_size", "__ockl_get_num_groups", + "__ockl_get_num_groups", "__ockl_get_num_groups", + "nvvm.read.ptx.sreg.warpsize"}; +#else +// AOCC End static const char *NVVM_SREG[] = { "llvm.nvvm.read.ptx.sreg.tid.x", "llvm.nvvm.read.ptx.sreg.tid.y", "llvm.nvvm.read.ptx.sreg.tid.z", "llvm.nvvm.read.ptx.sreg.ctaid.x", @@ -104,11 +148,24 @@ static const char *NVVM_SREG[] = { "llvm.nvvm.read.ptx.sreg.ntid.z", "llvm.nvvm.read.ptx.sreg.nctaid.x", "llvm.nvvm.read.ptx.sreg.nctaid.y", "llvm.nvvm.read.ptx.sreg.nctaid.z", "llvm.nvvm.read.ptx.sreg.warpsize"}; +// AOCC Begin +#endif +// AOCC End typedef enum NVVM_INTRINSICS_ENUM { barrier0, barrier } nvvm_intrinsics; +// AOCC Begin +#ifdef OMP_OFFLOAD_AMD +static const char *NVVM_INTRINSICS[] = {"llvm.amdgcn.s.barrier", + "llvm.amdgcn.s.barrier"}; +#else +// AOCC End static const char *NVVM_INTRINSICS[] = {"llvm.nvvm.barrier0", "llvm.nvvm.barrier"}; +// AOCC Begin +#endif +// AOCC End + typedef enum NVVM_BARRIERS { CTA_BARRIER, PARTIAL_BARRIER } nvvm_barriers; @@ -189,6 +246,24 @@ int ompaccel_nvvm_get_gbl_tid(void); /** \brief Emit shuffle reduce for reduction. (nvvm device only) */ + +// AOCC Begin +#ifdef OMP_OFFLOAD_AMD +SPTR ompaccel_nvvm_emit_shuffle_reduce(OMPACCEL_RED_SYM *, int, SPTR, + const char *); + +/** + \brief Emit reduce for reduction. (nvvm device only) + */ +SPTR ompaccel_nvvm_emit_reduce(OMPACCEL_RED_SYM *, int, const char *); + +/** + \brief Emit inter warp copy for reduction. (nvvm device only) + */ +SPTR ompaccel_nvvm_emit_inter_warp_copy(OMPACCEL_RED_SYM *, int, + const char *); +#else +// AOCC End SPTR ompaccel_nvvm_emit_shuffle_reduce(OMPACCEL_RED_SYM *, int, SPTR); /** @@ -200,6 +275,84 @@ SPTR ompaccel_nvvm_emit_reduce(OMPACCEL_RED_SYM *, int); \brief Emit inter warp copy for reduction. (nvvm device only) */ SPTR ompaccel_nvvm_emit_inter_warp_copy(OMPACCEL_RED_SYM *, int); +// AOCC Begin +#endif + +SPTR +mk_ompaccel_addsymbol(const char *name, DTYPE dtype, SC_KIND SCkind, + SYMTYPE symtype); + +void +mk_ompaccel_function_end(SPTR func_sptr); + +SPTR +mk_ompaccel_function(char *name, int n_params, const SPTR *param_sptrs, + bool isDeviceFunc); +/** + * \brief remembers \p func_sptr to be a parallel outlined function in target + * region for x86 offloading + */ +void ompaccel_x86_add_parallel_func(SPTR func_sptr); + +/** + * \brief returns true if \p func_sptr is a parallel func (as described above) + */ +bool ompaccel_x86_is_parallel_func(SPTR func_sptr); + +/** + * \brief returns true if we need to fork-call \p func_sptr + */ +bool ompaccel_x86_is_toplevel_parallel_func(SPTR func_sptr); + +/** + * \brief remembers \p func_sptr as fork-wrapper function + */ +void ompaccel_x86_add_fork_wrapper_func(SPTR func_sptr); + +/** + * \brief returns true if \p func_sptr is a fork-wrapper function + */ +bool ompaccel_x86_is_fork_wrapper_func(SPTR func_sptr); + +/** + * \brief returns true if the function \p func_sptr needs to go into the + * .omp_offloading.entries data section. + */ +bool ompaccel_x86_is_entry_func(SPTR func_sptr); + +/** + * \briefs prepends global_tid and bound_tid params to \p func_sptr + */ +void ompaccel_x86_add_tid_params(SPTR func_sptr); + +/** + * \brief generates the "wrapper" that emits __kmpc_fork_call to \p target_func + */ +void ompaccel_x86_gen_fork_wrapper(SPTR target_func); + +/** + * \brief emits the reduction code for tinfo. + */ +void ompaccel_x86_emit_reduce(OMPACCEL_TINFO *tinfo); + +/** + * \brief returns true if func_sptr has tid args. + */ +bool ompaccel_x86_has_tid_args(SPTR func_sptr); + +/** + * \brief sets the type of each argument of \p func_sptr for + * x86 offloading. + */ +void ompaccel_x86_fix_arg_types(SPTR func_sptr); + +/** + * \brief generates a fork_call as per \p kmpc_api (ie. teams or fork) to \p + * outlined_func. + * Functions implementing -Mx,232,0x1 must use this. + */ +int ompaccel_x86_fork_call(SPTR outlined_func, int kmpc_api = KMPC_API_FORK_CALL); +// AOCC End /* ################################################ */ /* OpenMP ACCEL - Target Information data structure */ @@ -360,6 +513,18 @@ void exp_ompaccel_map(ILM *, int, int); \brief Expand ILM and emit code for emap */ void exp_ompaccel_emap(ILM *, int); +/** + \brief Expand ILM and emit code for use_device_ptr + */ +void exp_ompaccel_use_device_ptr(ILM *, int, int); +/** + \brief Expand ILM and emit code for is_device_ptr + */ +void exp_ompaccel_is_device_ptr(ILM *, int); // AOCC +/** + \brief Expand ILM and emit code for use_device_addr + */ +void exp_ompaccel_use_device_addr(ILM *, int, int); // AOCC /** \brief Expand ILM and emit code for looptripcount */ @@ -368,6 +533,12 @@ void exp_ompaccel_looptripcount(ILM *, int); \brief Expand ILM and emit code for reductionitem */ void exp_ompaccel_reductionitem(ILM *, int); +// AOCC Begin +/** + \brief Expand ILM and emit code for target update + */ +void exp_ompaccel_target_update(ILM *, int, ILM_OP); +// AOCC End /** \brief Expand ILM and emit code for targetdata */ @@ -382,4 +553,41 @@ int mk_ompaccel_mul(int ili1, DTYPE dtype1, int ili2, DTYPE dtype2); int mk_ompaccel_add(int ili1, DTYPE dtype1, int ili2, DTYPE dtype2); int mk_ompaccel_ldsptr(SPTR sptr); void init_test(); + +// AOCC begin +int mk_reduction_op(int redop, int lili, DTYPE dtype1, int rili, DTYPE dtype2); + +/** + \brief Set current target info. + */ +void ompaccel_tinfo_current_set(OMPACCEL_TINFO *); +/** + \brief Creatre reduction wrappers + */ +void ompaccel_create_amd_reduction_wrappers(); +/** + \brief Update maptype for given symbol + */ +void ompaccel_update_devsym_maptype(SPTR dev_symbol, int map_type); +/** + \brief Set number of teams sptr to current tinfo + */ +void ompaccel_set_numteams_sptr(SPTR sptr); +/** + \brief Set number of teams sptr to current tinfo + */ +void ompaccel_set_numthreads_sptr(SPTR sptr); +/** + \brief Set default map type for current tinfo + */ +void ompaccel_set_default_map(int maptype); +/** + \brief Set symbol as target symbol + */ +void ompaccel_set_target_declare(); +/** + \brief Checks if given target mode is SPMD + */ +bool is_SPMD_mode(OMP_TARGET_MODE mode); +// AOCC End #endif diff --git a/tools/flang2/flang2exe/ompaccel_x86.cpp b/tools/flang2/flang2exe/ompaccel_x86.cpp new file mode 100644 index 0000000000..8bafa7e6b3 --- /dev/null +++ b/tools/flang2/flang2exe/ompaccel_x86.cpp @@ -0,0 +1,480 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Support for x86-64 OpenMP offloading + * Last Modified: Jun 2020 + */ +#ifdef OMP_OFFLOAD_LLVM + +#include "kmpcutil.h" +#include "error.h" +#include "semant.h" +#include "ilmtp.h" +#include "ilm.h" +#include "ili.h" +#include "expand.h" +#include "exputil.h" +#include "outliner.h" +#include "machreg.h" +#include "mp.h" +#include "ll_structure.h" +#include "llmputil.h" +#include "ccffinfo.h" +#include "llutil.h" +#include "ompaccel.h" +#include "tgtutil.h" +#include "dinit.h" +#include "assem.h" +#include "dinitutl.h" +#include "cgllvm.h" +#include "cgmain.h" + +#include "regutil.h" +#include "dtypeutl.h" +#include "llassem.h" +#include "ll_ftn.h" +#include "symfun.h" +#include +#include +#include + +static std::set ompaccel_x86_parallel_func_set; +static std::set ompaccel_x86_fork_wrapper_func_set; +static std::set ompaccel_x86_reduced_func_set; + +// flang reuses SPTR values, so we mangle the name with the SPTR to get globally +// unique name for each func_sptr in a compilation unit. +static std::string ompaccel_x86_get_mangled_sptr(SPTR func_sptr) { + std::string func_name(getprint(func_sptr)); + // FIXME: The Concatenation below results in some strange memory violations + // in some test-cases. The outlined func_name itself is mangled at this point, + // so we rely on the name for uniquness. + // return func_name + std::to_string(func_sptr); + + return func_name; +} + +// Returns the ompaccel-sym that corresponds to \p reduction_sym in \p tinfo +static OMPACCEL_SYM *get_ompaccel_sym_for(OMPACCEL_RED_SYM *reduction_sym, OMPACCEL_TINFO *tinfo) { + for (int i = 0; i < tinfo->n_symbols; i++) { + OMPACCEL_SYM *omp_sym = &(tinfo->symbols[i]); + if (strcmp(SYMNAME(omp_sym->host_sym), SYMNAME(reduction_sym->private_sym)) == 0) { + return omp_sym; + } + } + + return NULL; +} + +// Returns the nth reduction-sym in \p tinfo by keeping track of duplicate +// MP_REDUCTIONITEMs. +static OMPACCEL_RED_SYM *get_ompaccel_reduction_sym(OMPACCEL_TINFO *tinfo, int n) { + std::set seen_sym; + + for (int i = 0; i < tinfo->n_reduction_symbols; i++) { + OMPACCEL_RED_SYM *reduction_sym = &(tinfo->reduction_symbols[i]); + + // There are scenarios in which flang emits 2 MP_REDUCTIONITEM ilms + // for a single reduction variable. We keep track of those duplicates to get + // the "real" nth reduction symbol. + if (seen_sym.find(reduction_sym->private_sym) == seen_sym.end()) + seen_sym.insert(reduction_sym->private_sym); + else + n++; + if (i == n) { return reduction_sym; } + } + + return NULL; +} + +void ompaccel_x86_emit_reduce(OMPACCEL_TINFO *tinfo) { + bool debug_me = false; + SPTR func_sptr = gbl.currsub; + + // Emit the reduction code only for target function. + if (tinfo->func_sptr != func_sptr) { + return; + } + + std::string mangled_sptr = ompaccel_x86_get_mangled_sptr(func_sptr); + + // If we already did the reduction, then ignore. + if (ompaccel_x86_reduced_func_set.find(mangled_sptr) != + ompaccel_x86_reduced_func_set.end()) + return; + + std::set reduced_syms; + for (int i = 0; i < tinfo->n_reduction_symbols; i++) { + + OMPACCEL_RED_SYM *reduction_sym = &(tinfo->reduction_symbols[i]); + OMPACCEL_SYM *ompaccel_sym = get_ompaccel_sym_for(reduction_sym, tinfo); + SPTR device_sym = ompaccel_sym->device_sym; + SPTR host_sym = ompaccel_sym->device_sym; + + // If already reduced (happens incase there are multiple MP_REDUCTIONITEM + // for one reduction variable). + if (reduced_syms.find(device_sym) != reduced_syms.end()) { continue; } + + if (debug_me) { + printf("[ompaccel-x86] Reducing device_sym: %s private_sym: %s with redop: %d in %s\n", + getprint(device_sym), getprint(reduction_sym->private_sym), reduction_sym->redop, + getprint(func_sptr)); + } + + int ili = mk_reduction_op(reduction_sym->redop, + mk_ompaccel_ldsptr(device_sym), DTYPEG(host_sym), + mk_ompaccel_ldsptr(reduction_sym->private_sym), DTYPEG(reduction_sym->private_sym)); + + ili = mk_ompaccel_store(ili, DTYPEG(reduction_sym->private_sym), 0, mk_address(device_sym)); + + chk_block(ili); + reduced_syms.insert(device_sym); + } + + ompaccel_x86_reduced_func_set.insert(mangled_sptr); +} + +void ompaccel_x86_fix_arg_types(SPTR func_sptr) { + bool debug_me = false; + int func_paramct = PARAMCTG(func_sptr); + int func_dpsc = DPDSCG(func_sptr); + int start_idx = 0, adjust_idx = 0; + + // See the comments in ompaccel_x86_gen_fork_entry() regarding "x86 offloading + // friendly" variables. The same applies for args in target function that are + // entered via omp-runtime interfaces. + if (!gbl.ompaccel_intarget) + return; + + if (ompaccel_x86_is_fork_wrapper_func(func_sptr)) + return; + + // -Mx,232,0x1 implementation of parallel and teams expansion uses the + // ompaccel_x86_fork_call() which adds tid_args and fixes the arg types of the + // callback. So func_sptr with tid_args are already fixed. + if (XBIT(232, 0x1) && ompaccel_x86_has_tid_args(func_sptr)) { + return; + } + + if (ompaccel_x86_has_tid_args(func_sptr)) { + // Then skip the first 2 tid args. + adjust_idx = 2; + func_paramct -= 2; + } + + OMPACCEL_TINFO *tinfo = ompaccel_tinfo_get(func_sptr); + + // Remember all the reduction symbols of func_sptr so that we can blacklist + // them during the type update. + std::set reduc_syms; + if (tinfo) { + for (int i = 0; i < tinfo->n_reduction_symbols; i++) { + OMPACCEL_RED_SYM *reduction_sym = &(tinfo->reduction_symbols[i]); + OMPACCEL_SYM *ompaccel_sym = get_ompaccel_sym_for(reduction_sym, tinfo); + + if (!ompaccel_sym) + continue; + SPTR device_sym = ompaccel_sym->device_sym; + + if (PASSBYVALG(device_sym)) + continue; + + reduc_syms.insert(device_sym); + } + } + + for (int i = 0; i < func_paramct; i++) { + SPTR arg_sptr = (SPTR)aux.dpdsc_base[func_dpsc + i + adjust_idx]; + if (DTY(DTYPEG(arg_sptr)) != TY_ARRAY && +#if 1 // aocc flang does not have these two lines + DTY(DTYPEG(arg_sptr)) != TY_CMPLX && + DTY(DTYPEG(arg_sptr)) != TY_DCMPLX && +#endif + (DTY(DTYPEG(arg_sptr)) != TY_PTR)) { + // We skip reduction variables since they'll be lowered as pointers. + if (reduc_syms.find(arg_sptr) != reduc_syms.end()) { continue; } + + DTYPEP(arg_sptr, DT_INT8); + if (XBIT(232, 0x1)) { + // FIXME! This condition is not suppose to happen, but it does in + // -Mx,232,0x1. + if (PASSBYVALG(arg_sptr) == PASSBYREFG(arg_sptr) && + PASSBYREFG(arg_sptr) == 1) { + PASSBYREFP(arg_sptr, 1); + PASSBYVALP(arg_sptr, 0); + } + } + if (debug_me) { + printf("[ompaccel-x86]: For %s setting %s's type as DT_INT8 ", + SYMNAME(func_sptr), SYMNAME(arg_sptr)); + printf("PASSBYVAL: %d PASSBYREF: %d\n", + PASSBYVALG(arg_sptr), PASSBYREFG(arg_sptr)); + } + } + } +} + +void ompaccel_x86_add_parallel_func(SPTR func_sptr) { + bool debug_me = false; + if (debug_me) + printf("[ompaccel-x86]: adding as parallel: %s\n", SYMNAME(func_sptr)); + std::string mangled_sptr = ompaccel_x86_get_mangled_sptr(func_sptr); + ompaccel_x86_parallel_func_set.insert(mangled_sptr); + return; +} + +bool ompaccel_x86_is_parallel_func(SPTR func_sptr) { + std::string mangled_sptr = ompaccel_x86_get_mangled_sptr(func_sptr); + if (ompaccel_x86_parallel_func_set.find(mangled_sptr) != + ompaccel_x86_parallel_func_set.end()) + return true; + else + return false; +} + +bool ompaccel_x86_is_toplevel_parallel_func(SPTR func_sptr) { + // TODO. must check for cases when the parallel func is invoked by another + // outlined func in device. + return ompaccel_x86_is_parallel_func(func_sptr); +} + +void ompaccel_x86_add_fork_wrapper_func(SPTR func_sptr) { + std::string mangled_sptr = ompaccel_x86_get_mangled_sptr(func_sptr); + ompaccel_x86_fork_wrapper_func_set.insert(mangled_sptr); + return; +} + +bool ompaccel_x86_is_fork_wrapper_func(SPTR func_sptr) { + std::string mangled_sptr = ompaccel_x86_get_mangled_sptr(func_sptr); + if (ompaccel_x86_fork_wrapper_func_set.find(mangled_sptr) != + ompaccel_x86_fork_wrapper_func_set.end()) + return true; + else + return false; +} + +bool ompaccel_x86_is_entry_func(SPTR func_sptr) { + if (OMPACCFUNCKERNELG(func_sptr)) { + // Most likely an outlined parallel function, we should only add the + // fork_wrapper func corresponding to this. + if (ompaccel_x86_is_parallel_func(func_sptr)) { + if (XBIT(232, 0x1)) + return true; + + return false; + } else { + + // Should be a non parallel outlined function which we can enter directly. + return true; + } + } + + // In the case of a non outlined function, the only functions considered as + // entry are the fork-wrapper generated ones. + if (ompaccel_x86_is_fork_wrapper_func(func_sptr)) + return true; + return false; +} + +static std::set ompaccel_x86_tid_ready; + +bool ompaccel_x86_has_tid_args(SPTR func_sptr) { + std::string mangled_sptr = ompaccel_x86_get_mangled_sptr(func_sptr); + if (ompaccel_x86_tid_ready.find(mangled_sptr) + != ompaccel_x86_tid_ready.end()) + return true; + return false; +} + +void ompaccel_x86_add_tid_params(SPTR func_sptr) { + + int func_dpsc = DPDSCG(func_sptr); + int func_paramct = PARAMCTG(func_sptr); + int sym; + SPTR orig_params[func_paramct]; + + // If we already added the tid params for func_sptr then ignore. + if (ompaccel_x86_has_tid_args(func_sptr)) { + if (func_paramct >= 2) { + if (strcmp(getprint((SPTR)aux.dpdsc_base[func_dpsc + 0]), + "global_tid") == 0 && + strcmp(getprint((SPTR)aux.dpdsc_base[func_dpsc + 1]), + "bound_tid") == 0) { + return; + } + } + } + + // Store all the original params + for (int i = 0; i < func_paramct; i++) { + orig_params[i] = (SPTR)aux.dpdsc_base[func_dpsc + i]; + } + + // Expand the argument array memory + // (the +100 bit is copied from llMakeFtnOutlinedSignatureTarget()) + NEED(aux.dpdsc_avl + func_paramct + 2, aux.dpdsc_base, int, aux.dpdsc_size, + aux.dpdsc_size + func_paramct + 2 + 100); + + DPDSCP(func_sptr, aux.dpdsc_avl); + + // Prepend the thread-id params. + sym = mk_ompaccel_addsymbol("global_tid", DT_INT, SC_DUMMY, ST_VAR); + OMPACCDEVSYMP(sym, TRUE); + + if (XBIT(232, 0x1)) { + PASSBYREFP(sym, 1); + PASSBYVALP(sym, 0); + } + + aux.dpdsc_base[aux.dpdsc_avl + 0] = sym; + + sym = mk_ompaccel_addsymbol("bound_tid", DT_INT, SC_DUMMY, ST_VAR); + OMPACCDEVSYMP(sym, TRUE); + + if (XBIT(232, 0x1)) { + PASSBYREFP(sym, 1); + PASSBYVALP(sym, 0); + } + + aux.dpdsc_base[aux.dpdsc_avl + 1] = sym; + + // Append the original params. + for (int i = 0; i < func_paramct; i++) { + aux.dpdsc_base[aux.dpdsc_avl + 2 + i] = orig_params[i]; + } + + // Update the param-count and aux DS + PARAMCTP(func_sptr, func_paramct + 2); + aux.dpdsc_avl += func_paramct + 2; + + std::string mangled_sptr = ompaccel_x86_get_mangled_sptr(func_sptr); + ompaccel_x86_tid_ready.insert(mangled_sptr); +} + +void ompaccel_x86_gen_fork_wrapper(SPTR target_func) { + // TODO: Perhaps add special "Q" flags for x86 offloading ? + bool debug_me = false; + static long func_id = 0; + + // Must be a valid outlined function + if (!target_func || !gbl.outlined) + return; + + // Must be a function that's expected to be parallelized. + if (!ompaccel_x86_is_toplevel_parallel_func(target_func)) + return; + + assert(ompaccel_x86_has_tid_args(target_func), + "Expecting the fork-wrapper's target function to have tid args", + target_func, ERR_Fatal); + + SPTR orig_func = gbl.currsub; + int orig_bih = expb.curbih; + + char func_name[1024]; + // device functions gets "_" in the end. + sprintf(func_name, "%s_x86_entry_", SYMNAME(target_func)); + SPTR func_sptr; + + int target_func_args_count; + OMPACCEL_TINFO *omptinfo; + omptinfo = ompaccel_tinfo_get(target_func); + + target_func_args_count = PARAMCTG(target_func) - 2; // - 2 to exclude tid args + SPTR func_args[target_func_args_count]; + + if (debug_me) { + printf("[ompaccel-x86]: Fork wrapper target: %s (SPTR: %d) with %d arg(s)\n", + SYMNAME(target_func), target_func, target_func_args_count); + } + + int target_func_dpsc = DPDSCG(target_func); + for (int i = 0; i < target_func_args_count; ++i) { + SPTR dev_sptr = (SPTR)aux.dpdsc_base[target_func_dpsc + i + 2]; // + 2 to skip the tid args + + // We make each sptr names unique so that we can work on them without + // accidentally modifying another sptr with the same name (and usually the + // same sptr number). Although naming is a trivial thing, flang's symbol + // creation APIs force us to make unique names across the working + // gbl.currsub. + char new_arg_name[1024]; + sprintf(new_arg_name, "%s_%d_%dx86", SYMNAME(dev_sptr), func_id, i); + + // Every argument must be "x86 offloading friendly". ie it should transfer + // correctly via ffi_call() of libomptarget. So far, I only found pointers and + // i64 in the LLVM-type-system that works for almost all cases. + func_args[i] = mk_ompaccel_addsymbol(new_arg_name, DT_INT8, SC_DUMMY, STYPEG(dev_sptr)); + PASSBYVALP(func_args[i], 0); + PASSBYREFP(func_args[i], 1); + } + + func_sptr = mk_ompaccel_function(func_name, target_func_args_count, + func_args, /* device_func */true); + + // FIXME: The function we're generating is not an + // oulined function. If you see gen_ref_arg() which + // stb_process_routine_parameters() eventually call if params are references, + // there is a hard-coded "special" handling for outlined func. + // + // The following line is a lie! But a necessary one due to the inconsistency + // described above. + OUTLINEDP(func_sptr, 1); + + cr_block(); + int ilix = ll_make_kmpc_fork_call_variadic(target_func, target_func_args_count, + func_args); + + iltb.callfg = 1; + chk_block(ilix); + wr_block(); + mk_ompaccel_function_end(func_sptr); + func_id++; + + ompaccel_x86_add_fork_wrapper_func(func_sptr); + schedule(); + assemble(); + gbl.currsub = orig_func; + gbl.func_count++; + + if (debug_me) { + LL_Type *ll_ty = make_lltype_from_sptr(func_sptr); + printf("[ompaccel-x86]: Made fork wrapper %s of type %s\n", + SYMNAME(func_sptr), ll_ty->str); + } + return; +} + +int ompaccel_x86_fork_call(SPTR outlined_func, int kmpc_api) { + int nargs, nme, ili, i; + SPTR sptr; + OMPACCEL_TINFO *omptinfo; + omptinfo = ompaccel_tinfo_get(outlined_func); + nargs = omptinfo->n_symbols; + int args[nargs + 2], garg_ilis[nargs + 2]; + DTYPE arg_dtypes[nargs + 2]; + SPTR sptr_args[nargs + 2]; + + DTYPEP(outlined_func, DT_NONE); + STYPEP(outlined_func, ST_PROC); + CFUNCP(outlined_func, 1); + + for (i = 0; i < nargs; ++i) { + sptr_args[i] = omptinfo->symbols[i].host_sym; + } + + ompaccel_x86_fix_arg_types(outlined_func); + ompaccel_x86_add_tid_params(outlined_func); + + // The fork_call should be aware of the callback's type here + ll_process_routine_parameters(outlined_func); + return ll_make_kmpc_fork_call_variadic2(outlined_func, nargs, sptr_args); +} + +#endif diff --git a/tools/flang2/flang2exe/outliner.cpp b/tools/flang2/flang2exe/outliner.cpp index d5ea371802..a5771896ac 100644 --- a/tools/flang2/flang2exe/outliner.cpp +++ b/tools/flang2/flang2exe/outliner.cpp @@ -3,6 +3,22 @@ * See https://llvm.org/LICENSE.txt for license information. * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * + * + * + */ + +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading + * Last Modified: January 2020 + * + * Support for x86-64 OpenMP offloading + * Last modified: Apr 2020 + * + * Added support for quad precision + * Last modified: Feb 2020 */ /** @@ -32,6 +48,8 @@ #include #include "regutil.h" #include "symfun.h" +#include // AOCC +#include // AOCC #if !defined(TARGET_WIN) #include #endif @@ -313,10 +331,10 @@ get_opc_name(ILM_OP opc) break; } } - static char * ll_get_outlined_funcname(int fileno, int lineno, bool isompaccel, ILM_OP opc) { char *name; + const char* name_opc = get_opc_name(opc); static unsigned nmLen = 0; const unsigned maxDigitLen = 10; /* Len of 2147483647 */ unsigned nmSize; @@ -326,21 +344,22 @@ ll_get_outlined_funcname(int fileno, int lineno, bool isompaccel, ILM_OP opc) { int plen; char *host_prefix = "__nv_"; char *device_prefix = "nvkernel_"; + int funcNo = funcCnt; if(isompaccel) { prefix = device_prefix; } else { funcCnt++; prefix = host_prefix; } + plen = strlen(prefix); if(gbl.outlined) { - { - plen = strlen(host_prefix); - name_currfunc = strtok(&name_currfunc[plen], "_"); - } + assert(!strncmp(name_currfunc, prefix, plen), + "Outlined function doesn't start with correct prefix", r, ERR_Fatal); + name_currfunc = strtok(&name_currfunc[plen], "_"); } nmSize = (3 * maxDigitLen) + 5 + strlen(name_currfunc) + 1; name = (char *)malloc(nmSize + strlen(prefix)); - r = snprintf(name, nmSize, "%s%s_F%dL%d_%d", prefix, name_currfunc, fileno, lineno, funcCnt); + r = snprintf(name, nmSize, "%s%s_%s_F%dL%d_%d", prefix, name_currfunc, name_opc, fileno, lineno, funcCnt); assert(r < nmSize, "buffer overrun", r, ERR_Fatal); return name; } @@ -416,6 +435,12 @@ ll_ad_outlined_func2(ILI_OP result_opc, ILI_OP call_opc, int sptr, int nargs, argl = ad3ili(IL_ARGDP, arg, argl, 0); rg += 2; break; + // AOCC begin + case ILIA_QP: + argl = ad3ili(IL_ARGQP, arg, argl, 0); + rg += 2; + break; + // AOCC end case ILIA_KR: argl = ad3ili(IL_ARGKR, arg, argl, 0); rg += 2; @@ -1028,6 +1053,23 @@ llCollectSymbolInfo(ILM *ilmpx) } } +// AOCC Begin +/// \brief Returns true if \p opc doesn't have any sym operand. +bool +is_no_symbol_ilm(ILM_T opc) { + switch(opc) { + case IM_DMUL: + case IM_DSUB: + case IM_QMUL: + case IM_QSUB: + return true; + default: + return false; + } + return false; +} +// AOCC End + int ll_rewrite_ilms(int lineno, int ilmx, int len) { @@ -1080,6 +1122,7 @@ ll_rewrite_ilms(int lineno, int ilmx, int len) len = llGetILMLen(ilmx); } ilmpx = (ILM *)(ilmb.ilm_base + ilmx); + if (!gbl.outlined) llCollectSymbolInfo(ilmpx); { @@ -1099,6 +1142,11 @@ ll_rewrite_ilms(int lineno, int ilmx, int len) ompaccel_symreplacer(true); } else if (opc == IM_BCS) { ompaccel_symreplacer(false); + // AOCC Begin + } else if (opc == IM_ECS || opc == IM_MP_NUMTEAMS || + opc == IM_MP_NUMTHREADS) { + ompaccel_symreplacer(true); + // AOCC End } else if (ILM_OPC(ilmpx) == IM_ELEMENT && gbl.ompaccel_intarget ) { /* replace dtype for allocatable arrays */ ILM_OPND(ilmpx, 3) = @@ -1109,10 +1157,16 @@ ll_rewrite_ilms(int lineno, int ilmx, int len) op1Pld = ILM_OPND(ilmpx, 1); ILM_OPND(ilmpx, 2) = ompaccel_tinfo_current_get_devsptr(ILM_SymOPND(ilmpx, 2)); - } else if(gbl.ompaccel_intarget) { - /* replace host sptr with device sptrs */ - ILM_OPND(ilmpx, 1) = - ompaccel_tinfo_current_get_devsptr(ILM_SymOPND(ilmpx, 1)); + // AOCC begin + } else if (gbl.ompaccel_intarget) { + // We only replace the symbol operands of ILMs and ignore others. + for (int i = 1; i <= ilms[opc].oprs; i++) { + if (IM_OPRFLAG(opc, i) == OPR_SYM) { + ILM_OPND(ilmpx, i) = + ompaccel_tinfo_current_get_devsptr(ILM_SymOPND(ilmpx, i)); + } + } + // AOCC end } } } @@ -2323,9 +2377,32 @@ outlined_need_recompile() { return false; } +// AOCC begin +// Populates \p arg_vectors with SPTRs from each uplevel-sptr starting from +// \p uplevel. Set \p is_orig to fetch the originally assigned SPTR in the +// uplevel data-structure. (see comments in LLUplevel's definition) +void get_arg_vector_from_uplevel_chain(std::vector &arg_vector, + const LLUplevel *uplevel, bool is_orig) { + while (uplevel) { + for (int i = 0; i < uplevel->vals_count; i++) { + if (is_orig) + arg_vector.push_back((SPTR)uplevel->orig_vals[i]); + else + arg_vector.push_back((SPTR)uplevel->vals[i]); + } + + if (!uplevel->parent) + break; + + uplevel = llmp_has_uplevel(uplevel->parent); + } +} +// AOCC end + #ifdef OMP_OFFLOAD_LLVM static SPTR -llMakeFtnOutlinedSignatureTarget(SPTR func_sptr, OMPACCEL_TINFO *current_tinfo) +llMakeFtnOutlinedSignatureTarget(SPTR func_sptr, OMPACCEL_TINFO *current_tinfo, + std::map orig_sptr_map) // AOCC { SPTR sym, sptr_alloc = ((SPTR)0), ignoredsym; char name[MXIDLEN + 2]; @@ -2339,7 +2416,51 @@ llMakeFtnOutlinedSignatureTarget(SPTR func_sptr, OMPACCEL_TINFO *current_tinfo) for (i = 0; i < current_tinfo->n_symbols; ++i) { SPTR sptr = current_tinfo->symbols[i].host_sym; + + // AOCC begin + if (XBIT(232, 0x1)) { + if (orig_sptr_map.find(sptr) != orig_sptr_map.end()) { + sptr = orig_sptr_map[sptr]; + } + } + // AOCC end + sym = ompaccel_create_device_symbol(sptr, count); + + // AOCC Begin + if (flg.x86_64_omptarget || flg.amdgcn_target) { + /* Workaround for 6750 compilation error + * A conflict of dtype is there when mapping character pointer defined in a struct + * type of the target of pointer should be TY_KIND + */ + for (int j = 0; j < current_tinfo->n_quiet_symbols; ++j) { + if (MIDNUMG(current_tinfo->quiet_symbols[j].host_sym) == sptr) + if (POINTERG(current_tinfo->quiet_symbols[j].host_sym)) { + // type of target, must be an array + DTYPE dtype = DTYPEG(current_tinfo->quiet_symbols[j].host_sym); + if (DTY(dtype) == TY_ARRAY) { + // type for pointer + DTYPE dtype1 = DTYPE(dtype + 1); + // type of element in the array, must be character + dtype = DTySeqTyElement(dtype); + if (DTY(dtype) == TY_CHAR || DTY(dtype) == TY_NCHAR) { + // type of target of the pointer, must be TY_KIND + dtype1 = DTySeqTyElement(dtype1); + // TODO: add more TY_KIND checks if needed + if (DTY(dtype1) != TY_WORD + && DTY(dtype1) != TY_DWORD + && DTY(dtype1) != TY_PTR + && DTY(dtype1) != TY_ANY) { + // setting to TY_WORD is fine. + DTySet(dtype1,TY_WORD); + } + } + } + } + } + } + // AOCC End + count++; current_tinfo->symbols[i].device_sym = sym; OMPACCDEVSYMP(sym, TRUE); @@ -2348,6 +2469,35 @@ llMakeFtnOutlinedSignatureTarget(SPTR func_sptr, OMPACCEL_TINFO *current_tinfo) return ignoredsym; } +// AOCC begin +// The llMakeFtnOutlinedSignatureTarget() version for +// ll_make_outlined_ompaccel_func2() +// TODO: Inline this in ll_make_outlined_ompaccel_func2() +static SPTR +llMakeFtnOutlinedSignatureTarget2(SPTR func_sptr, OMPACCEL_TINFO *current_tinfo, + std::vector &arg_vector) +{ + int dpdscp = aux.dpdsc_avl; + + PARAMCTP(func_sptr, arg_vector.size()); + DPDSCP(func_sptr, dpdscp); + aux.dpdsc_avl += arg_vector.size(); + NEED(aux.dpdsc_avl, aux.dpdsc_base, int, aux.dpdsc_size, + aux.dpdsc_size + arg_vector.size() + 100); + + int argi = 0; + for (SPTR arg : arg_vector) { + SPTR dev_sptr = ompaccel_create_device_symbol(arg, argi); + current_tinfo->symbols[argi].device_sym = dev_sptr; + argi++; + OMPACCDEVSYMP(dev_sptr, TRUE); + aux.dpdsc_base[dpdscp++] = dev_sptr; + } + + return (SPTR)0; +} +// AOCC end + int ll_make_outlined_ompaccel_call(SPTR parent_func_sptr, SPTR outlined_func) { @@ -2467,10 +2617,14 @@ ompaccel_copy_arraydescriptors(SPTR arg_sptr) // check whether it is allocatable or not ADSC *new_ad; - ADSC *org_ad = AD_DPTR(DTYPEG(arg_sptr)); + // AOCC + // moved org_ad declaration from here to beow get_array_dtype + // get_array_dtype function will do reallocation of aux.arrdsc_base. + // if it gets reallocaed org_ad will point to invalid address. TY_KIND atype = DTY(DTYPE(DTYPEG(arg_sptr) + 1)); - int numdim = AD_NUMDIM(org_ad); + int numdim = AD_NUMDIM((ADSC*)AD_DPTR(DTYPEG(arg_sptr))); dtype = get_array_dtype(numdim, (DTYPE)atype); + ADSC *org_ad = AD_DPTR(DTYPEG(arg_sptr)); new_ad = AD_DPTR(dtype); AD_NUMDIM(new_ad) = numdim; @@ -2482,7 +2636,7 @@ ompaccel_copy_arraydescriptors(SPTR arg_sptr) // check global in the module? AD_SDSC(new_ad) = ompaccel_tinfo_current_get_devsptr((SPTR)AD_SDSC(org_ad)); - if (numdim >= 1 && numdim <= 7) { + if (is_legal_numdim(numdim)) { // AOCC int i; for (i = 0; i < numdim; ++i) { AD_LWBD(new_ad, i) = @@ -2535,8 +2689,18 @@ ll_make_outlined_ompaccel_func(SPTR stblk_sptr, SPTR scope_sptr, bool iskernel) SPTR func_sptr, arg_sptr; int n_args = 0, max_nargs, i, j; OMPACCEL_TINFO *current_tinfo; + std::map orig_sptr_map; // AOCC uplevel = llmp_has_uplevel(stblk_sptr); + + // AOCC begin + if (XBIT(232, 0x1)) { + if (uplevel && !uplevel->vals_count && uplevel->parent) { + uplevel = llmp_has_uplevel(uplevel->parent); + } + } + // AOCC end + max_nargs = uplevel != NULL ? uplevel->vals_count : 0; /* Create function symbol for target region */ func_sptr = create_target_outlined_func_sptr(scope_sptr, iskernel); @@ -2547,11 +2711,19 @@ ll_make_outlined_ompaccel_func(SPTR stblk_sptr, SPTR scope_sptr, bool iskernel) arg_sptr = (SPTR)uplevel->vals[i]; if (!arg_sptr && !ompaccel_tinfo_current_is_registered(arg_sptr)) continue; - if (SCG(arg_sptr) == SC_PRIVATE) - continue; + if (SCG(arg_sptr) == SC_PRIVATE) { + // Not skipping private variable + // continue; // AOCC + } if (DESCARRAYG(arg_sptr)) continue; + // AOCC begin + if (arg_sptr != (SPTR)uplevel->orig_vals[i]) { + orig_sptr_map[arg_sptr] = (SPTR)uplevel->orig_vals[i]; + } + // AOCC end + if (!iskernel && !OMPACCDEVSYMG(arg_sptr)) arg_sptr = ompaccel_tinfo_parent_get_devsptr(arg_sptr); ompaccel_tinfo_current_add_sym(arg_sptr, SPTR_NULL, 0); @@ -2559,7 +2731,7 @@ ll_make_outlined_ompaccel_func(SPTR stblk_sptr, SPTR scope_sptr, bool iskernel) n_args++; } - llMakeFtnOutlinedSignatureTarget(func_sptr, current_tinfo); + llMakeFtnOutlinedSignatureTarget(func_sptr, current_tinfo, orig_sptr_map); // AOCC ompaccel_symreplacer(true); if (isReplacerEnabled) { @@ -2580,4 +2752,59 @@ ll_make_outlined_ompaccel_func(SPTR stblk_sptr, SPTR scope_sptr, bool iskernel) return func_sptr; } + +// AOCC begin +SPTR +ll_make_outlined_ompaccel_func2(SPTR stblk_sptr, SPTR scope_sptr, bool iskernel) +{ + const LLUplevel *uplevel; + SPTR func_sptr; + OMPACCEL_TINFO *current_tinfo; + uplevel = llmp_has_uplevel(stblk_sptr); + + std::vector arg_vector, orig_arg_vector; + get_arg_vector_from_uplevel_chain(arg_vector, uplevel, /* is_orig */ false); + get_arg_vector_from_uplevel_chain(orig_arg_vector, uplevel, /* is_orig */ true); + + /* Create function symbol for target region */ + func_sptr = create_target_outlined_func_sptr(scope_sptr, iskernel); + + current_tinfo = ompaccel_tinfo_create(func_sptr, arg_vector.size()); + + for (SPTR arg_sptr : arg_vector) { + if (!arg_sptr && !ompaccel_tinfo_current_is_registered(arg_sptr)) + continue; + if (SCG(arg_sptr) == SC_PRIVATE) + continue; + if (DESCARRAYG(arg_sptr)) + continue; + + if (!iskernel && !OMPACCDEVSYMG(arg_sptr)) + arg_sptr = ompaccel_tinfo_parent_get_devsptr(arg_sptr); + ompaccel_tinfo_current_add_sym(arg_sptr, SPTR_NULL, 0); + } + + llMakeFtnOutlinedSignatureTarget2(func_sptr, current_tinfo, orig_arg_vector); + + ompaccel_symreplacer(true); + if (isReplacerEnabled) { + /* Data dtype replication for allocatable arrays */ + for (int i = 0; i < ompaccel_tinfo_current_get()->n_quiet_symbols; ++i) { + ompaccel_tinfo_current_get()->quiet_symbols[i].device_sym = + ompaccel_copy_arraydescriptors( + ompaccel_tinfo_current_get()->quiet_symbols[i].host_sym); + } + + for (int i = 0; i < ompaccel_tinfo_current_get()->n_symbols; ++i) { + if (SDSCG(ompaccel_tinfo_current_get()->symbols[i].host_sym)) + ompaccel_tinfo_current_get()->symbols[i].device_sym = + ompaccel_copy_arraydescriptors( + ompaccel_tinfo_current_get()->symbols[i].host_sym); + } + } + ompaccel_symreplacer(false); + + return func_sptr; +} +// AOCC end #endif /* End #ifdef OMP_OFFLOAD_LLVM */ diff --git a/tools/flang2/flang2exe/outliner.h b/tools/flang2/flang2exe/outliner.h index ed9573eaa5..642e739e26 100644 --- a/tools/flang2/flang2exe/outliner.h +++ b/tools/flang2/flang2exe/outliner.h @@ -5,6 +5,15 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * + * Support for x86-64 OpenMP offloading + * Last modified: Apr 2020 + */ + #ifndef OUTLINER_H_ #define OUTLINER_H_ @@ -340,6 +349,18 @@ ISZ_T getTaskSharedSize(SPTR scope_sptr); */ SPTR ll_make_outlined_ompaccel_func(SPTR, SPTR, bool); +/* AOCC begin */ +/** + \brief Create an outlining function that works for -Mx,232,0x1 implementing + functions. This functions fetches every symbol from the uplevel chain and + adds it to the outlined function. This is not important for regular -fopenmp + implementation, but imperative for -fopenmp-target since the symbols for the + outer uplevel (say the target uplevel that holds a parallel region) must be + accessible in the inner ones. + */ +SPTR ll_make_outlined_ompaccel_func2(SPTR, SPTR, bool); +/* AOCC end */ + /** \brief Create an function call to the outlininin function. */ diff --git a/tools/flang2/flang2exe/ppc64le-Linux/ll_abi.cpp b/tools/flang2/flang2exe/ppc64le-Linux/ll_abi.cpp index 1af6d3b3a8..f2efe34f18 100644 --- a/tools/flang2/flang2exe/ppc64le-Linux/ll_abi.cpp +++ b/tools/flang2/flang2exe/ppc64le-Linux/ll_abi.cpp @@ -63,6 +63,11 @@ update_homogeneous(void *context, DTYPE dtype, unsigned address, case DT_DCMPLX: dtype = DT_DBLE; break; + // AOCC begin + case DT_QCMPLX: + dtype = DT_QUAD; + break; + // AOCC end default: break; } @@ -75,6 +80,7 @@ update_homogeneous(void *context, DTYPE dtype, unsigned address, switch (llt->data_type) { case LL_FLOAT: case LL_DOUBLE: + case LL_FP128: /* OK. */ break; case LL_VECTOR: diff --git a/tools/flang2/flang2exe/ppc64le-Linux/machreg.h b/tools/flang2/flang2exe/ppc64le-Linux/machreg.h index 0c4b51f009..fe9841d749 100644 --- a/tools/flang2/flang2exe/ppc64le-Linux/machreg.h +++ b/tools/flang2/flang2exe/ppc64le-Linux/machreg.h @@ -199,6 +199,8 @@ extern int mr_res_xr[MR_MAX_XREG_RES + 1]; #define DP(i) ARG_XR(i) #define ISP(i) (i + 100) /* not used? */ #define IDP(i) (i + 100) +#define IQP(i) (i + 100) +#define IQP(i) (i + 100) /* Macro for defining alternate-return register for fortran subprograms. */ diff --git a/tools/flang2/flang2exe/regutil.cpp b/tools/flang2/flang2exe/regutil.cpp index 7b86b5e1e0..27032365d4 100644 --- a/tools/flang2/flang2exe/regutil.cpp +++ b/tools/flang2/flang2exe/regutil.cpp @@ -4,6 +4,15 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * Last Modified: Jun 2020 + * + */ /** \file * \brief Register allocation module used by the expander and the optimizer @@ -59,7 +68,7 @@ int il_rtype_df[RATA_RTYPES_TOTAL] = { IL_IRDF, IL_SPDF, /* RATA_IR , RATA_SP */ IL_DPDF, IL_ARDF, /* RATA_DP , RATA_AR */ IL_KRDF, 0, /* RATA_KR , RATA_VECT */ - 0, 0, /* RATA_QP , RATA_CSP */ + IL_QPDF, 0, /* RATA_QP , RATA_CSP */ 0, 0, /* RATA_CDP , RATA_CQP */ 0, 0, /* RATA_X87 , RATA_CX87*/ }; @@ -67,7 +76,7 @@ int il_mv_rtype[RATA_RTYPES_TOTAL] = { IL_MVIR, IL_MVSP, /* RATA_IR , RATA_SP */ IL_MVDP, IL_MVAR, /* RATA_DP , RATA_AR */ IL_MVKR, 0, /* RATA_KR , RATA_VECT */ - 0, 0, /* RATA_QP , RATA_CSP */ + IL_MVQP, 0, /* RATA_QP , RATA_CSP */ 0, 0, /* RATA_CDP , RATA_CQP */ 0, 0, /* RATA_X87 , RATA_CX87*/ }; @@ -150,6 +159,17 @@ addrcand(int ilix) case IL_LDDP: /* load double precision */ rtype = RATA_DP; msize = MSZ_F8; + goto ac_load; + + // AOCC begin + case IL_LDQCMPLX: + rtype = RATA_CQP; + msize = MSZ_F32; + goto ac_load; + case IL_LDQP: /* load quad precision */ + rtype = RATA_QP; + msize = MSZ_F16; + // AOCC end ac_load: /* common entry for the loads */ @@ -261,6 +281,16 @@ addrcand(int ilix) case IL_DSTS_SCALAR: rtype = RATA_DP; msize = MSZ_F8; + goto ac_store; + // AOCC begin + case IL_STQCMPLX: + rtype = RATA_CQP; + msize = MSZ_F32; + goto ac_store; + case IL_STQP: /* store quad precision */ + rtype = RATA_QP; + msize = MSZ_F16; + // AOCC end ac_store: /* common entry for the stores */ if ((rcand = NME_RAT(nme = ILI_OPND(ilix, 3))) != 0) if (RCAND_MSIZE(rcand) != msize) { @@ -312,6 +342,16 @@ addrcand(int ilix) case IL_DCON: rtype = RATA_DP; msize = MSZ_F8; + goto add_constant; + // AOCC begin + case IL_QCMPLXCON: + rtype = RATA_CQP; + msize = MSZ_F32; + goto add_constant; + case IL_QCON: + rtype = RATA_QP; + msize = MSZ_F16; + // AOCC end add_constant: rcand = ILI_RAT(ilix); if (rcand) { @@ -803,12 +843,22 @@ storedums(int exitbih, int first_rat) case RATA_DP: (void)addilt(0, ad4ili(IL_STDP, i, addr, nme, MSZ_F8)); break; + // AOCC begin + case RATA_QP: + (void)addilt(0, ad4ili(IL_STQP, i, addr, nme, MSZ_F16)); + break; + // AOCC end case RATA_CSP: (void)addilt(0, ad4ili(IL_STSCMPLX, i, addr, nme, MSZ_F8)); break; case RATA_CDP: (void)addilt(0, ad4ili(IL_STDCMPLX, i, addr, nme, MSZ_F16)); break; + // AOCC begin + case RATA_CQP: + (void)addilt(0, ad4ili(IL_STQCMPLX, i, addr, nme, MSZ_F16)); + break; + // AOCC end } } BIH_SMOVE(exitbih) = 1; /* (temp) mark block so sched limits scratch set */ @@ -857,7 +907,7 @@ static struct { /* Register temporary information */ {'g', "ga", DT_INT8, 0, 0, -1}, /* 4: integer*8 temps */ {'h', "ha", DT_CMPLX, 0, 0, -1}, /* 5: complex temps */ {'k', "ka", DT_DCMPLX, 0, 0, -1}, /* 6: double complex temps */ - {'h', "ha", DT_NONE, 0, 0, -1}, /* 7: filler */ + {'h', "ha", DT_QCMPLX, 0, 0, -1}, /* 7: quad complex temps */ {'v', "va", DT_NONE, 0, 0, -1}, /* 8: vector temps */ #if defined LONG_DOUBLE_FLOAT128 {'X', "Xa", DT_FLOAT128, 0, 0, -1}, /* 9: float128 temps */ @@ -866,6 +916,7 @@ static struct { /* Register temporary information */ {'X', "Xa", DT_NONE, 0, 0, -1}, /* 9 and 10: filler */ {'x', "xa", DT_NONE, 0, 0, -1}, /* 9 and 10: filler */ #endif + {'q', "qa", DT_QCMPLX, 0, 0, -1} /* 11: quad complex temps */ //AOCC }; static int select_rtemp(int); @@ -962,6 +1013,11 @@ mkrtemp_cpx_sc(DTYPE dtype, SC_KIND sc) case DT_DCMPLX: type = 6; break; + // AOCC begin + case DT_QCMPLX: + type = 7; + break; + // AOOC end #ifdef LONG_DOUBLE_FLOAT128 case DT_CMPLX128: type = 10; @@ -1003,6 +1059,10 @@ mkrtemp_arg1_sc(DTYPE dtype, SC_KIND sc) type = 5; else if (dtype == DT_DCMPLX) type = 6; + // AOCC begin + else if (dtype == DT_QCMPLX) + type = 7; + // AOCC end #ifdef LONG_DOUBLE_FLOAT128 else if (dtype == DT_CMPLX128) type = 6; @@ -1122,6 +1182,11 @@ _assn_rtemp(int ili, int temp) case IL_STDP: opc = IL_LDDP; break; + // AOCC begin + case IL_STQP: + opc = IL_LDQP; + break; + // AOCC end case IL_VST: opc = IL_VLD; break; @@ -1134,6 +1199,11 @@ _assn_rtemp(int ili, int temp) case IL_STDCMPLX: opc = IL_LDDCMPLX; break; + // AOCC begin + case IL_STQCMPLX: + opc = IL_LDQCMPLX; + break; + // AOCC end } switch (IL_RES(opc)) { @@ -1153,6 +1223,12 @@ _assn_rtemp(int ili, int temp) rtype = RCAND_RTYPE(rcand) = RATA_DP; RCAND_MSIZE(rcand) = MSZ_F8; break; + // AOCC begin + case ILIA_QP: + rtype = RCAND_RTYPE(rcand) = RATA_QP; + RCAND_MSIZE(rcand) = MSZ_F16; + break; + // AOCC end case ILIA_KR: rtype = RCAND_RTYPE(rcand) = RATA_KR; RCAND_MSIZE(rcand) = MSZ_I8; @@ -1169,6 +1245,14 @@ _assn_rtemp(int ili, int temp) RCAND_MSIZE(rcand) = MSZ_F16; break; #endif + // AOCC begin +#ifdef ILIA_CQ + case ILIA_CQ: + rtype = RCAND_RTYPE(rcand) = RATA_CQP; + RCAND_MSIZE(rcand) = MSZ_F16; + break; +#endif + // AOCC end case ILIA_LNK: if (IL_VECT(ILI_OPC(ili))) { RCAND_MSIZE(rcand) = ili_get_vect_dtype(ili); @@ -1288,6 +1372,16 @@ select_rtemp(int ili) type = 6; break; #endif + // AOCC begin + case ILIA_QP: + type = 7; + break; +#ifdef ILIA_CQ + case ILIA_CQ: + type = 11; + break; +#endif + // AOCC end #ifdef LONG_DOUBLE_FLOAT128 case ILIA_FLOAT128: type = 9; diff --git a/tools/flang2/flang2exe/regutil.h b/tools/flang2/flang2exe/regutil.h index 6908e1add4..bcbd8a4b13 100644 --- a/tools/flang2/flang2exe/regutil.h +++ b/tools/flang2/flang2exe/regutil.h @@ -4,6 +4,14 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Support for QCOMPLEX + * Date of Modification 18th Sept 2020 + * + */ #ifndef REGUTIL_H_ #define REGUTIL_H_ @@ -20,7 +28,7 @@ #include -#define RTEMPS 11 +#define RTEMPS 12 //AOCC #define LST_AREA 6 #define AR_AREA 7 diff --git a/tools/flang2/flang2exe/scope.cpp b/tools/flang2/flang2exe/scope.cpp index ffc54ffa18..01e1bfca39 100644 --- a/tools/flang2/flang2exe/scope.cpp +++ b/tools/flang2/flang2exe/scope.cpp @@ -4,6 +4,16 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * + * While removing the scope labels, blocks were traversed with a wrong loop + * terminating condition. This has been fixed. + * Date of Modification: 27th Aug 2019 + * + */ /** \file @@ -859,7 +869,11 @@ void remove_scope_labels(void) { int bihx, iltx, nextiltx; - for (bihx = gbl.entbih; 1; bihx = BIH_NEXT(bihx)) { + // AOCC Begin + // Replaced below loop condition from 1 to bihx. + // Block number will never be zero. Exit the loop if the block number is zero. + // AOCC End + for (bihx = gbl.entbih; bihx; bihx = BIH_NEXT(bihx)) { rdilts(bihx); for (iltx = BIH_ILTFIRST(bihx); iltx; iltx = nextiltx) { nextiltx = ILT_NEXT(iltx); diff --git a/tools/flang2/flang2exe/semant.h b/tools/flang2/flang2exe/semant.h index a50c42475e..748e8acceb 100644 --- a/tools/flang2/flang2exe/semant.h +++ b/tools/flang2/flang2exe/semant.h @@ -5,6 +5,28 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Support for transpose intrinsic during initialization + * Date of Modification: 1st March 2019 + * + * Support for nearest intrinsic + * Last modified: 01 March 2020 + * + * Added code to support SHIFTA intrinsic + * Last modified: April 2020 + * + * Added code to support cotan intrinsic + * Last modified: Oct 2020 + * + * Added support for openmp schedule clause + * Last modified: March 2021 + * + + */ + #ifndef SEMANT_H_ #define SEMANT_H_ @@ -56,6 +78,7 @@ #define OP_LT 24 #define OP_NE 25 #define OP_LNOT 26 +#define OP_XOR 27 // AOCC /* Different types of atomic actions. */ #define ATOMIC_UNDEF -1 @@ -173,6 +196,7 @@ typedef struct { /* DO-IF stack entries */ int sect_var; /* where to store section number */ } v1; struct { /* parallel do statements */ + int modifier; /* AOCC */ int sched_type; /* one of DI_SCHxxx if a parallel do */ int chunk; /* When the parallel do is parsed, this * field is the sptr representing the chunk size @@ -214,6 +238,17 @@ typedef struct { /* DO-IF stack entries */ #define DI_SCH_RUNTIME 4 #define DI_SCH_AUTO 5 #define DI_SCH_DIST_STATIC 6 +#define DI_MOD_NONMONOTONIC 8 +#define DI_MOD_MONOTONIC 9 +#define DI_DEP_MOD_SOURCE 10 +#define DI_DEP_TYPE_SINK 10 +#define DI_DEP_TYPE_IN 11 +#define DI_DEP_TYPE_OUT 12 +#define DI_DEP_TYPE_INOUT 13 +#define DI_DEP_TYPE_MUTEXINOUTSET 14 +#define DI_DEP_TYPE_DEPOBJ 15 +#define DI_MOD_SIMD 16 + #define DI_ID(d) sem.doif_base[d].Id #define DI_LINENO(d) sem.doif_base[d].lineno @@ -232,6 +267,7 @@ typedef struct { /* DO-IF stack entries */ #define DI_NOSCOPE_AVL(d) sem.doif_base[d].omp.no_scope_avail #define DI_CRITSYM(d) sem.doif_base[d].omp.v.v1.sect_lab #define DI_SCHED_TYPE(d) sem.doif_base[d].omp.v.v2.sched_type +#define DI_SCHED_MODIFIER(d) sem.doif_base[d].omp.v.v2.modifier //AOCC #define DI_CHUNK(d) sem.doif_base[d].omp.v.v2.chunk #define DI_IS_ORDERED(d) sem.doif_base[d].omp.v.v2.is_ordered #define DI_REDUC(d) sem.doif_base[d].omp.reduc @@ -366,6 +402,7 @@ struct CONST { #define AC_LNOT 23 #define AC_EXPX 24 #define AC_TRIPLE 25 +#define AC_LXOR 26 // AOCC #define AC_I_adjustl 1 #define AC_I_adjustr 2 @@ -422,6 +459,19 @@ struct CONST { #define AC_I_minloc 53 #define AC_I_minval 54 #define AC_I_scale 55 +/* AOCC begin */ +#define AC_I_transpose 56 +#define AC_I_merge_bits 57 +#define AC_I_shiftl 58 +#define AC_I_shiftr 59 +#define AC_I_dshiftl 60 +#define AC_I_dshiftr 61 +#define AC_I_nearest 62 +#define AC_I_shifta 63 +#define AC_I_anint 64 +#define AC_I_aint 65 +#define AC_I_cotan 66 +/* AOCC end */ #define AC_UNARY_OP(e) (e.op == AC_NEG || e.op == AC_CONV) typedef struct { /* STRUCTURE stack entries */ @@ -599,7 +649,7 @@ typedef struct { int uptype; ISZ_T lowb; ISZ_T upb; - } bounds[7]; + } bounds[MAXSUBS]; /* AOCC */ struct { /* mark assumed size and adjustable arrays */ int ndim; /* number of dimensions */ int assumsz; /* 0, not assumed size diff --git a/tools/flang2/flang2exe/semutil0.cpp b/tools/flang2/flang2exe/semutil0.cpp index d0e3cda2fb..9e1b295142 100644 --- a/tools/flang2/flang2exe/semutil0.cpp +++ b/tools/flang2/flang2exe/semutil0.cpp @@ -4,6 +4,15 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * Last Modified: Jun 2020 + * + */ /** * \file @@ -116,6 +125,7 @@ getrval(int ilmptr) case IM_HFFUNC: case IM_RFUNC: case IM_DFUNC: + case IM_QFUNC: // AOCC case IM_CFUNC: case IM_CDFUNC: case IM_CALL: @@ -123,8 +133,10 @@ getrval(int ilmptr) case IM_KVFUNCA: case IM_RVFUNCA: case IM_DVFUNCA: + case IM_QVFUNCA: // AOCC case IM_CVFUNCA: case IM_CDVFUNCA: + case IM_CQVFUNCA: // AOCC case IM_VCALLA: return opr2; @@ -132,15 +144,19 @@ getrval(int ilmptr) case IM_KFUNCA: case IM_RFUNCA: case IM_DFUNCA: + case IM_QFUNCA: // AOCC case IM_CFUNCA: case IM_CDFUNCA: + case IM_CQFUNCA: // AOCC case IM_CALLA: case IM_PIFUNCA: case IM_PKFUNCA: case IM_PRFUNCA: case IM_PDFUNCA: + case IM_PQFUNCA: // AOCC case IM_PCFUNCA: case IM_PCDFUNCA: + case IM_PCQFUNCA: // AOCC case IM_PCALLA: return getrval(opr2); @@ -492,9 +508,17 @@ cngcon(INT oldval, DTYPE oldtyp, DTYPE newtyp) num[1] = CONVAL2G(oldval); xdfix(num, &result); return result; + // AOCC begin + case TY_QCMPLX: + oldval = CONVAL1G(oldval); case TY_QUAD: - uf("QUAD"); - return 0; + num[0] = CONVAL1G(oldval); + num[1] = CONVAL2G(oldval); + num[2] = CONVAL3G(oldval); + num[3] = CONVAL4G(oldval); + xqfix(num, &result); + return result; + // AOCC end case TY_CHAR: if (flg.standard) ERR170("conversion of CHARACTER constant to numeric"); @@ -548,9 +572,17 @@ cngcon(INT oldval, DTYPE oldtyp, DTYPE newtyp) num1[1] = CONVAL2G(oldval); xdfix64(num1, num); return getcon(num, newtyp); + // AOCC begin + case TY_QCMPLX: + oldval = CONVAL1G(oldval); case TY_QUAD: - uf("QUAD"); - return 0; + num1[0] = CONVAL1G(oldval); + num1[1] = CONVAL2G(oldval); + num1[2] = CONVAL3G(oldval); + num1[3] = CONVAL4G(oldval); + xqfix64(num1, num); + return getcon(num, newtyp); + // AOCC end case TY_CHAR: if (flg.standard) ERR170("conversion of CHARACTER constant to numeric"); @@ -599,9 +631,17 @@ cngcon(INT oldval, DTYPE oldtyp, DTYPE newtyp) num[1] = CONVAL2G(oldval); xsngl(num, &result); return result; + // AOCC begin + case TY_QCMPLX: + oldval = CONVAL1G(oldval); case TY_QUAD: - uf("QUAD"); - return oldval; + num[0] = CONVAL1G(oldval); + num[1] = CONVAL2G(oldval); + num[2] = CONVAL3G(oldval); + num[3] = CONVAL4G(oldval); + xsngl(num, &result); + return result; + // AOCC end case TY_CHAR: if (flg.standard) ERR170("conversion of CHARACTER constant to numeric"); @@ -628,7 +668,12 @@ cngcon(INT oldval, DTYPE oldtyp, DTYPE newtyp) xdflt64(num1, num); } else if (TY_ISINT(from)) xdfloat(oldval, num); - else if (from == TY_DCMPLX) + // AOCC begin + else if (from == TY_QCMPLX) { + oldval = CONVAL1G(oldval); + xdble(oldval, num); + // AOCC end + } else if (from == TY_DCMPLX) return CONVAL1G(oldval); else if (from == TY_CMPLX) { oldval = CONVAL1G(oldval); @@ -652,14 +697,77 @@ cngcon(INT oldval, DTYPE oldtyp, DTYPE newtyp) } return getcon(&num[2], DT_DBLE); } else if (from == TY_QUAD) { - uf("QUAD"); - return oldval; + // AOCC begin + num[0] = CONVAL1G(oldval); + num[1] = CONVAL2G(oldval); + num[2] = CONVAL3G(oldval); + num[3] = CONVAL4G(oldval); + xqtod(num, &result); + return getcon(&result, DT_DBLE); + // AOCC end } else { errsev((error_code_t)91); return (stb.dbl0); } return getcon(num, DT_DBLE); + // AOCC begin + case TY_QUAD: + if (from == TY_WORD) { + num[0] = 0; + num[1] = oldval; + } else if (from == TY_DWORD) { + num[0] = CONVAL1G(oldval); + num[1] = CONVAL2G(oldval); + } else if (from == TY_INT8 || from == TY_LOG8) { + num1[0] = CONVAL1G(oldval); + num1[1] = CONVAL2G(oldval); + xqflt64(num1, num); + } else if (TY_ISINT(from)) + xqfloat(oldval, num); + else if (from == TY_QCMPLX) + return CONVAL1G(oldval); + else if (from == TY_DCMPLX) { + oldval = CONVAL1G(oldval); + xdtoq(&oldval, num); + } else if (from == TY_CMPLX) { + oldval = CONVAL1G(oldval); + xdtoq(&oldval, num); + } else if (from == TY_REAL) { + xftoq(oldval, num); + } else if (from == TY_DBLE) { + num1[0] = CONVAL1G(oldval); + num1[1] = CONVAL2G(oldval); + xdtoq(num1, num); + } + else if (from == TY_HOLL || from == TY_CHAR) { + if (flg.standard && from == TY_CHAR) + ERR170("conversion of CHARACTER constant to numeric"); + cp = stb.n_base + CONVAL1G(oldval); + holtonum(cp, num, 8); + if (flg.endian == 0) { + /* for little endian, need to swap words in each double word + * quantity. Order of bytes in a word is okay, but not the + * order of words. + */ + swap = num[2]; + num[2] = num[3]; + num[3] = swap; + } + return getcon(&num[2], DT_QUAD); + } else if (from == TY_QUAD) { + num[0] = CONVAL1G(oldval); + num[1] = CONVAL2G(oldval); + num[2] = CONVAL3G(oldval); + num[3] = CONVAL4G(oldval); + return getcon(num, DT_QUAD); + } else { + errsev((error_code_t)91); + return (stb.quad0); + } + return getcon(num, DT_QUAD); + // AOCC end + case TY_CMPLX: /* num[0] = real part * num[1] = imaginary part @@ -685,6 +793,12 @@ cngcon(INT oldval, DTYPE oldtyp, DTYPE newtyp) num1[0] = CONVAL1G(oldval); num1[1] = CONVAL2G(oldval); xsngl(num1, &num[0]); + } else if (from == TY_QUAD) { + num1[0] = CONVAL1G(oldval); + num1[1] = CONVAL2G(oldval); + num1[2] = CONVAL3G(oldval); + num1[3] = CONVAL4G(oldval); + xqtof(num1, &num[0]); } else if (from == TY_DCMPLX) { num1[0] = CONVAL1G(CONVAL1G(oldval)); num1[1] = CONVAL2G(CONVAL1G(oldval)); @@ -692,7 +806,16 @@ cngcon(INT oldval, DTYPE oldtyp, DTYPE newtyp) num1[0] = CONVAL1G(CONVAL2G(oldval)); num1[1] = CONVAL2G(CONVAL2G(oldval)); xsngl(num1, &num[1]); + // AOCC begin + } else if (from == TY_QCMPLX) { + num1[0] = CONVAL1G(CONVAL1G(oldval)); + num1[1] = CONVAL2G(CONVAL1G(oldval)); + xqtof(num1, &num[0]); + num1[0] = CONVAL1G(CONVAL2G(oldval)); + num1[1] = CONVAL2G(CONVAL2G(oldval)); + xqtof(num1, &num[1]); } else if (from == TY_HOLL || from == TY_CHAR) { + // AOCC end if (flg.standard && from == TY_CHAR) ERR170("conversion of CHARACTER constant to numeric"); cp = stb.n_base + CONVAL1G(oldval); @@ -739,6 +862,18 @@ cngcon(INT oldval, DTYPE oldtyp, DTYPE newtyp) num[0] = getcon(num1, DT_DBLE); xdble(CONVAL2G(oldval), num1); num[1] = getcon(num1, DT_DBLE); + // AOCC begin + } else if (from == TY_QCMPLX) { + num1[0] = CONVAL1G(CONVAL1G(oldval)); + num1[1] = CONVAL2G(CONVAL1G(oldval)); + xqtod(num1, &result); + num[0] = getcon(&result,DT_DBLE); + + num1[0] = CONVAL1G(CONVAL2G(oldval)); + num1[1] = CONVAL2G(CONVAL2G(oldval)); + xqtod(num1, &result); + num[1] = getcon(&result,DT_DBLE); + // AOCC end } else if (from == TY_HOLL || from == TY_CHAR) { if (flg.standard && from == TY_CHAR) ERR170("conversion of CHARACTER constant to numeric"); @@ -759,14 +894,97 @@ cngcon(INT oldval, DTYPE oldtyp, DTYPE newtyp) num[0] = getcon(&num1[0], DT_DBLE); num[1] = getcon(&num1[2], DT_DBLE); } else if (from == TY_QUAD) { - uf("QUAD"); - return oldval; + // AOCC begin + num1[0] = CONVAL1G(oldval); + num1[1] = CONVAL2G(oldval); + num1[2] = CONVAL3G(oldval); + num1[3] = CONVAL4G(oldval); + xqtod(num1, &result); + num[0] = getcon(&result,DT_DBLE); + num[1] = stb.dbl0; + // AOCC end } else { num[0] = 0; num[1] = 0; errsev((error_code_t)91); } return getcon(num, DT_DCMPLX); + // AOCC begin + case TY_QCMPLX: + if (from == TY_WORD) { + num[0] = 0; + num[1] = oldval; + num[0] = getcon(num, DT_QUAD); + num[1] = stb.quad0; + } else if (from == TY_DWORD) { + num[0] = CONVAL1G(oldval); + num[1] = CONVAL2G(oldval); + num[0] = getcon(num, DT_QUAD); + num[1] = stb.quad0; /* when is stb.quad0 set? -nzm */ + } else if (from == TY_INT8 || from == TY_LOG8) { + num1[0] = CONVAL1G(oldval); + num1[1] = CONVAL2G(oldval); + xqflt64(num1, num); + num[0] = getcon(num, DT_QUAD); + num[1] = stb.quad0; + } else if (TY_ISINT(from)) { + xqfloat(oldval, num); + num[0] = getcon(num, DT_QUAD); + num[1] = stb.quad0; + } else if (from == TY_REAL) { + xftoq(oldval, num); + num[0] = getcon(num, DT_QUAD); + num[1] = stb.quad0; + } else if (from == TY_DBLE) { + num1[0] = CONVAL1G(oldval); + num1[1] = CONVAL2G(oldval); + xdtoq(num1, num); + num[0] = getcon(num, DT_QUAD); + num[1] = stb.quad0; + } else if (from == TY_QUAD) { + num[0] = oldval; + num[1] = stb.quad0; + } else if (from == TY_CMPLX) { + xftoq(CONVAL1G(oldval), num1); + num[0] = getcon(num1, DT_QUAD); + xftoq(CONVAL2G(oldval), num1); + num[1] = getcon(num1, DT_QUAD); + } else if (from == TY_DCMPLX) { + num1[0] = CONVAL1G(CONVAL1G(oldval)); + num1[1] = CONVAL2G(CONVAL1G(oldval)); + xdtoq(num1, &result); + num[0] = getcon(&result, DT_QUAD); + + num1[0] = CONVAL1G(CONVAL2G(oldval)); + num1[1] = CONVAL2G(CONVAL2G(oldval)); + xdtoq(num1, &result); + num[1] = getcon(&result, DT_QUAD); + } else if (from == TY_HOLL || from == TY_CHAR) { + if (flg.standard && from == TY_CHAR) + ERR170("conversion of CHARACTER constant to numeric"); + cp = stb.n_base + CONVAL1G(oldval); + holtonum(cp, num1, 16); + if (flg.endian == 0) { + /* for little endian, need to swap words in each double word + * quantity. Order of bytes in a word is okay, but not the + * order of words. + */ + swap = num1[0]; + num1[0] = num1[1]; + num1[1] = swap; + swap = num1[2]; + num1[2] = num1[3]; + num1[3] = swap; + } + num[0] = getcon(&num1[0], DT_QUAD); + num[1] = getcon(&num1[2], DT_QUAD); + } else { + num[0] = 0; + num[1] = 0; + errsev((error_code_t)91); + } + return getcon(num, DT_QCMPLX); + // AOCC end case TY_NCHAR: if (from == TY_WORD) { diff --git a/tools/flang2/flang2exe/symacc.cpp b/tools/flang2/flang2exe/symacc.cpp index b0970172ef..a1216d2b04 100644 --- a/tools/flang2/flang2exe/symacc.cpp +++ b/tools/flang2/flang2exe/symacc.cpp @@ -4,6 +4,14 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ /******************************************************** FIXME: get rid of this "important notice" and proliferating copies. @@ -46,7 +54,7 @@ sym_init_first(void) STG_ALLOC(stb, 1000); assert(stb.stg_base, "sym_init: no room for symtab", stb.stg_size, ERR_Fatal); - stb.n_size = 5024; + stb.n_size = 5024 + 512; NEW(stb.n_base, char, stb.n_size); assert(stb.n_base, "sym_init: no room for namtab", stb.n_size, ERR_Fatal); stb.n_base[0] = 0; @@ -353,16 +361,36 @@ add_fp_constants(void) atoxd("0.5", &tmp[0], 3); stb.dblhalf = getcon(tmp, DT_DBLE); +// AOCC begin + atoxq("0.0", &tmp[0], 4); + stb.quad0 = getcon(tmp, DT_QUAD); + atoxq("1.0", &tmp[0], 4); + stb.quad1 = getcon(tmp, DT_QUAD); + atoxq("2.0", &tmp[0], 4); + stb.quad2 = getcon(tmp, DT_QUAD); + atoxq("0.5", &tmp[0], 4); + stb.quadhalf = getcon(tmp, DT_QUAD); +// AOCC end + tmp[0] = 0; res[0] = 0; tmp[1] = CONVAL2G(stb.flt0); xfneg(tmp[1], &res[1]); stb.fltm0 = getcon(res, DT_REAL); + tmp[0] = CONVAL1G(stb.dbl0); tmp[1] = CONVAL2G(stb.dbl0); xdneg(tmp, res); stb.dblm0 = getcon(res, DT_DBLE); +// AOCC begin + tmp[0] = CONVAL1G(stb.quad0); + tmp[1] = CONVAL2G(stb.quad0); + tmp[2] = CONVAL3G(stb.quad0); + tmp[3] = CONVAL4G(stb.quad0); + xqneg(tmp, res); + stb.quadm0 = getcon(tmp, DT_QUAD); +// AOCC end #ifdef LONG_DOUBLE_FLOAT128 atoxq("0.0", &tmp[0], 4); stb.float128_0 = getcon(tmp, DT_FLOAT128); diff --git a/tools/flang2/flang2exe/symacc.h b/tools/flang2/flang2exe/symacc.h index 6c4e5e4c35..a45ea633b3 100644 --- a/tools/flang2/flang2exe/symacc.h +++ b/tools/flang2/flang2exe/symacc.h @@ -4,6 +4,14 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ #ifndef SYMACC_H_ #define SYMACC_H_ @@ -201,9 +209,19 @@ inline SPTR SymConval1(SPTR sptr) { inline SPTR SymConval2(SPTR sptr) { return static_cast(CONVAL2G(sptr)); } +// AOCC begin +inline SPTR SymConval3(SPTR sptr) { + return static_cast(CONVAL3G(sptr)); +} +inline SPTR SymConval4(SPTR sptr) { + return static_cast(CONVAL4G(sptr)); +} +// AOCC end #else #define SymConval1 CONVAL1G #define SymConval2 CONVAL2G +#define SymConval3 CONVAL3G // AOCC +#define SymConval4 CONVAL4G // AOCC #endif /** mode parameter for installsym_ex. */ diff --git a/tools/flang2/flang2exe/symtab.cpp b/tools/flang2/flang2exe/symtab.cpp index 16765aeb4f..9ba22aa767 100644 --- a/tools/flang2/flang2exe/symtab.cpp +++ b/tools/flang2/flang2exe/symtab.cpp @@ -4,6 +4,14 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ /** \file * \brief Fortran symbol table access module @@ -346,7 +354,8 @@ getcon(INT *value, DTYPE dtype) if (hashval < 0) hashval = -hashval; for (sptr = stb.hashtb[hashval]; sptr != 0; sptr = HASHLKG(sptr)) { - if (DTY(dtype) == TY_128) { + if (DTY(dtype) == TY_128 || DTY(dtype) == TY_QUAD || + DTY(dtype) == TY_QCMPLX) { if (DTYPEG(sptr) != dtype || STYPEG(sptr) != ST_CONST || CONVAL1G(sptr) != value[0] || CONVAL2G(sptr) != value[1] || CONVAL3G(sptr) != value[2] || CONVAL4G(sptr) != value[3]) @@ -369,7 +378,8 @@ getcon(INT *value, DTYPE dtype) ADDSYM(sptr, hashval); CONVAL1P(sptr, value[0]); CONVAL2P(sptr, value[1]); - if (DTY(dtype) == TY_128) { + // AOCC: DT_QUAD + if (DTY(dtype) == TY_128 || DTY(dtype) == DT_QUAD) { CONVAL3P(sptr, value[2]); CONVAL4P(sptr, value[3]); } @@ -560,6 +570,11 @@ get_vcon1(DTYPE dtype) case TY_DBLE: one = stb.dbl1; break; + // AOCC begin + case TY_QUAD: + one = stb.quad1; + break; + // AOCC end default: one = 1; break; @@ -894,7 +909,7 @@ getprint(int sptr) static char *b = NULL; char *from, *end, *to; int c; - INT num[2]; + INT num[4]; DTYPE dtype; if (STYPEG(sptr) != ST_CONST) { @@ -959,6 +974,23 @@ getprint(int sptr) cprintf(&b[26], "%24.17le", num); break; + // AOCC begin + case TY_QCMPLX: + num[0] = CONVAL1G(CONVAL1G(sptr)); + num[1] = CONVAL2G(CONVAL1G(sptr)); + num[2] = CONVAL3G(CONVAL1G(sptr)); + num[3] = CONVAL4G(CONVAL1G(sptr)); + cprintf(b, "%44.37Lf", num); + b[44] = ','; + b[45] = ' '; + num[0] = CONVAL1G(CONVAL2G(sptr)); + num[1] = CONVAL2G(CONVAL2G(sptr)); + num[2] = CONVAL3G(CONVAL2G(sptr)); + num[3] = CONVAL4G(CONVAL2G(sptr)); + cprintf(&b[46], "%44.37Lf", num); + break; + // AOCC end + case TY_NCHAR: sptr = CONVAL1G(sptr); /* sptr to char string constant */ dtype = DTYPEG(sptr); @@ -990,6 +1022,18 @@ getprint(int sptr) *to = '\0'; break; + // AOCC begin + case TY_QUAD: + /*num[0] = CONVAL1G(sptr); + num[1] = CONVAL2G(sptr); + num[2] = CONVAL3G(sptr); + num[3] = CONVAL4G(sptr); + cprintf(b, "%44.37Lf", num);*/ + sprintf(b, "%08x %08x %08x %08x", CONVAL1G(sptr), CONVAL2G(sptr), + CONVAL3G(sptr), CONVAL4G(sptr)); + break; + // AOCC end + case TY_128: sprintf(b, "%08x %08x %08x %08x", CONVAL1G(sptr), CONVAL2G(sptr), CONVAL3G(sptr), CONVAL4G(sptr)); diff --git a/tools/flang2/flang2exe/tgtutil.cpp b/tools/flang2/flang2exe/tgtutil.cpp index ef97d24480..dd340bce20 100644 --- a/tools/flang2/flang2exe/tgtutil.cpp +++ b/tools/flang2/flang2exe/tgtutil.cpp @@ -4,6 +4,17 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading + * Last modified: August 2020 + * + * Support for x86-64 OpenMP offloading + * Last modified: Sept 2019 + * Last Modified: Jun 2020 + */ /** \file * \brief tgtutil.c - Various definitions for the libomptarget runtime @@ -41,17 +52,32 @@ #include "symfun.h" #include "ccffinfo.h" +// AOCC Begin +#ifdef OMP_OFFLOAD_AMD +#include +#include + +// Vector to keep track all array accesses with constant offset within device. +extern std::vector constArraySymbolList; +#endif +static int updateregion = 0; +// AOCC End + #ifdef OMP_OFFLOAD_LLVM static void change_target_func_smbols(int outlined_func_sptr, int stblk_sptr); -static SPTR init_tgt_target_syms(const char *kernelname); +// AOCC additional argument +//static SPTR init_tgt_target_syms(const char *kernelname); +static SPTR init_tgt_target_syms(const char *kernelname, SPTR sptr = SPTR_NULL); #endif #if defined(OMP_OFFLOAD_LLVM) || defined(OMP_OFFLOAD_PGI) #define MXIDLEN 100 -static int dataregion = 0; +int dataregion = 0; static DTYPE tgt_offload_entry_type = DT_NONE; +extern int HasRequiresUnifiedSharedMemory; +int mk_ompaccel_load(int ili, DTYPE dtype, int nme); /* Flags for use with the entry */ #define DT_VOID_NONE DT_NONE @@ -67,6 +93,10 @@ static class ClassTgtApiCalls return {"__INVALID_TGT_API_NAME__", -1, (DTYPE)-1}; case TGT_API_REGISTER_LIB: return {"__tgt_register_lib", 0, DT_NONE}; + // AOCC begin + case TGT_API_REGISTER_REQUIRES: + return {"__tgt_register_requires", 0, DT_NONE}; + // AOCC end case TGT_API_TARGET: return {"__tgt_target", 0, DT_INT}; case TGT_API_TARGET_TEAMS: @@ -86,6 +116,9 @@ static class ClassTgtApiCalls static const struct tgt_api_entry_t tgt_api_calls[] = { [TGT_API_BAD] = {"__INVALID_TGT_API_NAME__", -1, -1}, [TGT_API_REGISTER_LIB] = {"__tgt_register_lib", 0, DT_VOID_NONE}, + // AOCC begin + [TGT_API_REGISTER_REQUIRES] = {"__tgt_register_requires", 0, DT_VOID_NONE}, + // AOCC end [TGT_API_TARGET] = {"__tgt_target", 0, DT_INT}, [TGT_API_TARGET_TEAMS] = {"__tgt_target_teams", 0, DT_INT}, [TGT_API_TARGET_TEAMS_PARALLEL] = {"__tgt_target_teams_parallel", 0, DT_INT}, @@ -239,9 +272,17 @@ make_array_sptr(char *name, DTYPE atype, int arraysize) return array; } /* make_array_sptr*/ +// AOCC Begin +static bool +is_complex_dtype(DTYPE dtype) { + if (dtype == DT_CMPLX || dtype == DT_DCMPLX || dtype == DT_QCMPLX) + return true; + return false; +} +// AOCC End static int -_tgt_target_fill_size(SPTR sptr, int map_type) +_tgt_target_fill_size(SPTR sptr, int map_type, int base_ili) { DTYPE dtype = DTYPEG(sptr); int ilix, rilix; @@ -252,11 +293,19 @@ _tgt_target_fill_size(SPTR sptr, int map_type) } else /* find the size of pointee */ ilix = ad_kconi(size_of(DTySeqTyElement(dtype))); + // AOCC Begin + } else if (is_complex_dtype(dtype)) { + ilix = ad_kconi(size_of(dtype)); + // AOCC End } else if (llis_vector_kind(dtype)) { ompaccelInternalFail("Vector data type is not implemented, cannot be passed to target region. "); } else if (llis_struct_kind(dtype)) { - ompaccelInternalFail("Struct data type is not implemented, cannot be passed to target region. "); + // AOCC Begin +// ompaccelInternalFail("Struct data type is not implemented, cannot be passed to target region. "); + int size = DTyArrayDesc(dtype); + ilix = ad_icon(size); + // AOCC End } else if (llis_function_kind(dtype)) { ompaccelInternalFail("Function data type is not implemented, cannot be passed to target region. "); } else if (llis_integral_kind(dtype) || dtype == DT_DBLE || dtype == DT_FLOAT) { @@ -279,6 +328,34 @@ _tgt_target_fill_size(SPTR sptr, int map_type) int numdim = AD_NUMDIM(ad); int j; ilix = ad_kconi(1); + + // AOCC Begin + // For allocatable arrays section descriptor stores array size. +#ifdef OMP_OFFLOAD_AMD + bool all_zero = true; + for (j = 0; j < numdim; ++j) { + if (AD_UPBD(ad, j) != 0 || AD_LWBD(ad, j) != 0) { + all_zero = false; + } + } + if (AD_SDSC(ad) && SDSCG(sptr) && all_zero) { + SPTR sdsc = SDSCG(sptr); + int nme = addnme(NT_VAR, sdsc, 0, 0); + + // 6th Element in section descriptor is size, 48 = 6 * 8(INT8) + if (SCG(sdsc) == SC_NONE && base_ili) { + ilix = ad3ili(IL_AADD, base_ili, ad_aconi(ADDRESSG(sdsc)), 0); + ilix = ad3ili(IL_AADD, ilix, ad_aconi(48), 0); + ilix = ad3ili(IL_LD, ilix, nme, MSZ_WORD); + } else { + ilix = ad3ili(IL_LD, ad_acon(sdsc, 48), nme, MSZ_WORD); + } + ilix = ad2ili(IL_KMUL, ilix, ad_kconi(size_of(DTySeqTyElement(dtype)))); + return ilix; + } +#endif + // AOCC End + // todo ompaccel we do not support partial arrays here. for (j = 0; j < numdim; ++j) { if (AD_UPBD(ad, j) != 0) { @@ -290,7 +367,13 @@ _tgt_target_fill_size(SPTR sptr, int map_type) rilix = ad2ili(IL_KADD, ad_kconi(0), ad_kconi(1)); ilix = ad2ili(IL_KMUL, ilix, rilix); } - ilix = ad2ili(IL_KMUL, ilix, ad_kconi(size_of((DTYPE)(dtype + 1)))); + if (DTY( (DTYPE) DTY((DTYPE) (dtype + 1))) != TY_STRUCT) // AOCC + ilix = ad2ili(IL_KMUL, ilix, ad_kconi(size_of(DTySeqTyElement(dtype)))); + // AOCC Begin + else + ilix = ad2ili(IL_KMUL, ilix, + ad_kconi(DTyArrayDesc(DTYPE((DTY((DTYPE)(dtype + 1))))))); + // AOCC End } } }else { @@ -305,9 +388,12 @@ _tgt_target_fill_maptype(SPTR sptr, int maptype, int isMidnum, int midnum_maptyp /*todo ompaccel there are many cases to be covered. It is not completed yet. */ if(isMidnum) final_maptype |= midnum_maptype; - else if(maptype == 0) - final_maptype = OMP_TGT_MAPTYPE_IMPLICIT | OMP_TGT_MAPTYPE_TARGET_PARAM; - else + else if(maptype == 0) { + // AOCC Modification: Moving logical or of OMP_TGT_MAPTYPE_TARGET_PARAM + // to end of this function. This was moved here in + // Commit 1bd2b5172c227e09208b987cee27b2bcd720eed5 + final_maptype = OMP_TGT_MAPTYPE_IMPLICIT; + } else final_maptype = maptype; DTYPE dtype = DTYPEG(sptr); @@ -316,6 +402,10 @@ _tgt_target_fill_maptype(SPTR sptr, int maptype, int isMidnum, int midnum_maptyp } else if (llis_array_kind(dtype)) { + // AOCC Begin + } else if (is_complex_dtype(dtype)) { + final_maptype |= OMP_TGT_MAPTYPE_LITERAL; + // AOCC End } else if (llis_vector_kind(dtype)) { ompaccelInternalFail("Don't know how to implicitly define map type for vector data type "); } else if (llis_integral_kind(dtype) || dtype == DT_DBLE || dtype == DT_FLOAT) { @@ -323,26 +413,56 @@ _tgt_target_fill_maptype(SPTR sptr, int maptype, int isMidnum, int midnum_maptyp } else if (llis_function_kind(dtype)) { ompaccelInternalFail("Don't know how to implicitly define map type for function data type "); } else if (llis_struct_kind(dtype)) { - ompaccelInternalFail("Don't know how to implicitly define map type for struct data type "); + final_maptype |= OMP_TGT_MAPTYPE_LITERAL; } else { ompaccelInternalFail("Unknown data type"); } } + + // AOCC Modification: Adding back this, this was moved up in + // Commit 1bd2b5172c227e09208b987cee27b2bcd720eed5 + final_maptype |= OMP_TGT_MAPTYPE_TARGET_PARAM; return final_maptype; } +static bool isOpenMPKernelCall(int api_id) +{ + switch (api_id){ + case TGT_API_TARGET: + case TGT_API_TARGET_TEAMS: + case TGT_API_TARGET_TEAMS_PARALLEL: + return true; + default: + return false; + } + return false; +} + void tgt_target_fill_params(SPTR arg_base_sptr, SPTR arg_size_sptr, SPTR args_sptr, - SPTR args_maptypes_sptr, OMPACCEL_TINFO *targetinfo) + SPTR args_maptypes_sptr, OMPACCEL_TINFO *targetinfo, + int api_id) { int i, j, ilix, iliy; + char *name_base="", *name_length=""; + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + int temp_map_type = 0; +#endif + // AOCC End OMPACCEL_SYM midnum_sym; DTYPE param_dtype, load_dtype; SPTR param_sptr; - LOGICAL isPointer, isMidnum, showMinfo, isThis; + LOGICAL isPointer, isArray, isMidnum, showMinfo, isThis, isStruct; //AOCC /* fill the arrays */ /* Build the list: (size, sptr) pairs. */ + // AOCC Begin. + // This part of code to be emitted in host module, so disable the flag + bool old_intarget = gbl.ompaccel_intarget; + gbl.ompaccel_intarget = false; + // AOCC End + for (i = 0; i < targetinfo->n_symbols; ++i) { int nme_args, nme_size, nme_base, nme_types; nme_args = add_arrnme(NT_ARR, args_sptr, addnme(NT_VAR, args_sptr, 0, 0), 0, ad_icon(i), FALSE); @@ -354,6 +474,10 @@ tgt_target_fill_params(SPTR arg_base_sptr, SPTR arg_size_sptr, SPTR args_sptr, param_sptr = targetinfo->symbols[i].host_sym; param_dtype = DTYPEG(param_sptr); isPointer = llis_pointer_kind(param_dtype); + //AOCC Begin + isArray = llis_array_kind(param_dtype); + isStruct = llis_struct_kind(param_dtype) && !is_complex_dtype(param_dtype); + //AOCC End /* This is for fortran allocatable arrays. * We keep the base symbol as a quiet symbol that has the map type info. @@ -363,8 +487,14 @@ tgt_target_fill_params(SPTR arg_base_sptr, SPTR arg_size_sptr, SPTR args_sptr, if(isPointer) { for (j = 0; j < targetinfo->n_quiet_symbols; ++j) { SPTR midnum_sptr = MIDNUMG(targetinfo->quiet_symbols[j].host_sym); - if (midnum_sptr == param_sptr || HASHLKG(midnum_sptr) == param_sptr) { + if (midnum_sptr == param_sptr /*|| HASHLKG(midnum_sptr) == param_sptr */) { midnum_sym = targetinfo->quiet_symbols[j]; + // AOCC Begin + // No need to put `TO` in map type for 'target update from' + if(targetinfo->mode == mode_target_update && + targetinfo->quiet_symbols[j].map_type & OMP_TGT_MAPTYPE_FROM ) + targetinfo->quiet_symbols[j].map_type &= ~(OMP_TGT_MAPTYPE_TO); + // AOCC End isMidnum = TRUE; break; } @@ -374,11 +504,54 @@ tgt_target_fill_params(SPTR arg_base_sptr, SPTR arg_size_sptr, SPTR args_sptr, showMinfo = true; /* Implicit map(to:) for the array descriptor */ if(DESCARRAYG(param_sptr)) { - targetinfo->symbols[i].map_type = OMP_TGT_MAPTYPE_TARGET_PARAM | OMP_TGT_MAPTYPE_TO; + // AOCC Begin + if(targetinfo->mode == mode_target_update && + targetinfo->symbols[i].map_type & OMP_TGT_MAPTYPE_FROM) + targetinfo->symbols[i].map_type &= ~(OMP_TGT_MAPTYPE_TO); + else + // AOCC End + targetinfo->symbols[i].map_type = OMP_TGT_MAPTYPE_TARGET_PARAM | OMP_TGT_MAPTYPE_TO; showMinfo = false; } + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + temp_map_type = 0; + // As per OpenMP standards 4.5 data mapping rules, from section 2.15.5 + // " If a variable is not a scalar then it is treated as if it had + // appeared in a map clause with a map-type of tofrom." + if (targetinfo->symbols[i].map_type == 0 && (isArray || isPointer || isStruct)) { + temp_map_type = OMP_TGT_MAPTYPE_FROM | + OMP_TGT_MAPTYPE_TO | OMP_TGT_MAPTYPE_TARGET_PARAM; + } +#endif + // AOCC End /* assign map type */ targetinfo->symbols[i].map_type = _tgt_target_fill_maptype(param_sptr, targetinfo->symbols[i].map_type, isMidnum, midnum_sym.map_type); + // AOCC Begin +#ifdef OMP_OFFLOAD_AMD + if (temp_map_type != 0) { + targetinfo->symbols[i].map_type = temp_map_type; + } + if (isMidnum) { + // AOCC Begin + if(targetinfo->mode == mode_target_update && + targetinfo->symbols[i].map_type & OMP_TGT_MAPTYPE_FROM) + targetinfo->symbols[i].map_type &= ~(OMP_TGT_MAPTYPE_TO); + else + // AOCC End + targetinfo->symbols[i].map_type |= OMP_TGT_MAPTYPE_TO; + } +#endif + // AOCC End + + // Flang and Clang can generate OpenMP kernels where number of device + // kernel arguments is not equal to number of passed host arguments. + // That's why, if given host symbol is not mapped in the target kernel + // then we should not mark it as valid param. + if (isOpenMPKernelCall(api_id) && + targetinfo->symbols[i].device_sym == NOSYM) { + targetinfo->symbols[i].map_type &= ~(OMP_TGT_MAPTYPE_TARGET_PARAM); + } ilix = ad4ili(IL_ST, ad_icon(targetinfo->symbols[i].map_type), ad_acon(args_maptypes_sptr, i * TARGET_PTRSIZE), nme_types, MSZ_I8); chk_block(ilix); @@ -391,21 +564,43 @@ tgt_target_fill_params(SPTR arg_base_sptr, SPTR arg_size_sptr, SPTR args_sptr, param_dtype = array_element_dtype(param_dtype); else if (llis_pointer_kind(param_dtype)) param_dtype = DTySeqTyElement(param_dtype); + // AOCC Begin + // ILIs for base and lower bound symbols + if(!ILI_OF(targetinfo->symbols[i].ili_base)) + targetinfo->symbols[i].ili_base = mk_address(param_sptr); + if(!ILI_OF(targetinfo->symbols[i].ili_lowerbound)) + targetinfo->symbols[i].ili_lowerbound = + mk_ompaccel_ldsptr(targetinfo->symbols[i].sptr_lowerbound); + // AOCC End iliy = targetinfo->symbols[i].ili_base; ilix = mk_ompaccel_store(iliy, DT_ADDR, nme_base, ad_acon(arg_base_sptr, i * TARGET_PTRSIZE)); /* Assign args */ chk_block(ilix); ilix = ikmove(targetinfo->symbols[i].ili_lowerbound); + ilix = mk_ompaccel_add(ilix, DT_INT8, ad_kconi(-1), DT_INT8); // AOCC ilix = mk_ompaccel_mul(ilix, DT_INT8, ad_kconi(size_of(param_dtype)), DT_INT8); ilix = sel_aconv(ilix); ilix = mk_ompaccel_add(iliy, DT_ADDR, ilix, DT_INT8); ilix = mk_ompaccel_store(ilix, DT_ADDR, nme_args, ad_acon(args_sptr, i * TARGET_PTRSIZE)); chk_block(ilix); } else { + ADSC *ad = AD_DPTR(param_dtype); // AOCC /* Optimization - Pass by value for scalar */ - if (TY_ISSCALAR(DTY(param_dtype)) && (targetinfo->symbols[i].map_type & OMP_TGT_MAPTYPE_IMPLICIT) || isMidnum || isThis ) { + // AOCC Modification : Removed use of uninitalized variable isThis from condition + if (TY_ISSCALAR(DTY(param_dtype)) && (targetinfo->symbols[i].map_type & OMP_TGT_MAPTYPE_IMPLICIT) || isMidnum) { iliy = mk_ompaccel_ldsptr(param_sptr); load_dtype = param_dtype; + if (isMidnum && + SDSCG(midnum_sym.host_sym) && ALLOCATTRG(param_sptr) && + SCG(param_sptr) == SC_DUMMY) { + iliy = mk_ompaccel_load(iliy, DT_ADDR, addnme(NT_VAR, param_sptr, 0, 0)); + } + // AOCC Begin + } else if (targetinfo->symbols[i].ili_sptr && AD_SDSC(ad) + && AD_ZBASE(ad)) { + iliy = targetinfo->symbols[i].ili_sptr; + load_dtype = DT_ADDR; + // AOCC End } else { iliy = mk_address(param_sptr); load_dtype = DT_ADDR; @@ -418,19 +613,51 @@ tgt_target_fill_params(SPTR arg_base_sptr, SPTR arg_size_sptr, SPTR args_sptr, chk_block(ilix); } /* assign size */ - if(targetinfo->symbols[i].in_map) { + if(targetinfo->symbols[i].in_map && + targetinfo->symbols[i].sptr_length != SPTR_NULL) {// AOCC + // AOCC Begin + // ILI for the length symbol + if(!ILI_OF(targetinfo->symbols[i].sptr_length)) + targetinfo->symbols[i].ili_length = + mk_ompaccel_ldsptr(targetinfo->symbols[i].sptr_length); + // AOCC End ilix = ikmove(targetinfo->symbols[i].ili_length); ilix = mk_ompaccel_mul(ilix, DT_INT8, ad_kconi(size_of(param_dtype)), DT_INT8); } else { - if(isMidnum) - ilix = _tgt_target_fill_size(midnum_sym.host_sym, targetinfo->symbols[i].map_type); + bool useMidnum = true; + if(isMidnum) { + DTYPE dtype = DTYPEG(midnum_sym.host_sym); + if (llis_array_kind(dtype)) { + ADSC *ad = AD_DPTR(dtype); + int numdim = AD_NUMDIM(ad); + if (numdim == 0 ) useMidnum = false; + } + } + if(isMidnum && useMidnum ) { + if (SDSCG(midnum_sym.host_sym) && ALLOCATTRG(param_sptr) && SCG(param_sptr) == SC_DUMMY) { + SPTR sptr = midnum_sym.host_sym; + int nme = addnme(NT_VAR, sptr, 0, 0); + SPTR sdsc = SDSCG(sptr); + ilix=ad3ili(IL_LD, ad_acon(sdsc, 48), nme, MSZ_WORD); + ilix = mk_ompaccel_mul(ilix, DT_INT8, ad_kconi(size_of(param_dtype)), DT_INT8); + } else + ilix = _tgt_target_fill_size(midnum_sym.host_sym, + targetinfo->symbols[i].map_type, + targetinfo->symbols[i].ili_base); // AOCC + } else - ilix = _tgt_target_fill_size(param_sptr, targetinfo->symbols[i].map_type); + ilix = _tgt_target_fill_size(param_sptr, + targetinfo->symbols[i].map_type, + targetinfo->symbols[i].ili_base); // AOCC } ilix = ad4ili(IL_STKR, ilix, ad_acon(arg_size_sptr, i * TARGET_PTRSIZE), nme_size, TARGET_PTRSIZE == 8 ? MSZ_I8 : MSZ_WORD); chk_block(ilix); } + + // AOCC Begin + gbl.ompaccel_intarget = old_intarget; + // AOCC End } int @@ -442,11 +669,16 @@ ll_make_tgt_target(SPTR outlined_func_sptr, int64_t device_id, SPTR stblk_sptr) int ili_hostptr; rname = SYMNAME(outlined_func_sptr); - NEW(name, char, 100); + NEW(name, char, strlen(rname)+16); // AOCC targetinfo = ompaccel_tinfo_get(outlined_func_sptr); #if OMP_OFFLOAD_LLVM - sptr = init_tgt_target_syms(rname); + // AOCC begin + if (flg.x86_64_omptarget) + sptr = init_tgt_target_syms(rname, outlined_func_sptr); + else + sptr = init_tgt_target_syms(rname); + // AOCC end ili_hostptr = ad_acon(sptr, 0); #endif if (targetinfo->n_symbols == 0) { @@ -474,7 +706,7 @@ ll_make_tgt_target(SPTR outlined_func_sptr, int64_t device_id, SPTR stblk_sptr) args_maptypes_sptr = make_array_sptr(name, DT_INT8, targetinfo->n_symbols); tgt_target_fill_params(arg_base_sptr, arg_size_sptr, args_sptr, - args_maptypes_sptr, targetinfo); + args_maptypes_sptr, targetinfo, TGT_API_TARGET); // prepare argument for tgt target int locargs[7]; @@ -507,9 +739,15 @@ ll_make_tgt_target_teams(SPTR outlined_func_sptr, int64_t device_id, OMPACCEL_TINFO *targetinfo = ompaccel_tinfo_get(outlined_func_sptr); int ili_hostptr, nargs = targetinfo->n_symbols; rname = SYMNAME(outlined_func_sptr); - NEW(name, char, 100); + NEW(name, char, strlen(rname)+16); // AOCC #if OMP_OFFLOAD_LLVM - sptr = init_tgt_target_syms(rname); + // AOCC begin + // sptr = init_tgt_target_syms(rname); + if (flg.x86_64_omptarget) + sptr = init_tgt_target_syms(rname, outlined_func_sptr); + else + sptr = init_tgt_target_syms(rname); + // AOCC end ili_hostptr = ad_acon(sptr, 0); #endif @@ -523,7 +761,7 @@ ll_make_tgt_target_teams(SPTR outlined_func_sptr, int64_t device_id, args_maptypes_sptr = make_array_sptr(name, DT_INT8, nargs); tgt_target_fill_params(arg_base_sptr, arg_size_sptr, args_sptr, - args_maptypes_sptr, targetinfo); + args_maptypes_sptr, targetinfo, TGT_API_TARGET_TEAMS); // prepare argument for tgt target int locargs[9]; @@ -536,8 +774,32 @@ ll_make_tgt_target_teams(SPTR outlined_func_sptr, int64_t device_id, locargs[4] = ad_acon(args_sptr, 0); locargs[3] = ad_acon(arg_size_sptr, 0); locargs[2] = ad_acon(args_maptypes_sptr, 0); - locargs[1] = ad_icon(num_teams); - locargs[0] = ad_icon(thread_limit); + // AOCC Begin + if (targetinfo->num_teams != SPTR_NULL) { + int nme = addnme(NT_VAR, targetinfo->num_teams, 0, 0); + int address = mk_address(targetinfo->num_teams); + locargs[1] = ad3ili(IL_LD, address, nme, + mem_size(DTY(DTYPEG(targetinfo->num_teams)))); + } else { + // AOCC End + if (num_teams == 0 && targetinfo->n_reduction_symbols) { + int NTeams = XBIT(234,0x01ffff); + locargs[1] = ad_icon(NTeams ? NTeams : 0); + } else + locargs[1] = ad_icon(num_teams); + } + + // AOCC Begin + if (targetinfo->num_threads != SPTR_NULL) { + int nme = addnme(NT_VAR, targetinfo->num_threads, 0, 0); + int address = mk_address(targetinfo->num_threads); + locargs[0] = ad3ili(IL_LD, address, nme, + mem_size(DTY(DTYPEG(targetinfo->num_threads)))); + } else { + + locargs[0] = ad_icon(thread_limit); + } + // AOCC End #ifdef OMP_OFFLOAD_LLVM change_target_func_smbols(outlined_func_sptr, stblk_sptr); #endif @@ -558,7 +820,7 @@ ll_make_tgt_target_teams_parallel(SPTR outlined_func_sptr, int64_t device_id, OMPACCEL_TINFO *targetinfo = ompaccel_tinfo_get(outlined_func_sptr); int ili_hostptr, nargs = targetinfo->n_symbols; rname = SYMNAME(outlined_func_sptr); - NEW(name, char, 100); + NEW(name, char, strlen(rname)+16); // AOCC ili_hostptr = ad1ili(IL_ACON, get_acon(outlined_func_sptr, 0)); sprintf(name, "%s_base", rname); @@ -571,7 +833,8 @@ ll_make_tgt_target_teams_parallel(SPTR outlined_func_sptr, int64_t device_id, args_maptypes_sptr = make_array_sptr(name, DT_INT8, nargs); tgt_target_fill_params(arg_base_sptr, arg_size_sptr, args_sptr, - args_maptypes_sptr, targetinfo); + args_maptypes_sptr, targetinfo, + TGT_API_TARGET_TEAMS_PARALLEL); // prepare argument for tgt target int locargs[11]; @@ -601,7 +864,7 @@ ll_make_tgt_target_data_begin(int device_id, OMPACCEL_TINFO *targetinfo) { int call_ili, nargs; SPTR arg_base_sptr, args_sptr, arg_size_sptr, args_maptypes_sptr; - char name[12]; + char name[16]; int locargs[6]; DTYPE locarg_types[] = {DT_INT8, DT_INT, DT_ADDR, DT_ADDR, DT_ADDR, DT_ADDR}; @@ -622,7 +885,8 @@ ll_make_tgt_target_data_begin(int device_id, OMPACCEL_TINFO *targetinfo) dataregion++; tgt_target_fill_params(arg_base_sptr, arg_size_sptr, args_sptr, - args_maptypes_sptr, targetinfo); + args_maptypes_sptr, targetinfo, + TGT_API_TARGET_DATA_BEGIN); locargs[5] = ad_icon(device_id); locargs[4] = ad_icon(nargs); @@ -643,7 +907,7 @@ _tgt_target_fill_targetdata(int device_id, OMPACCEL_TINFO *targetinfo, int tgt_a { int call_ili, nargs; SPTR arg_base_sptr, args_sptr, arg_size_sptr, args_maptypes_sptr; - char name[12]; + char name[16]; int locargs[6]; DTYPE @@ -666,7 +930,7 @@ _tgt_target_fill_targetdata(int device_id, OMPACCEL_TINFO *targetinfo, int tgt_a dataregion++; tgt_target_fill_params(arg_base_sptr, arg_size_sptr, args_sptr, - args_maptypes_sptr, targetinfo); + args_maptypes_sptr, targetinfo, tgt_api); locargs[5] = ad_icon(device_id); locargs[4] = ad_icon(nargs); @@ -732,7 +996,7 @@ ll_make_struct(int count, char *name, TGT_ST_TYPE *meminfo, ISZ_T sz) char sname[MXIDLEN]; tag = SPTR_NULL; - dtype = cg_get_type(6, TY_STRUCT, NOSYM); + dtype = cg_get_type(count, TY_STRUCT, NOSYM); // AOCC dont return used type if (name) { sprintf(sname, "%s", name); tag = getsymbol(sname); @@ -820,12 +1084,22 @@ ll_make_tgt_bin_descriptor(char *name, DTYPE entrytype, DTYPE deviceimagetype) } static SPTR -init_tgt_target_syms(const char *kernelname) +init_tgt_target_syms(const char *_kernelname, SPTR func_sptr) { + char *kernelname; + size_t size = 100 + strlen(_kernelname); + NEW(kernelname, char, size); + strcpy(kernelname, _kernelname); SPTR eptr1, eptr2, eptr3; - size_t size; char *kernelname_, *sname_region, *sname_entry; - size = 100 + strlen(kernelname); + if (flg.x86_64_omptarget) { + // Assuming that this function is called for outlined functions that are + // entry points. + if (ompaccel_x86_is_parallel_func(func_sptr)) { + sprintf(kernelname, "%s_x86_entry", _kernelname); + } + } + // AOCC end /* regionId */ NEW(sname_region, char, size); @@ -843,7 +1117,9 @@ init_tgt_target_syms(const char *kernelname) // device functions gets "_" in the end. NEW(kernelname_, char, size); sprintf(kernelname_, "%s_\00", kernelname); - eptr2 = getstring(kernelname_, strlen(kernelname) + 1); + // AOCC Modification: Changed strlen(kernelname) to strlen(kernelname_) + // This is required to append null character at end + eptr2 = getstring(kernelname_, strlen(kernelname_) + 1); DINITP(eptr2, 1); NEW(sname_entry, char, size); @@ -874,35 +1150,59 @@ init_tgt_register_syms() { SPTR tptr1, tptr2, tptr3, tptr4; - tptr1 = (SPTR)addnewsym(".omp_offloading.entries_begin"); + // tptr1 = (SPTR)addnewsym(".omp_offloading.entries_begin"); // AOCC + tptr1 = (SPTR)addnewsym("__start_omp_offloading_entries"); // AOCC + // AOCC Begin + tgt_offload_entry_type = ll_make_tgt_offload_entry("__tgt_offload_entry_type_"); + // AOCC End DTYPEP(tptr1, tgt_offload_entry_type); - SCP(tptr1, SC_EXTERN); + /* SCP(tptr1, SC_EXTERN); */ SCP(tptr1, SC_PRIVATE); // AOCC DCLDP(tptr1, 1); STYPEP(tptr1, ST_VAR); SYMLKP(tptr1, gbl.consts); gbl.consts = tptr1; OMPACCRTP(tptr1, 1); - tptr2 = (SPTR)addnewsym(".omp_offloading.entries_end"); + // tptr2 = (SPTR)addnewsym(".omp_offloading.entries_end"); //AOCC + tptr2 = (SPTR)addnewsym("__stop_omp_offloading_entries"); // AOCC DTYPEP(tptr2, tgt_offload_entry_type); - SCP(tptr2, SC_EXTERN); + /* SCP(tptr2, SC_EXTERN); */ SCP(tptr2, SC_PRIVATE); // AOCC DCLDP(tptr2, 1); STYPEP(tptr2, ST_VAR); SYMLKP(tptr2, gbl.consts); gbl.consts = tptr2; OMPACCRTP(tptr2, 1); - tptr3 = (SPTR)addnewsym(".omp_offloading.img_start.nvptx64-nvidia-cuda"); + // AOCC begin +#ifdef OMP_OFFLOAD_AMD + if (flg.amdgcn_target) + tptr3 = (SPTR)addnewsym(".omp_offloading.img_start.amdgcn-amd-amdhsa"); + else if (flg.x86_64_omptarget) + tptr3 = (SPTR)addnewsym(".omp_offloading.img_start.x86_64-pc-linux-gnu"); + else +#endif + // AOCC end + tptr3 = (SPTR)addnewsym(".omp_offloading.img_start.nvptx64-nvidia-cuda"); DTYPEP(tptr3, DT_BINT); - SCP(tptr3, SC_EXTERN); + /* SCP(tptr3, SC_EXTERN); */ SCP(tptr3, SC_PRIVATE); // AOCC STYPEP(tptr3, ST_VAR); SYMLKP(tptr3, gbl.consts); gbl.consts = tptr3; OMPACCRTP(tptr3, 1); - tptr4 = (SPTR)addnewsym(".omp_offloading.img_end.nvptx64-nvidia-cuda"); + // AOCC begin +#ifdef OMP_OFFLOAD_AMD + if (flg.amdgcn_target) + tptr4 = (SPTR)addnewsym(".omp_offloading.img_end.amdgcn-amd-amdhsa"); + else if (flg.x86_64_omptarget) + tptr4 = (SPTR)addnewsym(".omp_offloading.img_end.x86_64-pc-linux-gnu"); + else +#endif + // AOCC end + tptr4 = (SPTR)addnewsym(".omp_offloading.img_end.nvptx64-nvidia-cuda"); + DTYPEP(tptr4, DT_BINT); - SCP(tptr4, SC_EXTERN); + /* SCP(tptr4, SC_EXTERN); */ SCP(tptr4, SC_PRIVATE); // AOCC DCLDP(tptr4, 1); STYPEP(tptr4, ST_VAR); SYMLKP(tptr4, gbl.consts); @@ -916,6 +1216,9 @@ ll_make_tgt_register_lib() SPTR sptr; DTYPE dtype_bindesc, dtype_entry, dtype_devimage, dtype_pofbindesc; + // AOCC Begin + tgt_offload_entry_type = ll_make_tgt_offload_entry("__tgt_offload_entry_"); + // AOCC End dtype_entry = tgt_offload_entry_type; dtype_devimage = ll_make_tgt_device_image("__tgt_device_image", dtype_entry); dtype_bindesc = @@ -934,6 +1237,38 @@ ll_make_tgt_register_lib() return mk_tgt_api_call(TGT_API_REGISTER_LIB, 1, arg_types, args); } +// AOCC begin +int +ll_make_tgt_register_requires() +{ + SPTR sptr; + DTYPE dtype_bindesc, dtype_entry, dtype_devimage, dtype_pofbindesc; + + // AOCC Begin + tgt_offload_entry_type = ll_make_tgt_offload_entry("__tgt_offload_entry_requires_"); + // AOCC End + dtype_entry = tgt_offload_entry_type; + dtype_devimage = ll_make_tgt_device_image("__tgt_device_image", dtype_entry); + dtype_bindesc = + ll_make_tgt_bin_descriptor("__tgt_bin_desc", dtype_entry, dtype_devimage); + + sptr = (SPTR)addnewsym(".omp_offloading.descriptor"); + STYPEP(sptr, ST_STRUCT); + SCP(sptr, SC_EXTERN); + REFP(sptr, 1); + DTYPEP(sptr, dtype_bindesc); + + int args[1]; + DTYPE arg_types[1] = {DT_INT8}; + if (HasRequiresUnifiedSharedMemory) { + args[0] = ad_kconi(OMP_REQ_UNIFIED_SHARED_MEMORY); + } + else + args[0] = ad_kconi(1); + return mk_tgt_api_call(TGT_API_REGISTER_REQUIRES, 1, arg_types, args); +} +// AOCC end + int ll_make_tgt_register_lib2() { @@ -953,11 +1288,20 @@ ll_make_tgt_register_lib2() break; } } - assert(!tptr || !tptr2 || !tptr3 || !tptr4, + // AOCC begin + // assert(!tptr || !tptr2 || !tptr3 || !tptr4, + /* + * MODIFICATION + * Changed assert expression from logical or to logical and + * because if it's logcal OR, assert will even if we find one variable. + * Assert shoudld fail only when we fail to find any of the variable + */ + + assert(tptr && tptr2 && tptr3 && tptr4, "OpenMP Offload structures are not found.", 0, ERR_Fatal); + // AOCC end - dtype_entry = - tgt_offload_entry_type; // ll_make_tgt_offload_entry("__tgt_offload_entry"); + dtype_entry = ll_make_tgt_offload_entry("__tgt_offload_entry_lib2_"); //AOCC dtype_devimage = ll_make_tgt_device_image("__tgt_device_image", dtype_entry); dtype_bindesc = ll_make_tgt_bin_descriptor("__tgt_bin_desc", dtype_entry, dtype_devimage); @@ -1049,7 +1393,50 @@ ll_make_tgt_register_lib2() void init_tgtutil() { - tgt_offload_entry_type = ll_make_tgt_offload_entry("__tgt_offload_entry_"); + tgt_offload_entry_type = ll_make_tgt_offload_entry("__tgt_offload_entry_type_"); +} + +// AOCC Begin +int +ll_make_tgt_target_update(int device_id, OMPACCEL_TINFO *targetinfo) +{ + int call_ili, nargs; + SPTR arg_base_sptr, arg_sptr, arg_size_sptr, arg_map_sptr; + char name[16]; + int local_args[12]; + + DTYPE locarg_types[] = {DT_INT8, DT_INT, DT_ADDR, DT_ADDR, DT_ADDR, DT_ADDR}; + + if (targetinfo == NULL) { + interr("Map item list is not found", 0, ERR_Fatal); + } + nargs = targetinfo->n_symbols; + + sprintf(name, "update%d_base", updateregion); + arg_base_sptr = make_array_sptr(name, DT_CPTR, nargs); + sprintf(name, "update%d_size", updateregion); + arg_size_sptr = make_array_sptr(name, DT_INT8, nargs); + sprintf(name, "update%d_args", updateregion); + arg_sptr = make_array_sptr(name, DT_CPTR, nargs); + sprintf(name, "update%d_type", updateregion); + arg_map_sptr = make_array_sptr(name, DT_INT8, nargs); + updateregion++; + + tgt_target_fill_params(arg_base_sptr, arg_size_sptr, arg_sptr, + arg_map_sptr, targetinfo, TGT_API_TARGETUPDATE); + + local_args[5] = ad_icon(device_id); + local_args[4] = ad_icon(nargs); + local_args[3] = ad_acon(arg_base_sptr, 0); + local_args[2] = ad_acon(arg_sptr, 0); + local_args[1] = ad_acon(arg_size_sptr, 0); + local_args[0] = ad_acon(arg_map_sptr, 0); + + call_ili = + mk_tgt_api_call(TGT_API_TARGETUPDATE, 6, locarg_types, local_args); + + return call_ili; } +// AOCC End #endif diff --git a/tools/flang2/flang2exe/tgtutil.h b/tools/flang2/flang2exe/tgtutil.h index 34b545b1ce..cb034ed79f 100644 --- a/tools/flang2/flang2exe/tgtutil.h +++ b/tools/flang2/flang2exe/tgtutil.h @@ -4,6 +4,14 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading + * Date of modification 23rd September 2019 + * + */ /** \file * \brief Various definitions for the libomptarget runtime @@ -22,6 +30,7 @@ enum { TGT_API_BAD, TGT_API_REGISTER_LIB, TGT_API_UNREGISTER_LIB, + TGT_API_REGISTER_REQUIRES, // AOCC TGT_API_TARGET, TGT_API_TARGET_NOWAIT, TGT_API_TARGET_TEAMS, @@ -40,6 +49,22 @@ enum { TGT_API_N_ENTRIES /* <-- Always last */ }; +enum OpenMPOffloadingRequiresDirFlags : int64_t { + /// flag undefined. + OMP_REQ_UNDEFINED = 0x000, + /// no requires clause present. + OMP_REQ_NONE = 0x001, + /// reverse_offload clause. + OMP_REQ_REVERSE_OFFLOAD = 0x002, + /// unified_address clause. + OMP_REQ_UNIFIED_ADDRESS = 0x004, + /// unified_shared_memory clause. + OMP_REQ_UNIFIED_SHARED_MEMORY = 0x008, + /// dynamic_allocators clause. + OMP_REQ_DYNAMIC_ALLOCATORS = 0x010 +}; + + typedef struct any_tgt_struct { char *name; DTYPE dtype; @@ -53,11 +78,21 @@ struct tgt_api_entry_t { const DTYPE ret_dtype; /* TGT API function return value type */ }; +extern int dataregion; // AOCC + /** \brief Register the file and load cubin file */ int ll_make_tgt_register_lib(void); +int ll_make_tgt_register_requires(void); // AOCC + +/** + \brief Create structure type + */ +DTYPE +ll_make_struct(int count, char *name, TGT_ST_TYPE *meminfo, ISZ_T sz); + /** \brief Register the file and load cubin file */ @@ -82,6 +117,13 @@ int ll_make_tgt_target_teams(SPTR, int64_t, SPTR, int32_t, int32_t); */ int ll_make_tgt_target_teams_parallel(SPTR, int64_t, SPTR, int32_t, int32_t, int32_t, int32_t); +// AOCC Begin +/** + \brief Start target update + */ +int ll_make_tgt_target_update(int, OMPACCEL_TINFO *); +// AOCC End + /** \brief Start target data begin. */ diff --git a/tools/flang2/flang2exe/upper.cpp b/tools/flang2/flang2exe/upper.cpp index 429cbc4020..d34153dfd4 100644 --- a/tools/flang2/flang2exe/upper.cpp +++ b/tools/flang2/flang2exe/upper.cpp @@ -4,6 +4,13 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights + * reserved. Notified per clause 4(b) of the license. + * + * Last modified: June 2020 + * + */ /** \file * \brief upper - import the lowered F90/HPF code @@ -135,7 +142,7 @@ static const namelist Datatypes[] = { "Logical2", "L2", TY_SLOG, "Logical4", "L4", TY_LOG, "Logical8", "L8", TY_LOG8, "Numeric", "N", TY_NUMERIC, "Pointer", "P", TY_PTR, "proc", "p", TY_PROC, - "Real2", "R2", TY_HALF, + "Real2", "R2", TY_HALF, "Complex32", "C32", TY_QCMPLX, "Real4", "R4", TY_REAL, "Real8", "R8", TY_DBLE, "Real16", "R16", TY_QUAD, "Struct", "S", TY_STRUCT, "Word4", "W4", TY_WORD, "Word8", "W8", TY_DWORD, @@ -1647,6 +1654,11 @@ read_datatype(void) case TY_DCMPLX: datatypexref[dtype] = DT_DCMPLX; break; + // AOCC begin + case TY_QCMPLX: + datatypexref[dtype] = DT_QCMPLX; + break; + // AOCC end case TY_HOLL: datatypexref[dtype] = DT_HOLL; break; @@ -2007,8 +2019,8 @@ read_symbol(void) int val[4], namelen, i, dpdsc, inmod; /* flags: */ int addrtkn, adjustable, afterentry, altname, altreturn, aret, argument, - assigned, assumedshape, assumedsize, autoarray, blank, Cfunc, ccsym, clen, - cmode, common, constant, count, currsub, decl; + assigned, assumedrank, assumedshape, assumedsize, autoarray, blank, Cfunc, + ccsym, clen, cmode, common, constant, count, currsub, decl; SPTR descriptor; int intentin, texture, device, dll, dllexportmod, enclfunc, end, endlab, format, func, gsame, gdesc, hccsym, hollerith, init, isdesc, linenum; @@ -2075,6 +2087,7 @@ read_symbol(void) case ST_STRUCT: case ST_UNION: case ST_VAR: + linenum = getval("lineno"); addrtkn = getbit("addrtaken"); argument = getbit("argument"); /* + */ assigned = getbit("assigned"); @@ -2130,6 +2143,7 @@ read_symbol(void) if (stype == ST_ARRAY) { adjustable = getbit("adjustable"); afterentry = getbit("afterentry"); + assumedrank = getbit("assumedrank"); assumedshape = getbit("assumedshape"); /* + */ assumedsize = getbit("assumedsize"); autoarray = getbit("autoarray"); @@ -2296,6 +2310,7 @@ read_symbol(void) } ORIGDIMP(newsptr, origdim); if (stype == ST_ARRAY) { + ASSUMRANKP(newsptr, assumedrank); ASSUMSHPP(newsptr, assumedshape); ASUMSZP(newsptr, assumedsize); ADJARRP(newsptr, adjustable); @@ -2360,6 +2375,7 @@ read_symbol(void) } INTENTINP(newsptr, intentin); ALLOCATTRP(newsptr, allocattr); + LINENOP(newsptr, linenum); if (flg.debug && has_alias) save_modvar_alias(newsptr, alias_name); break; @@ -2506,6 +2522,23 @@ read_symbol(void) val[3] = gethex(); newsptr = getcon(val, dtype); break; + // AOCC begin + case TY_QCMPLX: + val[0] = getval("sym"); + val[1] = getval("sym"); + val[2] = getval("sym"); + val[3] = getval("sym"); + /* always add a new symbol; don't use getcon() + * because the symbol pointers have not been resolved yet */ + newsptr = newsymbol(); + CONVAL1P(newsptr, val[0]); + CONVAL2P(newsptr, val[1]); + CONVAL3P(newsptr, val[0]); + CONVAL4P(newsptr, val[1]); + STYPEP(newsptr, ST_CONST); + DTYPEP(newsptr, dtype); + break; + // AOCC end case TY_PTR: val[0] = getval("sym"); address = getval("offset"); @@ -2840,9 +2873,14 @@ read_symbol(void) break; case ST_PARAM: + linenum = getval("lineno"); decl = getbit("decl"); /* + */ Private = getbit("private"); /* + */ ref = getbit("ref"); + Scope = getval("scope"); + if (Scope) { + Scope = symbolxref[Scope]; + } if (TY_ISWORD(DTY(dtype))) { val[0] = getval("val"); } else { @@ -2851,11 +2889,13 @@ read_symbol(void) newsptr = get_or_create_symbol(sptr); + LINENOP(newsptr, linenum); STYPEP(newsptr, stype); SCP(newsptr, sclass); DTYPEP(newsptr, dtype); REFP(newsptr, ref); + SCOPEP(newsptr, Scope); CONVAL1P(newsptr, val[0]); break; @@ -3796,6 +3836,18 @@ fix_symbol(void) val = CONVAL2G(sptr); CONVAL2P(sptr, symbolxref[val]); break; + // AOCC begin + case TY_QCMPLX: + val = CONVAL1G(sptr); + CONVAL1P(sptr, symbolxref[val]); + val = CONVAL2G(sptr); + CONVAL2P(sptr, symbolxref[val]); + val = CONVAL3G(sptr); + CONVAL2P(sptr, symbolxref[val]); + val = CONVAL4G(sptr); + CONVAL2P(sptr, symbolxref[val]); + break; + // AOCC end case TY_PTR: val = CONVAL1G(sptr); CONVAL1P(sptr, symbolxref[val]); @@ -3955,6 +4007,7 @@ fix_symbol(void) int parsptr = up->vals[i]; parsptr = symbolxref[parsptr]; up->vals[i] = parsptr; + up->orig_vals[i] = parsptr; // AOCC } if (up->parent) { up->parent = symbolxref[up->parent]; @@ -6500,6 +6553,8 @@ lookup_modvar_alias(SPTR sptr) return NULL; } +SPTR get_symbol_start(void) { return (SPTR)(oldsymbolcount + 1); } + /** \brief Given a alias name of a mod var sptr, create a new alias_syminfo node and add it to the linked list for later lookup. diff --git a/tools/flang2/flang2exe/upper.h b/tools/flang2/flang2exe/upper.h index 703c616a50..da90701f03 100644 --- a/tools/flang2/flang2exe/upper.h +++ b/tools/flang2/flang2exe/upper.h @@ -5,6 +5,13 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights + * reserved. Notified per clause 4(b) of the license. + * + * Last modified: June 2020 + */ + #ifndef UPPER_H_ #define UPPER_H_ @@ -278,4 +285,9 @@ void upper_save_syminfo(void); */ const char *lookup_modvar_alias(SPTR sptr); +/** + \brief return start symbol SPTR + */ +SPTR get_symbol_start(void); + #endif // UPPER_H_ diff --git a/tools/flang2/flang2exe/verify.cpp b/tools/flang2/flang2exe/verify.cpp index 936bad8a3b..69f91acac5 100644 --- a/tools/flang2/flang2exe/verify.cpp +++ b/tools/flang2/flang2exe/verify.cpp @@ -4,6 +4,14 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ #include "gbldefs.h" #include "error.h" @@ -263,6 +271,11 @@ verify_ili_ad_hoc(int ilix) case IL_STDP: VERIFY(ILI_OPND(ilix, 4) == MSZ_F8, "4th operand to STDP must be MSZ_F8"); break; + // AOCC begin + case IL_STQP: + VERIFY(ILI_OPND(ilix, 4) == MSZ_F16, "4th operand to STDP must be MSZ_F16"); + break; + // AOCC end #ifdef IL_STSPSP case IL_STSPSP: { ILI_OP opc1 = ILI_OPC(ILI_OPND(ilix, 1)); diff --git a/tools/flang2/flang2exe/x86_64-Linux/flgdf.h b/tools/flang2/flang2exe/x86_64-Linux/flgdf.h index f204ed1c6c..5a0961c695 100644 --- a/tools/flang2/flang2exe/x86_64-Linux/flgdf.h +++ b/tools/flang2/flang2exe/x86_64-Linux/flgdf.h @@ -61,6 +61,8 @@ FLG flg = { false, /* omptarget - don't allow OpenMP Offload directives */ 25, /* errorlimit */ false, /* trans_inv */ + 64, /* Warp size for target */ + NULL, /* Arch of the omp target */ #ifdef TARGET_X86 0, /* tpcount */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* tpvalue */ diff --git a/tools/flang2/flang2exe/x86_64-Linux/ll_abi.cpp b/tools/flang2/flang2exe/x86_64-Linux/ll_abi.cpp index 98132f9892..5fbf1eebdb 100644 --- a/tools/flang2/flang2exe/x86_64-Linux/ll_abi.cpp +++ b/tools/flang2/flang2exe/x86_64-Linux/ll_abi.cpp @@ -3,6 +3,11 @@ * See https://llvm.org/LICENSE.txt for license information. * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added TY_QUAD to update class + * Date of Modification: 18th July 2020 */ /* ll_abi.c - Lowering x86-64 function calls to LLVM IR. */ @@ -129,7 +134,7 @@ amd64_update_class(void *context, DTYPE dtype, unsigned address, return retval; } - if (size <= 8) { + if (size <= 8 || DTY(dtype) == TY_QUAD) { //AOCC bool is_ptr = DTY(dtype) == TY_PTR; enum amd64_class cls = AMD64_MEMORY; if (DT_ISINT(dtype) || is_ptr) @@ -158,6 +163,7 @@ amd64_update_class(void *context, DTYPE dtype, unsigned address, cls[1] = AMD64_INTEGER; break; + case TY_QCMPLX: // AOCC case TY_DCMPLX: cls[0] = AMD64_SSE; cls[1] = AMD64_SSE; diff --git a/tools/flang2/flang2exe/x86_64-Linux/machreg.h b/tools/flang2/flang2exe/x86_64-Linux/machreg.h index 6894bf4ad1..e1aa24672f 100644 --- a/tools/flang2/flang2exe/x86_64-Linux/machreg.h +++ b/tools/flang2/flang2exe/x86_64-Linux/machreg.h @@ -4,6 +4,14 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ #ifndef MACHREG_H_ #define MACHREG_H_ @@ -310,6 +318,10 @@ extern char *opmask_reg[N_OPMASK_REGS + 1]; /* OPMASK_REG_NAMES */ #define DP_RETVAL XR_XMM0 #define CS_RETVAL XR_XMM0 #define CD_RETVAL XR_XMM0 +//AOCC Begin +#define QP_RETVAL XR_XMM0 +#define CQ_RETVAL XR_XMM0 +//AOCC End #define IR_RETVAL IR_RAX #define AR_RETVAL IR_RAX @@ -349,8 +361,10 @@ extern int mr_res_xr[MR_MAX_XREG_RES]; #define IR(i) ARG_IR(i) #define SP(i) ARG_XR(i) #define DP(i) ARG_XR(i) +#define QP(i) ARG_XR(i) // AOCC: 128 bit #define ISP(i) (i + 100) /* not used? */ #define IDP(i) (i + 100) +#define IQP(i) (i + 100) /* Macro for defining alternate-return register for fortran subprograms. */ diff --git a/tools/flang2/utils/ilitp/aarch64/ilitp.n b/tools/flang2/utils/ilitp/aarch64/ilitp.n index 9cbeffcaf2..1383d0f298 100644 --- a/tools/flang2/utils/ilitp/aarch64/ilitp.n +++ b/tools/flang2/utils/ilitp/aarch64/ilitp.n @@ -4,6 +4,15 @@ .\" * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception .\" * .\" */ +.\"/* +.\" * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +.\" * Notified per clause 4(b) of the license. +.\" * +.\" * Added support for cotan and cotand intrinsics +.\" * Modified on Oct 2020 +.\" * +.\" * Last Modified: May 2020 +.\" */ .NS 13 "X86-32 ILI Definitions" .sh 2 "Key to ILI Template Listing" .lp @@ -600,6 +609,16 @@ Double-precision tangent. .AT arth null dp cse .CG notCG +.IL FCOTAN splnk +Single-precision floating-point tangent. +.AT arth null sp cse +.CG notCG + +.IL DCOTAN dplnk +Double-precision tangent. +.AT arth null dp cse +.CG notCG + .IL FLOG splnk Single-precision floating-point natural logarithm. .AT arth null sp cse @@ -792,6 +811,16 @@ Double-precision complex exponential. .AT arth null cd cse .CG notCG +.IL SCMPLXABS cslnk +Single-precision complex abs. +.AT arth null cs cse +.CG notCG + +.IL DCMPLXABS cdlnk +Double-precision complex abs. +.AT arth null cd cse +.CG notCG + .IL SCMPLXCOS cslnk Single-precision complex cosine. .AT arth null cs cse @@ -822,6 +851,16 @@ Double-precision complex tangent. .AT arth null cd cse .CG notCG +.IL SCMPLXCOTAN cslnk +Single-precision complex tangent. +.AT arth null cs cse +.CG notCG + +.IL DCMPLXCOTAN cdlnk +Double-precision complex tangent. +.AT arth null cd cse +.CG notCG + .IL SCMPLXACOS cslnk Single-precision complex arccosine. .AT arth null cs cse @@ -1874,12 +1913,12 @@ This ili should have been replaced before code generator. .AT arth null ir cse .CG notCG -.IL SHIFTA irlnk arlnk +.IL SHIFTB irlnk arlnk Shift op1 logically by op2. Left if op2 is > 0; else right. .AT arth null ir cse .CG notCG -.IL USHIFTA irlnk arlnk +.IL USHIFTB irlnk arlnk Unsigned shift op1 logically by op2. Left if op2 is > 0; else right. .AT arth null ir cse .CG notCG @@ -1904,6 +1943,12 @@ Shift left immediate of 64-bit value. .AT arth null kr cse .CG notAILI 'q' +.IL SHIFTA irlnk irlnk +Shift op1 arithmetically (sign extended) right by op2. +Used for right shifts (>> operator) of signed values. +.AT arth null ir cse +.CG memdest ccarith shiftop asm_special "sar" 'l' + .IL RSHIFT irlnk irlnk Shift op1 logically right by op2 (sign extended). .AT arth null ir cse @@ -1951,6 +1996,22 @@ The value, 0 or 1, of the second operand indicates .AT arth null kr cse .CG "lzcnt" 'q' +.IL ITRAILZI irlnk stc +8-/16- bit integer TRAILZ intrinsic. +The value, 0 or 1, of the second operand indicates +8-bit or 16-bit, respectively. +.AT arth null ir cse + +.IL ITRAILZ irlnk +32-bit integer TRAILZ intrinsic. +.AT arth null ir cse +.CG "tzcnt" 'l' + +.IL KTRAILZ krlnk +64-bit integer TRAILZ intrinsic. +.AT arth null kr cse +.CG "tzcnt" 'q' + .IL IPOPCNTI irlnk stc 8-/16- bit integer POPCNT intrinsic. The value of second operand indicates 8-bit if 0 and 16-bit diff --git a/tools/flang2/utils/ilitp/ilitp.cpp b/tools/flang2/utils/ilitp/ilitp.cpp index ae4d40b263..39e3de28bd 100644 --- a/tools/flang2/utils/ilitp/ilitp.cpp +++ b/tools/flang2/utils/ilitp/ilitp.cpp @@ -3,6 +3,15 @@ * See https://llvm.org/LICENSE.txt for license information. * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * + * + */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * */ /* ilitp.cpp - for ILI generation. @@ -61,8 +70,8 @@ struct processed_flags { // delivers the expansion of a line as a group of consecutive lines. std::vector processed; -/*static*/ ILIINFO ilis[1050]; /* declared external in ili.h */ -SCHINFO schinfo[1050]; +/*static*/ ILIINFO ilis[2050]; /* declared external in ili.h */ +SCHINFO schinfo[2050]; // AOCC: changed value from 1050 to 2050 static void do_IL_line(int pass); static void do_AT_line(void); diff --git a/tools/flang2/utils/ilitp/ppc64le/ilitp.n b/tools/flang2/utils/ilitp/ppc64le/ilitp.n index 062f54bc91..706a60484f 100644 --- a/tools/flang2/utils/ilitp/ppc64le/ilitp.n +++ b/tools/flang2/utils/ilitp/ppc64le/ilitp.n @@ -4,6 +4,14 @@ .\" * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception .\" * .\" */ +.\"/* +.\" * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +.\" * Notified per clause 4(b) of the license. +.\" * +.\" * +.\" * Added support for cotan and cotand intrinsics +.\" * Modified on Oct 2020 +.\" */ .NS 13 "Power ILI Definitions" .sh 2 "Key to ILI Template Listing" .lp @@ -599,6 +607,16 @@ Double-precision tangent. .AT arth null dp cse .CG notCG +.IL FCOTAN splnk +Single-precision floating-point tangent. +.AT arth null sp cse +.CG notCG + +.IL DCOTAN dplnk +Double-precision tangent. +.AT arth null dp cse +.CG notCG + .IL FLOG splnk Single-precision floating-point natural logarithm. .AT arth null sp cse @@ -789,6 +807,15 @@ Double-precision complex exponential. .AT arth null cd cse .CG notCG +.IL SCMPLXABS cslnk +Single-precision complex abs. +.AT arth null cs cse +.CG notCG + +.IL DCMPLXABS cdlnk +Double-precision complex abs. +.AT arth null cd cse +.CG notCG .IL SCMPLXCOS cslnk Single-precision complex cosine. .AT arth null cs cse @@ -819,6 +846,16 @@ Double-precision complex tangent. .AT arth null cd cse .CG notCG +.IL SCMPLXCOTAN cslnk +Single-precision complex tangent. +.AT arth null cs cse +.CG notCG + +.IL DCMPLXCOTAN cdlnk +Double-precision complex tangent. +.AT arth null cd cse +.CG notCG + .IL SCMPLXACOS cslnk Single-precision complex arccosine. .AT arth null cs cse @@ -1871,12 +1908,12 @@ This ili should have been replaced before code generator. .AT arth null ir cse .CG notCG -.IL SHIFTA irlnk arlnk +.IL SHIFTB irlnk arlnk Shift op1 logically by op2. Left if op2 is > 0; else right. .AT arth null ir cse .CG notCG -.IL USHIFTA irlnk arlnk +.IL USHIFTB irlnk arlnk Unsigned shift op1 logically by op2. Left if op2 is > 0; else right. .AT arth null ir cse .CG notCG @@ -1901,6 +1938,12 @@ Shift left immediate of 64-bit value. .AT arth null kr cse .CG notAILI 'q' +.IL SHIFTA irlnk irlnk +Shift op1 arithmetically (sign extended) right by op2. +Used for right shifts (>> operator) of signed values. +.AT arth null ir cse +.CG memdest ccarith shiftop asm_special "sar" 'l' + .IL RSHIFT irlnk irlnk Shift op1 logically right by op2 (sign extended). .AT arth null ir cse @@ -1948,6 +1991,22 @@ The value, 0 or 1, of the second operand indicates .AT arth null kr cse .CG "lzcnt" 'q' +.IL ITRAILZI irlnk stc +8-/16- bit integer TRAILZ intrinsic. +The value, 0 or 1, of the second operand indicates +8-bit or 16-bit, respectively. +.AT arth null ir cse + +.IL ITRAILZ irlnk +32-bit integer TRAILZ intrinsic. +.AT arth null ir cse +.CG "tzcnt" 'l' + +.IL KTRAILZ krlnk +64-bit integer TRAILZ intrinsic. +.AT arth null kr cse +.CG "tzcnt" 'q' + .IL IPOPCNTI irlnk stc 8-/16- bit integer POPCNT intrinsic. The value of second operand indicates 8-bit if 0 and 16-bit diff --git a/tools/flang2/utils/ilitp/x86_64/ilitp.n b/tools/flang2/utils/ilitp/x86_64/ilitp.n index bcf347f262..191a83d6da 100644 --- a/tools/flang2/utils/ilitp/x86_64/ilitp.n +++ b/tools/flang2/utils/ilitp/x86_64/ilitp.n @@ -4,6 +4,16 @@ .\" * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception .\" * .\" */ +.\"/* +.\" * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +.\" * Notified per clause 4(b) of the license. +.\" * +.\" * Added code support for dasinh +.\" * Modified on 31st Aug 2020 +.\" * +.\" * Added support for cotan and cotand intrinsics +.\" * Modified on Oct 2020 +.\" */ .NS 13 "X86-64 ILI Definitions" .sh 2 "Key to ILI Template Listing" .lp @@ -46,6 +56,10 @@ integer register number (for x86-64, one of the general purpose registers). floating-point register number. .OP dp double-precision register. +.\" AOCC begin +.OP qp +quad-precision register. +.\" AOCC end .OP kr 64 bit integer register. .OP cs @@ -121,6 +135,10 @@ result goes into an integer register. result goes into a floating-point register. .RT dp double-precision floating-point. +.\" AOCC begin +.RT qp +quad-precision floating-point. +.\" AOCC end .RT ar address register result. .RT trm @@ -324,6 +342,16 @@ Double-precision floating-point constant. .SI st direct fst lat(2) .SI direct fadd fmul lat(2) +.\" AOCC begin +.IL QCON sym +Quad-precision floating-point constant. +.AT cons null qp cse +.CG "movsq" move avx_special +.SI ld quad fadd fmul fst lat(3) +.SI st direct fst lat(2) +.SI direct fadd fmul lat(2) +.\" AOCC end + .IL SCMPLXCON sym Single-precision complex constant. .AT cons null cs cse @@ -340,6 +368,16 @@ Double-precision complex constant. .SI st direct fst lat(2) .SI direct fadd fmul lat(2) +.\" AOCC begin +.IL QCMPLXCON sym +Quad-precision complex constant. +.AT cons null cq cse +.CG "movapq" move sse_avx +.SI ld quad fadd fmul fst lat(3) +.SI st direct fst lat(2) +.SI direct fadd fmul lat(2) +.\" AOCC end + .IL LD arlnk nme stc \'arlnk' points to an address expression. .br @@ -368,6 +406,16 @@ Load single-precision floating value. 'stc' is not used. .SI st direct lat(2) .SI direct lat(2) +.\" AOCC begin +.IL LDQP arlnk nme stc +Load quad precision value. 'stc' is not used. +.AT load null qp +.CG "movsq" move avx_special +.SI ld quad fadd fmul fst lat(3) +.SI st direct fst lat(2) +.SI direct fadd fmul lat(2) +.\" AOCC end + .IL LDDP arlnk nme stc Load double precision value. 'stc' is not used. .AT load null dp @@ -392,6 +440,16 @@ Load double precision complex value. 'stc' is not used. .SI st direct fst lat(2) .SI direct fadd fmul lat(2) +.\" AOCC begin +.IL LDQCMPLX arlnk nme stc +Load quad precision complex value. 'stc' is not used. +.AT load null cq +.CG "movupq" move sse_avx +.SI ld quad fadd fmul fst lat(3) +.SI st direct fst lat(2) +.SI direct fadd fmul lat(2) +.\" AOCC end + .IL LDQ arlnk nme stc Load an __m128 value. 'stc' is not used. .AT load null dp @@ -485,6 +543,14 @@ cgoptim1.c:lili_peephole_opts_2(). .AT arth null dp cse .CG notAILI +.\" AOCC begin +.IL QNEG qplnk +Real*16 negation. This LILI is replaced by a QXOR LILI in +cgoptim1.c:lili_peephole_opts_2(). +.AT arth null qp cse +.CG notAILI +.\" AOCC end + .IL SCMPLXNEG cslnk Complex*8 negation. This LILI is replaced by an SCMPLXXOR LILI in cgoptim1.c:lili_peephole_opts_2(). @@ -497,6 +563,14 @@ cgoptim1.c:lili_peephole_opts_2(). .AT arth null cd cse .CG notAILI +.\" AOCC begin +.IL QCMPLXNEG cqlnk +Complex*32 negation. This LILI is replaced by a QCMPLXXOR LILI in +cgoptim1.c:lili_peephole_opts_2(). +.AT arth null cq cse +.CG notAILI +.\" AOCC end + .IL FXOR splnk splnk This only appears in the LILIs and AILIs, not in shared ILIs. It is generated in cgoptim1.c:lili_peephole_opts_2() by transforming @@ -516,6 +590,18 @@ sign bit with 1. This ILI is specified as non-commutative .CG CGonly "xorpd" sse_avx .SI double fmul lat(5:3) +.\" AOCC begin +.IL QXOR qplnk qplnk +This only appears in the LILIs and AILIs, not in shared ILIs. It is +generated in cgoptim1.c:lili_peephole_opts_2() by transforming +QNEG( op1 ) into a QXOR LILI in order to negate 'op1' by XORing its +sign bit with 1. This ILI is specified as non-commutative +(i.e. 'null', not 'comm') for reasons explained in that function. +.AT arth null qp cse +.CG CGonly "xorpq" sse_avx +.SI quad fmul lat(5:3) +.\" AOCC end + .IL SCMPLXXOR cslnk cslnk This only appears in the LILIs and AILIs, not in shared ILIs. It is generated in cgoptim1.c:lili_peephole_opts_2() by transforming @@ -534,6 +620,17 @@ XORing its sign bits with 1. This ILI is specified as non-commutative .AT arth null cd cse .CG CGonly "xorpd" sse_avx +.\" AOCC begin +.IL QCMPLXXOR cqlnk cqlnk +This only appears in the LILIs and AILIs, not in shared ILIs. It is +generated in cgoptim1.c:lili_peephole_opts_2() by transforming +QCMPLXNEG( op1 ) into a QCMPLXXOR LILI in order to negate 'op1' by +XORing its sign bits with 1. This ILI is specified as non-commutative +(i.e. 'null', not 'comm') for reasons explained in that function. +.AT arth null cq cse +.CG CGonly "xorpq" sse_avx +.\" AOCC end + .IL SCMPLXCONJG cslnk Single-precision complex conjugate. .AT arth null cs cse @@ -544,6 +641,13 @@ Double-precision complex conjugate. .AT arth null cd cse .CG "xorpd" sse_avx asm_special +.\" AOCC begin +.IL QCMPLXCONJG cqlnk +Quad-precision complex conjugate. +.AT arth null cq cse +.CG "xorpq" sse_avx asm_special +.\" AOCC end + .IL IABS irlnk Integer absolute value. Expanded into shift-xor-sub sequence. .AT arth null ir cse @@ -574,6 +678,13 @@ Double precision absolute value. .AT arth null dp cse .CG notAILI +.\" AOCC begin +.IL QABS qplnk +quad precision absolute value. +.AT arth null qp cse +.CG notAILI +.\" AOCC end + .IL DAND dplnk dplnk This only appears in the LILIs and AILIs, not in shared ILIs. It is generated in cglinear.c:gen_lilis() by transforming a DABS( op1 ) ILI @@ -619,6 +730,13 @@ Double-precision square root. .CG "sqrtsd" avx_special .SI direct fmul lat(29:27) +.\" AOCC begin +.IL QSQRT qplnk +Quad-precision square root. +.AT arth null qp cse +.CG notAILI +.\" AOCC end + .IL FRSQRT splnk Single-precision floating-point reciprocal square root. 1.0/sqrt(x) -- will be replaced by the Newton's appx via the @@ -665,6 +783,11 @@ Double precision sine. Implemented as a function call. .AT arth null dp cse .CG notAILI +.IL QSIN qplnk +Quad precision sine. Implemented as a function call. +.AT arth null qp cse +.CG notAILI + .IL FNCOS splnk Utility ili: only referenced by the 'alt' field of an FCOS ili; always points to an FSINCOS ili. @@ -687,6 +810,11 @@ Double precision cosine. Implemented as library call. .AT arth null dp cse .CG notAILI +.IL QCOS qplnk +Real128 cosine. Implemented as library call. +.AT arth null qp cse +.CG notAILI + .IL FSINCOS splnk Used to implement SINCOS optimization (single precision). .AT arth null sp cse @@ -707,6 +835,21 @@ Double-precision tangent. .AT arth null dp cse .CG notCG +.IL QTAN qplnk +Quad-precision tangent. +.AT arth null qp cse +.CG notAILI + +.IL FCOTAN splnk +Single-precision floating-point tangent. +.AT arth null sp cse +.CG notCG + +.IL DCOTAN dplnk +Double-precision tangent. +.AT arth null dp cse +.CG notCG + .IL FLOG splnk Single-precision floating-point natural logarithm. .AT arth null sp cse @@ -717,6 +860,13 @@ Double-precision natural logarithm. .AT arth null dp cse .CG notCG +.\" AOCC begin +.IL QLOG qplnk +Quad-precision natural logarithm. +.AT arth null qp cse +.CG notCG +.\" AOCC end + .IL FLOG10 splnk Single-precision floating-point common logarithm. .AT arth null sp cse @@ -727,6 +877,13 @@ Double-precision common logarithm. .AT arth null dp cse .CG notCG +.\" AOCC begin +.IL QLOG10 qplnk +Quad-precision common logarithm. +.AT arth null qp cse +.CG notCG +.\" AOCC end + .IL FEXP splnk Single-precision floating-point exponential. .AT arth null sp cse @@ -737,6 +894,13 @@ Double-precision exponential. .AT arth null dp cse .CG notCG +.\" AOCC begin +.IL QEXP qplnk +Quad-precision exponential. +.AT arth null qp cse +.CG notCG +.\" AOCC end + .IL FACOS splnk Single-precision floating-point arccosine. .AT arth null sp cse @@ -747,6 +911,11 @@ Double-precision arccosine. .AT arth null dp cse .CG notCG +.IL QACOS qplnk +Qaud-precision arccosine. +.AT arth null qp cse +.CG notCG + .IL FASIN splnk Single-precision floating-point arcsine. .AT arth null sp cse @@ -757,6 +926,11 @@ Double-precision arcsine. .AT arth null dp cse .CG notCG +.IL QASIN qplnk +Qaud-precision arcsine. +.AT arth null qp cse +.CG notCG + .IL FATAN splnk Single-precision floating-point arctangent. .AT arth null sp cse @@ -767,6 +941,16 @@ Double-precision arctangent. .AT arth null dp cse .CG notCG +.IL QATAN qplnk +Qaud-precision arctangent. +.AT arth null qp cse +.CG notCG + +.IL QATAN2 qplnk qplnk +Qaud-precision arc2tangent. +.AT arth null qp cse +.CG notCG + .IL FATAN2 splnk splnk Single-precision floating-point two-argument arctangent. .AT arth null sp cse @@ -787,6 +971,21 @@ Double-precision hyperbolic sin .AT arth null dp cse .CG notCG +.IL DASINH dplnk +Double-precision hyperbolic asin +.AT arth null dp cse +.CG notCG + +.IL QSINH dplnk +Quad-precision hyperbolic sin +.AT arth null qp cse +.CG notCG + +.IL QASINH qplnk +Quad-precision hyperbolic arc sine +.AT arth null qp cse +.CG notCG + .IL FCOSH splnk Single-precision floating-point hyperbolic cos .AT arth null sp cse @@ -797,6 +996,16 @@ Double-precision hyperbolic cos .AT arth null dp cse .CG notCG +.IL QCOSH qplnk +Quad-precision hyperbolic cos +.AT arth null qp cse +.CG notCG + +.IL QACOSH qplnk +Quad-precision hyperbolic arc cos +.AT arth null qp cse +.CG notCG + .IL FTANH splnk Single-precision floating-point hyperbolic tan .AT arth null sp cse @@ -807,6 +1016,16 @@ Double-precision hyperbolic tan .AT arth null dp cse .CG notCG +.IL QTANH dplnk +Quad-precision hyperbolic tan +.AT arth null qp cse +.CG notCG + +.IL QATANH qplnk +Quad-precision hyperbolic arc tangent +.AT arth null qp cse +.CG notCG + .IL FNEWT splnk splnk splnk Single-precision floating-point multiply used for single divides. Not used by the x86-64 compilers. @@ -869,6 +1088,11 @@ Double dim. .AT arth null dp cse .CG notCG +.IL QDIM qplnk qplnk +QUAD dim. +.AT arth null qp cse +.CG notCG + .IL FFLOOR splnk Real FLOOR. .AT arth null sp cse @@ -879,6 +1103,13 @@ Double FLOOR. .AT arth null dp cse .CG "roundsd" sse_avx +.\" AOCC begin +.IL QFLOOR qplnk +Quad FLOOR. +.AT arth null qp cse +.CG "roundsd" sse_avx +.\" AOCC end + .IL FCEIL splnk Real CEILING. .AT arth null sp cse @@ -889,6 +1120,13 @@ Double CEILING. .AT arth null dp cse .CG "roundsd" sse_avx +.\" AOCC begin +.IL QCEIL qplnk +QUAD CEILING. +.AT arth null qp cse +.CG "roundsq" sse_avx +.\" AOCC end + .IL AINT splnk Single precision trunction. .AT arth null sp cse @@ -899,6 +1137,11 @@ Double precision trunction. .AT arth null dp cse .CG notAILI +.IL QINT qplnk +Quad precision trunction. +.AT arth null qp cse +.CG notAILI + .IL SCMPLXEXP cslnk Single-precision complex exponential. .AT arth null cs cse @@ -909,6 +1152,23 @@ Double-precision complex exponential. .AT arth null cd cse .CG notCG +.IL SCMPLXABS cslnk +Single-precision complex abs. +.AT arth null cs cse +.CG notCG + +.IL DCMPLXABS cdlnk +Double-precision complex abs. +.AT arth null cd cse +.CG notCG + +.\" AOCC begin +.IL QCMPLXEXP cqlnk +Quad-precision complex exponential. +.AT arth null cq cse +.CG notCG +.\" AOCC end + .IL SCMPLXCOS cslnk Single-precision complex cosine. .AT arth null cs cse @@ -919,6 +1179,13 @@ Double-precision complex cosine. .AT arth null cd cse .CG notCG +./" AOCC begin +.IL QCMPLXCOS cqlnk +Quad-precision complex cos. +.AT arth null cq cse +.CG notCG +./" AOCC end + .IL SCMPLXSIN cslnk Single-precision complex sine. .AT arth null cs cse @@ -929,6 +1196,13 @@ Double-precision complex sine. .AT arth null cd cse .CG notCG +./" AOCC begin +.IL QCMPLXSIN cqlnk +Quad-precision complex sine. +.AT arth null cq cse +.CG notCG +./" AOCC end + .IL SCMPLXTAN cslnk Single-precision complex tangent. .AT arth null cs cse @@ -939,6 +1213,30 @@ Double-precision complex tangent. .AT arth null cd cse .CG notCG +./" AOCC begin +.IL QCMPLXTAN cqlnk +Quad-precision complex tangent. +.AT arth null cq cse +.CG notCG +./" AOCC end + +.IL SCMPLXCOTAN cslnk +Single-precision complex tangent. +.AT arth null cs cse +.CG notCG + +.IL DCMPLXCOTAN cdlnk +Double-precision complex tangent. +.AT arth null cd cse +.CG notCG + +./" AOCC begin +.IL QCMPLXCOTAN cqlnk +Quad-precision complex tangent. +.AT arth null cq cse +.CG notCG +./" AOCC end + .IL SCMPLXACOS cslnk Single-precision complex arccosine. .AT arth null cs cse @@ -949,6 +1247,18 @@ Double-precision complex arccosine. .AT arth null cd cse .CG notCG +./" AOCC begin +.IL QCMPLXACOS cqlnk +Quad-precision complex arccosine. +.AT arth null cq cse +.CG notCG + +.IL QCMPLXACOSH cqlnk +Quad-precision complex arccosine. +.AT arth null cq cse +.CG notCG +./" AOCC end + .IL SCMPLXASIN cslnk Single-precision complex arcsine. .AT arth null cs cse @@ -959,6 +1269,18 @@ Double-precision complex arcsine. .AT arth null cd cse .CG notCG +./" AOCC begin +.IL QCMPLXASIN cqlnk +Quad-precision complex arcsine. +.AT arth null cq cse +.CG notCG + +.IL QCMPLXASINH cqlnk +Quad-precision complex arcsine. +.AT arth null cq cse +.CG notCG +./" AOCC end + .IL SCMPLXATAN cslnk Single-precision complex arctangent. .AT arth null cs cse @@ -969,6 +1291,23 @@ Double-precision complex arctangent. .AT arth null cd cse .CG notCG +./" AOCC begin +.IL QCMPLXATAN cqlnk +Quad-precision complex arctangent. +.AT arth null cq cse +.CG notCG + +.IL QCMPLXATAN2 cqlnk cqlnk +Quad-precision complex arc2tangent. +.AT arth null cq cse +.CG notCG + +.IL QCMPLXATANH cqlnk +Quad-precision complex arctangent. +.AT arth null cq cse +.CG notCG +./" AOCC end + .IL SCMPLXCOSH cslnk Single-precision complex hyperbolic cos. .AT arth null cs cse @@ -979,6 +1318,13 @@ Double-precision complex hyperbolic cos. .AT arth null cd cse .CG notCG +./" AOCC begin +.IL QCMPLXCOSH cqlnk +Quad-precision complex hyperbolic cos. +.AT arth null cq cse +.CG notCG +./" AOCC end + .IL SCMPLXSINH cslnk Single-precision complex hyperbolic sin. .AT arth null cs cse @@ -989,6 +1335,13 @@ Double-precision complex hyperbolic sin. .AT arth null cd cse .CG notCG +./" AOCC begin +.IL QCMPLXSINH cqlnk +Quad-precision complex hyperbolic sin. +.AT arth null cq cse +.CG notCG +./" AOCC end + .IL SCMPLXTANH cslnk Single-precision complex hyperbolic tan. .AT arth null cs cse @@ -999,6 +1352,13 @@ Double-precision complex hyperbolic tan. .AT arth null cd cse .CG notCG +./" AOCC begin +.IL QCMPLXTANH cqlnk +Quad-precision complex hyperbolic tan. +.AT arth null cq cse +.CG notCG +./" AOCC end + .IL SCMPLXLOG cslnk Single-precision complex natural logarithm. .AT arth null cs cse @@ -1009,6 +1369,13 @@ Double-precision complex natural logarithm. .AT arth null cd cse .CG notCG +./" AOCC begin +.IL QCMPLXLOG cqlnk +Quad-precision complex natural logarithm. +.AT arth null cq cse +.CG notCG +./" AOCC end + .IL SCMPLXSQRT cslnk Single-precision complex square root. .AT arth null cs cse @@ -1019,6 +1386,13 @@ Double-precision complex square root. .AT arth null cd cse .CG notCG +./" AOCC begin +.IL QCMPLXSQRT cqlnk +Quad-precision complex square root. +.AT arth null cq cse +.CG notCG +./" AOCC end + .IL SCMPLXPOW cslnk cslnk Single-precision complex raised to a single-precision complex power. .AT arth null cs cse @@ -1029,6 +1403,13 @@ Double-precision complex raised to a double-precision complex power. .AT arth null cd cse .CG notCG +.\"AOCC begin +.IL QCMPLXPOW cqlnk cqlnk +Quad-precision complex raised to a quad-precision complex power. +.AT arth null cq cse +.CG notCG +.\"AOCC end + .IL SCMPLXPOWI cslnk irlnk Single-precision complex raised to an integer power. .AT arth null cs cse @@ -1039,6 +1420,13 @@ Double-precision complex raised to an integer power. .AT arth null cd cse .CG notCG +.\"AOCC begin +.IL QCMPLXPOWI cqlnk cqlnk +Quad-precision complex raised to an integer power. +.AT arth null cq cse +.CG notCG +.\"AOCC end + .IL SCMPLXPOWK cslnk krlnk Single-precision complex raised to an integer power. .AT arth null cs cse @@ -1049,6 +1437,13 @@ Double-precision complex raised to an integer power. .AT arth null cd cse .CG notCG +.\"AOCC begin +.IL QCMPLXPOWK cqlnk cqlnk +Quad-precision complex raised to an integer power. +.AT arth null cq cse +.CG notCG +.\"AOCC end + .\" .\" Start of type conversion ILIs. .\" @@ -1363,6 +1758,33 @@ into real*8 values in 'xmm2'. .CG terminal notAILI +.\" AOCC begin +.IL QFLOAT irlnk +Integer*4 to real*16 type conversion. +.AT arth null qp cse +.CG "cvtsi2sq" 'l' sse_avx asm_special +.SI ld direct fst lat(6) +.SI quad fst lat(11) + +.IL QFLOATK krlnk +Integer*8 to real*16 type conversion. +.AT arth null qp cse +.CG "cvtsi2sq" 'q' avx_special +.SI ld direct fst lat(6) +.SI quad fst lat(11) + +.IL QFLOATUK krlnk +Unsigned integer*8 to real*16 type conversion. +.AT arth null qp cse +.CG notAILI + +.IL QFLOATU irlnk +Unsigned integer*4 to real*16 type conversion. +Equivalent to UIKMV + QFLOATK combination. +.AT arth null qp cse +.CG notCG +.\" AOCC end + .IL FIX splnk Real*4 to integer*4 type conversion. .AT arth null ir cse @@ -1413,6 +1835,21 @@ KIMV combination. .AT arth null ir cse .CG notCG +./" AOCC begin +.IL QFIX qplnk +Real*16 to integer*4 type conversion. +.AT arth null ir cse +.CG "cvttsq2si" 'l' sse_avx asm_special +.SI quad fst lat(9) +.SI ld vector fadd fmul fstore lat(10) + +.IL QFIXU qplnk +Real*16 to unsigned integer*4 type conversion. Equivalent to QFIXK + +KIMV combination. +.AT arth null ir cse +.CG notCG +./" AOCC end + .IL PDFIX arlnk xmm nme Convert 2 real*8 values from 'arlnk' into 2 integer*4 values in the low half of 'xmm'. @@ -1438,6 +1875,19 @@ Real*8 to unsigned integer*8 type conversion. Implemented as a QJSR. .AT arth null kr cse .CG notCG +./" AOCC begin +.IL QFIXK dplnk +Real*16 to to integer*8 type conversion. +.AT arth null kr cse +.CG "cvttsq2si" 'q' sse_avx asm_special +.SI quad fst lat(9) +.SI ld vector fadd fmul fstore lat(10) + +.IL QFIXUK qplnk +Real*16 to unsigned integer*8 type conversion. Implemented as a QJSR. +.AT arth null kr cse +.CG notCG +./" AOCC end .IL SNGL dplnk Real*8 to real*4 type conversion. @@ -1458,6 +1908,29 @@ half of 'xmm2'. .CG terminal "cvtpd2ps" avx_special .SI vector lat(8) +.\" AOCC begin +.IL QUAD qplnk +Real*8 to real*16 type conversion. +.AT arth null qp cse +.CG "cvtss2sd" avx_special + +.IL PQUAD arlnk xmm nme +Convert 'N' packed real*8 values from 'arlnk' into 'N' packed real*16 +values in 'xmm', where 'N' is 2, 4, 8, 16 if 'xmm' is an xmm (>= SSE2), +ymm (>= AVX) or zmm (AVX-512F) register respectively. +.AT other null trm ssenme +.CG terminal "cvtps2pq" ssedp sse_avx +.SI quad lat(5) + +.IL PQUADX xmm xmm +Convert 'N' packed real*8 values from 'xmm1' (an xmm or ymm register) +into 'N' packed real*16 values in 'xmm2' (an xmm, ymm or zmm register), +where 'N' is 2, 4 , 8 or 16 if 'xmm' is an xmm (>= SSE2), ymm (>= AVX) or +zmm (AVX-512F) register respectively. +.AT other null trm +.CG terminal "cvtps2pd" ssedp avx_special +.SI quad lat(3) +.\" AOCC end .IL DBLE splnk Real*4 to real*8 type conversion. @@ -1519,6 +1992,14 @@ Not used. .AT arth null kr .CG notCG +.\" AOCC begin +.IL QP2KR qplnk +Copy a real*16 value from an 'xmm' register to a 'gp' register without +type conversion. +.AT arth null kr +.CG 'q' sse_avx asm_special +.\" AOCC end + .IL DP2KR dplnk Copy a real*8 value from an 'xmm' register to a 'gp' register without type conversion. @@ -1574,6 +2055,14 @@ Single-precision floating-point addition. .CG "addss" sse_avx .SI fadd double lat(6:4) +.\" AOCC begin +.IL QADD qplnk qplnk +Quad-precision floating-point addition. +.AT arth comm qp cse +.CG "addsq" sse_avx +.SI fadd direct lat(6:4) +.\" AOCC end + .IL DADD dplnk dplnk Double-precision floating-point addition. .AT arth comm dp cse @@ -1592,6 +2081,14 @@ Double-precision complex addition. .CG "addpd" sse_avx .SI double fadd lat(5:7) +.\" AOCC begin +.IL QCMPLXADD cqlnk cqlnk +Quad-precision complex addition. +.AT arth comm cq cse +.CG "addpq" sse_avx +.SI quad fadd lat(5:7) +.\" AOCC end + .IL ISUB irlnk irlnk Signed 32-bit integer subtraction. .AT arth null ir cse @@ -1633,6 +2130,14 @@ Single-precision floating-point subtraction - operands reversed .AT arth null sp cse .CG notCG +.\" AOCC begin +.IL QSUB qplnk qplnk +Quad-precision floating-point subtraction. +.AT arth null qp cse +.CG "subsd" sse_avx +.SI direct fadd lat(6:4) +.\" AOCC end + .IL DSUB dplnk dplnk Double-precision floating-point subtraction. .AT arth null dp cse @@ -1651,6 +2156,14 @@ Double-precision complex subtraction. .CG "subpd" sse_avx .SI double fadd lat(7:5) +./" AOCC begin +.IL QCMPLXSUB cqlnk cqlnk +Quad-precision complex subtraction. +.AT arth null cq cse +.CG "subpd" sse_avx +.SI quad fadd lat(7:5) +./" AOCC end + .IL IMUL irlnk irlnk Integer Multiply. It'a a bug to give this opcode the 'cc' attribute. .AT arth comm ir cse @@ -1709,6 +2222,14 @@ Double-precision multiply. .CG "mulsd" sse_avx .SI direct fmul lat(6:4) +.\" AOCC begin +.IL QMUL qplnk qplnk +Quad-precision multiply. +.AT arth comm qp cse +.CG "mulsq" sse_avx +.SI direct fmul lat(10:8) +.\" AOCC end + .IL SCMPLXMUL cslnk cslnk Single-complex multiply. .AT arth comm cs cse @@ -1719,6 +2240,13 @@ Double-complex multiply. .AT arth comm cd cse .CG sse_avx asm_special +./" AOCC begin +.IL QCMPLXMUL cqlnk cqlnk +Quad-complex multiply. +.AT arth comm cq cse +.CG sse_avx asm_special +./" AOCC end + .IL IDIV irlnk irlnk Signed integer divide. .AT arth null ir cse @@ -1819,6 +2347,14 @@ Double divide. .CG "divsd" sse_avx .SI direct fmul lat(22:20) +.\" AOCC begin +.IL QDIV qplnk qplnk +Quad divide. +.AT arth null qp cse +.CG "divsq" sse_avx +.SI direct fmul lat(22:20) +.\" AOCC end + .IL SCMPLXDIV cslnk cslnk Single precision complex divide. .AT arth null cs cse @@ -1829,6 +2365,13 @@ Double precision complex divide. .AT arth null cd cse .CG "divpd" sse_avx +.\" AOCC begin +.IL QCMPLXDIV cqlnk cqlnk +Quad precision complex divide. +.AT arth null cq cse +.CG "divpq" sse_avx +.\" AOCC end + .IL MOD irlnk irlnk Integer remainder. .AT arth null ir cse @@ -1899,6 +2442,13 @@ Double-precision mod. .AT arth null dp cse .CG notCG +.\" AOCC begin +.IL QMOD qplnk qplnk +Quad-precision mod. +.AT arth null qp cse +.CG notCG +.\" AOCC end + .IL IMAX irlnk irlnk Integer maximum value. Expanded in-line by Code Generator. .AT arth comm ir cse @@ -1963,6 +2513,22 @@ Double precison minimum. .CG "minsd" sse_avx .SI direct fadd lat(4:2) +.\" AOCC begin +.IL QMAX qplnk qplnk +Quad precision maximum. +.AT arth comm qp cse +.CG "maxsq" sse_avx +.SI direct fadd lat(4:2) +.\" AOCC end + +.\" AOCC begin +.IL QMIN qplnk qplnk +QUAD precison minimum. +.AT arth comm qp cse +.CG "minsq" sse_avx +.SI direct fadd lat(4:2) +.\" AOCC end + .IL JN irlnk splnk float bessel_jn .AT arth null sp cse @@ -1973,6 +2539,11 @@ double bessel_jn .AT arth null dp cse .CG notCG +.IL QJN irlnk qplnk +QUAD bessel_jn +.AT arth null qp cse +.CG notCG + .IL YN irlnk splnk float bessel_yn .AT arth null sp cse @@ -1983,6 +2554,11 @@ double bessel_yn .AT arth null dp cse .CG notCG +.IL QYN irlnk qplnk +QUAD bessel_yn +.AT arth null qp cse +.CG notCG + .IL DFMA dplnk dplnk dplnk This opcode is only used in AILIs, not shared or linear ILIs. It represents a scalar double-precision FMA3 or FMA4 instruction which @@ -2049,6 +2625,11 @@ Double raised to a double power. .AT arth null dp cse .CG notCG +.IL QPOWI qplnk irlnk +QUAD raised to a integer power. +.AT arth null qp cse +.CG notCG + .IL ICMP irlnk irlnk stc Integer compare with result of true or false. For C the value of true is 1, and for Fortran, -1. @@ -2095,6 +2676,19 @@ Double precision compare with result of true or false. .CG asm_special "ucomisd" ccmod sse_avx .SI vector fadd lat(5:4) +.\" AOCC begin +.IL QPOWQ qplnk qplnk +Quad raised to a quad power. +.AT arth null qp cse +.CG notCG + +.IL QCMP qplnk qplnk stc +Quad precision compare with result of true or false. +.AT arth null ir cse +.CG asm_special "ucomisq" ccmod sse_avx +.SI vector fadd lat(5:4) +.\" AOCC end + .IL SCMPLXCMP dplnk dplnk stc Single precision complex compare with result of true or false. .AT arth comm ir cse @@ -2107,6 +2701,14 @@ Double precision complex compare with result of true or false. .CG asm_special "ucomisd" ccmod sse_avx .SI vector fadd lat(5:4) +./" AOCC begin +.IL QCMPLXCMP qplnk qplnk stc +QUad precision complex compare with result of true or false. +.AT arth comm ir cse +.CG asm_special "ucomisd" ccmod sse_avx +.SI vector fadd lat(5:4) +./" AOCC end + .IL ICMPZ irlnk stc Integer compare with zero. Conditions are same as ICJMP ILI. @@ -2141,11 +2743,33 @@ Single float compare with zero; result is TRUE or FALSE. .AT arth null ir cse .CG notCG +.IL FCMPZNZ splnk stc +Single float compare with zero which distinguishes negative zero; result is TRUE or FALSE. +.AT arth null ir cse +.CG notCG + .IL DCMPZ dplnk stc Double precision compare with zero. .AT arth null ir cse .CG notCG +.\" AOCC begin +.IL QCMPZ qplnk stc +Quad precision compare with zero. +.AT arth null ir cse +.CG notCG + +.IL QCMPZNZ qplnk stc +Quad precision compare with zero which distinguishes negative zero. +.AT arth null ir cse +.CG notCG +.\" AOCC end + +.IL DCMPZNZ dplnk stc +Double precision compare with zero which distinguishes negative zero. +.AT arth null ir cse +.CG notCG + .IL TEST irlnk irlnk Compare register value with 0. .AT arth comm ir cse @@ -2180,6 +2804,12 @@ operation pointed to by the 1st operand. .AT other null dp cse .CG notAILI +./" AOCC begin +.IL QSELECT irlnk qplnk qplnk +.AT other null qp cse +.CG notAILI +./" AOCC end + .IL CSSELECT irlnk cslnk cslnk .AT other null cs cse .CG notAILI @@ -2188,6 +2818,10 @@ operation pointed to by the 1st operand. .AT other null cd cse .CG notAILI +.IL CQSELECT irlnk cqlnk cqlnk +.AT other null cq cse +.CG notAILI + .IL AND irlnk irlnk Bitwise 32-bit 'and' operation. .AT arth comm ir cse @@ -2258,12 +2892,12 @@ This ili should have been replaced before code generator. .AT arth null ir cse .CG notCG -.IL SHIFTA irlnk arlnk +.IL SHIFTB irlnk arlnk Shift op1 logically by op2. Left if op2 is > 0; else right. .AT arth null ir cse .CG notCG -.IL USHIFTA irlnk arlnk +.IL USHIFTB irlnk arlnk Unsigned shift op1 logically by op2. Left if op2 is > 0; else right. .AT arth null ir cse .CG notCG @@ -2291,6 +2925,13 @@ Shift left immediate of 64-bit value. .CG memdest ccarith shiftop "shl" CGonly 'q' .SI direct lat(4:1) +.IL SHIFTA irlnk irlnk +Shift op1 arithmetically (sign extended) right by op2. +Used for right shifts (>> operator) of signed values. +.AT arth null ir cse +.CG memdest ccarith shiftop asm_special "sar" 'l' +.SI direct lat(4:1) + .IL RSHIFT irlnk irlnk Shift op1 logically right by op2 (sign extended). .AT arth null ir cse @@ -2343,6 +2984,22 @@ The value, 0 or 1, of the second operand indicates .AT arth null kr cse .CG "lzcnt" 'q' +.IL ITRAILZI irlnk stc +8-/16- bit integer TRAILZ intrinsic. +The value, 0 or 1, of the second operand indicates +8-bit or 16-bit, respectively. +.AT arth null ir cse + +.IL ITRAILZ irlnk +32-bit integer TRAILZ intrinsic. +.AT arth null ir cse +.CG "tzcnt" 'l' + +.IL KTRAILZ krlnk +64-bit integer TRAILZ intrinsic. +.AT arth null kr cse +.CG "tzcnt" 'q' + .IL IPOPCNTI irlnk stc 8-/16- bit integer POPCNT intrinsic. The value of second operand indicates 8-bit if 0 and 16-bit @@ -2484,6 +3141,14 @@ if the condition, denoted by stc, is true. .AT branch null trm dom .CG terminal conditional_branch notAILI +.\" AOCC begin +.IL QCJMP qplnk qplnk stc sym +Quad precision compare and jump to the label 'sym' +if the condition, denoted by stc, is true. +.AT branch null trm dom +.CG terminal conditional_branch notAILI +.\" AOCC end + .IL ICJMPZ irlnk stc sym Integer compare with zero and branch to label 'sym' - the allowed values (and meanings) for stc are the same as @@ -2536,6 +3201,13 @@ Double compare with zero and branch to label 'sym'. .AT branch null trm dom .CG notCG conditional_branch +.\" AOCC begin +.IL QCJMPZ qplnk stc sym +Quad compare with zero and branch to label 'sym'. +.AT branch null trm dom +.CG notCG conditional_branch +.\" AOCC end + .IL JCC Conditional jump based on immediately preceding compare operation. Used only in the AILI. @@ -2563,6 +3235,13 @@ Double precision register cse. .AT arth null dp .CG notCG +.\" AOCC begin +.IL CSEQP qplnk +Quad precision register cse. +.AT arth null qp +.CG notCG +.\" AOCC end + .IL CSECS cslnk Single precision complex register cse. .AT arth null cs @@ -2573,6 +3252,13 @@ Double precision complex register cse. .AT arth null cd .CG notCG +./" AOCC begin +.IL CSECQ cqlnk +Quad precision complex register cse. +.AT arth null cq +.CG notCG +./" AOCC end + .IL CSEAR arlnk Address register cse. .AT arth null ar @@ -2722,6 +3408,16 @@ Store double precision quantity. 'stc' must be MSZ_F8. .SI st direct fst lat(2) .SI direct fadd fmul lat(2) +./" AOCC begin +.IL STQP qplnk arlnk nme stc +Store quad precision quantity. 'stc' must be MSZ_F16. +.AT store null trm +.CG terminal "movsq" move avx_special +.SI ld quad fadd fmul fst lat(3) +.SI st direct fst lat(2) +.SI direct fadd fmul lat(2) +./" AOCC end + .IL STSCMPLX cslnk arlnk nme stc Store single precision complex quantity. 'stc' is not used. .AT store null trm @@ -2738,6 +3434,16 @@ Store double precision complex quantity. 'stc' is not used. .SI st direct fst lat(2) .SI direct fadd fmul lat(2) +./" AOCC begin +.IL STQCMPLX cqlnk arlnk nme stc +Store quad precision complex quantity. 'stc' is not used. +.AT store null trm +.CG terminal "movupq" move sse_avx +.SI ld quad fadd fmul fst lat(3) +.SI st direct fst lat(2) +.SI direct fadd fmul lat(2) +./" AOCC end + .IL STQ dplnk arlnk nme stc Store an __m128 quantity. 'stc' is not used. .AT store null trm @@ -2826,7 +3532,7 @@ stc2 dtype .IL QJSR sym lnk Quick (intrinsic) call. \'sym' is the external procedure being called. -\'lnk' locates the list of arguments (define arg ILI - DAAR, DADR, DADP). +\'lnk' locates the list of arguments (define arg ILI - DAAR, DADR, DADP, DAQP). .AT proc null lnk dom .CG terminal "call" asm_special ccmod @@ -2907,6 +3613,18 @@ Defines a double precision memory argument. .SI st direct fst lat(2) .SI direct fadd fmul lat(2) +./" AOCC begin +.IL ARGQP qplnk lnk +Defines a quad precision memory argument. +\'qplnk' points to the register value of the argument. +\'lnk' points to the next ARG ILI. +.AT define null lnk +.CG memarg "movsq" avx_special +.SI ld quad fadd fmul fst lat(3) +.SI st direct fst lat(2) +.SI direct fadd fmul lat(2) +./" AOCC end + .IL ARGAR arlnk lnk stc A memory argument of type pointer or struct/union. .sp @@ -2975,6 +3693,16 @@ Define a C struct argument of two double, passed in the indicated xmm register. .SI st double fst lat(4) .SI double fadd fmul lat(2) +./" AOCC begin +.IL DACQ cqlnk cd lnk +Define a C struct argument of two quad, passed in the indicated xmm register. +.AT define null lnk +.CG "movupq" move sse_avx +.SI ld quad fadd fmul fst lat(4) +.SI st quad fst lat(4) +.SI quad fadd fmul lat(2) +./" AOCC end + .IL DADP dplnk dp lnk Define a double precision argument for a JSR or QJSR. .AT define null lnk @@ -2983,6 +3711,16 @@ Define a double precision argument for a JSR or QJSR. .SI st direct fst lat(2) .SI direct fadd fmul lat(2) +./" AOCC begin +.IL DAQP qplnk dp lnk +Define a quad precision argument for a JSR or QJSR. +.AT define null lnk +.CG "movsq" move avx_special +.SI ld quad fadd fmul fst lat(3) +.SI st direct fst lat(2) +.SI direct fadd fmul lat(2) +./" AOCC end + .IL DA128 dplnk dp lnk Define an __m128 argument for a JSR or QJSR. .AT define null lnk @@ -3047,6 +3785,13 @@ Define double precision function result in an xmm register. .AT define null dp cse .CG terminal asm_nop +.\" AOCC begin +.IL DFRQP lnk dp +Define quad precision function result in an xmm register. +.AT define null qp cse +.CG terminal asm_nop +.\" AOCC end + .IL DFRCS lnk cs Define single precision complex function result in an xmm register. .AT define null cs cse @@ -3057,6 +3802,13 @@ Define double precision complex function result in an xmm register. .AT define null cd cse .CG terminal asm_nop +./" AOCC begin +.IL DFRCQ lnk cd +Define quad precision complex function result in an xmm register. +.AT define null cq cse +.CG terminal asm_nop +./" AOCC end + .IL DFR128 lnk dp Define 128-bit function result in an xmm register. .AT define null dp cse @@ -3103,6 +3855,13 @@ Define double precision register (xmm register). .AT define null dp cse .CG terminal asm_nop +.\" AOCC begin +.IL QPDF dp +Define quad precision register (xmm register). +.AT define null qp cse +.CG terminal asm_nop +.\" AOCC end + .IL ARDF ar Define address register. (ar is actual register number). .AT define null ar cse @@ -3156,6 +3915,18 @@ Form a double complex value out of two double precision real values, imaginary p .AT other null cd cse .CG "unpcklpd" sse_avx asm_special +.\" AOCC begin +.IL QPQP2QCMPLX qplnk qplnk +Form a quad complex value out of two quad precision real values. +.AT other null cq cse +.CG "unpcklpq" sse_avx asm_special + +.IL QPQP2QCMPLXI0 qplnk +Form a quad complex value out of two quad precision real values, imaginary part is 0. +.AT other null cq cse +.CG "unpcklpq" sse_avx asm_special +.\" AOCC end + .IL SCMPLX2IMAG cslnk Return single precision imaginary part of a single complex value. .AT other null sp cse @@ -3166,6 +3937,13 @@ Return double precision imaginary part of a double complex value. .AT other null dp cse .CG "unpckhpd" sse_avx asm_special +.\" AOCC begin +.IL QCMPLX2IMAG cqlnk +Return quad precision imaginary part of a quad complex value. +.AT other null qp cse +.CG "unpckhpd" sse_avx asm_special +.\" AOCC end + .IL SCMPLX2REAL cslnk Return single precision real part of a single complex value. .AT other null sp cse @@ -3176,6 +3954,13 @@ Return double precision real part of a double complex value. .AT other null dp cse .CG "movsd" sse_avx asm_special +.\" AOCC begin +.IL QCMPLX2REAL cqlnk +Return quad precision real part of a quad complex value. +.AT other null qp cse +.CG "movsq" sse_avx asm_special +.\" AOCC end + .IL MVDP dplnk dp This ili represents a double precision function return value. For X86_64, the value is moved into the specified xmm register. @@ -3185,6 +3970,17 @@ For X86_64, the value is moved into the specified xmm register. .SI st direct fst lat(2) .SI direct fadd fmul lat(2) +./" AOCC begin +.IL MVQP qplnk dp +This ili represents a quad precision function return value. +For X86_64, the value is moved into the specified xmm register. +.AT move null trm +.CG terminal "movsd" move avx_special +.SI ld quad fadd fmul fst lat(3) +.SI st direct fst lat(2) +.SI direct fadd fmul lat(2) +./" AOCC end + .IL MVQ dplnk dp This ili represents an __m128 function return value. For X86_64, the value is moved into the specified xmm register. @@ -3219,6 +4015,16 @@ Move a double-precision xmm register value. .SI st direct fst lat(2) .SI direct fadd fmul lat(2) +./" AOCC begin +.IL MOVQ +Move a quad-precision xmm register value. +.AT move null qp +.CG CGonly "movsq" move avx_special +.SI ld quad fadd fmul fst lat(3) +.SI st direct fst lat(2) +.SI direct fadd fmul lat(2) +./" AOCC end + .IL MOVCS Move a single-precision complex xmm register value. .AT move null cs @@ -3275,6 +4081,12 @@ The FREExx ili are eliminated by the linearizer phase of the code generator. .AT other null trm .CG terminal notAILI +.\" AOCC begin +.IL FREEQP qplnk +.AT other null trm +.CG terminal notAILI +.\" AOCC end + .IL FREECS cslnk .AT other null trm .CG terminal notAILI @@ -3283,6 +4095,12 @@ The FREExx ili are eliminated by the linearizer phase of the code generator. .AT other null trm .CG terminal notAILI +./" AOCC begin +.IL FREECQ cqlnk +.AT other null trm +.CG terminal notAILI +./" AOCC end + .IL FREEAR arlnk .AT other null trm .CG terminal notCG replaceby FREEKR @@ -5941,17 +6759,6 @@ The argument is the label of the top of the loop. .AT branch null trm .CG notCG notAILI accel - -.IL ARGQP dplnk lnk -Defines a quad precision memory argument. -\'dplnk' points to the register value of the argument. -\'lnk' points to the next ARG ILI. -.AT define null lnk -.CG memarg "movupd" sse_avx -.SI ld double fadd fmul fst lat(3) -.SI st direct fst lat(2) -.SI direct fadd fmul lat(2) - .IL ARG256 dplnk lnk Defines a 256-bit memory argument. \'dplnk' points to the register value of the argument. diff --git a/tools/flang2/utils/ilmtp/aarch64/ilmtp.n b/tools/flang2/utils/ilmtp/aarch64/ilmtp.n index a91e483646..75d99287ec 100644 --- a/tools/flang2/utils/ilmtp/aarch64/ilmtp.n +++ b/tools/flang2/utils/ilmtp/aarch64/ilmtp.n @@ -3,6 +3,25 @@ .\" * See https://llvm.org/LICENSE.txt for license information. .\" * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception .\" * +.\" * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +.\" * Notified per clause 4(b) of the license. +.\" * +.\" * Complex data types support for acosh, asinh and atanh +.\" * Date of Modification: 08 January 2020 +.\" * +.\" * Added code to support SHIFTA intrinsic +.\" * Last modified: April 2020 +.\" * +.\" * Complex datatype support for atan2 under flag f2008 +.\" * Modified on 13th March 2020 +.\" * +.\" * Added quad support for floor and ceiling intrinsics +.\" * Last modified: August 2020 +.\" * +.\" * Added support for cotan and cotand intrinsics +.\" * Last modified: Oct 2020 +.\" * +.\" * .\" */ .NS 25 "ILM Definitions" "Appendix IV - " .sh 2 "ILM Definitions" @@ -217,6 +236,9 @@ Convert real number to unsigned. .IL DBLE arth lnk Convert single precision floating point value to double precision. .OP DBLE r p1 +.IL QFIX arth lnk +Convert double precision floating point number to integer. +.OP QFIX r p1 .IL DFIX arth lnk Convert double precision floating point number to integer. .OP DFIX r p1 @@ -369,6 +391,8 @@ EXP intrinsic for single precision floating point values. .AT spec dcmplx .IL CATAN arth lnk .AT spec +.IL CATAN2 arth lnk lnk +.AT spec .IL CDATAN arth lnk .AT spec dcmplx .IL CCOSH arth lnk @@ -387,6 +411,16 @@ EXP intrinsic for single precision floating point values. .AT spec .IL CDTAN arth lnk .AT spec dcmplx +.IL CCOTAN arth lnk +.AT spec +.IL CDCOTAN arth lnk +.AT spec dcmplx +.IL CACOSH arth lnk +.AT spec +.IL CASINH arth lnk +.AT spec +.IL CATANH arth lnk +.AT spec .IL ALOG arth lnk .OP FLOG r p1 .IL DLOG arth lnk @@ -440,6 +474,24 @@ Tangent of a single precision value .\".OP ARGSP t1 p1 t1 .\".OP QJSR t2 =e'%s%__mth_i_tan t1 .\".OP DFRSP r t2 spret +.IL COTAN arth lnk +Cotangent of a single precision value +.OP FCOTAN r p1 +.\".OP NULL t1 iv0 +.\".OP ARGSP t1 p1 t1 +.\".OP QJSR t2 =e'%s%__mth_i_cotan t1 +.\".OP DFRSP r t2 spret +.IL DCOTAN arth lnk +.OP DCOTAN r p1 +.\".OP NULL t1 iv0 +.\".OP ARGDP t1 p1 t1 +.\".OP QJSR t2 =e'%d%_mth_i_dcotan t1 +.\".OP DFRDP r t2 dpret +.IL QCOTAN arth lnk +.OP NULL t1 iv0 +.OP ARGQP t1 p1 t1 +.OP QJSR t2 =e'%d%__mth_i_qcotan t1 +.OP DFRQP r t2 qpret .IL DTAN arth lnk .OP DTAN r p1 .\".OP NULL t1 iv0 @@ -484,6 +536,22 @@ COS in degrees. .OP ARGDP t1 p1 t1 .OP QJSR t2 =e'%d%__mth_i_dcosd t1 .OP DFRDP r t2 dpret +.IL COTAND arth lnk +TAN in degrees. +.OP NULL t1 iv0 +.OP ARGSP t1 p1 t1 +.OP QJSR t2 =e'%s%__mth_i_cotand t1 +.OP DFRSP r t2 spret +.IL DCOTAND arth lnk +.OP NULL t1 iv0 +.OP ARGDP t1 p1 t1 +.OP QJSR t2 =e'%d%__mth_i_dcotand t1 +.OP DFRDP r t2 dpret +.IL QCOTAND arth lnk +.OP NULL t1 iv0 +.OP ARGQP t1 p1 t1 +.OP QJSR t2 =e'%d%__mth_i_qcotand t1 +.OP DFRQP r t2 qpret .IL TAND arth lnk TAN in degrees. .OP NULL t1 iv0 @@ -1004,6 +1072,12 @@ Real valued DIM intrinsic. .OP ARGDP t2 p1 t1 .OP QJSR t3 =e'%d%ftn_i_ddim t2 .OP DFRDP r t3 dpret +.IL QDIM arth lnk lnk +.OP NULL t1 iv0 +.OP ARGQP t1 p2 t1 +.OP ARGQP t2 p1 t1 +.OP QJSR t3 =e'%q%ftn_i_ddim t2 +.OP DFRQP r t3 qpret .IL DPROD arth lnk lnk Multiply two single precision real values and return double precision value. (DPROD intrinsic). @@ -1091,6 +1165,12 @@ value and second is assumed to be a positive integer. .OP RSHIFT r p1 p2 .IL KRSHIFT arth lnk lnk .AT spec i8 +.IL SHIFTA arth lnk lnk +Right shift operator (>>). First operand is 32 bit signed integer +value and second is assumed to be a positive integer. +.OP SHIFTA r p1 p2 +.IL KSHIFTA arth lnk lnk +.AT spec i8 .IL ULSHIFT arth lnk lnk Left shift operator (<<) - first operand is 32 bit unsigned integer value and second is a positive integer. @@ -1195,6 +1275,7 @@ IBITS(p1, p2, p3) - extract p3 bits beginning at p2 from p1. .nf r = p3 != 0 ? (p1 >> p2) & (-1 >> (32 - p3)) : 0 .OP RSHIFT t1 p1 p2 +.OP SHIFTA t1 p1 p2 .OP ICON t2 =i'-1 .OP ICON t3 =i'32 .OP ISUB t4 t3 p3 @@ -1231,6 +1312,12 @@ FLOOR of real to real .IL DFLOOR arth lnk FLOOR of double to double .OP DFLOOR r p1 +.IL QFLOOR arth lnk +FLOOR of quad to quad +.OP QFLOOR r p1 +.IL QCEIL arth lnk +CEIL of quad to quad +.OP QCEIL r p1 .IL RCEIL arth lnk CELING of real to real .OP FCEIL r p1 @@ -2090,6 +2177,7 @@ computed as (x+y) >> 1 .OP ICON t1 =i'1 .OP IADD t2 p1 p2 .OP RSHIFT r t2 t1 +.OP SHIFTA r t2 t1 .IL UHADD arth lnk lnk hadd(x,y), where x and y are unsigned char or unsigned short, and computed as (x+y) >> 1 @@ -2145,6 +2233,7 @@ computed as (x+y+1) >> 1 .OP IADD t2 p1 p2 .OP IADD t2 t2 t1 .OP RSHIFT r t2 t1 +.OP SHIFTA r t2 t1 .IL URHADD arth lnk lnk rhadd(x,y), where x and y are unsigned char or unsigned short, and computed as (x+y+1) >> 1 @@ -2820,6 +2909,19 @@ Cast an unsigned integer to a 64-bit integer. 64-bit integer LEADZ intrinsic .AT i8 .OP KLEADZ r p1 +.IL BTRAILZ intr lnk +8-bit integer TRAILZ intrinsic +.OP ITRAILZI r p1 iv0 +.IL STRAILZ intr lnk +16-bit integer TRAILZ intrinsic +.OP ITRAILZI r p1 iv1 +.IL ITRAILZ intr lnk +32-bit integer TRAILZ intrinsic +.OP ITRAILZ r p1 +.IL KTRAILZ intr lnk +64-bit integer TRAILZ intrinsic +.AT i8 +.OP KTRAILZ r p1 .IL BPOPCNT intr lnk 8-bit integer POPCNT intrinsic .OP IPOPCNTI r p1 iv0 @@ -3263,6 +3365,8 @@ sym - upperD stc - dtype of loop bound type stc - schedule type .AT spec trm +.IL REQUIRES stc +.AT spec trm .IL BTASKDUP SMP Begin taskdup routine .AT spec trm @@ -3677,6 +3781,23 @@ stc Combined costruct mode lnk link to num_teams clause if exists lnk link to thread_limit clause if exists lnk link to num_threads clause if exists +.\" AOCC Begin +.AT spec trm +.IL MP_NUMTEAMS SMP sym +Number of teams symbol. +sym Number of teams +.AT spec trm +.IL MP_NUMTHREADS SMP sym +Number of Threads symbol. +sym Number of threads +.AT spec trm +.IL MP_DEFAULTMAP stc +Default map construct. +stc - Default map type +.IL MP_TARGETDECLARE SMP +Target declare construct. +sym - Target symbol +.\" AOCC End .AT spec trm .IL MP_TARGETLOOPTRIPCOUNT SMP sym loop trip count for target region @@ -3715,6 +3836,27 @@ Begin directive .IL MP_END_DIR SMP End directive .AT spec trm +.IL MP_USE_DEVICE_PTR SMP lnk stc +use the device pointer for symbol +.nf +lnk - symbol whose address need to be mapped +stc - map type +.fi +.AT spec trm +.IL MP_IS_DEVICE_PTR SMP lnk stc +use the already mapped device pointer for symbol +.nf +lnk - symbol already on target +stc - map type +.fi +.AT spec trm +.IL MP_USE_DEVICE_ADDR SMP lnk stc +use the device address for symbol +.nf +lnk - symbol whose address need to be mapped +stc - map type +.fi +.AT spec trm .IL HFLD load lnk Load half precision .AT spec diff --git a/tools/flang2/utils/ilmtp/ilmtp.cpp b/tools/flang2/utils/ilmtp/ilmtp.cpp index 0aab1d4efd..b4f3c2e376 100644 --- a/tools/flang2/utils/ilmtp/ilmtp.cpp +++ b/tools/flang2/utils/ilmtp/ilmtp.cpp @@ -4,6 +4,14 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * + */ #include "utils.h" typedef void ILM_T; /* FIXME: used in ilm.h, can be anything, doesn't @@ -168,11 +176,13 @@ class ILMTPApp : UtilityApplication { ilmo.push_back(ILMO("arret", 5, ILMO_ARRET, 0)); ilmo.push_back(ILMO("spret", 5, ILMO_SPRET, 0)); ilmo.push_back(ILMO("dpret", 5, ILMO_DPRET, 0)); + ilmo.push_back(ILMO("qpret", 5, ILMO_QPRET, 0)); // AOCC ilmo.push_back(ILMO("krret", 5, ILMO_KRRET, 0)); ilmo.push_back(ILMO("drpos", 5, ILMO_DRPOS, 0)); ilmo.push_back(ILMO("arpos", 5, ILMO_ARPOS, 0)); ilmo.push_back(ILMO("sppos", 5, ILMO_SPPOS, 0)); ilmo.push_back(ILMO("dppos", 5, ILMO_DPPOS, 0)); + ilmo.push_back(ILMO("qppos", 5, ILMO_QPPOS, 0)); // AOCC ilmo.push_back(ILMO("null", 4, ILMO_NULL, 0)); ilmo.push_back(ILMO("isp(", 4, ILMO_ISP, 0)); ilmo.push_back(ILMO("idp(", 4, ILMO_IDP, 0)); @@ -189,6 +199,7 @@ class ILMTPApp : UtilityApplication { ilmo.push_back(ILMO("ar(", 3, ILMO_AR, 0)); ilmo.push_back(ILMO("sp(", 3, ILMO_SP, 0)); ilmo.push_back(ILMO("dp(", 3, ILMO_DP, 0)); + ilmo.push_back(ILMO("qp(", 3, ILMO_QP, 0)); // AOCC ilmo.push_back(ILMO("scz", 3, ILMO_SCZ, 0)); ilmo.push_back(ILMO("scf", 3, ILMO_SCF, 0)); ilmo.push_back(ILMO("sz", 2, ILMO_SZ, 0)); @@ -698,6 +709,7 @@ class ILMTPApp : UtilityApplication { case ILMO_ARRET: case ILMO_SPRET: case ILMO_DPRET: + case ILMO_QPRET: // AOCC case ILMO_KRRET: iliopr[1] = 0; ilmtp.push_back(find_op(iliopr)); @@ -751,6 +763,7 @@ class ILMTPApp : UtilityApplication { case ILMO_AR: case ILMO_SP: case ILMO_DP: + case ILMO_QP: // AOCC case ILMO_ISP: case ILMO_IDP: case ILMO_SCZ: @@ -762,6 +775,7 @@ class ILMTPApp : UtilityApplication { case ILMO_ARPOS: case ILMO_SPPOS: case ILMO_DPPOS: + case ILMO_QPPOS: // AOCC { auto s = tok.substr(6); iliopr[1] = atoi(s.c_str()); diff --git a/tools/flang2/utils/ilmtp/ppc64le/ilmtp.n b/tools/flang2/utils/ilmtp/ppc64le/ilmtp.n index a91e483646..8fe8c2c603 100644 --- a/tools/flang2/utils/ilmtp/ppc64le/ilmtp.n +++ b/tools/flang2/utils/ilmtp/ppc64le/ilmtp.n @@ -3,6 +3,24 @@ .\" * See https://llvm.org/LICENSE.txt for license information. .\" * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception .\" * +.\" * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +.\" * Notified per clause 4(b) of the license. +.\" * +.\" * Complex data types support for acosh, asinh and atanh +.\" * Date of Modification: 08 January 2020 +.\" * +.\" * Added code to support SHIFTA intrinsic +.\" * Last modified: April 2020 +.\" * +.\" * Complex datatype support for atan2 under flag f2008 +.\" * Modified on 13th March 2020 +.\" * +.\" * Added quad support for floor and ceiling intrinsics +.\" * Last modified: August 2020 +.\" * +.\" * Added support for cotan and cotand intrinsics +.\" * Last modified: Oct 2020 +.\" * .\" */ .NS 25 "ILM Definitions" "Appendix IV - " .sh 2 "ILM Definitions" @@ -217,6 +235,9 @@ Convert real number to unsigned. .IL DBLE arth lnk Convert single precision floating point value to double precision. .OP DBLE r p1 +.IL QFIX arth lnk +Convert double precision floating point number to integer. +.OP QFIX r p1 .IL DFIX arth lnk Convert double precision floating point number to integer. .OP DFIX r p1 @@ -387,6 +408,18 @@ EXP intrinsic for single precision floating point values. .AT spec .IL CDTAN arth lnk .AT spec dcmplx +.IL CCOTAN arth lnk +.AT spec +.IL CDCOTAN arth lnk +.AT spec dcmplx +.IL CACOSH arth lnk +.AT spec +.IL CASINH arth lnk +.AT spec +.IL CATANH arth lnk +.AT spec +.IL CATAN2 arth lnk lnk +.AT spec .IL ALOG arth lnk .OP FLOG r p1 .IL DLOG arth lnk @@ -440,12 +473,30 @@ Tangent of a single precision value .\".OP ARGSP t1 p1 t1 .\".OP QJSR t2 =e'%s%__mth_i_tan t1 .\".OP DFRSP r t2 spret +.IL COTAN arth lnk +Cotangent of a single precision value +.OP FCOTAN r p1 +.\".OP NULL t1 iv0 +.\".OP ARGSP t1 p1 t1 +.\".OP QJSR t2 =e'%s%__mth_i_cotan t1 +.\".OP DFRSP r t2 spret .IL DTAN arth lnk .OP DTAN r p1 .\".OP NULL t1 iv0 .\".OP ARGDP t1 p1 t1 .\".OP QJSR t2 =e'%d%_mth_i_dtan t1 .\".OP DFRDP r t2 dpret +.IL DCOTAN arth lnk +.OP DCOTAN r p1 +.\".OP NULL t1 iv0 +.\".OP ARGDP t1 p1 t1 +.\".OP QJSR t2 =e'%d%_mth_i_dcotan t1 +.\".OP DFRDP r t2 dpret +.IL QCOTAN arth lnk +.OP NULL t1 iv0 +.OP ARGQP t1 p1 t1 +.OP QJSR t2 =e'%d%__mth_i_qcotan t1 +.OP DFRQP r t2 qpret .IL ASIN arth lnk .OP FASIN r p1 .IL DASIN arth lnk @@ -484,6 +535,22 @@ COS in degrees. .OP ARGDP t1 p1 t1 .OP QJSR t2 =e'%d%__mth_i_dcosd t1 .OP DFRDP r t2 dpret +.IL COTAND arth lnk +COTAN in degrees. +.OP NULL t1 iv0 +.OP ARGSP t1 p1 t1 +.OP QJSR t2 =e'%s%__mth_i_cotand t1 +.OP DFRSP r t2 spret +.IL DCOTAND arth lnk +.OP NULL t1 iv0 +.OP ARGDP t1 p1 t1 +.OP QJSR t2 =e'%d%__mth_i_dcotand t1 +.OP DFRDP r t2 dpret +.IL QCOTAND arth lnk +.OP NULL t1 iv0 +.OP ARGQP t1 p1 t1 +.OP QJSR t2 =e'%d%__mth_i_qcotand t1 +.OP DFRQP r t2 qpret .IL TAND arth lnk TAN in degrees. .OP NULL t1 iv0 @@ -1004,6 +1071,12 @@ Real valued DIM intrinsic. .OP ARGDP t2 p1 t1 .OP QJSR t3 =e'%d%ftn_i_ddim t2 .OP DFRDP r t3 dpret +.IL QDIM arth lnk lnk +.OP NULL t1 iv0 +.OP ARGQP t1 p2 t1 +.OP ARGQP t2 p1 t1 +.OP QJSR t3 =e'%q%ftn_i_qdim t2 +.OP DFRQP r t3 qpret .IL DPROD arth lnk lnk Multiply two single precision real values and return double precision value. (DPROD intrinsic). @@ -1091,6 +1164,12 @@ value and second is assumed to be a positive integer. .OP RSHIFT r p1 p2 .IL KRSHIFT arth lnk lnk .AT spec i8 +.IL SHIFTA arth lnk lnk +Right shift operator (>>). First operand is 32 bit signed integer +value and second is assumed to be a positive integer. +.OP SHIFTA r p1 p2 +.IL KSHIFTA arth lnk lnk +.AT spec i8 .IL ULSHIFT arth lnk lnk Left shift operator (<<) - first operand is 32 bit unsigned integer value and second is a positive integer. @@ -1195,6 +1274,7 @@ IBITS(p1, p2, p3) - extract p3 bits beginning at p2 from p1. .nf r = p3 != 0 ? (p1 >> p2) & (-1 >> (32 - p3)) : 0 .OP RSHIFT t1 p1 p2 +.OP SHIFTA t1 p1 p2 .OP ICON t2 =i'-1 .OP ICON t3 =i'32 .OP ISUB t4 t3 p3 @@ -1231,6 +1311,12 @@ FLOOR of real to real .IL DFLOOR arth lnk FLOOR of double to double .OP DFLOOR r p1 +.IL QFLOOR arth lnk +FLOOR of quad to quad +.OP QFLOOR r p1 +.IL QCEIL arth lnk +CEIL of quad to quad +.OP QCEIL r p1 .IL RCEIL arth lnk CELING of real to real .OP FCEIL r p1 @@ -2090,6 +2176,7 @@ computed as (x+y) >> 1 .OP ICON t1 =i'1 .OP IADD t2 p1 p2 .OP RSHIFT r t2 t1 +.OP SHIFTA r t2 t1 .IL UHADD arth lnk lnk hadd(x,y), where x and y are unsigned char or unsigned short, and computed as (x+y) >> 1 @@ -2145,6 +2232,7 @@ computed as (x+y+1) >> 1 .OP IADD t2 p1 p2 .OP IADD t2 t2 t1 .OP RSHIFT r t2 t1 +.OP SHIFTA r t2 t1 .IL URHADD arth lnk lnk rhadd(x,y), where x and y are unsigned char or unsigned short, and computed as (x+y+1) >> 1 @@ -2820,6 +2908,19 @@ Cast an unsigned integer to a 64-bit integer. 64-bit integer LEADZ intrinsic .AT i8 .OP KLEADZ r p1 +.IL TRAILZ intr lnk +8-bit integer TRAILZ intrinsic +.OP ITRAILZI r p1 iv0 +.IL STRAILZ intr lnk +16-bit integer TRAILZ intrinsic +.OP ITRAILZI r p1 iv1 +.IL ITRAILZ intr lnk +32-bit integer TRAILZ intrinsic +.OP ITRAILZ r p1 +.IL KTRAILZ intr lnk +64-bit integer TRAILZ intrinsic +.AT i8 +.OP KTRAILZ r p1 .IL BPOPCNT intr lnk 8-bit integer POPCNT intrinsic .OP IPOPCNTI r p1 iv0 @@ -3263,6 +3364,8 @@ sym - upperD stc - dtype of loop bound type stc - schedule type .AT spec trm +.IL REQUIRES stc +.AT spec trm .IL BTASKDUP SMP Begin taskdup routine .AT spec trm @@ -3677,6 +3780,23 @@ stc Combined costruct mode lnk link to num_teams clause if exists lnk link to thread_limit clause if exists lnk link to num_threads clause if exists +.\" AOCC Begin +.AT spec trm +.IL MP_NUMTEAMS SMP sym +Number of teams symbol. +sym Number of teams +.AT spec trm +.IL MP_NUMTHREADS SMP sym +Number of threads symbol. +sym Number of threads +.AT spec trm +.IL MP_DEFAULTMAP stc +Default map construct. +stc - Default map type +.IL MP_TARGETDECLARE SMP +Target declare construct. +sym - Target symbol +.\" AOCC End .AT spec trm .IL MP_TARGETLOOPTRIPCOUNT SMP sym loop trip count for target region @@ -3715,6 +3835,27 @@ Begin directive .IL MP_END_DIR SMP End directive .AT spec trm +.IL MP_USE_DEVICE_PTR SMP lnk stc +use the device pointer for symbol +.nf +lnk - symbol whose address need to be mapped +stc - map type +.fi +.AT spec trm +.IL MP_IS_DEVICE_PTR SMP lnk stc +use the already mapped device pointer for symbol +.nf +lnk - symbol already on target +stc - map type +.fi +.AT spec trm +.IL MP_USE_DEVICE_ADDR SMP lnk stc +use the device address for symbol +.nf +lnk - symbol whose address need to be mapped +stc - map type +.fi +.AT spec trm .IL HFLD load lnk Load half precision .AT spec diff --git a/tools/flang2/utils/ilmtp/x86_64/ilmtp.n b/tools/flang2/utils/ilmtp/x86_64/ilmtp.n index 0032e5e2c0..db44827da7 100644 --- a/tools/flang2/utils/ilmtp/x86_64/ilmtp.n +++ b/tools/flang2/utils/ilmtp/x86_64/ilmtp.n @@ -3,6 +3,34 @@ \" * See https://llvm.org/LICENSE.txt for license information. \" * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception \" * +\" * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +\" * Notified per clause 4(b) of the license. +\" * +\" * Complex data types support for acosh, asinh and atanh +\" * Date of Modification: 08 January 2020 +\" * +\" * Added support for quad precision +\" * Last modified: Feb 2020 +\" * +\" * Complex datatype support for atan2 under flag f2008 +\" * Modified on 13th March 2020 +\" +.\" * Support for Real128 support for math intrinsics +.\" * Date of Modification: Feb 2020 +.\" * +.\" * Added code to support SHIFTA intrinsic +.\" * Last modified: April 2020 +.\" * +.\" * Added quad support for floor and ceiling intrinsics +.\" * Last modified: August 2020 +.\" * +.\" * Added complex quad support for asin, asinh, acos, acosh, atan, atanh +.\" * Last modified: 19th August 2020 +.\" * +.\" * Added support for cotan and cotand intrinsics +.\" * Last modified: Oct 2020 +.\" * + \" */ .NS 25 "ILM Definitions" "Appendix IV - " .sh 2 "ILM Definitions" @@ -50,9 +78,24 @@ stc2 - current file index, default is 1. stc3 - number of words for this ILM block (including the BOS). .fi .AT spec trm +\" AOCC BEGIN +.IL RISNAN arth lnk +.AT spec trm +.IL DISNAN arth lnk +.AT spec trm +.IL QISNAN arth lnk +.AT spec trm +.IL MM_PREFETCH misc lnk lnk +.AT spec trm +\" AOCC END .IL FLOAT arth lnk Convert integer to real number (REAL and FLOAT intrinsics). .OP FLOAT r p1 +\" AOCC BEGIN +.IL QFLOAT arth lnk +Convert integer to double precision (QFLOAT intrinsic). +.OP QFLOAT r p1 +\" AOCC END .IL DFLOAT arth lnk Convert integer to double precision (DFLOAT intrinsic). .OP DFLOAT r p1 @@ -96,6 +139,9 @@ Convert unsigned short to unsigned integer. .OP SP2IR t1 rp1 .OP UIKMV r t1 .IL DTOUDI arth lnk +.\" AOCC begin +.IL QTOUDI arth lnk +.\" AOCC end .AT i8 .OP DP2KR r rp1 .IL DTOUI arth lnk @@ -105,6 +151,9 @@ Convert unsigned short to unsigned integer. .AT i8 .OP KCON r v1 .IL UDITOD arth lnk +.\" AOCC begin +.IL UQITOD arth lnk +.\" AOCC end .OP KR2DP r p1 .IL UDITOR arth lnk .OP KIMV t1 p1 @@ -146,6 +195,10 @@ Cast a real to a 64-bit unsigned integer (dword). .AT i8 .OP SP2IR t1 p1 .OP UIKMV r t1 +./" AOCC begin +.IL CQTOI arth lnk lnk +.AT spec +./" AOCC end .IL CRTOI arth lnk lnk Cast a complex to integer (C) .AT spec @@ -192,6 +245,9 @@ Convert real number to unsigned. .IL DBLE arth lnk Convert single precision floating point value to double precision. .OP DBLE r p1 +.IL QFIX arth lnk +Convert double precision floating point number to integer. +.OP QFIX r p1 .IL DFIX arth lnk Convert double precision floating point number to integer. .OP DFIX r p1 @@ -200,6 +256,9 @@ Convert double precision floating point number to unsigned integer. .OP DFIXK t1 p1 .OP KIMV r t1 +.IL QUAD arth lnk +Convert double precision floating point value to quad precision. +.OP QUAD r p1 .IL REAL arth lnk Returns real part of complex number (single precision). .AT spec @@ -208,6 +267,16 @@ Returns real part of complex number (single precision). Returns double precision real part of a double complex value. .AT spec .OP MVDP r rp1 iv-1 +.\" AOCC begin +.IL QTOQ arth lnk lnk +.OP QPOWQ r p1 p2 +.IL CQTOCQ arth lnk lnk +.AT spec dcmplx +.IL QREAL arth lnk +Returns quad precision real part of a quad complex value. +.AT spec +.OP MVQP r rp1 iv-1 +.\" AOCC end .IL IMAG arth lnk Returns imaginary part of complex value (single precision) (AIMAG intrinsic). @@ -218,12 +287,24 @@ Returns double precision imaginary part of a double complex value (DIMAG intrinsic). .AT spec .OP MVDP r ip1 iv-1 +.\" AOCC begin +.IL QIMAG arth lnk +Returns quad precision imaginary part of a quad complex value +(QIMAG intrinsic). +.AT spec +.OP MVQP r ip1 iv-1 +.\" AOCC end .IL CMPLX arth lnk lnk Form complex number out of two single precision real values. .AT spec .IL DCMPLX arth lnk lnk Form double complex number out of two double precision real values. .AT spec dcmplx +.\" AOCC begin +.IL QCMPLX arth lnk lnk +Form quad complex number out of two quad precision real values. +.AT spec +.\" AOCC end .IL ICHAR fstr lnk Converts single character to integer. .AT spec @@ -242,6 +323,11 @@ AINT intrinsic (converts real to real). .IL DINT arth lnk DINT intrinsic (converts double to double). .OP DINT r p1 +.\" AOCC begin +.IL QINT arth lnk +QINT intrinsic (converts quad to quad). +.OP QINT r p1 +.\" AOCC end .IL ANINT arth lnk ANINT intrinsic (converts real to real). .OP NULL t1 iv0 @@ -254,6 +340,14 @@ DNINT intrinsic (converts double to double). .OP DADP t1 p1 dp(0) t1 .OP QJSR t2 =e'%d%__mth_i_dnint t1 .OP DFRDP r t2 dpret +.\" AOCC begin +.IL QNINT arth lnk +QNINT intrinsic (converts quad to integer). +.OP NULL t1 iv0 +.OP DAQP t1 p1 qp(0) t1 +.OP QJSR t2 =e'%q%__mth_i_qnint t1 +.OP DFRQP r t2 drret +.\" AOCC end .IL NINT arth lnk NINT intrinsic (converts real to integer). \".OP NULL t1 iv0 @@ -283,10 +377,18 @@ Absolute value of single precision real number. .OP FABS r p1 .IL DABS arth lnk .OP DABS r p1 +.\" AOCC begin +.IL QABS arth lnk +.OP QABS r p1 +.\" AOCC end .IL CABS arth lnk .AT spec .OP DBLE t1 rp1 .OP DBLE t2 ip1 +.\" AOCC begin +.OP QUAD t1 rp1 +.OP QUAD t2 ip1 +.\" AOCC end .OP DMUL t1 t1 t1 .OP DMUL t2 t2 t2 .OP DADD t3 t1 t2 @@ -299,6 +401,15 @@ Absolute value of single precision real number. .OP DADP t2 rp1 dp(1) t1 .OP QJSR t3 =e'%d%__mth_i_cdabs t2 .OP DFRDP r t3 dpret +./" AOCC begin +.IL CQABS arth lnk +.AT spec +.OP NULL t1 iv0 +.OP DAQP t1 ip1 qp(0) t1 +.OP DAQP t2 rp1 qp(1) t1 +.OP QJSR t3 =e'%d%cqabs t2 +.OP DFRQP r t3 qpret +./" AOCC end .IL LEN fstr lnk Length of a character expression. This ILM contains a link to one character expression. @@ -317,11 +428,24 @@ Conjugate of a double complex number. .AT spec dcmplx .OP MVDP rr rp1 iv-1 .OP DNEG ir ip1 +.\" AOCC begin +.IL QCONJG arth lnk +Conjugate of a quad complex number. +.AT spec +.OP MVQP rr rp1 iv-1 +.OP QNEG ir ip1 +.\" AOCC end .IL SQRT arth lnk Square root of a single precision real number (SQRT intrinsic). .OP FSQRT r p1 .IL DSQRT arth lnk .OP DSQRT r p1 +.\" AOCC begin +.IL QSQRT arth lnk +.OP QSQRT r p1 +.IL CQSQRT arth lnk +.AT spec +.\" AOCC end .IL CSQRT arth lnk .AT spec .IL CDSQRT arth lnk @@ -331,6 +455,12 @@ EXP intrinsic for single precision floating point values. .OP FEXP r p1 .IL DEXP arth lnk .OP DEXP r p1 +.\" AOCC begin +.IL QEXP arth lnk +.OP QEXP r p1 +.IL CQEXP arth lnk +.AT spec +.\" AOCC end .IL CEXP arth lnk .AT spec .IL CDEXP arth lnk @@ -351,10 +481,20 @@ EXP intrinsic for single precision floating point values. .AT spec .IL CDCOSH arth lnk .AT spec dcmplx +.\" AOCC begin +.IL CQCOSH arth lnk +.AT spec +.\" AOCC end .IL CSINH arth lnk .AT spec .IL CDSINH arth lnk .AT spec dcmplx +.\" AOCC begin +.IL CQSINH arth lnk +.AT spec +.IL CQTANH arth lnk +.AT spec +.\" AOCC end .IL CTANH arth lnk .AT spec .IL CDTANH arth lnk @@ -363,10 +503,39 @@ EXP intrinsic for single precision floating point values. .AT spec .IL CDTAN arth lnk .AT spec dcmplx +.\" AOCC begin +.IL CQTAN arth lnk +.AT spec +.IL CCOTAN arth lnk +.AT spec +.IL CDCOTAN arth lnk +.AT spec dcmplx +.\" AOCC begin +.IL CQCOTAN arth lnk +.AT spec +.IL CQATAN arth lnk +.AT spec +.IL CQATAN2 arth lnk lnk +.AT spec +.IL CQATANH arth lnk +.AT spec +.\" AOCC end +.IL CACOSH arth lnk +.AT spec +.IL CASINH arth lnk +.AT spec +.IL CATANH arth lnk +.AT spec +.IL CATAN2 arth lnk lnk +.AT spec .IL ALOG arth lnk .OP FLOG r p1 .IL DLOG arth lnk .OP DLOG r p1 +.\" AOCC begin +.IL QLOG arth lnk +.OP QLOG r p1 +.\" AOCC end .IL CLOG arth lnk .AT spec .IL CDLOG arth lnk @@ -375,6 +544,12 @@ EXP intrinsic for single precision floating point values. .OP FLOG10 r p1 .IL DLOG10 arth lnk .OP DLOG10 r p1 +.\" AOCC begin +.IL CQLOG arth lnk +.AT spec +.IL QLOG10 arth lnk +.OP QLOG10 r p1 +.\" AOCC end .IL SIN arth lnk Sine of a single precision value .OP FSIN r p1 @@ -388,10 +563,18 @@ Sine of a single precision value \".OP DADP t1 p1 dp(0) t1 \".OP QJSR t2 =e'%d%__mth_i_dsin t1 \".OP DFRDP r t2 dpret +.IL QSIN arth lnk +.OP QSIN r p1 .IL CSIN arth lnk .AT spec .IL CDSIN arth lnk .AT spec dcmplx +.IL CQSIN arth lnk +.AT spec +.IL CQASIN arth lnk +.AT spec +.IL CQASINH arth lnk +.AT spec .IL COS arth lnk Cosine of a single precision number .OP FCOS r p1 @@ -405,10 +588,20 @@ Cosine of a single precision number \".OP DADP t1 p1 dp(0) t1 \".OP QJSR t2 =e'%d%__mth_i_dcos t1 \".OP DFRDP r t2 dpret +.IL QCOS arth lnk +.OP QCOS r p1 .IL CCOS arth lnk .AT spec .IL CDCOS arth lnk .AT spec dcmplx +.\" AOCC begin +.IL CQCOS arth lnk +.AT spec +.IL CQACOS arth lnk +.AT spec +.IL CQACOSH arth lnk +.AT spec +.\" AOCC end .IL TAN arth lnk Tangent of a single precision value .OP FTAN r p1 @@ -416,28 +609,56 @@ Tangent of a single precision value \".OP DASP t1 p1 sp(0) t1 \".OP QJSR t2 =e'%s%__mth_i_tan t1 \".OP DFRSP r t2 spret +.IL COTAN arth lnk +Cotangent of a single precision value +.OP FCOTAN r p1 +\".OP NULL t1 iv0 +\".OP DASP t1 p1 sp(0) t1 +\".OP QJSR t2 =e'%s%__mth_i_cotan t1 +\".OP DFRSP r t2 spret .IL DTAN arth lnk .OP DTAN r p1 \".OP NULL t1 iv0 \".OP DADP t1 p1 dp(0) t1 -\".OP QJSR t2 =e'%d%__mth_i_dtan t1 +\".OP QJSR t2 =e'%d%__mth_i_dcotan t1 +\".OP DFRDP r t2 dpret +.IL QTAN arth lnk +.OP QTAN r p1 +.IL DCOTAN arth lnk +.OP DCOTAN r p1 +\".OP NULL t1 iv0 +\".OP DADP t1 p1 dp(0) t1 +\".OP QJSR t2 =e'%d%__mth_i_dcotan t1 \".OP DFRDP r t2 dpret +.IL QCOTAN arth lnk +.OP NULL t1 iv0 +.OP DAQP t1 p1 qp(0) t1 +.OP QJSR t2 =e'%q%__mth_i_qcotan t1 +.OP DFRQP r t2 qpret .IL ASIN arth lnk .OP FASIN r p1 .IL DASIN arth lnk .OP DASIN r p1 +.IL QASIN arth lnk +.OP QASIN r p1 .IL ACOS arth lnk .OP FACOS r p1 .IL DACOS arth lnk .OP DACOS r p1 +.IL QACOS arth lnk +.OP QACOS r p1 .IL ATAN arth lnk .OP FATAN r p1 .IL DATAN arth lnk .OP DATAN r p1 +.IL QATAN arth lnk +.OP QATAN r p1 .IL ATAN2 arth lnk lnk .OP FATAN2 r p1 p2 .IL DATAN2 arth lnk lnk .OP DATAN2 r p1 p2 +.IL QATAN2 arth lnk lnk +.OP QATAN2 r p1 p2 .IL SIND arth lnk SIN in degrees. .OP NULL t1 iv0 @@ -449,6 +670,11 @@ SIN in degrees. .OP DADP t1 p1 dp(0) t1 .OP QJSR t2 =e'%d%__mth_i_dsind t1 .OP DFRDP r t2 dpret +.IL QSIND arth lnk +.OP NULL t1 iv0 +.OP DAQP t1 p1 qp(0) t1 +.OP QJSR t2 =e'%q%__mth_i_qsind t1 +.OP DFRQP r t2 qpret .IL COSD arth lnk COS in degrees. .OP NULL t1 iv0 @@ -460,6 +686,11 @@ COS in degrees. .OP DADP t1 p1 dp(0) t1 .OP QJSR t2 =e'%d%__mth_i_dcosd t1 .OP DFRDP r t2 dpret +.IL QCOSD arth lnk +.OP NULL t1 iv0 +.OP DAQP t1 p1 qp(0) t1 +.OP QJSR t2 =e'%q%__mth_i_qcosd t1 +.OP DFRQP r t2 qpret .IL TAND arth lnk TAN in degrees. .OP NULL t1 iv0 @@ -471,6 +702,27 @@ TAN in degrees. .OP DADP t1 p1 dp(0) t1 .OP QJSR t2 =e'%d%__mth_i_dtand t1 .OP DFRDP r t2 dpret +.IL QTAND arth lnk +.OP NULL t1 iv0 +.OP DAQP t1 p1 qp(0) t1 +.OP QJSR t2 =e'%q%__mth_i_qtand t1 +.OP DFRQP r t2 qpret +.IL COTAND arth lnk +COTAN in degrees. +.OP NULL t1 iv0 +.OP DASP t1 p1 sp(0) t1 +.OP QJSR t2 =e'%s%__mth_i_cotand t1 +.OP DFRSP r t2 spret +.IL DCOTAND arth lnk +.OP NULL t1 iv0 +.OP DADP t1 p1 dp(0) t1 +.OP QJSR t2 =e'%d%__mth_i_dcotand t1 +.OP DFRDP r t2 dpret +.IL QCOTAND arth lnk +.OP NULL t1 iv0 +.OP DAQP t1 p1 qp(0) t1 +.OP QJSR t2 =e'%q%__mth_i_qcotand t1 +.OP DFRQP r t2 qpret .IL ASIND arth lnk ASIN in degrees. .OP NULL t1 iv0 @@ -482,6 +734,11 @@ ASIN in degrees. .OP DADP t1 p1 dp(0) t1 .OP QJSR t2 =e'%d%__mth_i_dasind t1 .OP DFRDP r t2 dpret +.IL QASIND arth lnk +.OP NULL t1 iv0 +.OP DAQP t1 p1 qp(0) t1 +.OP QJSR t2 =e'%q%__mth_i_qasind t1 +.OP DFRQP r t2 qpret .IL ACOSD arth lnk ACOS in degrees. .OP NULL t1 iv0 @@ -493,6 +750,11 @@ ACOS in degrees. .OP DADP t1 p1 dp(0) t1 .OP QJSR t2 =e'%d%__mth_i_dacosd t1 .OP DFRDP r t2 dpret +.IL QACOSD arth lnk +.OP NULL t1 iv0 +.OP DAQP t1 p1 qp(0) t1 +.OP QJSR t2 =e'%q%__mth_i_qacosd t1 +.OP DFRDP r t2 qpret .IL ATAND arth lnk ATAN in degrees. .OP NULL t1 iv0 @@ -504,6 +766,11 @@ ATAN in degrees. .OP DADP t1 p1 dp(0) t1 .OP QJSR t2 =e'%d%__mth_i_datand t1 .OP DFRDP r t2 dpret +.IL QATAND arth lnk +.OP NULL t1 iv0 +.OP DAQP t1 p1 qp(0) t1 +.OP QJSR t2 =e'%q%__mth_i_qatand t1 +.OP DFRQP r t2 qpret .IL ATAN2D arth lnk lnk ATAN2 in degrees. .OP NULL t1 iv0 @@ -517,6 +784,12 @@ ATAN2 in degrees. .OP DADP t2 p1 dp(0) t1 .OP QJSR t3 =e'%d%__mth_i_datan2d t2 .OP DFRDP r t3 dpret +.IL QATAN2D arth lnk lnk +.OP NULL t1 iv0 +.OP DAQP t1 p2 qp(1) t1 +.OP DAQP t2 p1 qp(0) t1 +.OP QJSR t3 =e'%q%__mth_i_qatan2d t2 +.OP DFRDP r t3 qpret .IL SINH arth lnk .OP FSINH r p1 \".OP NULL t1 iv0 @@ -529,14 +802,20 @@ ATAN2 in degrees. \".OP DADP t1 p1 dp(0) t1 \".OP QJSR t2 =e'%d%__mth_i_dsinh t1 \".OP DFRDP r t2 dpret +.IL QSINH arth lnk +.OP QSINH r p1 .IL COSH arth lnk .OP FCOSH r p1 .IL DCOSH arth lnk .OP DCOSH r p1 +.IL QCOSH arth lnk +.OP QCOSH r p1 .IL TANH arth lnk .OP FTANH r p1 .IL DTANH arth lnk .OP DTANH r p1 +.IL QTANH arth lnk +.OP QTANH r p1 .IL ERF arth lnk .OP NULL t1 iv0 .OP DASP t1 p1 sp(0) t1 @@ -547,6 +826,11 @@ ATAN2 in degrees. .OP DADP t1 p1 dp(0) t1 .OP QJSR t2 =e'%d%__mth_i_derf t1 .OP DFRDP r t2 dpret +.IL QERF arth lnk +.OP NULL t1 iv0 +.OP DAQP t1 p1 qp(0) t1 +.OP QJSR t2 =e'%q%__mth_i_qerf t1 +.OP DFRQP r t2 qpret .IL ERFC arth lnk .OP NULL t1 iv0 .OP DASP t1 p1 sp(0) t1 @@ -557,6 +841,11 @@ ATAN2 in degrees. .OP DADP t1 p1 dp(0) t1 .OP QJSR t2 =e'%d%__mth_i_derfc t1 .OP DFRDP r t2 dpret +.IL QERFC arth lnk +.OP NULL t1 iv0 +.OP DAQP t1 p1 qp(0) t1 +.OP QJSR t2 =e'%q%__mth_i_qerfc t1 +.OP DFRQP r t2 qpret .IL ERFC_SCALED arth lnk .OP NULL t1 iv0 .OP DASP t1 p1 sp(0) t1 @@ -567,6 +856,11 @@ ATAN2 in degrees. .OP DADP t1 p1 dp(0) t1 .OP QJSR t2 =e'%d%__mth_i_derfc_scaled t1 .OP DFRDP r t2 dpret +.IL QERFC_SCALED arth lnk +.OP NULL t1 iv0 +.OP DAQP t1 p1 qp(0) t1 +.OP QJSR t2 =e'%q%__mth_i_qerfc_scaled t1 +.OP DFRQP r t2 qpret .IL GAMMA arth lnk .OP NULL t1 iv0 .OP DASP t1 p1 sp(0) t1 @@ -577,6 +871,11 @@ ATAN2 in degrees. .OP DADP t1 p1 dp(0) t1 .OP QJSR t2 =e'%d%__mth_i_dgamma t1 .OP DFRDP r t2 dpret +.IL QGAMMA arth lnk +.OP NULL t1 iv0 +.OP DAQP t1 p1 qp(0) t1 +.OP QJSR t2 =e'%q%__mth_i_qgamma t1 +.OP DFRQP r t2 qpret .IL LOG_GAMMA arth lnk .OP NULL t1 iv0 .OP DASP t1 p1 sp(0) t1 @@ -587,6 +886,11 @@ ATAN2 in degrees. .OP DADP t1 p1 dp(0) t1 .OP QJSR t2 =e'%d%__mth_i_dlog_gamma t1 .OP DFRDP r t2 dpret +.IL QLOG_GAMMA arth lnk +.OP NULL t1 iv0 +.OP DAQP t1 p1 qp(0) t1 +.OP QJSR t2 =e'%q%__mth_i_qlog_gamma t1 +.OP DFRQP r t2 qpret .IL HYPOT arth lnk lnk .OP NULL t1 iv0 .OP DASP t1 p2 sp(1) t1 @@ -599,6 +903,12 @@ ATAN2 in degrees. .OP DADP t2 p1 dp(0) t1 .OP QJSR t3 =e'%d%__mth_i_dhypot t2 .OP DFRDP r t3 dpret +.IL QHYPOT arth lnk lnk +.OP NULL t1 iv0 +.OP DAQP t1 p2 qp(1) t1 +.OP DAQP t2 p1 qp(0) t1 +.OP QJSR t3 =e'%q%__mth_i_qhypot t2 +.OP DFRQP r t3 qpret .IL ACOSH arth lnk .OP NULL t1 iv0 .OP DASP t1 p1 sp(0) t1 @@ -609,6 +919,8 @@ ATAN2 in degrees. .OP DADP t1 p1 dp(0) t1 .OP QJSR t2 =e'%d%__mth_i_dacosh t1 .OP DFRDP r t2 dpret +.IL QACOSH arth lnk +.OP QACOSH r p1 .IL ASINH arth lnk .OP NULL t1 iv0 .OP DASP t1 p1 sp(0) t1 @@ -619,6 +931,8 @@ ATAN2 in degrees. .OP DADP t1 p1 dp(0) t1 .OP QJSR t2 =e'%d%__mth_i_dasinh t1 .OP DFRDP r t2 dpret +.IL QASINH arth lnk +.OP QASINH r p1 .IL ATANH arth lnk .OP NULL t1 iv0 .OP DASP t1 p1 sp(0) t1 @@ -629,6 +943,8 @@ ATAN2 in degrees. .OP DADP t1 p1 dp(0) t1 .OP QJSR t2 =e'%d%__mth_i_datanh t1 .OP DFRDP r t2 dpret +.IL QATANH arth lnk +.OP QATANH r p1 .IL BESSEL_J0 arth lnk .OP NULL t1 iv0 .OP DASP t1 p1 sp(0) t1 @@ -639,6 +955,11 @@ ATAN2 in degrees. .OP DADP t1 p1 dp(0) t1 .OP QJSR t2 =e'%d%__mth_i_dbessel_j0 t1 .OP DFRDP r t2 dpret +.IL QBESSEL_J0 arth lnk +.OP NULL t1 iv0 +.OP DAQP t1 p1 qp(0) t1 +.OP QJSR t2 =e'%q%__mth_i_qbessel_j0 t1 +.OP DFRDP r t2 qpret .IL BESSEL_J1 arth lnk .OP NULL t1 iv0 .OP DASP t1 p1 sp(0) t1 @@ -649,6 +970,11 @@ ATAN2 in degrees. .OP DADP t1 p1 dp(0) t1 .OP QJSR t2 =e'%d%__mth_i_dbessel_j1 t1 .OP DFRDP r t2 dpret +.IL QBESSEL_J1 arth lnk +.OP NULL t1 iv0 +.OP DAQP t1 p1 qp(0) t1 +.OP QJSR t2 =e'%q%__mth_i_qbessel_j1 t1 +.OP DFRDP r t2 qpret .IL BESSEL_JN arth lnk lnk .OP NULL t1 iv0 .OP DASP t1 p2 sp(0) t1 @@ -661,6 +987,12 @@ ATAN2 in degrees. .OP DAIR t2 p1 dr(0) t1 .OP QJSR t3 =e'%d%__mth_i_dbessel_jn t2 .OP DFRDP r t3 dpret +.IL QBESSEL_JN arth lnk lnk +.OP NULL t1 iv0 +.OP DAQP t1 p2 qp(0) t1 +.OP DAIR t2 p1 dr(0) t1 +.OP QJSR t3 =e'%q%__mth_i_qbessel_jn t2 +.OP DFRQP r t3 dpret .IL BESSEL_Y0 arth lnk .OP NULL t1 iv0 .OP DASP t1 p1 sp(0) t1 @@ -671,6 +1003,11 @@ ATAN2 in degrees. .OP DADP t1 p1 dp(0) t1 .OP QJSR t2 =e'%d%__mth_i_dbessel_y0 t1 .OP DFRDP r t2 dpret +.IL QBESSEL_Y0 arth lnk +.OP NULL t1 iv0 +.OP DAQP t1 p1 dp(0) t1 +.OP QJSR t2 =e'%q%__mth_i_qbessel_y0 t1 +.OP DFRQP r t2 dpret .IL BESSEL_Y1 arth lnk .OP NULL t1 iv0 .OP DASP t1 p1 sp(0) t1 @@ -681,6 +1018,11 @@ ATAN2 in degrees. .OP DADP t1 p1 dp(0) t1 .OP QJSR t2 =e'%d%__mth_i_dbessel_y1 t1 .OP DFRDP r t2 dpret +.IL QBESSEL_Y1 arth lnk +.OP NULL t1 iv0 +.OP DAQP t1 p1 qp(0) t1 +.OP QJSR t2 =e'%q%__mth_i_qbessel_y1 t1 +.OP DFRDP r t2 qpret .IL BESSEL_YN arth lnk lnk .OP NULL t1 iv0 .OP DASP t1 p2 sp(0) t1 @@ -693,6 +1035,12 @@ ATAN2 in degrees. .OP DAIR t2 p1 dr(0) t1 .OP QJSR t3 =e'%d%__mth_i_dbessel_yn t2 .OP DFRDP r t3 dpret +.IL QBESSEL_YN arth lnk lnk +.OP NULL t1 iv0 +.OP DAQP t1 p2 qp(0) t1 +.OP DAIR t2 p1 dr(0) t1 +.OP QJSR t3 =e'%q%__mth_i_qbessel_yn t2 +.OP DFRQP r t3 qpret .IL SNGL arth lnk Convert double precision number to single precision (SNGL intrinsic). .OP SNGL r p1 @@ -725,6 +1073,8 @@ Integer negation. .OP FNEG r p1 .IL DNEG arth lnk .OP DNEG r p1 +.IL QNEG arth lnk +.OP QNEG r p1 .IL CNEG arth lnk .AT spec .OP FNEG rr rp1 @@ -734,6 +1084,13 @@ Double complex negation. .AT spec dcmplx .OP DNEG rr rp1 .OP DNEG ir ip1 +./" AOCC begin +.IL CQNEG arth lnk +Quad complex negation. +.AT spec +.OP QNEG rr rp1 +.OP QNEG ir ip1 +./" AOCC end .IL NOT64 arth lnk Bitwise negation of 64 bit value (NOT intrinsic). .AT i8 @@ -805,6 +1162,15 @@ p3 - mask .fi .OP ICMPZ t1 p3 ne .OP DSELECT r t1 p2 p1 +.IL QMERGE arth lnk lnk lnk +Real*16 valued f90 merge intrinsic. +.nf +p1 - tsource +p2 - fsource +p3 - mask +.fi +.OP ICMPZ t1 p3 ne +.OP QSELECT r t1 p2 p1 .IL CMERGE arth lnk lnk lnk Real*4 complex valued f90 merge intrinsic. .nf @@ -823,6 +1189,17 @@ p3 - mask .fi .OP ICMPZ t1 p3 ne .OP CDSELECT r t1 p2 p1 +./" AOCC begin +.IL CQMERGE arth lnk lnk lnk +Real*16 complex valued f90 merge intrinsic. +.nf +p1 - tsource +p2 - fsource +p3 - mask +.fi +.OP ICMPZ t1 p3 ne +.OP CQSELECT r t1 p2 p1 +./" AOCC end .IL IADD arth lnk lnk .OP IADD r p1 p2 .IL UIADD arth lnk lnk @@ -831,6 +1208,14 @@ p3 - mask .OP FADD r p1 p2 .IL DADD arth lnk lnk .OP DADD r p1 p2 +.\" AOCC begin +.IL QADD arth lnk lnk +.OP QADD r p1 p2 +.IL CQADD arth lnk lnk +.AT spec dcmplx +.OP QADD rr rp1 rp2 +.OP QADD ir ip1 ip2 +.\" AOCC end .IL CADD arth lnk lnk .AT spec .OP FADD rr rp1 rp2 @@ -866,12 +1251,20 @@ the pointer (lnk1) points to. .OP FSUB r p1 p2 .IL DSUB arth lnk lnk .OP DSUB r p1 p2 +.\" AOCC begin +.IL QSUB arth lnk lnk +.OP QSUB r p1 p2 +.IL CQSUB arth lnk lnk +.AT spec +.OP QSUB rr rp1 rp2 +.OP QSUB ir ip1 ip2 +.\" AOCC end .IL CSUB arth lnk lnk .AT spec .OP FSUB rr rp1 rp2 .OP FSUB ir ip1 ip2 .IL CDSUB arth lnk lnk -.AT spec dcmplx +.AT spec .OP DSUB rr rp1 rp2 .OP DSUB ir ip1 ip2 .IL PSUB arth lnk lnk stc @@ -914,6 +1307,8 @@ the pointer (lnk1) points to. .OP FMUL r p1 p2 .IL DMUL arth lnk lnk .OP DMUL r p1 p2 +.IL QMUL arth lnk lnk +.OP QMUL r p1 p2 .IL CMUL arth lnk lnk .AT spec .OP FMUL t1 rp1 rp2 @@ -930,6 +1325,16 @@ the pointer (lnk1) points to. .OP DMUL t1 ip1 rp2 .OP DMUL t2 ip2 rp1 .OP DADD ir t2 t1 +.\" AOCC begin +.IL CQMUL arth lnk lnk +.AT spec +.OP QMUL t1 rp1 rp2 +.OP QMUL t2 ip1 ip2 +.OP QSUB rr t1 t2 +.OP QMUL t1 ip1 rp2 +.OP QMUL t2 ip2 rp1 +.OP QADD ir t2 t1 +.\" AOCC end .IL IDIV arth lnk lnk .OP IDIV r p1 p2 .IL UIDIV arth lnk lnk @@ -938,6 +1343,16 @@ the pointer (lnk1) points to. .OP FDIV r p1 p2 .IL DDIV arth lnk lnk .OP DDIV r p1 p2 +.\" AOCC begin +.IL QDIV arth lnk lnk +.OP QDIV r p1 p2 +.IL CQDIV arth lnk lnk +.AT spec +.IL CQDIVQ arth lnk lnk +.AT spec +.OP QDIV rr rp1 p2 +.OP QDIV ir ip1 p2 +.\" AOCC end .IL CDIV arth lnk lnk .AT spec .IL CDIVR arth lnk lnk @@ -957,6 +1372,8 @@ Exponentiation - integer to an integer power. .OP FPOWI r p1 p2 .IL DTOI arth lnk lnk .OP DPOWI r p1 p2 +.IL QTOI arth lnk lnk +.OP QPOWI r p1 p2 .CL MOD arth lnk lnk Integer remainder .OP MOD r p1 p2 @@ -969,6 +1386,10 @@ Integer remainder (MOD intrinsic). .OP FMOD r p1 p2 .IL DMOD arth lnk lnk .OP DMOD r p1 p2 +.\" AOCC begin +.IL QMOD arth lnk lnk +.OP QMOD r p1 p2 +.\" AOCC end .IL ISIGN arth lnk lnk .OP ICMPZ t1 p2 lt .OP IABS t2 p1 @@ -980,11 +1401,34 @@ Real valued SIGN intrinsic. .OP FABS t2 p1 .OP FNEG t3 t2 .OP FSELECT r t1 t2 t3 +.IL SIGNNZ arth lnk lnk +Real valued SIGN intrinsic that distinguishes negative zero. +.OP FCMPZNZ t1 p2 lt +.OP FABS t2 p1 +.OP FNEG t3 t2 +.OP FSELECT r t1 t2 t3 .IL DSIGN arth lnk lnk .OP DCMPZ t1 p2 lt .OP DABS t2 p1 .OP DNEG t3 t2 .OP DSELECT r t1 t2 t3 +.IL DSIGNNZ arth lnk lnk +.OP DCMPZNZ t1 p2 lt +.OP DABS t2 p1 +.OP DNEG t3 t2 +.OP DSELECT r t1 t2 t3 +./" AOCC begin +.IL QSIGN arth lnk lnk +.OP QCMPZ t1 p2 lt +.OP QABS t2 p1 +.OP QNEG t3 t2 +.OP QSELECT r t1 t2 t3 +.IL QSIGNNZ arth lnk lnk +.OP QCMPZNZ t1 p2 lt +.OP QABS t2 p1 +.OP QNEG t3 t2 +.OP QSELECT r t1 t2 t3 +./" AOCC end .IL IDIM arth lnk lnk .OP NULL t1 iv0 .OP DAIR t1 p2 dr(1) t1 @@ -1004,6 +1448,12 @@ Real valued DIM intrinsic. .OP DADP t2 p1 sp(0) t1 .OP QJSR t3 =e'%d%ftn_i_ddim t2 .OP DFRDP r t3 dpret +.IL QDIM arth lnk lnk +.OP NULL t1 iv0 +.OP DAQP t1 p2 qp(1) t1 +.OP DAQP t2 p1 qp(0) t1 +.OP QJSR t3 =e'%q%ftn_i_qdim t2 +.OP DFRQP r t3 qpret .IL DPROD arth lnk lnk Multiply two single precision real values and return double precision value. (DPROD intrinsic). @@ -1018,6 +1468,10 @@ precision value. (DPROD intrinsic). .OP FMAX r p1 p2 .IL DMAX arth lnk lnk .OP DMAX p p1 p2 +.\" AOCC begin +.IL QMAX arth lnk lnk +.OP QMAX p p1 p2 +.\" AOCC end .IL IMIN arth lnk lnk .OP IMIN r p1 p2 .IL UIMIN arth lnk lnk @@ -1026,6 +1480,10 @@ precision value. (DPROD intrinsic). .OP FMIN r p1 p2 .IL DMIN arth lnk lnk .OP DMIN r p1 p2 +.\" AOCC begin +.IL QMIN arth lnk lnk +.OP QMIN r p1 p2 +.\" AOCC end .IL INDEX fstr lnk lnk INDEX intrinsic (inputs are two character strings and result is an integer). .AT spec @@ -1080,6 +1538,12 @@ value and second is assumed to be a positive integer. .OP RSHIFT r p1 p2 .IL KRSHIFT arth lnk lnk .AT i8 +.IL SHIFTA arth lnk lnk +Right shift operator (>>). First operand is 32 bit signed integer +value and second is assumed to be a positive integer. +.OP SHIFTA r p1 p2 +.IL KSHIFTA arth lnk lnk +.AT i8 .OP KARSHIFT r p1 p2 .IL ULSHIFT arth lnk lnk Left shift operator (<<) - first operand is 32 bit unsigned integer @@ -1187,6 +1651,7 @@ IBITS(p1, p2, p3) - extract p3 bits beginning at p2 from p1. r = p3 != 0 ? (p1 >> p2) & (-1 >> (32 - p3)) : 0 .fi .OP RSHIFT t1 p1 p2 +.OP SHIFTA t1 p1 p2 .OP ICON t2 =i'-1 .OP ICON t3 =i'32 .OP ISUB t4 t3 p3 @@ -1226,12 +1691,19 @@ FLOOR of real to real .IL DFLOOR arth lnk FLOOR of double to double .OP DFLOOR r p1 +.IL QFLOOR arth lnk +FLOOR of quad to quad +.OP QFLOOR r p1 .IL RCEIL arth lnk CELING of real to real .OP FCEIL r p1 .IL DCEIL arth lnk CELING of double to double .OP DCEIL r p1 +.IL QCEIL arth lnk +CEIL of quad to quad +.OP QCEIL r p1 + .IL ICMP arth lnk lnk Integer comparision of two integer numbers. The compare ILMs are used only in the context of a relational expression @@ -1246,6 +1718,11 @@ Compare two single precision floating point numbers. .AT spec .IL DCMP arth lnk lnk Compare two double precision floating point numbers. +.\" AOCC begin +.AT spec +.IL QCMP arth lnk lnk +Compare two quad precision floating point numbers. +.\" AOCC end .AT spec .IL UICMP arth lnk lnk Unsigned integer comparison. @@ -1253,6 +1730,9 @@ Unsigned integer comparison. .IL UDICMP arth lnk lnk Unsigned double integer comparison. .AT spec +.IL UQICMP arth lnk lnk +Unsigned quad integer comparison. +.AT spec .CL PCMP arth lnk lnk Pointer comparison. .AT spec @@ -1264,6 +1744,12 @@ The value computed is 0 if equal and -1 or 1 if not equal. Compare two double complex numbers. The value computed is the same as for the ICMP ILM. .AT spec +./" AOCC begin +.IL CQCMP arth lnk lnk +Compare two quad complex numbers. +The value computed is the same as for the ICMP ILM. +.AT spec +./" AOCC end .IL SCMP fstr lnk lnk Compare two strings. The value computed is the same as for the ICMP ILM. SCMP has no @@ -1347,6 +1833,14 @@ lnk3 - stride .OP FCON r v1 .IL DCON cons sym .OP DCON r v1 +.\" AOCC begin +.IL QCON cons sym +.OP QCON r v1 +.IL CQCON cons sym +.AT spec +.OP QCON rr iv0 +.OP QCON ir iv0 +.\" AOCC end .IL CCON cons sym .AT spec .OP FCON rr iv0 @@ -1419,6 +1913,13 @@ Arithmetic if branch on real expression. .OP DCJMPZ null p1 le v2 .OP DCJMPZ null p1 eq v3 .OP DCJMPZ null p1 gt v4 +.\" AOCC begin +.IL QAIF branch lnk sym1 sym2 sym3 +.AT spec trm +.OP QCJMPZ null p1 le v2 +.OP QCJMPZ null p1 eq v3 +.OP QCJMPZ null p1 gt v4 +.\" AOCC end .IL AGOTO branch n lnk sym* Assigned GOTO. 'lnk' is to an ILD ILM. @@ -1458,6 +1959,11 @@ Load real .IL DLD load lnk Load double .AT spec +.\" AOCC begin +.IL QPLD load lnk +Load quad +.AT spec +.\" AOCC end .IL QLD load lnk Load m128 .AT spec @@ -1468,6 +1974,10 @@ Load m256 .AT spec .IL CDLD load lnk .AT spec dcmplx +.\" AOCC begin +.IL CQLD load lnk +.AT spec +.\" AOCC end .IL LLD load lnk Load logical value. .AT spec @@ -1528,6 +2038,11 @@ Store float .IL DST store lnk lnk Store double .AT spec trm +.\" AOCC begin +.IL QPST store lnk lnk +Store quad +.AT spec trm +.\" AOCC end .IL QST store lnk lnk Store m128 .AT spec trm @@ -1549,6 +2064,15 @@ Store the real part of a double complex .AT spec trm .IL CDSTI store lnk lnk Store the imaginary part of a double complex +.\" AOCC begin +.IL CQST store lnk lnk +.AT spec trm +.IL CQSTR store lnk lnk +Store the real part of a quad complex +.AT spec trm +.IL CQSTI store lnk lnk +Store the imaginary part of a quad complex +.\" AOCC end .AT spec trm .IL LST store lnk lnk .AT spec trm @@ -1596,7 +2120,7 @@ loads and stores or a call (JSR) to one of: Zero memory locations. lnk1 - base address to zero lnk2 - number of units to zero -stc - data type of units to zero: char, short, int, dble +stc - data type of units to zero: char, short, int, dble, quad The expansion of this ILM can generate ILI for a sequence of stores or a JSR to one of "c_bzero" zero bytes @@ -1725,6 +2249,9 @@ Call m128 function .IL QFUNCA proc n stc lnk lnk* Call m128 function .AT spec +.IL PQFUNCA proc n stc sym lnk lnk* +Call m128 function through procedure pointer +.AT spec .CL M256FUNC proc n lnk lnk* Call m256 function .AT spec @@ -1778,6 +2305,8 @@ in the CALL statement. .AT spec .CL CDFUNC proc n lnk lnk* .AT spec dcmplx +.CL CQFUNC proc n lnk lnk* +.AT spec .FL CFUNC proc n sym lnk* .AT spec .IL CFUNCA proc n stc lnk lnk* @@ -1796,6 +2325,17 @@ Call double complex function through procedure pointer. .AT spec dcmplx .IL CDVFUNCA proc n stc sym lnk sym lnk* .AT spec dcmplx +./" AOCC begin +.FL CQFUNC proc n sym lnk* +.AT spec +.IL CQFUNCA proc n stc lnk lnk* +.AT spec +.IL PCQFUNCA proc n stc sym lnk lnk* +Call quad complex function through procedure pointer. +.AT spec +.IL CQVFUNCA proc n stc sym lnk sym lnk* +.AT spec +./" AOCC end .IL LFUNC proc n sym lnk* .AT spec .IL LFUNCA proc n stc lnk lnk* @@ -2086,6 +2626,7 @@ computed as (x+y) >> 1 .OP ICON t1 =i'1 .OP IADD t2 p1 p2 .OP RSHIFT r t2 t1 +.OP SHIFTA r t2 t1 .IL UHADD arth lnk lnk hadd(x,y), where x and y are unsigned char or unsigned short, and computed as (x+y) >> 1 @@ -2141,6 +2682,7 @@ computed as (x+y+1) >> 1 .OP IADD t2 p1 p2 .OP IADD t2 t2 t1 .OP RSHIFT r t2 t1 +.OP SHIFTA r t2 t1 .IL URHADD arth lnk lnk rhadd(x,y), where x and y are unsigned char or unsigned short, and computed as (x+y+1) >> 1 @@ -2304,6 +2846,12 @@ Return the value of an expression in a variable format item (). .AT spec trm .IL PRAGMA misc stc1 stc2 stc3 pragma/directive ILM +.\" AOCC Begin +.IL QFLOATK arth lnk +Convert long long to quad precision (QFLOAT intrinsic). +.AT i8 +.OP QFLOATK r p1 +.\" AOCC end .IL FLOATK arth lnk Convert long long to real number (REAL and FLOAT intrinsics). .AT i8 @@ -2382,6 +2930,8 @@ Exponentiation - integer to an integer power. .AT spec .IL CDTOK intr lnk lnk .AT spec dcmplx +.IL CQTOK intr lnk lnk +.AT spec .IL KCMP arth lnk lnk .AT spec .IL UKCMP arth lnk lnk @@ -2401,6 +2951,12 @@ Convert real number to integer*8 (INT and IFIX intrinsics). Convert double precision floating point number to integer*8. .AT i8 .OP DFIXK r p1 +./" AOCC begin +.IL KQFIX arth lnk +Convert quad precision floating point number to integer*8. +.AT i8 +.OP QFIXK r p1 +./" AOCC end .IL UKDFIX arth lnk Convert double precision floating point number to integer*8. .AT spec i8 @@ -2744,6 +3300,19 @@ Cast an unsigned integer to a 64-bit integer. 64-bit integer LEADZ intrinsic .AT i8 .OP KLEADZ r p1 +.IL BTRAILZ intr lnk +8-bit integer TRAILZ intrinsic +.OP ITRAILZI r p1 iv0 +.IL STRAILZ intr lnk +16-bit integer TRAILZ intrinsic +.OP ITRAILZI r p1 iv1 +.IL ITRAILZ intr lnk +32-bit integer TRAILZ intrinsic +.OP ITRAILZ r p1 +.IL KTRAILZ intr lnk +64-bit integer TRAILZ intrinsic +.AT i8 +.OP KTRAILZ r p1 .IL BPOPCNT intr lnk 8-bit integer POPCNT intrinsic .OP IPOPCNTI r p1 iv0 @@ -3282,6 +3851,8 @@ Task firstprivate sym - symbol table pointer to the shared variable. sym - symbol table pointer to the private copy. .AT spec trm +.IL REQUIRES SMP stc +.AT spec trm .IL BTASK SMP sym stc lnk lnk Begin task Always matches a ETASK ilm @@ -3622,6 +4193,24 @@ stc Combined costruct mode lnk link to num_teams clause if exists lnk link to thread_limit clause if exists lnk link to num_threads clause if exists +.\" AOCC Begin +.AT spec trm +.IL MP_NUMTEAMS SMP sym +Number of teams symbol. +sym Number of teams +.AT spec trm +.IL MP_NUMTHREADS SMP sym +Number of threads symbol. +sym Number of threads +.AT spec trm +.IL MP_DEFAULTMAP SMP stc +Default map construct. +stc - Default map type +.AT spec trm +.IL MP_TARGETDECLARE SMP +Target declare construct. +sym - Target symbol +.\" AOCC End .AT spec trm .IL MP_TARGETLOOPTRIPCOUNT SMP sym loop trip count for target region @@ -3634,6 +4223,16 @@ map with to map type lnk - symbol to be mapped stc - map type .fi +\" AOCC BEGIN +.AT spec trm +.IL MP_MAP_MEM SMP lnk stc lnk +map with to map type +.nf +lnk - symbol to be mapped +stc - map type +lnk - Base incase of memory pointers +.fi +\" AOCC END .AT spec trm .IL MP_REDUCTIONITEM SMP sym sym stc Begin of reduction clause. @@ -3658,6 +4257,27 @@ Begin directive .IL MP_END_DIR SMP End directive .AT spec trm +.IL MP_USE_DEVICE_PTR SMP lnk stc +use the device pointer for symbol +.nf +lnk - symbol whose address need to be mapped +stc - map type +.fi +.AT spec trm +.IL MP_IS_DEVICE_PTR SMP lnk stc +use the already mapped device pointer for symbol +.nf +lnk - symbol already on target +stc - map type +.fi +.AT spec trm +.IL MP_USE_DEVICE_ADDR SMP lnk stc +use the device address for symbol +.nf +lnk - symbol whose address need to be mapped +stc - map type +.fi +.AT spec trm .IL HFLD load lnk Load half precision .AT spec diff --git a/tools/flang2/utils/machar/machar.n b/tools/flang2/utils/machar/machar.n index f7e1a9e5ee..bd8cc72432 100644 --- a/tools/flang2/utils/machar/machar.n +++ b/tools/flang2/utils/machar/machar.n @@ -2,7 +2,17 @@ .\" * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. .\" * See https://llvm.org/LICENSE.txt for license information. .\" * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -.\" * +.\" * +.\" * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +.\" * Notified per clause 4(b) of the license. +.\" * +.\" * Added support for quad precision +.\" * Last modified: Feb 2020 +.\" * +.\" * Added code to support SHIFTA intrinsic +.\" * Last modified: April 2020 +.\" * +.\" * Last modified: July 2020 .\" */ .NS 24 "Target Machine" "Appendix III - " .de DN @@ -60,6 +70,7 @@ lw(1n) lfCW | l | c. %TM_IDIV2%divide by power of 2 instruction%no %TM_FDIV%single precision divide instruction%yes %TM_DDIV%double precision divide instruction%yes +%TM_QDIV%quad precision divide instruction%yes %TM_UICMP%unsigned integer compare instruction%yes %TM_SQRT%square root instruction%yes %TM_FIELD_INST%bit field support instructions%no @@ -72,8 +83,10 @@ lw(1n) lfCW | l | c. %TM_AUTOINC_FP%auto increment when addressing single/double%no %TM_FCMPZ%single precision compare with zero%no %TM_DCMPZ%double precision compare with zero%no +%TM_QCMPZ%quad precision compare with zero%no %TM_FCJMPZ%single precision compare with zero and jump%yes %TM_DCJMPZ%double precision compare with zero and jump%yes +%TM_QCJMPZ%quad precision compare with zero and jump%yes %TM_I8%integer*8 (long long)%yes .TE .lp @@ -106,6 +119,10 @@ signed quantity. .DA "( (x) << (y) )" .DN RSHIFT(x,y) .DA "( (x) >> (y) )" +.DN SHIFTA(x,y) +.DA "( (x) & 0x80000000 ?" +.DA "( (unsigned)(x) >> (y) ) | ( (~0u) << (32-(y)) ) :" +.DA "(x) >> (y) )" .np Constant fold shift per target machine; operand which is shifted is an unsigned quantity. @@ -153,10 +170,11 @@ lw(1n) lfCW | l | l | l | l | l | l. %TY_HALF%2%1%16%0%reg1%Half Precision Real %TY_REAL%4%3%32%0%reg1%Floating Point Real %TY_DBLE%8%7%64%0%reg2%Double Precision Real -%TY_QUAD%0%0%64%0%reg2%Quad Precision Real +%TY_QUAD%16%15%128%0%reg2%Quad Precision Real \* AOCC \* %TY_HCMPLX%4%1%32%0%mem0%half precision complex %TY_CMPLX%8%3%64%0%mem0%Complex %TY_DCMPLX%16%7%128%0%mem1%Double Precision Complex +%TY_QCMPLX%32%15%128%0%mem1%Quad Precision Complex \* AOCC \* %TY_BLOG%1%0%8%0%reg0%Byte Logical %TY_SLOG%2%1%16%0%reg0%Short Logical %TY_LOG%4%3%32%0%reg0%Logical diff --git a/tools/flang2/utils/symtab/symini.cpp b/tools/flang2/utils/symtab/symini.cpp index f75aa33bb6..77e1b9f725 100644 --- a/tools/flang2/utils/symtab/symini.cpp +++ b/tools/flang2/utils/symtab/symini.cpp @@ -4,6 +4,15 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * Last Modified: Jun 2020 + * + */ /* symbol initialization for Fortran */ #include "scutil.h" @@ -33,7 +42,7 @@ * out2 - generated macros which define the predeclared numbers (pd.h) *---------------------------------------------------------------------*/ -STB stb; +extern STB stb; /** * Formats of lines in the symini*.n input file: @@ -67,8 +76,10 @@ class SyminiF90 : public UtilityApplication argtype["I"] = DT_INT; argtype["R"] = DT_REAL; argtype["D"] = DT_DBLE; + argtype["Q"] = DT_QUAD; // AOCC argtype["C"] = DT_CMPLX; argtype["CD"] = DT_DCMPLX; + argtype["CQ"] = DT_QCMPLX; // AOCC argtype["SI"] = DT_SINT; argtype["H"] = DT_CHAR; argtype["N"] = DT_NUMERIC; @@ -406,6 +417,18 @@ class SyminiF90 : public UtilityApplication printError(SEVERE, "Non-existent CD intrinsic"); GDCMPLXP(sptr, sptr1); } + // AOCC begin + /* cqname */ + tok = makeLower(getToken()); + if (tok.length() == 0 || tok[0] == '-') + GDCMPLXP(sptr, 0); + else { + auto sptr1 = installsym(tok.c_str(), tok.length()); + if (STYPEG(sptr1) != ST_INTRIN) + printError(SEVERE, "Non-existent CQ intrinsic"); + GDCMPLXP(sptr, sptr1); + } + // AOCC end /* i8name */ tok = makeLower(getToken()); #ifdef TM_I8 diff --git a/tools/flang2/utils/symtab/symini_ftn.n b/tools/flang2/utils/symtab/symini_ftn.n index fdd1e99554..68e1529752 100644 --- a/tools/flang2/utils/symtab/symini_ftn.n +++ b/tools/flang2/utils/symtab/symini_ftn.n @@ -2,7 +2,24 @@ .\" * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. .\" * See https://llvm.org/LICENSE.txt for license information. .\" * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -.\" * +.\" * +.\" * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +.\" * Notified per clause 4(b) of the license. +.\" * +.\" * Added support for quad precision +.\" * Last modified: Feb 2020 +.\" * +.\" * Support for Real128 support for math intrinsics +.\" * Date of Modification: Feb 2020 +.\" * +.\" * Added code to support SHIFTA intrinsic +.\" * Last modified: April 2020 +.\" * +.\" * Added code support for dasinh +.\" * Modified on 31st Aug 2020 +.\" * +.\" * Added code support for cotan and cotand +.\" * Modified on Oct 2020 .\" */ .NS 28 "Intrinsics & Generics" "Appendix VII - " .de IN @@ -73,10 +90,12 @@ sptr name pcnt atyp dtype ILM pname .IN DSQRT 1 D D DSQRT ftn_dsqrt .IN CSQRT 1 C C CSQRT ftn_csqrt .IN CDSQRT 1 CD CD CDSQRT ftn_cdsqrt +.IN CQSQRT 1 CQ CQ CQSQRT ftn_cqsqrt .IN ALOG 1 R R ALOG ftn_alog .IN DLOG 1 D D DLOG ftn_dlog .IN CLOG 1 C C CLOG ftn_clog .IN CDLOG 1 CD CD CDLOG ftn_cdlog +.IN CQLOG 1 CQ CQ CQLOG ftn_cqlog .IN ALOG10 1 R R ALOG10 ftn_alog10 .IN DLOG10 1 D D DLOG10 ftn_dlog10 .IN .EXP 1 R R EXP ftn_exp @@ -84,49 +103,75 @@ sptr name pcnt atyp dtype ILM pname .IN CEXP 1 C C CEXP ftn_cexp .IN CDEXP 1 CD CD CDEXP ftn_cdexp .IN .SIN 1 R R SIN ftn_sin -.IN DSIN 1 D D DSIN ftn_dsin +.IN DSIN 1 D D DSIN ftn_dsin +.IN QSIN 1 Q Q QSIN ftn_qsin .IN CSIN 1 C C CSIN ftn_csin .IN CDSIN 1 CD CD CDSIN ftn_cdsin +.IN CQSIN 1 CQ CQ CQSIN ftn_cqsin .IN .SIND 1 R R SIND ftn_sind .IN DSIND 1 D D DSIND ftn_dsind .IN .COS 1 R R COS ftn_cos .IN DCOS 1 D D DCOS ftn_dcos +.IN QCOS 1 Q Q QCOS ftn_qcos .IN CCOS 1 C C CCOS ftn_ccos .IN CDCOS 1 CD CD CDCOS ftn_cdcos +.IN CQCOS 1 CQ CQ CQCOS ftn_cqcos .IN .COSD 1 R R COSD ftn_cosd .IN DCOSD 1 D D DCOSD ftn_dcosd .IN .TAN 1 R R TAN ftn_tan .IN DTAN 1 D D DTAN ftn_dtan +.IN QTAN 1 Q Q QTAN ftn_qtan .IN .TAND 1 R R TAND ftn_tand .IN DTAND 1 D D DTAND ftn_dtand +.IN .COTAN 1 R R COTAN ftn_cotan +.IN DCOTAN 1 D D DCOTAN ftn_dcotan +.IN QCOTAN 1 Q Q QCOTAN ftn_qcotan +.IN .COTAND 1 R R COTAND ftn_cotand +.IN DCOTAND 1 D D DCOTAND ftn_dcotand +.IN QCOTAND 1 Q Q QCOTAND ftn_qcotand .IN .ASIN 1 R R ASIN ftn_asin .IN DASIN 1 D D DASIN ftn_dasin +.IN QASIN 1 Q Q QASIN ftn_qasin .IN .ASIND 1 R R ASIND ftn_asind .IN DASIND 1 D D DASIND ftn_dasind .IN .ACOS 1 R R ACOS ftn_acos .IN DACOS 1 D D DACOS ftn_dacos +.IN QACOS 1 Q Q QACOS ftn_qacos .IN .ACOSD 1 R R ACOSD ftn_acosd .IN DACOSD 1 D D DACOSD ftn_dacosd .IN .ATAN 1 R R ATAN ftn_atan .IN DATAN 1 D D DATAN ftn_datan +.IN QATAN 1 Q Q QATAN ftn_qatan .IN .ATAND 1 R R ATAND ftn_atand .IN DATAND 1 D D DATAND ftn_datand .IN .ATAN2 2 R R ATAN2 ftn_atan2 .IN DATAN2 2 D D DATAN2 ftn_datan2 .IN .ATAN2D 2 R R ATAN2D ftn_atan2d .IN DATAN2D 2 D D DATAN2D ftn_datan2d +.IN QATAN2 2 Q Q QATAN2 ftn_qatan2 .IN .SINH 1 R R SINH ftn_sinh .IN DSINH 1 D D DSINH ftn_dsinh +.IN DASINH 1 D D DASINH ftn_dasinh +.IN QSINH 1 Q Q QSINH ftn_qsinh +.IN QASINH 1 Q Q QASINH ftn_qasinh .IN .COSH 1 R R COSH ftn_cosh .IN DCOSH 1 D D DCOSH ftn_dcosh +.IN QCOSH 1 Q Q QCOSH ftn_qcosh +.IN QACOSH 1 Q Q QACOSH ftn_qacosh .IN .TANH 1 R R TANH ftn_tanh .IN DTANH 1 D D DTANH ftn_dtanh +.IN QTANH 1 Q Q QTANH ftn_qtanh +.IN QATANH 1 Q Q QATANH ftn_qatanh .IN IABS 1 I I IABS ftn_iabs .IN IIABS 1 SI SI IABS ftn_iiabs .IN JIABS 1 I I IABS ftn_iabs .IN =KIABS 1 I8 I8 KABS ftn_kabs .IN .ABS 1 R R ABS ftn_abs .IN DABS 1 D D DABS ftn_dabs +.\" AOCC begin +.IN QABS 1 Q Q QABS ftn_qabs +.IN CQABS 1 CQ Q CQABS ftn_cqabs +.\" AOCC end .IN CABS 1 C R CABS ftn_cabs .IN CDABS 1 CD D CDABS ftn_cdabs .IN .INT 1 R I tc @@ -191,10 +236,20 @@ Convert any numeric data type to double precision. Convert any numeric data type to complex. .IN .2CD 11 N CD tc Convert any numeric data type to double complex. +.\" AOCC begin +.IN .2Q 1 N Q tc +Convert any numeric data type to quad precision. +.IN .2CQ 1 N CQ tc +Convert any numeric data type to quad complex. +.IN QREAL 1 CQ Q tc +Converts complex*32 to quad. +.\" AOCC end .IN .AIMAG 1 C R IMAG ftn_aimag .IN DIMAG 1 CD D DIMAG ftn_dimag +.IN QIMAG 1 CQ Q QIMAG ftn_qimag .IN .CONJG 1 C C CONJG ftn_conjg .IN DCONJG 1 CD CD DCONJG ftn_dconjg +.IN QCONJG 1 CQ CQ QCONJG ftn_qconjg .IN DPROD 2 R D DPROD ftn_dprod .IN IMAX0 12 SI SI IMAX - .IN MAX0 12 I I IMAX - @@ -230,6 +285,7 @@ Convert any numeric data type to double complex. .IN IDIM 2 I I IDIM ftn_idim .IN .DIM 2 R R DIM ftn_dim .IN DDIM 2 D D DDIM ftn_ddim +.IN QDIM 2 Q Q QDIM ftn_qdim .IN IMOD 2 SI SI MOD ftn_imod .IN JMOD 2 I I MOD ftn_mod .IN =KMOD 2 I8 I8 KMOD ftn_kmod @@ -288,6 +344,9 @@ Convert any numeric data type to double complex. .IN .IRSHIFT 2 SI SI URSHIFT .IN .JRSHIFT 2 I I URSHIFT .IN =.KRSHIFT 2 I8 I8 KURSHIFT +.IN .ISHIFTA 2 SI SI SHIFTA +.IN .JSHIFTA 2 I I SHIFTA +.IN =.KSHIFTA 2 I8 I8 KSHIFTA .IN .2SCH 1 SI H CHAR .IN .CHAR 1 I H CHAR .IN =.2KCH 1 I8 H CHAR @@ -331,17 +390,21 @@ sptr name siname iname rname dname cname cdname i8name .GN =INT8 .2KI .2KI .INT8 .IDINT8 .2KI .2KI .2KI .GN REAL FLOATI .REAL .2R SNGL .2R .2R .FLOATK .GN DBLE DFLOTI DFLOAT .2D .2D .2D DREAL .DFLOTK +.\" AOCC: QUAD +.GN QUAD QFLOTI QFLOAT .2Q .2Q .2Q QREAL .QFLOTK .GN CMPLX .2C .2C .2C .2C .2C .2C .2C .GN DCMPLX .2CD .2CD .2CD .2CD .2CD .2CD .2CD -.GN AIMAG - - - - .AIMAG DIMAG - -.GN CONJG - - - - .CONJG DCONJG - +.\" AOCC: QUAD +.GN QCMPLX .2CQ .2CQ .2CQ .2CQ .2CQ .2CQ .2CQ +.GN AIMAG - - - - .AIMAG DIMAG QIMAG +.GN CONJG - - - - .CONJG DCONJG QCONJG .GN AINT - - .AINT DINT - - - .GN ANINT - - .ANINT DNINT - - - .GN ININT - - .ININT IIDNNT - - - .GN JNINT - - .JNINT JIDNNT - - - .GN NINT - - .NINT IDNINT - - - .GN =KNINT - - .KNINT KIDNNT - - - -.GN ABS IIABS IABS .ABS DABS CABS CDABS KIABS +.GN ABS IIABS IABS .ABS DABS CABS CDABS CQABS KIABS .GN MOD IMOD .MOD AMOD DMOD - - KMOD .GN SIGN IISIGN ISIGN .SIGN DSIGN - - KISIGN .GN DIM IIDIM IDIM .DIM DDIM - - KIDIM @@ -349,14 +412,16 @@ sptr name siname iname rname dname cname cdname i8name .GN MIN IMIN0 MIN0 AMIN1 DMIN1 - - .KMIN0 .GN SQRT - - .SQRT DSQRT CSQRT CDSQRT - .GN EXP - - .EXP DEXP CEXP CDEXP - -.GN LOG - - ALOG DLOG CLOG CDLOG - -.GN LOG10 - - ALOG10 DLOG10 - - - -.GN SIN - - .SIN DSIN CSIN CDSIN - +.GN LOG - - ALOG DLOG CLOG CDLOG CQLOG +.GN LOG10 - - ALOG10 DLOG10 QLOG10 - - +.GN SIN - - .SIN DSIN CSIN CDSIN QSIN QASIN- .GN SIND - - .SIND DSIND - - - -.GN COS - - .COS DCOS CCOS CDCOS - +.GN COS - - .COS DCOS CCOS CDCOS QCOS QACOS- .GN COSD - - .COSD DCOSD - - - +.GN COTAN - - .COTAN DCOTAN QCOTAN - - +.GN COTAND - - .COTAND DCOTAND QCOTAND - - - - .GN TAN - - .TAN DTAN - - - -.GN TAND - - .TAND DTAND - - - +.GN TAND - - .TAND DTAND QTAN QATAN- - - .GN ASIN - - .ASIN DASIN - - - .GN ASIND - - .ASIND DASIND - - - .GN ACOS - - .ACOS DACOS - - - @@ -365,9 +430,9 @@ sptr name siname iname rname dname cname cdname i8name .GN ATAND - - .ATAND DATAND - - - .GN ATAN2 - - .ATAN2 DATAN2 - - - .GN ATAN2D - - .ATAN2D DATAN2D - - - -.GN SINH - - .SINH DSINH - - - -.GN COSH - - .COSH DCOSH - - - -.GN TANH - - .TANH DTANH - - - +.GN SINH - - .SINH DSINH QSINH - - - +.GN COSH - - .COSH DCOSH QCOSH - - - +.GN TANH - - .TANH DTANH QTANH - - - .GN IBITS IIBITS JIBITS - - - - KIBITS .GN IBSET IIBSET JIBSET - - - - KIBSET .GN BTEST BITEST BJTEST - - - - BKTEST @@ -375,6 +440,7 @@ sptr name siname iname rname dname cname cdname i8name .GN ISHFTC IISHFTC JISHFTC - - - - KISHFTC .GN LSHIFT .ILSHIFT .JLSHIFT - - - - .KLSHIFT .GN RSHIFT .IRSHIFT .JRSHIFT - - - - .KRSHIFT +.GN SHIFTA .ISHIFTA .JSHIFTA - - - - .KSHIFTA .GN CHAR .2SCH .CHAR - - - - .2KCH .bp .sh 2 "Predeclared\ Names" diff --git a/tools/flang2/utils/symtab/symtab.n b/tools/flang2/utils/symtab/symtab.n index e81560146d..dac37004ee 100644 --- a/tools/flang2/utils/symtab/symtab.n +++ b/tools/flang2/utils/symtab/symtab.n @@ -2,7 +2,13 @@ .\" * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. .\" * See https://llvm.org/LICENSE.txt for license information. .\" * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -.\" * +.\" * +.\" * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +.\" * Notified per clause 4(b) of the license. +.\" * +.\" * Added support for quad precision +.\" * Last modified: Feb 2020 +.\" * .\" */ .NS 11 "Symbol Table" .de OC \"overloading class @@ -611,6 +617,8 @@ Set by Expander. Assumed size array. .FL ADJARR f10 Adjustable array. +.FL ASSUMRANK f37 +Assumed-rank array. .FL ASSUMSHP f19 Assumed-shape array. .FL AFTENT f20 @@ -716,8 +724,6 @@ This is set in an F90 program for an array that is being used as a section descriptor with a non-stride-1 leading dimension; in this case, the leftmost subscript must be multiplied by the stride in the section descriptor. -.FL RESERVED_f37 f37 -reserved .FL LSCOPE f41 If set, the local variable is accessed only in the function's local scope; any internal procedure does not access this variable. @@ -1310,9 +1316,13 @@ auxiliary data structures described below). Number of dummy parameters for this entry point. This count also includes any implicit arguments required for the entry. containing the initialization values for this variable. -.SE FUNCLINE w14 -Source line number of first line of function definition (used for LSD block -entry for this function). +.SE LINENO w14 +Source line number of variable declaration. +#.SE FUNCLINE w14 +#This field overloads LINENO, so it's commented out for documentation +#purposes. +#Source line number of first line of function definition (used for LSD block +#entry for this function). .SE BIHNUM w15 The .cw BIH @@ -1633,10 +1643,18 @@ Second constant value: 32-bit floating point value. .ip \f(CWTY_DBLE\fP Second 32-bit word of double precision constant. +.\" AOCC begin +.ip \f(CWTY_QUAD\fP +Second 32-bit word of quad precision constant. +.\" AOCC end .ip \f(CWTY_CMPLX\fP 32-bit floating point value of imaginary part. .ip \f(CWTY_DCMPLX\fP symbol table pointer to double precision constant for imaginary part. +.\" AOCC begin +.\".ip \f(CWTY_QCMPLX\fP +.\"symbol table pointer to quad precision constant for imaginary part. +.\" AOCC end .ip \f(CWTY_LOG\fP 1 for TRUE, and 0 for FALSE. .ip \f(CWTY_CHAR\fP @@ -1765,6 +1783,7 @@ means the arguments can be either .cw DT_INT , .cw DT_REAL , .cw DT_DBLE , +.cw DT_QUAD , .cw DT_CMPLX , or .cw DT_DCMPLX . @@ -2060,6 +2079,7 @@ or (2 x 32-bit). .TY TY_DCMPLX "double complex" CMPLX BASIC SCALAR VEC (2 x 64-bit). +.TY TY_QCMPLX "quad complex" CMPLX BASIC SCALAR VEC .TY TY_BLOG logical*1 LOG BASIC SCALAR VEC WORD INT .TY TY_SLOG logical*2 LOG BASIC SCALAR VEC WORD INT .TY TY_LOG logical LOG BASIC SCALAR VEC WORD INT @@ -2210,6 +2230,7 @@ on context. Internal to the PGFTN compiler. .PD DT_HCMPLX "half complex" TY_HCMPLX .PD DT_CMPLX complex TY_CMPLX .PD DT_DCMPLX "double complex" TY_DCMPLX +.PD DT_QCMPLX "quad complex" TY_QCMPLX .PD DT_BLOG "logical*1" TY_BLOG .PD DT_SLOG "logical*2" TY_SLOG .PD DT_LOG "logical" TY_LOG @@ -2230,10 +2251,14 @@ Assumed size kanji string dummy argument. Assumed size character. .PD DT_128F "__m128" TY_128 .PD DT_128D "__m128d" TY_128 +.\" AOCC: 128Q +.PD DT_128Q "__m128q" TY_128 .PD DT_128I "__m128i" TY_128 .PD DT_256 "256-bit" TY_256 .PD DT_256F "__m256" TY_256 .PD DT_256D "__m256d" TY_256 +.\" AOCC: 256Q +.PD DT_256Q "__m256q" TY_256 .PD DT_256I "__m256i" TY_256 .PD DT_512 "512-bit" TY_512 .PD DT_512F "__m512" TY_512 diff --git a/tools/flang2/utils/upper/upperilm.in b/tools/flang2/utils/upper/upperilm.in index 10f4f59b5b..fd6eb806bf 100644 --- a/tools/flang2/utils/upper/upperilm.in +++ b/tools/flang2/utils/upper/upperilm.in @@ -3,6 +3,30 @@ # See https://llvm.org/LICENSE.txt for license information. # SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception # +# Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. +# Notified per clause 4(b) of the license. +# +# Complex data types support for acosh, asinh and atanh +# Date of Modification:08 January 2020 +# +# Complex datatype support for atan2 under flag f2008 +# Modified on 13th March 2020 +# +# Added support for quad precision +# Last modified: Feb 2020 +# +# Added code to support SHIFTA intrinsic +# Last modified: April 2020 +# +# Added quad support for floor and ceiling intrinsics +# Last modified: August 2020 +# +# Added complex quad support for asin, asinh, acos, acosh, atan, atanh +# Last modified: 19th August 2020 +# +# Added code support for cotan and cotand +# Last modified: Oct 2020 +# ABS ilm ACON sym ACOS ilm @@ -24,18 +48,24 @@ ATAN2 ilm ilm ATAN2D ilm ilm ATAND ilm ERF ilm -DERF ilm ERFC ilm ERFC_SCALED ilm +DERF ilm DERFC ilm DERFC_SCALED ilm +QERF ilm +QERFC ilm +QERFC_SCALED ilm GAMMA ilm DGAMMA ilm +QGAMMA ilm LOG_GAMMA ilm LSECTION ilm sym sym DLOG_GAMMA ilm +QLOG_GAMMA ilm HYPOT ilm ilm DHYPOT ilm ilm +QHYPOT ilm ilm ACOSH ilm DACOSH ilm ASINH ilm @@ -44,16 +74,23 @@ ATANH ilm DATANH ilm BESSEL_J0 ilm DBESSEL_J0 ilm +DBESSEL_J0 ilm +QBESSEL_J0 ilm BESSEL_J1 ilm DBESSEL_J1 ilm +QBESSEL_J1 ilm BESSEL_JN ilm ilm DBESSEL_JN ilm ilm +QBESSEL_JN ilm ilm BESSEL_Y0 ilm DBESSEL_Y0 ilm +QBESSEL_Y0 ilm BESSEL_Y1 ilm DBESSEL_Y1 ilm +QBESSEL_Y1 ilm BESSEL_YN ilm ilm DBESSEL_YN ilm ilm +QBESSEL_YN ilm ilm BARRIER BASE sym BCOPYIN @@ -77,6 +114,7 @@ BRF ilm sym BRT ilm sym BDISTRIBUTE BSECTIONS sym +REQUIRES num BTASK sym num ilm ilm BTASKDUP BTASKLOOP sym num ilm ilm ilm ilm @@ -85,6 +123,7 @@ BTEAMSN ilm ilm BTARGET ilm num BTARGETDATA ilm BTEST ilm ilm +BTRAILZ ilm BYVAL ilm dtype CABS ilm CACOS ilm @@ -96,6 +135,7 @@ CCOSH ilm CSINH ilm CTANH ilm CTAN ilm +CCOTAN ilm CADD ilm ilm CALL num sym ilms CALLA num num ilm ilms @@ -106,12 +146,17 @@ CCON sym CCOS ilm CDABS ilm CDACOS ilm +CACOSH ilm CDASIN ilm +CASINH ilm CDATAN ilm +CATANH ilm +CATAN2 ilm ilm CDCOSH ilm CDSINH ilm CDTANH ilm CDTAN ilm +CDCOTAN ilm CDADD ilm ilm CDCMP ilm ilm CDCON sym @@ -140,6 +185,55 @@ CDUFUNC/CDFUNC num sym args CDUFUNCA/CDFUNCA num num ilm args PCDUFUNCA/PCDFUNCA num num sym ilm args CDUVFUNCA/CDVFUNCA num num sym ilm sym args +# AOCC BEGIN +CQABS ilm +#CQACOS ilm +#CACOSH ilm +#CQASIN ilm +#CASINH ilm +#CQATAN ilm +#CATANH ilm +CQCOSH ilm +CQSINH ilm +CQTANH ilm +CQTAN ilm +CQCOTAN ilm +CQATAN ilm +CQATAN2 ilm ilm +CQATANH ilm +CQADD ilm ilm +CQCMP ilm ilm +CQCON sym +CQCOS ilm +CQACOS ilm +CQACOSH ilm +CQDIV ilm ilm +CQEXP ilm +CQFUNC num sym ilms +CQFUNCA num num ilm ilms +PCQFUNCA num num sym ilm ilms +CQVFUNCA num num sym ilm sym ilms +#CDIV ilm ilm +CQLD ilm +CQLOG ilm +CQMERGE ilm ilm ilm +CQMUL ilm ilm +CQNEG ilm +CQSIN ilm +CQASIN ilm +CQASINH ilm +CQSQRT ilm +CQST ilm ilm +CQSUB ilm ilm +CQTOCQ ilm ilm +CQTOI ilm ilm +#CQTOK ilm ilm +#CQTOUDI ilm +CQUFUNC/CQFUNC num sym args +CQUFUNCA/CQFUNCA num num ilm args +PCQUFUNCA/PCQFUNCA num num sym ilm args +CQUVFUNCA/CQVFUNCA num num sym ilm sym args +# AOCC END CEXP ilm CFUNC num sym ilms CFUNCA num num ilm ilms @@ -188,14 +282,18 @@ D2K ilm DABS ilm DACOS ilm DACOSD ilm +QACOSD ilm DADD ilm ilm DAIF ilm sym sym sym DASIN ilm DASIND ilm +QASIND ilm DATAN ilm DATAN2 ilm ilm DATAN2D ilm ilm +QATAN2D ilm ilm DATAND ilm +QATAND ilm DBLE ilm DCEIL ilm DCMP ilm ilm @@ -210,9 +308,12 @@ DDIV ilm ilm DEALLOCA ilm sym sym num DEXP ilm DFIX ilm +QFIX ilm DFLOAT ilm DFLOATK ilm DFLOOR ilm +QFLOOR ilm +QCEIL ilm DFUNC num sym ilms DFUNCA num num ilm ilms PDFUNCA num num sym ilm ilms @@ -220,6 +321,9 @@ DVFUNCA num num sym ilm sym ilms DIM ilm ilm DIMAG ilm DINT ilm +# AOCC BEGIN +DISNAN ilm +# AOCC END DLD ilm DLOG ilm DLOG10 ilm @@ -241,6 +345,7 @@ DPSCON num DPVAL ilm DREAL ilm DSIGN ilm ilm +DSIGNNZ ilm ilm DSIN ilm DSIND ilm DSINH ilm @@ -248,7 +353,9 @@ DSQRT ilm DST ilm ilm DSUB ilm ilm DTAN ilm +DCOTAN ilm DTAND ilm +DCOTAND ilm DTANH ilm DTOD ilm ilm DTOI ilm ilm @@ -346,6 +453,7 @@ ITOS ilm ITOSC ilm ITOUDI ilm ITOUI ilm +ITRAILZ ilm IUFUNC/IFUNC num sym args IUFUNCA/IFUNCA num num ilm args PIUFUNCA/PIFUNCA num num sym ilm args @@ -366,6 +474,7 @@ KBTEST ilm ilm KCMP ilm ilm KCON sym KDFIX ilm +KQFIX ilm KDIM ilm ilm KDIV ilm ilm KDNINT ilm @@ -400,6 +509,7 @@ KST ilm ilm KSUB ilm ilm KTOI ilm ilm KTOK ilm ilm +KTRAILZ ilm KUFUNC/KFUNC num sym args KUFUNCA/KFUNCA num num ilm args PKUFUNCA/PKFUNCA num num sym ilm args @@ -443,6 +553,9 @@ PLUFUNCA/PLFUNCA num num sym ilm args LUVFUNCA/LVFUNCA num num sym ilm sym args MASTER sym MEMBER ilm sym +# AOCC begin +MM_PREFETCH ilm ilm +# AOCC end MOD ilm ilm MPBORDERED MPEORDERED @@ -504,6 +617,80 @@ PUFUNC/PFUNC num sym args PUFUNCA/PFUNCA num num ilm args PPUFUNCA/PPFUNCA num num sym ilm args PUVFUNCA/PVFUNCA num num sym ilm sym args +#AOCC begin +QABS ilm +QPLD ilm +QLOG ilm +QLOG10 ilm +QUAD ilm +QADD ilm ilm +QAIF ilm sym sym sym +QCON sym +QCONJG ilm +QCMP ilm ilm +QDIV ilm ilm +QMAX ilm ilm +QMERGE ilm ilm ilm +QMIN ilm ilm +QMOD ilm ilm +QMUL ilm ilm +QNEG ilm +QNINT ilm +QDIM ilm ilm +#QOBEG ilm sym sym +QFLOAT ilm +QFLOATK ilm +QFUNC num sym ilms +QUFUNC/QFUNC num sym args +QUFUNCA/QFUNCA num num ilm args +PQUFUNCA/PQFUNCA num num sym ilm args +QUVFUNCA/QVFUNCA num num sym ilm sym args +#QOBEGNZ ilm sym sym ilm +#QOEND sym sym +#QOENDNZ sym sym +#QPNULL +#QPREF ilm +#QPROD ilm ilm +#QPSCON num +#QPVAL ilm +QMAX ilm ilm +QMIN ilm ilm +QREAL ilm +QSIGN ilm ilm +#QSIGNNZ ilm ilm +QCOS ilm +QCOSD ilm +QCOSH ilm +QACOS ilm +QACOSH ilm +QEXP ilm +QSIN ilm +QSINH ilm +QASIN ilm +QASINH ilm +QSIND ilm +#QSINH ilm +QSQRT ilm +QPST ilm ilm +QSUB ilm ilm +QTAN ilm +QCOTAN ilm +QTANH ilm +QATAN ilm +QATAN2 ilm ilm +QATANH ilm +QCMPLX ilm ilm +QIMAG ilm +QTAND ilm +QCOTAND ilm +#QTANH ilm +QTOQ ilm ilm +QTOI ilm ilm +#QTOK ilm ilm +#QTOUDI ilm +#QTOUI ilm +QISNAN ilm +#AOCC end R2K ilm RADD ilm ilm RAIF ilm sym sym sym @@ -516,6 +703,9 @@ RET RFLOOR ilm RFUNC num sym ilms RFUNCA num num ilm ilms +# AOCC BEGIN +RISNAN ilm +# AOCC END PRFUNCA num num sym ilm ilms RVFUNCA num num sym ilm sym ilms RLD ilm @@ -547,6 +737,7 @@ SHD ilm ilm ilm SHIFT ilm ilm SHIFT64 ilm ilm SIGN ilm ilm +SIGNNZ ilm ilm SILD ilm SIN ilm SIND ilm @@ -565,9 +756,12 @@ SST ilm ilm STOI ilm STOUDI ilm STOUI ilm +STRAILZ ilm SUBS ilm ilm ilm TAN ilm +COTAN ilm TAND ilm +COTAND ilm TANH ilm TARGETENTERDATA ilm num TARGETEXITDATA ilm num @@ -599,6 +793,7 @@ UITOSC ilm UITOUDI ilm ULSHIFT ilm ilm URSHIFT ilm ilm +SHIFTA ilm ilm V sym XNOR/EQV ilm ilm XNOR64 ilm ilm @@ -606,12 +801,22 @@ XOR ilm ilm XOR64 ilm ilm XOR8/KXOR ilm ilm MP_MAP ilm num +#AOCC Begin +MP_MAP_MEM ilm num ilm +MP_DEFAULTMAP num +MP_NUMTEAMS sym +MP_NUMTHREADS sym +MP_TARGETDECLARE +#AOCC End MP_TARGETLOOPTRIPCOUNT sym MP_EMAP MP_BREDUCTION MP_EREDUCTION MP_REDUCTIONITEM sym sym num MP_TARGETMODE num ilm ilm ilm +MP_USE_DEVICE_PTR ilm num +MP_IS_DEVICE_PTR ilm num +MP_USE_DEVICE_ADDR ilm num HFLD ilm HFST ilm ilm HFCON sym diff --git a/tools/flang2/utils/upper/upperilm_ppc64le.in b/tools/flang2/utils/upper/upperilm_ppc64le.in new file mode 100644 index 0000000000..13f8f4684f --- /dev/null +++ b/tools/flang2/utils/upper/upperilm_ppc64le.in @@ -0,0 +1,653 @@ +# +# Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +# See https://llvm.org/LICENSE.txt for license information. +# SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +# +#Copyright (c) 2018, Advanced Micro Devices, Inc. All rights reserved. +# +#Complex data types support for acosh, asinh and atanh +#Date of Modification:08 January 2020 +# +ABS ilm +ACON sym +ACOS ilm +ACOSD ilm +ADJARR sym sym sym +AGOTO num ilm syms +AINT ilm +ALLOCA ilm ilm sym num +AMOD ilm ilm +AND ilm ilm +AND64 ilm ilm +ANINT ilm +ARET ilm +ASIN ilm +ASIND ilm +AST ilm ilm +ATAN ilm +ATAN2 ilm ilm +ATAN2D ilm ilm +ATAND ilm +ERF ilm +DERF ilm +ERFC ilm +ERFC_SCALED ilm +DERFC ilm +DERFC_SCALED ilm +GAMMA ilm +DGAMMA ilm +LOG_GAMMA ilm +LSECTION ilm sym sym +DLOG_GAMMA ilm +HYPOT ilm ilm +DHYPOT ilm ilm +ACOSH ilm +DACOSH ilm +ASINH ilm +DASINH ilm +ATANH ilm +DATANH ilm +BESSEL_J0 ilm +DBESSEL_J0 ilm +BESSEL_J1 ilm +DBESSEL_J1 ilm +BESSEL_JN ilm ilm +DBESSEL_JN ilm ilm +BESSEL_Y0 ilm +DBESSEL_Y0 ilm +BESSEL_Y1 ilm +DBESSEL_Y1 ilm +BESSEL_YN ilm ilm +DBESSEL_YN ilm ilm +BARRIER +BASE sym +BCOPYIN +BCOPYPRIVATE ilm +BEGINATOMIC +BEGINATOMICCAPTURE +BEGINATOMICREAD +BEGINATOMICWRITE +BLEADZ ilm +BCS +BMPSCOPE sym +BOS line num num +BPAR ilm +BPARA ilm ilm num num +BPARN ilm ilm +BPDO +BPOPCNT ilm +BPOPPAR ilm +BR sym +BRF ilm sym +BRT ilm sym +BDISTRIBUTE +BSECTIONS sym +BTASK sym num ilm ilm +BTASKDUP +BTASKLOOP sym num ilm ilm ilm ilm +BTEAMS +BTEAMSN ilm ilm +BTARGET ilm num +BTARGETDATA ilm +BTEST ilm ilm +BYVAL ilm dtype +CABS ilm +CACOS ilm +CANCEL sym num ilm +CANCELPOINT sym num +CASIN ilm +CATAN ilm +CCOSH ilm +CSINH ilm +CTANH ilm +CTAN ilm +CADD ilm ilm +CALL num sym ilms +CALLA num num ilm ilms +PCALLA num num sym ilm ilms +VCALLA num num sym ilm sym ilms +CCMP ilm ilm +CCON sym +CCOS ilm +CDABS ilm +CDACOS ilm +CACOSH ilm +CDASIN ilm +CASINH ilm +CDATAN ilm +CATANH ilm +CDCOSH ilm +CDSINH ilm +CDTANH ilm +CDTAN ilm +CDADD ilm ilm +CDCMP ilm ilm +CDCON sym +CDCOS ilm +CDDIV ilm ilm +CDEXP ilm +CDFUNC num sym ilms +CDFUNCA num num ilm ilms +PCDFUNCA num num sym ilm ilms +CDVFUNCA num num sym ilm sym ilms +CDIV ilm ilm +CDLD ilm +CDLOG ilm +CDMERGE ilm ilm ilm +CDMUL ilm ilm +CDNEG ilm +CDSIN ilm +CDSQRT ilm +CDST ilm ilm +CDSUB ilm ilm +CDTOCD ilm ilm +CDTOI ilm ilm +CDTOK ilm ilm +CDTOUDI ilm +CDUFUNC/CDFUNC num sym args +CDUFUNCA/CDFUNCA num num ilm args +PCDUFUNCA/PCDFUNCA num num sym ilm args +CDUVFUNCA/CDVFUNCA num num sym ilm sym args +CEXP ilm +CFUNC num sym ilms +CFUNCA num num ilm ilms +PCFUNCA num num sym ilm ilms +CVFUNCA num num sym sym ilm sym ilms +CGOTO ilm num +CHAR ilm +CHFUNC num sym ilm ilms +CHFUNCA num num ilm ilm ilms +PCHFUNCA num num sym ilm ilm ilms +CHVFUNCA num num sym ilm ilm sym ilms +CHLD ilm +CHST ilm ilm +CHUFUNC/CHFUNC num sym args +CHUFUNCA/CHFUNCA num num ilm args +PCHUFUNCA/PCHFUNCA num num sym ilm args +CHUVFUNCA/CHVFUNCA num num sym ilm sym args +CLD ilm +CLOG ilm +CMPLX ilm ilm +CMERGE ilm ilm ilm +CMUL ilm ilm +CNEG ilm +CONJG ilm +COPYIN sym +COPYIN_A sym ilm +COPYPRIVATE ilm sym +COPYPRIVATE_P ilm ilm +COPYPRIVATE_PA ilm ilm ilm +COS ilm +COSD ilm +COSH ilm +CSIN ilm +CSQRT ilm +CST ilm ilm +CSUB ilm ilm +CTOC ilm ilm +CTOI ilm ilm +CTOK ilm ilm +CTOUDI ilm +CUFUNC/CFUNC num sym args +CUFUNCA/CFUNCA num num ilm args +PCUFUNCA/PCFUNCA num num sym ilm args +CUVFUNCA/CVFUNCA num num sym ilm sym args +D2K ilm +DABS ilm +DACOS ilm +DACOSD ilm +DADD ilm ilm +DAIF ilm sym sym sym +DASIN ilm +DASIND ilm +DATAN ilm +DATAN2 ilm ilm +DATAN2D ilm ilm +DATAND ilm +DBLE ilm +DCEIL ilm +DCMP ilm ilm +DCMPLX ilm ilm +DCON sym +DCONJG ilm +DCOS ilm +DCOSD ilm +DCOSH ilm +DDIM ilm ilm +DDIV ilm ilm +DEALLOCA ilm sym sym num +DEXP ilm +DFIX ilm +DFLOAT ilm +DFLOATK ilm +DFLOOR ilm +DFUNC num sym ilms +DFUNCA num num ilm ilms +PDFUNCA num num sym ilm ilms +DVFUNCA num num sym ilm sym ilms +DIM ilm ilm +DIMAG ilm +DINT ilm +DLD ilm +DLOG ilm +DLOG10 ilm +DMAX ilm ilm +DMERGE ilm ilm ilm +DMIN ilm ilm +DMOD ilm ilm +DMUL ilm ilm +DNEG ilm +DNINT ilm +DOBEG ilm sym sym +DOBEGNZ ilm sym sym ilm +DOEND sym sym +DOENDNZ sym sym +DPNULL +DPREF ilm +DPROD ilm ilm +DPSCON num +DPVAL ilm +DREAL ilm +DSIGN ilm ilm +DSIN ilm +DSIND ilm +DSINH ilm +DSQRT ilm +DST ilm ilm +DSUB ilm ilm +DTAN ilm +DTAND ilm +DTANH ilm +DTOD ilm ilm +DTOI ilm ilm +DTOK ilm ilm +DTOUDI ilm +DTOUI ilm +DUFUNC/DFUNC num sym args +DUFUNCA/DFUNCA num num ilm args +PDUFUNCA/PDFUNCA num num sym ilm args +DUVFUNCA/DVFUNCA num num sym ilm sym args +ECOPYIN +ECOPYPRIVATE ilm +ECS +ELEMENT num ilm dtype ilms +EMASTER sym +EMPSCOPE +END +ENDATOMIC +ENDATOMICCAPTURE +ENDATOMICREAD +ENDATOMICWRITE +ENDF ilm +ENLAB +ENTRY sym +EPAR +EPARN +EPDO +EQ ilm +EQ8 ilm +EQV ilm ilm +EDISTRIBUTE +ESECTIONS sym +ESINGLE sym +ETARGET +ETARGETDATA +ETASK sym +ETASKDUP +ETASKGROUP +ETASKLOOP sym +ETASKLOOPREG +ETASKREG +ETEAMS +EXP ilm +FARG ilm dtype +FARGF ilm dtype num +FILE num num num +FIX ilm +FLOAT ilm +FLOATK ilm +FLUSH +GE ilm +GE8 ilm +GT ilm +GT8 ilm +I1SHFTC ilm ilm ilm +I2K ilm +I8TOI ilm +IABS ilm +IADD ilm ilm +IAIF ilm sym sym sym +IBCLR ilm ilm +IBITS ilm ilm ilm +IBSET ilm ilm +ICHAR ilm +ICMP ilm ilm +ICON sym +IDIM ilm ilm +IDIV ilm ilm +IDNINT ilm +IISHFT ilm ilm +IISHFTC ilm ilm ilm +IFUNC num sym ilms +IFUNCA num num ilm ilms +PIFUNCA num num sym ilm ilms +IVFUNCA num num sym ilm sym ilms +ILD ilm +ILEADZ ilm +IMAG ilm +IMAX ilm ilm +IMERGE ilm ilm ilm +IMIN ilm ilm +IMUL ilm ilm +INCHAR ilm +INDEX ilm ilm +INEG ilm +IPOPCNT ilm +IPOPPAR ilm +ISHFTC ilm ilm ilm +ISIGN ilm ilm +IST ilm ilm +ISUB ilm ilm +ITOI ilm ilm +ITOI8 ilm +ITOS ilm +ITOSC ilm +ITOUDI ilm +ITOUI ilm +IUFUNC/IFUNC num sym args +IUFUNCA/IFUNCA num num ilm args +PIUFUNCA/PIFUNCA num num sym ilm args +IUVFUNCA/IVFUNCA num num sym ilm sym args +JISHFT ilm ilm +K2D ilm +K2I ilm +K2R ilm +KABS ilm +KADD ilm ilm +KAIF ilm sym sym sym +KAND ilm ilm +KAST ilm ilm +KBCLR ilm ilm +KBITS ilm ilm ilm +KBSET ilm ilm +KBTEST ilm ilm +KCMP ilm ilm +KCON sym +KDFIX ilm +KDIM ilm ilm +KDIV ilm ilm +KDNINT ilm +KEQV ilm ilm +KFIX ilm +KFUNC num sym ilms +KFUNCA num num ilm ilms +PKFUNCA num num sym ilm ilms +KVFUNCA num num sym ilm sym ilms +KINDEX ilm ilm +KISHFT ilm ilm +KLD ilm +KLEADZ ilm +KLEN ilm +KLLD ilm +KLST ilm ilm +KMAX ilm ilm +KMIN ilm ilm +KMERGE ilm ilm ilm +KMOD ilm ilm +KMUL ilm ilm +KNEG ilm +KNINT ilm +KNOT ilm +KOR ilm ilm +KPOPCNT ilm +KPOPPAR ilm +KSHFTC ilm ilm ilm +KSHIFT/KISHFT ilm ilm +KSIGN ilm ilm +KST ilm ilm +KSUB ilm ilm +KTOI ilm ilm +KTOK ilm ilm +KUFUNC/KFUNC num sym args +KUFUNCA/KFUNCA num num ilm args +PKUFUNCA/PKFUNCA num num sym ilm args +KUVFUNCA/KVFUNCA num num sym ilm sym args +KULSHIFT ilm ilm +KURSHIFT ilm ilm +KXNOR/KEQV ilm ilm +KXOR ilm ilm +LABEL sym +LAND ilm ilm +LAND8 ilm ilm +LCON sym +LCPU2 +LE ilm +LE8 ilm +LEN ilm +LEQV ilm ilm +LEQV8 ilm ilm +LFUNC num sym ilms +LFUNCA num num ilm ilms +PLFUNCA num num sym ilm ilms +LVFUNCA num num sym ilm sym ilms +LLD ilm +LNEQV ilm ilm +LNEQV8 ilm ilm +LNOP ilm +LNOP8 ilm +LNOT ilm +LNOT8 ilm +LOC ilm +LOG/ALOG ilm +LOG10/ALOG10 ilm +LOR ilm ilm +LOR8 ilm ilm +LST ilm ilm +LT ilm +LT8 ilm +LUFUNC/LFUNC num sym args +LUFUNCA/LFUNCA num num ilm args +PLUFUNCA/PLFUNCA num num sym ilm args +LUVFUNCA/LVFUNCA num num sym ilm sym args +MASTER sym +MEMBER ilm sym +MOD ilm ilm +MPBORDERED +MPEORDERED +MPDISTLOOP sym sym sym sym sym sym dtype num +MPLOOP sym sym sym sym sym dtype num +MPLOOPFINI dtype num +MPSCHED sym sym sym sym dtype +MPTASKLOOP sym sym sym sym dtype +MP_ATOMIC +MP_ATOMICCAPTURE ilm ilm num num num +MP_ATOMICREAD ilm num +MP_ATOMICUPDATE ilm ilm num num +MP_ATOMICWRITE ilm ilm num +MP_ENDATOMIC +NCHAR ilm +NCHFUNC num sym ilm ilms +NCHFUNCA num num ilm ilm ilms +PNCHFUNCA num num sym ilm ilm ilms +NCHVFUNCA num num sym ilm ilm sym ilms +NCHUFUNC/NCHFUNC num sym args +NCHUFUNCA/NCHFUNCA num num ilm args +PNCHUFUNCA/PNCHFUNCA num num sym ilm args +NCHUVFUNCA/NCHVFUNCA num num sym ilm sym args +NCPUS2 +NE ilm +NE8 ilm +NINDEX ilm ilm +NINT ilm +NLEN ilm +NOP +NOT ilm +NOT64 ilm +NSCAT ilm ilm +NSCMP ilm ilm +NSST ilm ilm +NSUBS ilm ilm ilm +OR ilm ilm +OR64 ilm ilm +P sym +PARG ilm ilm +PCMP ilm ilm +PDO sym num +PFUNC num sym ilms +PFUNCA num num ilm ilms +PPFUNCA num num sym ilm ilms +PVFUNCA num num sym ilm sym ilms +PLD ilm sym +PRAGMADPSELIST num num num ilm num ilms +PRAGMAEXPR num num num ilm nums +PRAGMAGEN num num num nums +PRAGMASELIST num num num ilm ilms +PRAGMASLIST num num num ilms +PRAGMASYM num num num syms +PRAGMASYMEXPR num num num sym ilms +PRE_TLS_COPY sym +PST ilm ilm +PUFUNC/PFUNC num sym args +PUFUNCA/PFUNCA num num ilm args +PPUFUNCA/PPFUNCA num num sym ilm args +PUVFUNCA/PVFUNCA num num sym ilm sym args +R2K ilm +RADD ilm ilm +RAIF ilm sym sym sym +RCEIL ilm +RCMP ilm ilm +RCON sym +RDIV ilm ilm +REAL ilm +RET +RFLOOR ilm +RFUNC num sym ilms +RFUNCA num num ilm ilms +PRFUNCA num num sym ilm ilms +RVFUNCA num num sym ilm sym ilms +RLD ilm +RMAX ilm ilm +RMERGE ilm ilm ilm +RMIN ilm ilm +RMUL ilm ilm +RNEG ilm +RST ilm ilm +RSUB ilm ilm +RTOI ilm ilm +RTOK ilm ilm +RTOR ilm ilm +RTOUDI ilm +RTOUI ilm +RUFUNC/RFUNC num sym args +RUFUNCA/RFUNCA num num ilm args +PRUFUNCA/PRFUNCA num num sym ilm args +RUVFUNCA/RVFUNCA num num sym ilm sym args +SCAT ilm ilm +SCMP ilm ilm +SCTOI ilm +SCTOUDI ilm +SCTOUI ilm +SECTION ilm sym sym +SFUNC num sym args +SHAPE num ilm +SHD ilm ilm ilm +SHIFT ilm ilm +SHIFT64 ilm ilm +SIGN ilm ilm +SILD ilm +SIN ilm +SIND ilm +SINGLE ilm sym +SINH ilm +SIST ilm ilm +SLEADZ ilm +SLLD ilm +SLST ilm ilm +SMOVE ilm ilm dtype +SNGL ilm +SPOPCNT ilm +SPOPPAR ilm +SQRT ilm +SST ilm ilm +STOI ilm +STOUDI ilm +STOUI ilm +SUBS ilm ilm ilm +TAN ilm +TAND ilm +TANH ilm +TARGETENTERDATA ilm num +TARGETEXITDATA ilm num +BTARGETUPDATE ilm num +TASKFIRSTPRIV sym sym +TASKGROUP +TASKLOOPREG ilm ilm ilm +TASKLOOPVARS +TASKREG +TASKWAIT +TASKYIELD +UCALL/CALL num sym args +UCALLA/CALLA num num ilm args +UPCALLA/PCALLA num num sym ilm args +UVCALLA/VCALLA num num sym ilm sym args +UDITOD ilm +UDITOI ilm +UDITOR ilm +UDITOS ilm +UDITOSC ilm +UDITOUI ilm +UI2K ilm +UICMP ilm ilm +UITOD ilm +UITOI ilm +UITOR ilm +UITOS ilm +UITOSC ilm +UITOUDI ilm +ULSHIFT ilm ilm +URSHIFT ilm ilm +V sym +XNOR/EQV ilm ilm +XNOR64 ilm ilm +XOR ilm ilm +XOR64 ilm ilm +XOR8/KXOR ilm ilm +MP_MAP ilm num +#AOCC Begin +MP_DEFAULTMAP num +MP_NUMTEAMS sym +MP_NUMTHREADS sym +MP_TARGETDECLARE +#AOCC End +MP_TARGETLOOPTRIPCOUNT sym +MP_EMAP +MP_BREDUCTION +MP_EREDUCTION +MP_REDUCTIONITEM sym sym num +MP_TARGETMODE num ilm ilm ilm +HFLD ilm +HFST ilm ilm +HFCON sym +HFADD ilm ilm +HFMUL ilm ilm +HFSUB ilm ilm +HFDIV ilm ilm +HFNEG ilm +HFCMP ilm ilm +R2HF ilm +D2HF ilm +HF2R ilm +HFFUNC num sym ilms +HFUFUNC/HFFUNC num sym args +HFMIN ilm ilm +HFMAX ilm ilm +UXLNEQV ilm ilm +UXLEQV ilm ilm +UXLAND ilm ilm +UXLNOT ilm +UXLNEQV8 ilm ilm +UXLEQV8 ilm ilm +UXLAND8 ilm ilm +UXLNOT8 ilm +MP_BEGIN_DIR +MP_END_DIR diff --git a/tools/shared/CMakeLists.txt b/tools/shared/CMakeLists.txt index 6a2dc434cf..d810559a3c 100644 --- a/tools/shared/CMakeLists.txt +++ b/tools/shared/CMakeLists.txt @@ -6,6 +6,9 @@ set(SHARED_SOURCES ${CMAKE_CURRENT_SOURCE_DIR}/ccffinfo.c +# AOCC BEGIN + ${CMAKE_CURRENT_SOURCE_DIR}/debug.c +# AOCC END ${CMAKE_CURRENT_SOURCE_DIR}/direct.c ${CMAKE_CURRENT_SOURCE_DIR}/error.c ${CMAKE_CURRENT_SOURCE_DIR}/go.c diff --git a/tools/shared/debug.c b/tools/shared/debug.c new file mode 100644 index 0000000000..6c299b4bfb --- /dev/null +++ b/tools/shared/debug.c @@ -0,0 +1,38 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + +/* + * Copyright (c) 2021 Advanced Micro Devices, Inc. All rights reserved. + * + */ + +/* + * This provides a similar interface to LLVM to emit debug logs on console - DEBUG(), + * or a file - DEBUG_LOG_FD(). Wherever these macros are used, there must be a DEBUG_ONLY + * string defined in that source file (.c/.cpp) which "categorizes" the logs. + */ + +#include +#include +#include + +#include "debug.h" + +bool debug_log_enable; +char *debug_log_strs; + +void debug_log_init(bool enable_debug, const char *debug_strs) +{ + debug_log_enable = enable_debug; + debug_log_strs = debug_strs == NULL ? NULL : strdup(debug_strs); +} + +void debug_log_deinit() +{ + if (debug_log_strs == NULL) return; + free(debug_log_strs); +} diff --git a/tools/shared/debug.h b/tools/shared/debug.h new file mode 100644 index 0000000000..b83f07106d --- /dev/null +++ b/tools/shared/debug.h @@ -0,0 +1,116 @@ +/* + * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. + * See https://llvm.org/LICENSE.txt for license information. + * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception + * + */ + +/* + * Copyright (c) 2021 Advanced Micro Devices, Inc. All rights reserved. + * + */ + +/* + * This provides a similar interface to LLVM to emit debug logs on console - DEBUG_LOG(), + * or a file - DEBUG_LOG_FD(). Wherever these macros are used, there must be a DEBUG_ONLY + * string defined in that source file (.c/.cpp) which "categorizes" the logs. + */ + +#ifndef DEBUG_H_ +#define DEBUG_H_ + +#include + +#ifdef DEBUG + + /** + * \brief Defines if debug logging is enabled or not (fetched from flang1exe/main.c). + */ + extern bool debug_log_enable; + + /** + * \brief Contains all -debug-only command line argument strings (fetched from flang1exe/main.c). + */ + extern char *debug_log_strs; + + /** + * \brief Initializes the debug log system. + * + * \param enable_debug Enable or disable the debug log system. + * \param debug_strs Specific strings (types) to enable for debugging (NULLable). + */ + void debug_log_init(bool enable_debug, const char *debug_strs); + /** + * \brief Deinitializes the debug log system. + * + */ + void debug_log_deinit(); + + /** + * \brief Writes debug information on given file descriptor IFF debug_enable is true + or debug_strs contains the type string. + * + * \param fd The file descriptor to write debug information to. + * \param only_str String, defining debug category (type). + */ + #define DEBUG_LOG_CORE(fd, only_str, ...) \ + if (debug_log_enable || (debug_log_strs != NULL && strstr(debug_log_strs, only_str) != NULL)) \ + do { fprintf(fd, __VA_ARGS__); } while (false) \ + + /** + * \brief Initializes the debug log system. + * + * \param enable_debug Enable or disable the debug log system. + * \param debug_strs Specific strings (types) to enable for debugging (NULLable). + */ + #define DEBUG_LOG_INIT(enable_debug, debug_strs) debug_log_init(enable_debug, debug_strs) + + /** + * \brief Deinitializes the debug log system. + * + */ + #define DEBUG_LOG_DEINIT() debug_log_deinit() + +#else // DEBUG + + /** + * \brief Writes debug information on given file descriptor IFF debug_enable is true + or debug_strs contains the type string. + * + * \param fd The file descriptor to write debug information to. + * \param type String, defining debug category (type). + */ + #define DEBUG_LOG_CORE(fd, type, ...) do {} while (false) + + /** + * \brief Initializes the debug log system. + * + * \param enable_debug Enable or disable the debug log system. + * \param debug_strs Specific strings (types) to enable for debugging (NULLable). + */ + #define DEBUG_LOG_INIT(enable_debug, debug_strs) do {} while (false) + + /** + * \brief Deinitializes the debug log system. + * + */ + #define DEBUG_LOG_DEINIT() do {} while (false) + +#endif // DEBUG + +/** + * \brief Writes debug information on given file descriptor IFF debugging is enabled. + * + * \param fd The file descriptor to write debug information to. + * \param type String, defining debug category (type). + */ +#define DEBUG_LOG_FD(fd, ...) DEBUG_LOG_CORE(fd, DEBUG_ONLY, __VA_ARGS__) + +/** + * \brief Used to output debug information. Uses DEBUG_ONLY, writes on stderr by default. + * + * \param variadic information to print - in printf set of functions' format. + */ +#define DEBUG_LOG(...) DEBUG_LOG_FD(stderr, __VA_ARGS__) + +#endif // DEBUG_H_ diff --git a/tools/shared/expand.h b/tools/shared/expand.h index d6fcc7000f..156d5449c0 100644 --- a/tools/shared/expand.h +++ b/tools/shared/expand.h @@ -120,6 +120,7 @@ typedef struct { #define ILM_ISX87CMPLX 5 #define ILM_ISDOUBLEDOUBLECMPLX 6 #define ILM_ISFLOAT128CMPLX 7 +#define ILM_ISQCMPLX 8 /* character stuff */ #define ILM_MXLEN(i) (expb.ilmb.stg_base[i].w5) diff --git a/tools/shared/llmputil.c b/tools/shared/llmputil.c index 48f324ef0b..1bbe625526 100644 --- a/tools/shared/llmputil.c +++ b/tools/shared/llmputil.c @@ -5,6 +5,16 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * + * Support for x86-64 OpenMP offloading + * Last modified: Apr 2020 + */ + + /* llmputil.c: OpenMP utility routines for our LLVM compilers */ #include "llmputil.h" @@ -141,7 +151,9 @@ llmp_add_shared_var(LLUplevel *up, int shared_sptr) ++up->vals_count; NEED(up->vals_count, up->vals, int, up->vals_size, up->vals_size + 8); + NEED(up->vals_count, up->orig_vals, int, up->orig_vals_size, up->orig_vals_size + 8); // AOCC up->vals[idx] = shared_sptr; + up->orig_vals[idx] = shared_sptr; // AOCC return 1; } @@ -157,7 +169,9 @@ llmp_add_shared_var_charlen(LLUplevel *up, int shared_sptr) if (up->vals[i] == shared_sptr) { ++up->vals_count; NEED(up->vals_count, up->vals, int, up->vals_size, up->vals_size + 8); + NEED(up->vals_count, up->orig_vals, int, up->orig_vals_size, up->orig_vals_size + 8); // AOCC up->vals[idx] = 0; + up->orig_vals[idx] = 0; // AOCC } } @@ -201,8 +215,10 @@ llmp_reset_uplevel(void) if (llmp_all_uplevels.avl) { for (i = 1; i < llmp_all_uplevels.avl; ++i) { up = (LLUplevel *)(&llmp_all_uplevels.base[i]); - if (up->vals_count) + if (up->vals_count) { FREE(up->vals); + FREE(up->orig_vals); // AOCC + } } FREE(llmp_all_uplevels.base); memset(&llmp_all_uplevels, 0, sizeof(llmp_all_uplevels)); diff --git a/tools/shared/llmputil.h b/tools/shared/llmputil.h index 859a3d2d68..bacb523b48 100644 --- a/tools/shared/llmputil.h +++ b/tools/shared/llmputil.h @@ -4,6 +4,16 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support AMDGPU OpenMP offloading + * Date of modification 23rd September 2019 + * + * Support for x86-64 OpenMP offloading + * Last modified: Apr 2020 + */ #ifndef LLMPUTIL_H_ #define LLMPUTIL_H_ @@ -21,6 +31,16 @@ * are represented as a list of unique sptrs. */ typedef struct { + /* AOCC begin */ + /* + * orig_vals[] track the original SPTRs assigned to this uplevel. + * change_target_func_smbols() is called for omptarget compilation that + * changes vals[i] to it's corresponding device-sptr. So APIs that require + * the originally assigned SPTR should refer to orig_vals[] instead of vals[] + */ + int *orig_vals; /* Contains the original shared var sptrs */ + int orig_vals_size; /* Total allocated slots in orig_vals */ + /* AOCC end */ int *vals; /* Array containing shared var sptrs */ int vals_size; /* Total allocated slots in vals */ int vals_count; /* Traditionally "available" or vals_avl */ @@ -96,6 +116,9 @@ typedef enum { mode_target_data_region, mode_outlinedfunc_teams, mode_outlinedfunc_parallel, + // AOCC Begin + mode_target_update, + // AOCC End mode_targetupdate_begin, mode_targetupdate_end, } OMP_TARGET_MODE; @@ -120,6 +143,9 @@ static const char *omp_target_mode_names[] = { "target data", "outlined teams region", "outlined parallel region", + // AOCC Begin + "target update", + // AOCC End "target update begin", "target update end" }; diff --git a/tools/shared/miscutil.c b/tools/shared/miscutil.c index 05dd0308b5..4ac24a90a2 100644 --- a/tools/shared/miscutil.c +++ b/tools/shared/miscutil.c @@ -4,6 +4,12 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified: May 2020 + */ /** \file \brief Compiler miscellaneous utility programs. @@ -97,6 +103,27 @@ set_xflag(int indx, INT val) flg.opt = 2; } +// AOCC begin + +// Returns the maximum dimension allowed by considering -std option. +// (There are checks, for eg " :: = : | *" handlers in +// semant.c that only depends on maxdim.) +unsigned get_legal_maxdim() { + if (flg.std == F2008) + return 15; + return 7; +} + +// return true if numdim is legal by considering -std option +bool is_legal_numdim(int numdim) { + if (numdim > 0 && numdim <= get_legal_maxdim()) + return true; + + return false; +} + +// AOCC end + /** \brief Called only from main() */ void set_yflag(int indx, INT val) diff --git a/tools/shared/mp.h b/tools/shared/mp.h index f31e4fc73d..e848edc7f0 100644 --- a/tools/shared/mp.h +++ b/tools/shared/mp.h @@ -5,6 +5,18 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * + * Changes to support AMDGPU OpenMP offloading. + * Date of modification 04th February 2020 + * + * Added support for openmp schedule clause + * Last modified: March 2021 + */ + /* mp.h - various OpenMP definitions */ #ifndef __MP_H__ @@ -39,6 +51,10 @@ #define MP_SCH_AUTO 0x5 #define MP_SCH_DIST_STATIC 0x6 /* use in distribute parallel for */ #define MP_SCH_DIST_DYNAMIC 0x7 /* use in distribute parallel for */ +#define MP_MOD_NONMONOTONIC (1 << 29) // AOCC +#define MP_MOD_MONOTONIC (1 << 30) // AOCC +#define MP_MOD_SIMD (1 << 31) // AOCC + /* The second byte represents special case flags for static (maskable) */ #define MP_SCH_SPC_MASK 0x0000FF00 @@ -54,6 +70,10 @@ #define MP_SCH_ATTR_CHUNKED 0x00020000 /* Chunked */ #define MP_SCH_ATTR_DIST 0x00040000 /* distributed */ #define MP_SCH_ATTR_DEVICEDIST 0x00080000 /* fast GPU scheduler for TTDPF */ +// AOCC Begin +// Same as above, since 0x00080000 is too large to store in flags. +#define MP_SCH_TEAMS_DIST 0x0001600 +// AOCC End /* Target/Target combine attribute */ #define MP_TGT_NOWAIT 0x01 /* if NOWAIT is present */ diff --git a/tools/shared/nme.h b/tools/shared/nme.h index 5b76998335..3d79f38e9c 100644 --- a/tools/shared/nme.h +++ b/tools/shared/nme.h @@ -4,6 +4,15 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Changes to support voltile flag in nme. + * This is used in Accelarator codegen. + * Date of modification 05th September 2019 + * + */ #ifndef NME_H_ #define NME_H_ @@ -40,6 +49,9 @@ typedef struct { int exp_loop; /* Dependent on type. */ int f6; /* Dependent on type. */ ISZ_T cnst; /* Dependent on type. */ + // AOCC Begin + int nme_vol; /* if this nme is volatile */ + // AOCC End int sub; /* subscript info (0 if NA or not array) */ int f13; /* dependent on type */ int base; /* base nme */ @@ -112,6 +124,9 @@ typedef struct { #define NME_TYPE(i) nmeb.stg_base[NMECHECK(i)].type #define NME_INLARR(i) nmeb.stg_base[NMECHECK(i)].inlarr #define NME_SYM(i) nmeb.stg_base[NMECHECK(i)].sym +// AOCC Begin +#define NME_VOLATILE(i) nmeb.stg_base[NMECHECK(i)].nme_vol +// AOCC End #define NME_NM(i) nmeb.stg_base[NMECHECK(i)].nm #define NME_HSHLNK(i) nmeb.stg_base[NMECHECK(i)].hshlnk #define NME_RFPTR(i) nmeb.stg_base[NMECHECK(i)].rfptr diff --git a/tools/shared/nmeutil.c b/tools/shared/nmeutil.c index 9c60f12320..b8ee04c9a3 100644 --- a/tools/shared/nmeutil.c +++ b/tools/shared/nmeutil.c @@ -4,6 +4,13 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Last Modified: Jun 2020 + * + */ /** \file * \brief names table utility module @@ -554,7 +561,11 @@ dt_nme(int nm) case NT_MEM: if (NME_SYM(nm) == 0 || NME_SYM(nm) == 1) { - if (dt_nme((int)NME_NM(nm)) == DT_DCMPLX) { + // AOCC begin + if (dt_nme((int)NME_NM(nm)) == DT_QCMPLX) { + return DT_QUAD; + // AOCC end + } else if (dt_nme((int)NME_NM(nm)) == DT_DCMPLX) { return DT_DBLE; } else { return DT_REAL; diff --git a/tools/shared/pragma.c b/tools/shared/pragma.c index dee5ffbaba..eecaf4cbc3 100644 --- a/tools/shared/pragma.c +++ b/tools/shared/pragma.c @@ -4,6 +4,17 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Support for vector and novector directives + * Date of Modification: 19th July 2019 + * + * Ignoring simd directive for AMDGCN target + * Date of modification: 21st April 2020 + * + */ /** \file * \brief PGC & PGFTN directive scan & semantic module @@ -20,6 +31,14 @@ #include "semsym.h" #endif #include "direct.h" +// AOCC BEGIN +#include "debug.h" + +// string for using with -debug-only= command line argument +#ifdef DEBUG +static const char *DEBUG_ONLY = "pragma"; +#endif // DEBUG +// AOCC END #if defined(TARGET_X8664) && (!defined(FE90) || defined(PGF90)) #include "x86.h" @@ -412,6 +431,9 @@ p_pragma(char *pg, int pline) #define SW_SAVE_USED 69 #define SW_LIBM 70 #define SW_SIMD 71 +// AOCC BEGIN +#define SW_FORCEINLINE 73 +// AOCC END struct c { char *cmd; @@ -430,6 +452,9 @@ struct c { static struct c table[] = { {"align", SW_ALIGN, false, S_NONE, S_NONE}, {"altcode", SW_ALTCODE, true, S_LOOP, S_LOOP | S_ROUTINE | S_GLOBAL}, +// AOCC BEGIN + {"forceinline", SW_FORCEINLINE, false, S_ROUTINE, S_ROUTINE | S_GLOBAL}, +// AOCC END {"assoc", SW_ASSOC, true, S_LOOP, S_LOOP | S_ROUTINE | S_GLOBAL}, {"bounds", SW_BOUNDS, true, S_ROUTINE, S_ROUTINE | S_GLOBAL}, {"c", SW_C, false, S_NONE, S_NONE}, @@ -525,6 +550,7 @@ do_sw(void) int xval; SPTR sptr; int got_init; + int backup_nowarn; #if defined(TARGET_X8664) && (!defined(FE90) || defined(PGF90)) int tpvalue[TPNVERSION]; #endif @@ -581,8 +607,19 @@ do_sw(void) bclr(DIR_OFFSET(currdir, vect), 0x04); break; case SW_IVDEP: - no_specified = true; - /* fall thru */ + // AOCC Begin + // Do not pass DEPCHK flag to flang2 if user has disabled processing + // loop vectorizing pragmas + if (flg.disable_loop_vectorize_pragmas) + break; + if (no_specified) { + bclr(DIR_OFFSET(currdir, x[200]), 0x01); + } else { + bset(DIR_OFFSET(currdir, x[200]), 0x01); + DEBUG_LOG("Encountered ivdep directive\n"); + } + break; + // AOCC End case SW_DEPCHK: if (no_specified) assn(DIR_OFFSET(currdir, depchk), 0); @@ -646,12 +683,50 @@ do_sw(void) else bclr(DIR_OFFSET(currdir, x[19]), 0x40); break; +// AOCC BEGIN + // x:183 0x4000000 is used to pass NOVECTOR pragma to flang2 + // x:183 0x80000000 is used to pass VECTOR pragma to flang2 case SW_VECTOR: - if (no_specified) - bset(DIR_OFFSET(currdir, x[19]), 0x18); /* notransform | norecog */ - else - bclr(DIR_OFFSET(currdir, x[19]), 0x18); + // Do not pass vector pragma to ilm file + // loop vectorizing pragmas are disabled + if (flg.disable_loop_vectorize_pragmas) + break; + + if (no_specified) { + bset(DIR_OFFSET(currdir, x[183]), 0x4000000); + bclr(DIR_OFFSET(currdir, x[183]), 0x80000000); + DEBUG_LOG("Encountered novector directive\n"); + } else { + typ = gtok(); + if (typ != T_IDENT) { + bclr(DIR_OFFSET(currdir, x[183]), 0x4000000); + bset(DIR_OFFSET(currdir, x[183]), 0x80000000); + DEBUG_LOG("Encountered vector directive\n"); + break; + } + if (strcmp(ctok, "always") == 0) { + no_specified = true; + bset(DIR_OFFSET(currdir, x[69]), 0x200000); + assn(DIR_OFFSET(currdir, depchk), 0); + DEBUG_LOG("Encountered vector always directive\n"); + } else if (strcmp(ctok, "never") == 0) { + bset(DIR_OFFSET(currdir, x[183]), 0x4000000); + bclr(DIR_OFFSET(currdir, x[183]), 0x80000000); + DEBUG_LOG("Encountered vector never directive\n"); + } else { + backup_nowarn = gbl.nowarn; + gbl.nowarn = false; + errwarn((error_code_t)603); + gbl.nowarn = backup_nowarn; + } + } + break; + case SW_FORCEINLINE: + bclr(DIR_OFFSET(currdir, x[14]), 0x8); + bset(DIR_OFFSET(currdir, x[191]), 0x2); + DEBUG_LOG("Encountered forceinline directive\n"); break; +// AOCC END case SW_VINTR: if (no_specified) bset(DIR_OFFSET(currdir, x[34]), 0x8); @@ -1159,37 +1234,33 @@ do_sw(void) return true; break; case SW_UNROLL: - /* [no]unroll -x/y 11 3 - * [no]unroll = c -x/y 11 1 - * [no]unroll = n -x/y 11 2 - * unroll = c:v -y 11 3 -x 9 v - * unroll = n:v -y 11 3 -x 10 v + /* unroll -x 11 0x1 -y 11 0x402 + * unroll = n -x 11 0x2 -y 11 0x401 -x 9 n + * unroll (n) -x 11 0x2 -y 11 0x401 -x 9 n + * nounroll -x 11 0x400 -y 11 0x3 */ typ = gtok(); - if (typ != T_EQUAL) { - if (no_specified) - bset(DIR_OFFSET(currdir, x[11]), 0x3); - else + // !dir$ [no]unroll + if (typ == T_END) { + if (no_specified) { // !dir$ nounroll + bset(DIR_OFFSET(currdir, x[11]), 0x400); bclr(DIR_OFFSET(currdir, x[11]), 0x3); - } else if (gtok() == T_IDENT) { - if (strcmp(ctok, "c") == 0) - i = 9; - else if (strcmp(ctok, "n") == 0) - i = 10; - else - return true; - if (no_specified) - bset(DIR_OFFSET(currdir, x[11]), i - 8); - else if (gtok() != T_COLON) - bclr(DIR_OFFSET(currdir, x[11]), i - 8); - else if (gtok() != T_INT) - return true; - else { - if (itok <= 0) - itok = 1; - assn(DIR_OFFSET(currdir, x[i]), (int)itok); - bclr(DIR_OFFSET(currdir, x[11]), 3); + // AOCC BEGIN + DEBUG_LOG("Encountered nounroll directive\n"); + // AOCC END + } else { // !dir$ unroll + bset(DIR_OFFSET(currdir, x[11]), 0x1); + bclr(DIR_OFFSET(currdir, x[11]), 0x402); + // AOCC BEGIN + DEBUG_LOG("Encountered unroll directive\n"); + // AOCC END } + } else if (typ == T_EQUAL || typ == T_LP) { + // !dir$ unroll = n or !dir$ unroll(n) + int unroll_count = atoi(currp); + assn(DIR_OFFSET(currdir, x[9]), unroll_count); + bset(DIR_OFFSET(currdir, x[11]), 0x2); + bclr(DIR_OFFSET(currdir, x[11]), 0x401); } else return true; break; @@ -1268,10 +1339,21 @@ do_sw(void) break; case SW_SSE: case SW_SIMD: - if (no_specified) - bset(DIR_OFFSET(currdir, x[19]), 0x400); - else - bclr(DIR_OFFSET(currdir, x[19]), 0x400); + // AOCC Begin + if (flg.disable_loop_vectorize_pragmas) { + break; + } + // originally x[19], 0x400 + // currently delegated to IVDEP (69, 0x200000) + // TODO: change to a new implementation, supporting clauses + // and combined with omp simd pragma + if (no_specified) { + bclr(DIR_OFFSET(currdir, x[69]), 0x200000); + } else { + bset(DIR_OFFSET(currdir, x[69]), 0x200000); + assn(DIR_OFFSET(currdir, depchk), 0); + } + // AOCC End break; case SW_NOINLINE: /* @@ -1280,7 +1362,11 @@ do_sw(void) * mark routine or all routines as not-to-be-extracted, and therefore * not to be inlined */ + bclr(DIR_OFFSET(currdir, x[191]), 0x2); bset(DIR_OFFSET(currdir, x[14]), 8); + // AOCC BEGIN + DEBUG_LOG("Encountered noinline pragma\n"); + // AOCC END break; case SW_ZEROTRIP: if (no_specified) @@ -1487,6 +1573,11 @@ rouprg_enter(void) void apply_nodepchk(int dir_lineno, int dir_scope) { + // AOCC Begin + if (flg.amdgcn_target) { + return; + } + // AOCC End int index, diroff; DIRSET* tempdir; if (!ALLOW_NODEPCHK_SIMD) @@ -1559,9 +1650,12 @@ getindex(struct c table[], int num_elem, char *string) return_it: if (fnd >= 0) { if (scope == S_NONE) { - if (craydir && table[fnd].caselabel == SW_VECTOR) - scope = S_ROUTINE; - else +// AOCC BEGIN +// // Commented the below code as the vector pragma is applied on a loop not on the routine. +// if (craydir && table[fnd].caselabel == SW_VECTOR) +// scope = S_ROUTINE; +// else +// AOCC END scope = table[fnd].def_scope; } switch (scope) { diff --git a/tools/shared/rtlRtns.c b/tools/shared/rtlRtns.c index fc0b8c475e..4edda6847e 100644 --- a/tools/shared/rtlRtns.c +++ b/tools/shared/rtlRtns.c @@ -5,6 +5,35 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Support for DNORM intrinsic + * Date of Modification: 21st February 2019 + * + * Support for Bit Sequence Comparsion intrinsic + * Month of Modification: May 2019 + * + * Support for Bit Masking intrinsics. + * Month of Modification: May 2019 + * + * Support for F2008 EXECUTE_COMMAND_LINE intrinsic subroutine. + * Month of Modification: July 2019 + * + * Support for TRAILZ intrinsic. + * Month of Modification: July 2019 + * + * Support for Bit transformational intrinsic iany, iall, iparity. + * Month of Modification: July 2019 + * + * Added support for quad precision + * Last modified: Feb 2020 + * + * Support for real*16 intrinsics + * Date of Modification: 18th July 2020 + */ + /** \file Provides the front-end access to the run time library structure * defined in rte_rtns.h */ @@ -54,6 +83,10 @@ FtnRteRtn ftnRtlRtns[] = { {"auto_dealloc", "", true, ""}, {"auto_deallocm", "", true, ""}, {"auto_deallocp", "", true, ""}, + /* AOCC begin */ + {"bitcmp", "", false, ""}, + {"bitmask", "", false, ""}, + /* AOCC end */ {"c_f_procptr", "", false, ""}, {"c_f_ptr", "", true, ""}, {"calloc03a", "", true, ""}, @@ -104,6 +137,7 @@ FtnRteRtn ftnRtlRtns[] = { {"dfloorv", "", false, "k"}, {"dmodulev", "", false, ""}, {"dmodulov", "", false, ""}, + {"qmodulov", "", false, ""}, {"errorstop08a_char", "", false, ""}, {"errorstop08a_int", "", false, ""}, {"execcmdline", "", false, ""}, @@ -111,6 +145,7 @@ FtnRteRtn ftnRtlRtns[] = { {"expon", "", false, "k"}, {"expond", "", false, "k"}, {"expondx", "", false, "k"}, + {"exponqx", "", false, "k"}, {"exponx", "", false, "k"}, {"extends_type_of", "", true, "k"}, {"finalize", "", true, ""}, @@ -119,6 +154,8 @@ FtnRteRtn ftnRtlRtns[] = { {"frac", "", false, ""}, {"fracd", "", false, ""}, {"fracdx", "", false, ""}, + {"fracq", "", false, ""}, + {"fracqx", "", false, ""}, {"fracx", "", false, ""}, {"get_cmda", "", false, ""}, {"get_cmd_arga", "", false, ""}, @@ -182,6 +219,7 @@ FtnRteRtn ftnRtlRtns[] = { {"matmul_cplx16", "", true, ""}, {"matmul_cplx16mxv_t", "", true, ""}, {"matmul_cplx32", "", true, ""}, + {"matmul_cplx32mxv_t", "", true, ""}, {"matmul_cplx8", "", true, ""}, {"matmul_cplx8mxv_t", "", true, ""}, {"matmul_int1", "", true, ""}, @@ -197,11 +235,13 @@ FtnRteRtn ftnRtlRtns[] = { {"matmul_real4mxv_t", "", true, ""}, {"matmul_real8", "", true, ""}, {"matmul_real8mxv_t", "", true, ""}, + {"matmul_real16mxv_t", "", true, ""}, {"max", "", false, "k"}, {"mcopy1", "", false, ""}, {"mcopy2", "", false, ""}, {"mcopy4", "", false, ""}, {"mcopy8", "", false, ""}, + {"mcopyz32", "", false, ""}, {"mcopyz16", "", false, ""}, {"mcopyz4", "", false, ""}, {"mcopyz8", "", false, ""}, @@ -219,8 +259,10 @@ FtnRteRtn ftnRtlRtns[] = { {"mergel2", "", false, ""}, {"mergel8", "", false, ""}, {"mergeq", "", false, ""}, + {"mergeqc", "", false, ""}, // AOCC {"merger", "", false, ""}, {"min", "", false, "k"}, + {"mmul_cmplx32", "", false, ""}, {"mmul_cmplx16", "", false, ""}, {"mmul_cmplx8", "", false, ""}, {"mmul_real4", "", false, ""}, @@ -233,6 +275,7 @@ FtnRteRtn ftnRtlRtns[] = { {"mset2", "", false, ""}, {"mset4", "", false, ""}, {"mset8", "", false, ""}, + {"msetz32", "", false, ""}, {"msetz16", "", false, ""}, {"msetz4", "", false, ""}, {"msetz8", "", false, ""}, @@ -241,6 +284,7 @@ FtnRteRtn ftnRtlRtns[] = { {"mzero2", "", false, ""}, {"mzero4", "", false, ""}, {"mzero8", "", false, ""}, + {"mzeroz32", "", false, ""}, {"mzeroz16", "", false, ""}, {"mzeroz4", "", false, ""}, {"mzeroz8", "", false, ""}, @@ -251,8 +295,21 @@ FtnRteRtn ftnRtlRtns[] = { {"nearestd", "", false, ""}, {"nearestdx", "", false, ""}, {"nearestx", "", false, ""}, + //AOCC Begin + {"nearestq", "", false, ""}, + {"nearestqx", "", false, ""}, + //AOCC End {"nlena", "", true, ""}, {"nlentrim", "", false, ""}, + // AOCC Begin + // Enable i8 descriptor to access the dims in library + {"norm2_real4", "", true, ""}, + {"norm2_real4_dim", "", true, ""}, + {"norm2_real8", "", true, ""}, + {"norm2_real8_dim", "", true, ""}, + {"norm2_real16", "", true, ""}, + {"norm2_real16_dim", "", true, ""}, + // AOCC End {"nrepeat", "", false, ""}, {"nscan", "", false, "k"}, {"nstr_copy", "", false, ""}, @@ -295,6 +352,7 @@ FtnRteRtn ftnRtlRtns[] = { {"ptrchk", "", false, ""}, {"ptrcp", "", false, ""}, {"real", "", false, ""}, + {"real32", "", false, ""}, {"real16", "", false, ""}, {"real4", "", false, ""}, {"real8", "", false, ""}, @@ -302,6 +360,8 @@ FtnRteRtn ftnRtlRtns[] = { {"rrspacing", "", false, ""}, {"rrspacingd", "", false, ""}, {"rrspacingdx", "", false, ""}, + {"rrspacingq", "", false, ""}, + {"rrspacingqx", "", false, ""}, {"rrspacingx", "", false, ""}, {"rtn_name", "", false, ""}, {"same_intrin_type_as", "", true, "k"}, @@ -309,6 +369,10 @@ FtnRteRtn ftnRtlRtns[] = { {"scale", "", false, ""}, {"scaled", "", false, ""}, {"scaledx", "", false, ""}, + //AOCC Begin + {"scaleq", "", false, ""}, + {"scaleqx", "", false, ""}, + //AOCC End {"scalex", "", false, ""}, {"scana", "", false, "k"}, {"sect", "", true, ""}, @@ -326,6 +390,8 @@ FtnRteRtn ftnRtlRtns[] = { {"setexp", "", false, ""}, {"setexpd", "", false, ""}, {"setexpdx", "", false, ""}, + {"setexpq", "", false, ""}, + {"setexpqx", "", false, ""}, {"setexpx", "", false, ""}, {"shape", "", true, "k"}, {"shape1", "", true, ""}, @@ -337,6 +403,8 @@ FtnRteRtn ftnRtlRtns[] = { {"spacing", "", false, ""}, {"spacingd", "", false, ""}, {"spacingdx", "", false, ""}, + {"spacingq", "", false, ""}, + {"spacingqx", "", false, ""}, {"spacingx", "", false, ""}, {"stopa", "", false, ""}, {"stop08a", "", false, ""}, @@ -394,10 +462,10 @@ FtnRteRtn ftnRtlRtns[] = { {"uboundaz8", "", false, ""}, {"verifya", "", false, "k"}, {"END_OF_PFX_F90,", "", false, ""}, - {"all", "", false, ""}, + {"all", "", true, ""}, {"all_scatterx", "", false, ""}, {"alls", "", true, ""}, - {"any", "", false, ""}, + {"any", "", true, ""}, {"any_scatterx", "", false, ""}, {"anys", "", true, ""}, {"associated", "", true, ""}, @@ -411,10 +479,11 @@ FtnRteRtn ftnRtlRtns[] = { {"comm_gatherx", "", false, ""}, {"comm_scatterx", "", false, ""}, {"copy_out", "", true, ""}, - {"count", "", false, ""}, + {"count", "", true, ""}, {"counts", "", true, ""}, {"cpu_time", "", false, ""}, {"cpu_timed", "", false, ""}, + {"cpu_timeq", "", false, ""}, {"cshift", "", true, ""}, {"cshiftc", "", true, ""}, {"cshifts", "", true, ""}, @@ -463,8 +532,15 @@ FtnRteRtn ftnRtlRtns[] = { {"global_product", "", false, ""}, {"global_sum", "", false, ""}, {"globalize", "", false, ""}, + {"iparity", "", false, ""}, + {"iparity_scatterx", "", false, ""}, + {"iparitys", "", true, ""}, + {"iall", "", false, ""}, {"iall_scatterx", "", false, ""}, + {"ialls", "", true, ""}, + {"iany", "", false, ""}, {"iany_scatterx", "", false, ""}, + {"ianys", "", true, ""}, {"idate", "", false, ""}, {"ilen", "", false, ""}, {"indexa", "", true, "k"}, @@ -473,7 +549,6 @@ FtnRteRtn ftnRtlRtns[] = { {"indexx_cr_nma", "", true, "k"}, {"init", "", false, ""}, {"instance", "", true, ""}, - {"iparity_scatterx", "", false, ""}, {"islocal_idx", "", false, ""}, {"jdate", "", false, ""}, {"lastval", "", false, ""}, @@ -574,12 +649,13 @@ FtnRteRtn ftnRtlRtns[] = { {"reshapeca", "", true, ""}, {"rnum", "", true, ""}, {"rnumd", "", true, ""}, + {"rnumq", "", true, ""}, // AOCC {"rseed", "", true, ""}, {"secnds", "", true, ""}, {"secndsd", "", true, ""}, {"shape", "", true, "k"}, {"size", "", true, "k"}, - {"spread", "", false, ""}, + {"spread", "", true, ""}, {"spread_descriptor", "", true, ""}, {"spreadca", "", false, ""}, {"spreadcs", "", false, ""}, @@ -589,6 +665,9 @@ FtnRteRtn ftnRtlRtns[] = { {"sums", "", true, ""}, {"sysclk", "", true, ""}, {"template", "", true, ""}, + /* AOCC begin */ + {"trailz", "", false, ""}, + /* AOCC end */ {"transfer", "", true, ""}, {"type", "", false, ""}, {"typep", "", false, ""}, @@ -692,6 +771,8 @@ FtnRteRtn ftnRtlRtns[] = { {"f90io_open_sharea", "", false, ""}, {"f90io_print_init", "", false, ""}, {"f90io_rewind", "", false, ""}, + {"f90io_sc_cq_fmt_write", "", false, ""}, // AOCC + {"f90io_sc_cq_ldw", "", false, ""}, // AOCC {"f90io_sc_cd_fmt_write", "", false, ""}, {"f90io_sc_cd_ldw", "", false, ""}, {"f90io_sc_cf_fmt_write", "", false, ""}, @@ -700,6 +781,8 @@ FtnRteRtn ftnRtlRtns[] = { {"f90io_sc_ch_ldw", "", false, ""}, {"f90io_sc_d_fmt_write", "", false, ""}, {"f90io_sc_d_ldw", "", false, ""}, + {"f90io_sc_q_fmt_write", "", false, ""}, // AOCC + {"f90io_sc_q_ldw", "", false, ""}, // AOCC {"f90io_sc_f_fmt_write", "", false, ""}, {"f90io_sc_f_ldw", "", false, ""}, {"f90io_sc_fmt_write", "", false, ""}, diff --git a/tools/shared/rtlRtns.h b/tools/shared/rtlRtns.h index 957f1f5c36..2435ae1aca 100644 --- a/tools/shared/rtlRtns.h +++ b/tools/shared/rtlRtns.h @@ -5,6 +5,35 @@ * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Support for DNORM intrinsic + * Date of Modification: 21st February 2019 + * + * Support for Bit Sequence Comparsion intrinsic + * Month of Modification: May 2019 + * + * Support for Bit Masking intrinsics. + * Month of Modification: May 2019 + * + * Support for F2008 EXECUTE_COMMAND_LINE intrinsic subroutine. + * Month of Modification: July 2019 + * + * Support for Bit transformational intrinsic iany, iall, iparity. + * Month of Modification: July 2019 + * + * Added support for quad precision + * Last modified: Feb 2020 + * + * Support for TRAILZ intrinsic. + * Month of Modification: July 2019 + * + * Support for real*16 intrinsics + * Date of modification: 18th July 2020 + */ + #ifndef FORTRAN_RTLRTNS_H_ #define FORTRAN_RTLRTNS_H_ @@ -57,6 +86,10 @@ typedef enum { RTE_auto_dealloc, RTE_auto_deallocm, RTE_auto_deallocp, + /* AOCC begin */ + RTE_bitcmp, + RTE_bitmask, + /* AOCC end */ RTE_c_f_procptr, RTE_c_f_ptr, RTE_calloc03a, @@ -109,6 +142,7 @@ typedef enum { RTE_dfloorv, RTE_dmodulev, RTE_dmodulov, + RTE_qmodulov, RTE_errorstop08a_char, RTE_errorstop08a_int, RTE_execcmdline, @@ -116,6 +150,7 @@ typedef enum { RTE_expon, RTE_expond, RTE_expondx, + RTE_exponqx, RTE_exponx, RTE_extends_type_of, RTE_finalize, @@ -124,6 +159,8 @@ typedef enum { RTE_frac, RTE_fracd, RTE_fracdx, + RTE_fracq, + RTE_fracqx, RTE_fracx, RTE_get_cmda, RTE_get_cmd_arga, @@ -187,6 +224,7 @@ typedef enum { RTE_matmul_cplx16, RTE_matmul_cplx16mxv_t, RTE_matmul_cplx32, + RTE_matmul_cplx32mxv_t, RTE_matmul_cplx8, RTE_matmul_cplx8mxv_t, RTE_matmul_int1, @@ -202,11 +240,13 @@ typedef enum { RTE_matmul_real4mxv_t, RTE_matmul_real8, RTE_matmul_real8mxv_t, + RTE_matmul_real16mxv_t, RTE_max, RTE_mcopy1, RTE_mcopy2, RTE_mcopy4, RTE_mcopy8, + RTE_mcopyz32, RTE_mcopyz16, RTE_mcopyz4, RTE_mcopyz8, @@ -224,8 +264,10 @@ typedef enum { RTE_mergel2, RTE_mergel8, RTE_mergeq, + RTE_mergeqc, // AOCC RTE_merger, RTE_min, + RTE_mmul_cmplx32, // AOCC RTE_mmul_cmplx16, RTE_mmul_cmplx8, RTE_mmul_real4, @@ -238,6 +280,7 @@ typedef enum { RTE_mset2, RTE_mset4, RTE_mset8, + RTE_msetz32, RTE_msetz16, RTE_msetz4, RTE_msetz8, @@ -246,6 +289,7 @@ typedef enum { RTE_mzero2, RTE_mzero4, RTE_mzero8, + RTE_mzeroz32, RTE_mzeroz16, RTE_mzeroz4, RTE_mzeroz8, @@ -256,8 +300,21 @@ typedef enum { RTE_nearestd, RTE_nearestdx, RTE_nearestx, + //AOCC Begin + RTE_nearestq, + RTE_nearestqx, + //AOCC End RTE_nlena, RTE_nlentrim, + // AOCC Begin + // Order should match the order in ftnRtlRtns[] + RTE_norm2_real4, + RTE_norm2_real4_dim, + RTE_norm2_real8, + RTE_norm2_real8_dim, + RTE_norm2_real16, + RTE_norm2_real16_dim, + // AOCC End RTE_nrepeat, RTE_nscan, RTE_nstr_copy, @@ -300,6 +357,7 @@ typedef enum { RTE_ptrchk, RTE_ptrcp, RTE_real, + RTE_real32, RTE_real16, RTE_real4, RTE_real8, @@ -307,6 +365,8 @@ typedef enum { RTE_rrspacing, RTE_rrspacingd, RTE_rrspacingdx, + RTE_rrspacingq, + RTE_rrspacingqx, RTE_rrspacingx, RTE_rtn_name, RTE_same_intrin_type_as, @@ -314,6 +374,10 @@ typedef enum { RTE_scale, RTE_scaled, RTE_scaledx, + //AOCC Begin + RTE_scaleq, + RTE_scaleqx, + //AOCC End RTE_scalex, RTE_scana, RTE_sect, @@ -331,6 +395,8 @@ typedef enum { RTE_setexp, RTE_setexpd, RTE_setexpdx, + RTE_setexpq, + RTE_setexpqx, RTE_setexpx, RTE_shape, RTE_shape1, @@ -342,6 +408,8 @@ typedef enum { RTE_spacing, RTE_spacingd, RTE_spacingdx, + RTE_spacingq, + RTE_spacingqx, RTE_spacingx, RTE_stopa, RTE_stop08a, @@ -420,6 +488,7 @@ typedef enum { RTE_counts, RTE_cpu_time, RTE_cpu_timed, + RTE_cpu_timeq, RTE_cshift, RTE_cshiftca, RTE_cshifts, @@ -468,8 +537,15 @@ typedef enum { RTE_global_product, RTE_global_sum, RTE_globalize, + RTE_iparity, + RTE_iparity_scatterx, + RTE_iparitys, + RTE_iall, RTE_iall_scatterx, + RTE_ialls, + RTE_iany, RTE_iany_scatterx, + RTE_ianys, RTE_idate, RTE_ilen, RTE_indexDsc, @@ -478,7 +554,6 @@ typedef enum { RTE_indexx_cr_nma, RTE_init, RTE_instance, - RTE_iparity_scatterx, RTE_islocal_idx, RTE_jdate, RTE_lastval, @@ -579,6 +654,7 @@ typedef enum { RTE_reshapeca, RTE_rnum, RTE_rnumd, + RTE_rnumq, // AOCC RTE_rseed, RTE_secnds, RTE_secndsd, @@ -594,6 +670,9 @@ typedef enum { RTE_sums, RTE_sysclk, RTE_templateDsc, + /* AOCC begin */ + RTE_trailz, + /* AOCC end */ RTE_transfer, RTE_type, RTE_typep, @@ -697,6 +776,8 @@ typedef enum { RTE_f90io_open_sharea, RTE_f90io_print_init, RTE_f90io_rewind, + RTE_f90io_sc_cq_fmt_write, // AOCC + RTE_f90io_sc_cq_ldw, // AOCC RTE_f90io_sc_cd_fmt_write, RTE_f90io_sc_cd_ldw, RTE_f90io_sc_cf_fmt_write, @@ -705,6 +786,8 @@ typedef enum { RTE_f90io_sc_ch_ldw, RTE_f90io_sc_d_fmt_write, RTE_f90io_sc_d_ldw, + RTE_f90io_sc_q_fmt_write, // AOCC + RTE_f90io_sc_q_ldw, // AOCC RTE_f90io_sc_f_fmt_write, RTE_f90io_sc_f_ldw, RTE_f90io_sc_fmt_write, diff --git a/tools/shared/symfun.h b/tools/shared/symfun.h index ec82e2d4f2..e3077b4220 100644 --- a/tools/shared/symfun.h +++ b/tools/shared/symfun.h @@ -3,6 +3,11 @@ * See https://llvm.org/LICENSE.txt for license information. * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * + * + * Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved. + * + * Date of Modification : May 2020 + * */ #ifndef FORTRAN_SYMFUN_H_ @@ -404,6 +409,12 @@ ST_GetterInstance(GDCMPLXG, SPTR, GDoubleComplex) #undef GDCMPLXG #define GDCMPLXG(X) STGetGDoubleComplex(X) +// AOCC begin +#undef GQCMPLXG +#define GQCMPLXG(X) STGetGQuadComplex(X) +ST_GetterInstance(GQCMPLXG, SPTR, GQuadComplex) +// AOCC end + ST_GetterInstance(GINTG, SPTR, GInteger) #undef GINTG #define GINTG(X) STGetGInteger(X) diff --git a/tools/shared/utils/common/utils.h b/tools/shared/utils/common/utils.h index 47fda013ff..8aecac1a18 100644 --- a/tools/shared/utils/common/utils.h +++ b/tools/shared/utils/common/utils.h @@ -474,7 +474,7 @@ class SphinxConverter for (std::vector::const_iterator it = tokens.begin() + 1, E = tokens.end(); it != E; ++it) { - tgt << " " << *it; + tgt << ' ' << *it; } tgt << "\n"; return; @@ -566,7 +566,7 @@ class SphinxConverter for (std::vector::const_iterator it = tokens.begin() + 1, E = tokens.end(); it != E; ++it) { - tgt << " " << *it; + tgt << ' ' << *it; } tgt << "\n"; } @@ -578,7 +578,7 @@ class SphinxConverter for (std::vector::const_iterator it = tokens.begin() + 2, E = tokens.end(); it != E; ++it) { - tgt << " " << *it; + tgt << ' ' << *it; } tgt << "\n\n"; } @@ -654,7 +654,7 @@ class SphinxConverter ss << "#. **" << tokens[1] << "**"; for (std::vector::size_type it = 3; it < tokens.size(); ++it) { - ss << " " << tokens[it]; + ss << ' ' << tokens[it]; } ss << " *Type*: *" << tokens[2] << "*\n\n"; } @@ -666,7 +666,7 @@ class SphinxConverter if (it != E) { ss << " ``" << *it++ << "``"; for (; it != E; ++it) { - ss << " " << *it; + ss << ' ' << *it; } } } @@ -1037,7 +1037,7 @@ class SphinxConverter for (cell_type::const_iterator ci = formatting[it].begin(), E = formatting[it].end(); ci != E; ++ci) { - tgt << " " << *ci; + tgt << ' ' << *ci; } tgt << '\n'; } @@ -1180,7 +1180,7 @@ class SphinxConverter it = widths.begin(), E = widths.end(); it != E; ++it) { - tgt << " " << *it; + tgt << ' ' << *it; } tgt << '\n'; } diff --git a/tools/shared/utils/global.h b/tools/shared/utils/global.h index c7bd2e2729..14ef411d85 100644 --- a/tools/shared/utils/global.h +++ b/tools/shared/utils/global.h @@ -1,10 +1,21 @@ /* + * * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. * See https://llvm.org/LICENSE.txt for license information. * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Use llvm math intrinsic instead of flang runtime; + * assume function arguments are aliasing. + * Date of Modification: February 2018 + * + */ + #ifndef GLOBAL_H_ #define GLOBAL_H_ @@ -23,6 +34,17 @@ typedef enum SPTR { SPTR_MAX = 67108864 /* Maximum allowed value */ } SPTR; +// AOCC begin +typedef enum { + STD_UNKNOWN, /* default */ + F2008, + F2003, + F77, + F95, + F90 +} FORTRAN_STD; +// AOCC end + #ifdef __cplusplus // Enable symbol table traversals to work. static inline void operator++(SPTR &s) @@ -206,10 +228,30 @@ typedef struct { bool trans_inv; /* global equiv to -Mx,7,0x10000 */ int tpcount; int tpvalue[TPNVERSION]; /* target processor(s), for unified binary */ + // AOCC Begin + LOGICAL use_llvm_math_intrin; /* AOCC: use llvm math intrinsic instead of flang runtime */ + LOGICAL func_args_alias; /* assume function arguments are aliasing */ + char *std_string; /* input string arg of -std= */ + FORTRAN_STD std; + bool amdgcn_target; /*chech if we are offloading to amd gcn */ + bool x86_64_omptarget; /*chech if we are offloading to x86-64 */ + bool disable_loop_vectorize_pragmas; /* Disable Loop vecroizing pragmas */ + int warp_size; /* Warp size for target */ + char *march; /* Arch of the omp target */ +#ifdef DEBUG + LOGICAL debug_log; /* TRUE enables all debug log statements */ + char *debug_only_strs; /* enables only debug log categories in this string */ +#endif // DEBUG + // AOCC End } FLG; extern FLG flg; +// AOCC begin +extern unsigned get_legal_maxdim(); +extern bool is_legal_numdim(int numdim); +// AOCC end + #define IEEE_CMP (flg.ieee || !XBIT(15, 0x8000000)) #endif // GLOBAL_H_ diff --git a/tools/shared/utils/machar.cpp b/tools/shared/utils/machar.cpp index 1cee169b47..b67342bfce 100644 --- a/tools/shared/utils/machar.cpp +++ b/tools/shared/utils/machar.cpp @@ -183,7 +183,7 @@ class Machar : public UtilityApplication bool is_space(const std::string &text, size_t i, size_t j) { - return line.find_first_not_of(" ", i, j - i) >= j; + return line.find_first_not_of(" ", i) >= j; } void diff --git a/tools/shared/utils/symacc.c b/tools/shared/utils/symacc.c index 8e50a80ea4..fe2972421f 100644 --- a/tools/shared/utils/symacc.c +++ b/tools/shared/utils/symacc.c @@ -4,6 +4,15 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * Added support for quad precision + * Last modified: Feb 2020 + * Last modified: Jun 2020 + * Last Modified: Jun 2020 + */ /******************************************************** FIXME: get rid of this "important notice" and proliferating copies. @@ -70,7 +79,7 @@ sym_init_first(void) #if defined(PGHPF) && !defined(PGF90) stb.n_size = 7011; #else - stb.n_size = 5024; + stb.n_size = 7024; // AOCC #endif NEW(stb.n_base, char, stb.n_size); assert(stb.n_base, "sym_init: no room for namtab", stb.n_size, ERR_Fatal); @@ -110,6 +119,7 @@ sym_init_first(void) DT_LOG = DT_LOG4; DT_DBLE = DT_REAL8; DT_DCMPLX = DT_CMPLX16; + DT_QCMPLX = DT_CMPLX32; DT_PTR = DT_INT4; #endif #endif @@ -483,16 +493,23 @@ add_fp_constants(void) /* 1.0, 2.0, 0.5, -0.0 as double, quad */ atoxd("0.0", &tmp[0], 3); stb.dbl0 = getcon(tmp, DT_DBLE); - stb.quad0 = getcon(tmp, DT_QUAD); /* quad currently the same as double */ atoxd("1.0", &tmp[0], 3); stb.dbl1 = getcon(tmp, DT_DBLE); - stb.quad1 = getcon(tmp, DT_QUAD); /* quad currently the same as double */ atoxd("2.0", &tmp[0], 3); stb.dbl2 = getcon(tmp, DT_DBLE); - stb.quad2 = getcon(tmp, DT_QUAD); /* quad currently the same as double */ atoxd("0.5", &tmp[0], 3); stb.dblhalf = getcon(tmp, DT_DBLE); - stb.quadhalf = getcon(tmp, DT_QUAD); /* quad currently the same as double */ + + // AOCC begin + atoxq("0.0", &tmp[0], 4); + stb.quad0 = getcon(tmp, DT_QUAD); + atoxq("0.0", &tmp[0], 4); + stb.quad1 = getcon(tmp, DT_QUAD); + atoxq("0.0", &tmp[0], 4); + stb.quad2 = getcon(tmp, DT_QUAD); + atoxq("0.0", &tmp[0], 4); + stb.quadhalf = getcon(tmp, DT_QUAD); + // AOCC end tmp[0] = 0; res[0] = 0; @@ -503,7 +520,14 @@ add_fp_constants(void) tmp[1] = CONVAL2G(stb.dbl0); xdneg(tmp, res); stb.dblm0 = getcon(res, DT_DBLE); - stb.quadm0 = getcon(res, DT_QUAD); /* quad currently the same as double */ + // AOCC begin + tmp[0] = CONVAL1G(stb.quad0); + tmp[1] = CONVAL2G(stb.quad0); + tmp[2] = CONVAL3G(stb.quad0); + tmp[3] = CONVAL4G(stb.quad0); + xqneg(tmp, res); + stb.quadm0 = getcon(res, DT_QUAD); + // AOCC end #endif #ifdef LONG_DOUBLE_X87 diff --git a/tools/shared/utils/symacc.h b/tools/shared/utils/symacc.h index 101f53cbe4..94355c4a54 100644 --- a/tools/shared/utils/symacc.h +++ b/tools/shared/utils/symacc.h @@ -4,6 +4,16 @@ * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ +/* + * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. + * Notified per clause 4(b) of the license. + * + * + * Added support for quad precision + * Last modified: Feb 2020 + * Last Modified: Jun 2020 + * + */ #ifndef SYMACC_H_ #define SYMACC_H_ @@ -317,6 +327,9 @@ typedef struct { DTYPE dt_cmplx; /* default cmplx - DT_CMPLX */ DTYPE dt_log; /* default logical - DT_LOG */ DTYPE dt_dble; /* default double precision - DT_DBLE */ + // AOCC + DTYPE dt_quad; /* default quad precision - DT_QUAD */ + DTYPE dt_qcmplx; /* default quad cmplx - DT_QCMPLX */ DTYPE dt_dcmplx; /* default double cmplx - DT_DCMPLX */ DTYPE dt_ptr; /* default pointer integer - DT_PTR */ /* The following members are the default integer, real, complex, and @@ -342,9 +355,21 @@ inline SPTR SymConval1(SPTR sptr) { inline SPTR SymConval2(SPTR sptr) { return static_cast(CONVAL2G(sptr)); } +// AOCC begin +inline SPTR SymConval3(SPTR sptr) { + return static_cast(CONVAL3G(sptr)); +} +inline SPTR SymConval4(SPTR sptr) { + return static_cast(CONVAL4G(sptr)); +} +// AOCC end #else #define SymConval1 CONVAL1G #define SymConval2 CONVAL2G +// AOCC begin +#define SymConval3 CONVAL3G +#define SymConval4 CONVAL4G +// AOCC end #endif /** mode parameter for installsym_ex. */