diff --git a/test/ncar_kernels/CAM5_mg2_pgi/CESM_license.txt b/test/ncar_kernels/CAM5_mg2_pgi/CESM_license.txt new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/CAM5_mg2_pgi/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..8789c516486 --- /dev/null +++ b/test/ncar_kernels/CAM5_mg2_pgi/README @@ -0,0 +1,7 @@ +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 new file mode 100644 index 00000000000..a4a693cc022 Binary files /dev/null and b/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.10.0 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 new file mode 100644 index 00000000000..b22a3eacb02 Binary files /dev/null and b/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.10.100 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 new file mode 100644 index 00000000000..f4ddea35c4f Binary files /dev/null and b/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.10.300 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 new file mode 100644 index 00000000000..f8fa66805d4 Binary files /dev/null and b/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.100.0 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 new file mode 100644 index 00000000000..2e081a3058f Binary files /dev/null and b/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.100.100 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 new file mode 100644 index 00000000000..3a79e0153ad Binary files /dev/null and b/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.100.300 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 new file mode 100644 index 00000000000..87b0e231b3f Binary files /dev/null and b/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.50.0 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 new file mode 100644 index 00000000000..e7d775ee6bd Binary files /dev/null and b/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.50.100 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 new file mode 100644 index 00000000000..b69b024e5e4 Binary files /dev/null and b/test/ncar_kernels/CAM5_mg2_pgi/data/micro_mg_tend2_0.50.300 differ diff --git a/test/ncar_kernels/CAM5_mg2_pgi/inc/t1.mk b/test/ncar_kernels/CAM5_mg2_pgi/inc/t1.mk new file mode 100644 index 00000000000..4e9a6c87500 --- /dev/null +++ b/test/ncar_kernels/CAM5_mg2_pgi/inc/t1.mk @@ -0,0 +1,82 @@ +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/CAM5_mg2_pgi/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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/lit/t1.sh b/test/ncar_kernels/CAM5_mg2_pgi/lit/t1.sh new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/CAM5_mg2_pgi/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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_mg2_pgi/makefile b/test/ncar_kernels/CAM5_mg2_pgi/makefile new file mode 100644 index 00000000000..8a2d861261c --- /dev/null +++ b/test/ncar_kernels/CAM5_mg2_pgi/makefile @@ -0,0 +1,43 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..c29ab608f68 --- /dev/null +++ b/test/ncar_kernels/CAM5_mg2_pgi/src/kernel_driver.f90 @@ -0,0 +1,85 @@ + +! 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 new file mode 100644 index 00000000000..288050edebc --- /dev/null +++ b/test/ncar_kernels/CAM5_mg2_pgi/src/micro_mg2_0.F90 @@ -0,0 +1,2144 @@ + +! 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 new file mode 100644 index 00000000000..afd230cc6bb --- /dev/null +++ b/test/ncar_kernels/CAM5_mg2_pgi/src/micro_mg_cam.F90 @@ -0,0 +1,1244 @@ + +! 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 new file mode 100644 index 00000000000..b0022299097 --- /dev/null +++ b/test/ncar_kernels/CAM5_mg2_pgi/src/micro_mg_utils.F90 @@ -0,0 +1,960 @@ + +! 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 new file mode 100644 index 00000000000..c7e22c38c13 --- /dev/null +++ b/test/ncar_kernels/CAM5_mg2_pgi/src/shr_const_mod.F90 @@ -0,0 +1,65 @@ + +! 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 new file mode 100644 index 00000000000..60f3771dd1b --- /dev/null +++ b/test/ncar_kernels/CAM5_mg2_pgi/src/shr_kind_mod.F90 @@ -0,0 +1,30 @@ + +! 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 new file mode 100644 index 00000000000..72408ec6361 --- /dev/null +++ b/test/ncar_kernels/CAM5_mg2_pgi/src/shr_spfn_mod.F90 @@ -0,0 +1,457 @@ + +! 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 new file mode 100644 index 00000000000..f953436dbee --- /dev/null +++ b/test/ncar_kernels/CAM5_mg2_pgi/src/wv_sat_methods.F90 @@ -0,0 +1,299 @@ + +! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/CAM5_wetdepa/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..78befe241fa --- /dev/null +++ b/test/ncar_kernels/CAM5_wetdepa/README @@ -0,0 +1,20 @@ +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 new file mode 100644 index 00000000000..9bc3cecd76a --- /dev/null +++ b/test/ncar_kernels/CAM5_wetdepa/inc/t1.mk @@ -0,0 +1,96 @@ +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/CAM5_wetdepa/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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/lit/t1.sh b/test/ncar_kernels/CAM5_wetdepa/lit/t1.sh new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/CAM5_wetdepa/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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/makefile b/test/ncar_kernels/CAM5_wetdepa/makefile new file mode 100644 index 00000000000..2462d27e6ca --- /dev/null +++ b/test/ncar_kernels/CAM5_wetdepa/makefile @@ -0,0 +1,42 @@ +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..17906b5a0ed --- /dev/null +++ b/test/ncar_kernels/CAM5_wetdepa/src/kinds_mod.F90 @@ -0,0 +1,8 @@ +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 new file mode 100644 index 00000000000..272ba77cf8a --- /dev/null +++ b/test/ncar_kernels/CAM5_wetdepa/src/params.F90 @@ -0,0 +1,12 @@ +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 new file mode 100644 index 00000000000..cf4c17a0f11 --- /dev/null +++ b/test/ncar_kernels/CAM5_wetdepa/src/shr_const_mod.F90 @@ -0,0 +1,61 @@ +!=============================================================================== +! 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 new file mode 100644 index 00000000000..212bde08913 --- /dev/null +++ b/test/ncar_kernels/CAM5_wetdepa/src/shr_kind_mod.F90 @@ -0,0 +1,23 @@ +!=============================================================================== +! 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 new file mode 100644 index 00000000000..475453c7456 --- /dev/null +++ b/test/ncar_kernels/CAM5_wetdepa/src/wetdep.F90 @@ -0,0 +1,1009 @@ +!#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 new file mode 100644 index 00000000000..475453c7456 --- /dev/null +++ b/test/ncar_kernels/CAM5_wetdepa/src/wetdep.f90 @@ -0,0 +1,1009 @@ +!#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 new file mode 100644 index 00000000000..c130e3044b5 --- /dev/null +++ b/test/ncar_kernels/CAM5_wetdepa/src/wetdep_orig.F90 @@ -0,0 +1,1199 @@ +!#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 new file mode 100644 index 00000000000..c130e3044b5 --- /dev/null +++ b/test/ncar_kernels/CAM5_wetdepa/src/wetdep_orig.f90 @@ -0,0 +1,1199 @@ +!#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 new file mode 100644 index 00000000000..3ff6db46949 --- /dev/null +++ b/test/ncar_kernels/CAM5_wetdepa/src/wetdepa_driver.F90 @@ -0,0 +1,262 @@ + ! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/HOMME_div_sphere/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..c71e5934dab --- /dev/null +++ b/test/ncar_kernels/HOMME_div_sphere/inc/t1.mk @@ -0,0 +1,61 @@ +# +# Copyright (c) 2016-2019, NVIDIA CORPORATION. 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. +# + +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/HOMME_div_sphere/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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/lit/t1.sh b/test/ncar_kernels/HOMME_div_sphere/lit/t1.sh new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/HOMME_div_sphere/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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_div_sphere/makefile b/test/ncar_kernels/HOMME_div_sphere/makefile new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/HOMME_div_sphere/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..635474e7b3c --- /dev/null +++ b/test/ncar_kernels/HOMME_div_sphere/src/kernel_divergence_sphere.F90 @@ -0,0 +1,477 @@ + 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/HOMME_grad_sphere/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..a3f3ecbac1f --- /dev/null +++ b/test/ncar_kernels/HOMME_grad_sphere/inc/t1.mk @@ -0,0 +1,71 @@ +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/HOMME_grad_sphere/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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/lit/t1.sh b/test/ncar_kernels/HOMME_grad_sphere/lit/t1.sh new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/HOMME_grad_sphere/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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/makefile b/test/ncar_kernels/HOMME_grad_sphere/makefile new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/HOMME_grad_sphere/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..0aa9e624603 --- /dev/null +++ b/test/ncar_kernels/HOMME_grad_sphere/src/grad_sphere.edison.pbs @@ -0,0 +1,14 @@ +#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 new file mode 100644 index 00000000000..1777c3534c3 --- /dev/null +++ b/test/ncar_kernels/HOMME_grad_sphere/src/kernel_gradient_sphere.F90 @@ -0,0 +1,356 @@ + 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/HOMME_limiter_optim_iter_full/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..85e10410f92 Binary files /dev/null and b/test/ncar_kernels/HOMME_limiter_optim_iter_full/data/limiter_optim_iter_full.1.0 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 new file mode 100644 index 00000000000..1e8b429a3b8 Binary files /dev/null and b/test/ncar_kernels/HOMME_limiter_optim_iter_full/data/limiter_optim_iter_full.10.0 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 new file mode 100644 index 00000000000..5f8a8658989 Binary files /dev/null and b/test/ncar_kernels/HOMME_limiter_optim_iter_full/data/limiter_optim_iter_full.20.0 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 new file mode 100644 index 00000000000..87d444d5864 --- /dev/null +++ b/test/ncar_kernels/HOMME_limiter_optim_iter_full/inc/t1.mk @@ -0,0 +1,70 @@ +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/HOMME_limiter_optim_iter_full/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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/lit/t1.sh b/test/ncar_kernels/HOMME_limiter_optim_iter_full/lit/t1.sh new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/HOMME_limiter_optim_iter_full/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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/makefile b/test/ncar_kernels/HOMME_limiter_optim_iter_full/makefile new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/HOMME_limiter_optim_iter_full/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..1400c3637bf --- /dev/null +++ b/test/ncar_kernels/HOMME_limiter_optim_iter_full/readme.txt @@ -0,0 +1,20 @@ +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 new file mode 100644 index 00000000000..497f70cd2a4 --- /dev/null +++ b/test/ncar_kernels/HOMME_limiter_optim_iter_full/src/dimensions_mod.F90 @@ -0,0 +1,48 @@ + +! 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 new file mode 100644 index 00000000000..a32304cff1a --- /dev/null +++ b/test/ncar_kernels/HOMME_limiter_optim_iter_full/src/kernel_driver.f90 @@ -0,0 +1,74 @@ + +! 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 new file mode 100644 index 00000000000..722035c4f5a --- /dev/null +++ b/test/ncar_kernels/HOMME_limiter_optim_iter_full/src/kinds.F90 @@ -0,0 +1,22 @@ + +! 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 new file mode 100644 index 00000000000..6b5f5236581 --- /dev/null +++ b/test/ncar_kernels/HOMME_limiter_optim_iter_full/src/prim_advection_mod.F90 @@ -0,0 +1,703 @@ + +! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_hydrostatic/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..5db394fa1f3 Binary files /dev/null and b/test/ncar_kernels/HOMME_preq_hydrostatic/data/preq_hydrostatic.1.0 differ diff --git a/test/ncar_kernels/HOMME_preq_hydrostatic/inc/t1.mk b/test/ncar_kernels/HOMME_preq_hydrostatic/inc/t1.mk new file mode 100644 index 00000000000..5fe66d33f82 --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_hydrostatic/inc/t1.mk @@ -0,0 +1,103 @@ +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_hydrostatic/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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/lit/t1.sh b/test/ncar_kernels/HOMME_preq_hydrostatic/lit/t1.sh new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_hydrostatic/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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_preq_hydrostatic/makefile b/test/ncar_kernels/HOMME_preq_hydrostatic/makefile new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_hydrostatic/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..9a201ae3e61 --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_hydrostatic/src/README @@ -0,0 +1,12 @@ +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 new file mode 100644 index 00000000000..f161d67d301 --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_hydrostatic/src/constituents.F90 @@ -0,0 +1,101 @@ + +! 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 new file mode 100644 index 00000000000..83934bd240c --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_hydrostatic/src/coordinate_systems_mod.F90 @@ -0,0 +1,294 @@ + +! 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 new file mode 100644 index 00000000000..4a9ec73ed14 --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_hydrostatic/src/dimensions_mod.F90 @@ -0,0 +1,54 @@ + +! 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 new file mode 100644 index 00000000000..da98978a8a9 --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_hydrostatic/src/edge_mod.F90 @@ -0,0 +1,919 @@ + +! 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 new file mode 100644 index 00000000000..9b3e197b7f1 --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_hydrostatic/src/element_mod.F90 @@ -0,0 +1,1290 @@ + +! 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 new file mode 100644 index 00000000000..5d352467857 --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_hydrostatic/src/gridgraph_mod.F90 @@ -0,0 +1,272 @@ + +! 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 new file mode 100644 index 00000000000..0212a471e17 --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_hydrostatic/src/kernel_driver.f90 @@ -0,0 +1,105 @@ + +! 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 new file mode 100644 index 00000000000..cfa8d114e07 --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_hydrostatic/src/kgen_utils.f90 @@ -0,0 +1,61 @@ +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 new file mode 100644 index 00000000000..72f600879b0 --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_hydrostatic/src/kinds.F90 @@ -0,0 +1,31 @@ + +! 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 new file mode 100644 index 00000000000..64942559f9e --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_hydrostatic/src/physconst.F90 @@ -0,0 +1,92 @@ + +! 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 new file mode 100644 index 00000000000..038558fa593 --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_hydrostatic/src/physical_constants.F90 @@ -0,0 +1,27 @@ + +! 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 new file mode 100644 index 00000000000..137b78cd4ce --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_hydrostatic/src/prim_advance_mod.F90 @@ -0,0 +1,220 @@ + +! 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 new file mode 100644 index 00000000000..01f4e8b8890 --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_hydrostatic/src/prim_si_mod.F90 @@ -0,0 +1,124 @@ + +! 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 new file mode 100644 index 00000000000..23f7803c1ec --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_hydrostatic/src/shr_const_mod.F90 @@ -0,0 +1,66 @@ + +! 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 new file mode 100644 index 00000000000..dd456df48ca --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_hydrostatic/src/shr_kind_mod.F90 @@ -0,0 +1,31 @@ + +! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_omega_ps/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..7d7d0f721dc Binary files /dev/null and b/test/ncar_kernels/HOMME_preq_omega_ps/data/preq_omega_ps.1.0 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 new file mode 100644 index 00000000000..8dbf5d9500e Binary files /dev/null and b/test/ncar_kernels/HOMME_preq_omega_ps/data/preq_omega_ps.10.0 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 new file mode 100644 index 00000000000..37a5b72c86a Binary files /dev/null and b/test/ncar_kernels/HOMME_preq_omega_ps/data/preq_omega_ps.20.0 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 new file mode 100644 index 00000000000..0a75920cf0e --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_omega_ps/inc/t1.mk @@ -0,0 +1,76 @@ +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_omega_ps/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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/lit/t1.sh b/test/ncar_kernels/HOMME_preq_omega_ps/lit/t1.sh new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_omega_ps/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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_preq_omega_ps/makefile b/test/ncar_kernels/HOMME_preq_omega_ps/makefile new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_omega_ps/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..6ac56cb46fa --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_omega_ps/readme.txt @@ -0,0 +1,20 @@ +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 new file mode 100644 index 00000000000..a0bd4e12a16 --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_omega_ps/src/dimensions_mod.F90 @@ -0,0 +1,51 @@ + +! 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 new file mode 100644 index 00000000000..0c002c5c378 --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_omega_ps/src/hybvcoord_mod.F90 @@ -0,0 +1,64 @@ + +! 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 new file mode 100644 index 00000000000..469410fe3f7 --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_omega_ps/src/kernel_driver.f90 @@ -0,0 +1,77 @@ + +! 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 new file mode 100644 index 00000000000..3a0649a997d --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_omega_ps/src/kinds.F90 @@ -0,0 +1,24 @@ + +! 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 new file mode 100644 index 00000000000..56de857c733 --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_omega_ps/src/prim_advance_mod.F90 @@ -0,0 +1,353 @@ + +! 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 new file mode 100644 index 00000000000..3d750c902da --- /dev/null +++ b/test/ncar_kernels/HOMME_preq_omega_ps/src/prim_si_mod.F90 @@ -0,0 +1,129 @@ + +! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/HOMME_remap_q_ppm/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..e752097d50a Binary files /dev/null and b/test/ncar_kernels/HOMME_remap_q_ppm/data/remap_q_ppm.1.0 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 new file mode 100644 index 00000000000..bcb80b4d073 Binary files /dev/null and b/test/ncar_kernels/HOMME_remap_q_ppm/data/remap_q_ppm.10.0 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 new file mode 100644 index 00000000000..fc6abb63e7d Binary files /dev/null and b/test/ncar_kernels/HOMME_remap_q_ppm/data/remap_q_ppm.20.0 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 new file mode 100644 index 00000000000..bb27f1403d5 --- /dev/null +++ b/test/ncar_kernels/HOMME_remap_q_ppm/inc/t1.mk @@ -0,0 +1,78 @@ +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/HOMME_remap_q_ppm/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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/lit/t1.sh b/test/ncar_kernels/HOMME_remap_q_ppm/lit/t1.sh new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/HOMME_remap_q_ppm/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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_remap_q_ppm/makefile b/test/ncar_kernels/HOMME_remap_q_ppm/makefile new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/HOMME_remap_q_ppm/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..901bfb554b4 --- /dev/null +++ b/test/ncar_kernels/HOMME_remap_q_ppm/readme.txt @@ -0,0 +1,20 @@ +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 new file mode 100644 index 00000000000..f3778f8d560 --- /dev/null +++ b/test/ncar_kernels/HOMME_remap_q_ppm/src/control_mod.F90 @@ -0,0 +1,126 @@ + +! 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 new file mode 100644 index 00000000000..ea03b99b873 --- /dev/null +++ b/test/ncar_kernels/HOMME_remap_q_ppm/src/dimensions_mod.F90 @@ -0,0 +1,47 @@ + +! 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 new file mode 100644 index 00000000000..6819d26d54b --- /dev/null +++ b/test/ncar_kernels/HOMME_remap_q_ppm/src/kernel_driver.f90 @@ -0,0 +1,133 @@ + +! 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 new file mode 100644 index 00000000000..eb7bf612816 --- /dev/null +++ b/test/ncar_kernels/HOMME_remap_q_ppm/src/kinds.F90 @@ -0,0 +1,22 @@ + +! 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 new file mode 100644 index 00000000000..769c3945f07 --- /dev/null +++ b/test/ncar_kernels/HOMME_remap_q_ppm/src/perf_mod.F90 @@ -0,0 +1,341 @@ + +! 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 new file mode 100644 index 00000000000..f865826e36f --- /dev/null +++ b/test/ncar_kernels/HOMME_remap_q_ppm/src/perf_utils.F90 @@ -0,0 +1,209 @@ + +! 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 new file mode 100644 index 00000000000..f936d433e6c --- /dev/null +++ b/test/ncar_kernels/HOMME_remap_q_ppm/src/prim_advection_mod.F90 @@ -0,0 +1,593 @@ + +! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..ac3ddbdb9c7 --- /dev/null +++ b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/README @@ -0,0 +1,12 @@ +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 new file mode 100644 index 00000000000..21205259841 Binary files /dev/null and b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/data/vlaplace_sphere_wk.1.0 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 new file mode 100644 index 00000000000..af9c197e107 --- /dev/null +++ b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/inc/t1.mk @@ -0,0 +1,111 @@ +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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/lit/t1.sh b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/lit/t1.sh new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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_vlaplace_sphere_wk/makefile b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/makefile new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..ef709a0101b --- /dev/null +++ b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/constituents.F90 @@ -0,0 +1,101 @@ + +! 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 new file mode 100644 index 00000000000..9dcf88dc2ff --- /dev/null +++ b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/control_mod.F90 @@ -0,0 +1,128 @@ + +! 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 new file mode 100644 index 00000000000..0a02dbd5040 --- /dev/null +++ b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/coordinate_systems_mod.F90 @@ -0,0 +1,294 @@ + +! 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 new file mode 100644 index 00000000000..1030f1084cd --- /dev/null +++ b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/derivative_mod.F90 @@ -0,0 +1,757 @@ + +! 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 new file mode 100644 index 00000000000..c4f730078e4 --- /dev/null +++ b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/dimensions_mod.F90 @@ -0,0 +1,56 @@ + +! 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 new file mode 100644 index 00000000000..650d3c23abe --- /dev/null +++ b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/edge_mod.F90 @@ -0,0 +1,919 @@ + +! 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 new file mode 100644 index 00000000000..113c562f8b9 --- /dev/null +++ b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/element_mod.F90 @@ -0,0 +1,1290 @@ + +! 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 new file mode 100644 index 00000000000..fa58f27a791 --- /dev/null +++ b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/gridgraph_mod.F90 @@ -0,0 +1,272 @@ + +! 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 new file mode 100644 index 00000000000..ace6711a15c --- /dev/null +++ b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/kernel_driver.f90 @@ -0,0 +1,152 @@ + +! 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 new file mode 100644 index 00000000000..cfa8d114e07 --- /dev/null +++ b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/kgen_utils.f90 @@ -0,0 +1,61 @@ +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 new file mode 100644 index 00000000000..c534803ce66 --- /dev/null +++ b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/kinds.F90 @@ -0,0 +1,31 @@ + +! 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 new file mode 100644 index 00000000000..c72a467b5fd --- /dev/null +++ b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/parallel_mod.F90 @@ -0,0 +1,180 @@ + +! 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 new file mode 100644 index 00000000000..d8c4734a390 --- /dev/null +++ b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/physconst.F90 @@ -0,0 +1,92 @@ + +! 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 new file mode 100644 index 00000000000..77b68ab7e23 --- /dev/null +++ b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/physical_constants.F90 @@ -0,0 +1,26 @@ + +! 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 new file mode 100644 index 00000000000..4126a9260e0 --- /dev/null +++ b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/shr_const_mod.F90 @@ -0,0 +1,66 @@ + +! 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 new file mode 100644 index 00000000000..0a4e7acfc7a --- /dev/null +++ b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/shr_kind_mod.F90 @@ -0,0 +1,31 @@ + +! 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 new file mode 100644 index 00000000000..b511d89fa9a --- /dev/null +++ b/test/ncar_kernels/HOMME_vlaplace_sphere_wk/src/viscosity_mod.F90 @@ -0,0 +1,233 @@ + +! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/PORT_binterp/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..2136099db35 Binary files /dev/null and b/test/ncar_kernels/PORT_binterp/data/binterp.1.0 differ diff --git a/test/ncar_kernels/PORT_binterp/data/binterp.1.1 b/test/ncar_kernels/PORT_binterp/data/binterp.1.1 new file mode 100644 index 00000000000..a2c28268a65 Binary files /dev/null and b/test/ncar_kernels/PORT_binterp/data/binterp.1.1 differ diff --git a/test/ncar_kernels/PORT_binterp/data/binterp.1.2 b/test/ncar_kernels/PORT_binterp/data/binterp.1.2 new file mode 100644 index 00000000000..f19e429fe04 Binary files /dev/null and b/test/ncar_kernels/PORT_binterp/data/binterp.1.2 differ diff --git a/test/ncar_kernels/PORT_binterp/inc/t1.mk b/test/ncar_kernels/PORT_binterp/inc/t1.mk new file mode 100644 index 00000000000..39eac389b8d --- /dev/null +++ b/test/ncar_kernels/PORT_binterp/inc/t1.mk @@ -0,0 +1,65 @@ +# +# Copyright (c) 2016-2019, NVIDIA CORPORATION. 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. +# + +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/PORT_binterp/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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 new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/PORT_binterp/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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 new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/PORT_binterp/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..28cd30a0e6b --- /dev/null +++ b/test/ncar_kernels/PORT_binterp/src/kernel_binterp.F90 @@ -0,0 +1,528 @@ + 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 new file mode 100644 index 00000000000..734fa5af1a4 --- /dev/null +++ b/test/ncar_kernels/PORT_binterp/src_orig/kernel_binterp.F90 @@ -0,0 +1,481 @@ + 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/PORT_cldprmc/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..3a12099f607 Binary files /dev/null and b/test/ncar_kernels/PORT_cldprmc/data/cldprmc.10.1 differ diff --git a/test/ncar_kernels/PORT_cldprmc/data/cldprmc.10.2 b/test/ncar_kernels/PORT_cldprmc/data/cldprmc.10.2 new file mode 100644 index 00000000000..680a163fe30 Binary files /dev/null and b/test/ncar_kernels/PORT_cldprmc/data/cldprmc.10.2 differ diff --git a/test/ncar_kernels/PORT_cldprmc/data/cldprmc.20.1 b/test/ncar_kernels/PORT_cldprmc/data/cldprmc.20.1 new file mode 100644 index 00000000000..8c745699863 Binary files /dev/null and b/test/ncar_kernels/PORT_cldprmc/data/cldprmc.20.1 differ diff --git a/test/ncar_kernels/PORT_cldprmc/data/cldprmc.20.2 b/test/ncar_kernels/PORT_cldprmc/data/cldprmc.20.2 new file mode 100644 index 00000000000..7efb085b142 Binary files /dev/null and b/test/ncar_kernels/PORT_cldprmc/data/cldprmc.20.2 differ diff --git a/test/ncar_kernels/PORT_cldprmc/inc/t1.mk b/test/ncar_kernels/PORT_cldprmc/inc/t1.mk new file mode 100644 index 00000000000..67ea680037f --- /dev/null +++ b/test/ncar_kernels/PORT_cldprmc/inc/t1.mk @@ -0,0 +1,62 @@ +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# + +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/PORT_cldprmc/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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 new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/PORT_cldprmc/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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 new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/PORT_cldprmc/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..22ce93c8c21 --- /dev/null +++ b/test/ncar_kernels/PORT_cldprmc/src/kernel_cldprmc.F90 @@ -0,0 +1,291 @@ + 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 new file mode 100644 index 00000000000..483338257cd --- /dev/null +++ b/test/ncar_kernels/PORT_cldprmc/src/kernel_cldprmc.F90_orig @@ -0,0 +1,283 @@ + 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/PORT_inatm/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..35fb13a7bb5 Binary files /dev/null and b/test/ncar_kernels/PORT_inatm/data/inatm.1.0 differ diff --git a/test/ncar_kernels/PORT_inatm/inc/t1.mk b/test/ncar_kernels/PORT_inatm/inc/t1.mk new file mode 100644 index 00000000000..87adfe4f28f --- /dev/null +++ b/test/ncar_kernels/PORT_inatm/inc/t1.mk @@ -0,0 +1,62 @@ +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# + +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/PORT_inatm/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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 new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/PORT_inatm/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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 new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/PORT_inatm/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..166f76c7951 --- /dev/null +++ b/test/ncar_kernels/PORT_inatm/src/kernel_inatm.F90 @@ -0,0 +1,960 @@ + 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 new file mode 100644 index 00000000000..b8133ace786 --- /dev/null +++ b/test/ncar_kernels/PORT_inatm/src/kernel_inatm.F90_orig @@ -0,0 +1,912 @@ + 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 new file mode 100644 index 00000000000..7536f2fe8e4 --- /dev/null +++ b/test/ncar_kernels/PORT_inatm/src/rrtmg_lw_rad.f90 @@ -0,0 +1,590 @@ + 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_cldprmc/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..71fb53cbd9e Binary files /dev/null and b/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.1.1 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 new file mode 100644 index 00000000000..a9c3d6a6fc6 Binary files /dev/null and b/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.1.4 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 new file mode 100644 index 00000000000..66033f8a755 Binary files /dev/null and b/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.1.8 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 new file mode 100644 index 00000000000..4d14bc35629 Binary files /dev/null and b/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.10.1 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 new file mode 100644 index 00000000000..69827747ae1 Binary files /dev/null and b/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.10.4 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 new file mode 100644 index 00000000000..3cee8622bcc Binary files /dev/null and b/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.10.8 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 new file mode 100644 index 00000000000..3960ab01dda Binary files /dev/null and b/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.5.1 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 new file mode 100644 index 00000000000..2adcad418ff Binary files /dev/null and b/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.5.4 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 new file mode 100644 index 00000000000..3e6977ed837 Binary files /dev/null and b/test/ncar_kernels/PORT_lw_cldprmc/data/cldprmc.5.8 differ diff --git a/test/ncar_kernels/PORT_lw_cldprmc/inc/t1.mk b/test/ncar_kernels/PORT_lw_cldprmc/inc/t1.mk new file mode 100644 index 00000000000..460c85aa59a --- /dev/null +++ b/test/ncar_kernels/PORT_lw_cldprmc/inc/t1.mk @@ -0,0 +1,87 @@ +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# + +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_cldprmc/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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 new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_cldprmc/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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 new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_cldprmc/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..4f5f2f96b95 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_cldprmc/src/kernel_driver.f90 @@ -0,0 +1,85 @@ + +! 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 new file mode 100644 index 00000000000..cfa8d114e07 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_cldprmc/src/kgen_utils.f90 @@ -0,0 +1,61 @@ +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 new file mode 100644 index 00000000000..11ccbf65fed --- /dev/null +++ b/test/ncar_kernels/PORT_lw_cldprmc/src/parrrtm.f90 @@ -0,0 +1,75 @@ + +! 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 new file mode 100644 index 00000000000..1d668e13d04 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_cldprmc/src/rrlw_cld.f90 @@ -0,0 +1,52 @@ + +! 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 new file mode 100644 index 00000000000..93b46bafb47 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_cldprmc/src/rrlw_vsn.f90 @@ -0,0 +1,63 @@ + +! 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 new file mode 100644 index 00000000000..99fdff57b88 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_cldprmc/src/rrlw_wvn.f90 @@ -0,0 +1,67 @@ + +! 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 new file mode 100644 index 00000000000..3451ec536d2 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_cldprmc/src/rrtmg_lw_cldprmc.f90 @@ -0,0 +1,245 @@ + +! 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 new file mode 100644 index 00000000000..90b36b6b2e1 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_cldprmc/src/rrtmg_lw_rad.f90 @@ -0,0 +1,551 @@ + +! 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 new file mode 100644 index 00000000000..c725fa8aef4 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_cldprmc/src/shr_kind_mod.f90 @@ -0,0 +1,26 @@ + +! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_inatm/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..4d266217554 Binary files /dev/null and b/test/ncar_kernels/PORT_lw_inatm/data/inatm.1.1 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 new file mode 100644 index 00000000000..93102f2bb3c Binary files /dev/null and b/test/ncar_kernels/PORT_lw_inatm/data/inatm.1.4 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 new file mode 100644 index 00000000000..bbe26b684f3 Binary files /dev/null and b/test/ncar_kernels/PORT_lw_inatm/data/inatm.1.8 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 new file mode 100644 index 00000000000..73664596d9e Binary files /dev/null and b/test/ncar_kernels/PORT_lw_inatm/data/inatm.10.1 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 new file mode 100644 index 00000000000..cd274e51c43 Binary files /dev/null and b/test/ncar_kernels/PORT_lw_inatm/data/inatm.10.4 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 new file mode 100644 index 00000000000..2c18a3751f9 Binary files /dev/null and b/test/ncar_kernels/PORT_lw_inatm/data/inatm.10.8 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 new file mode 100644 index 00000000000..b469141461d Binary files /dev/null and b/test/ncar_kernels/PORT_lw_inatm/data/inatm.5.1 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 new file mode 100644 index 00000000000..01f6b01727e Binary files /dev/null and b/test/ncar_kernels/PORT_lw_inatm/data/inatm.5.4 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 new file mode 100644 index 00000000000..469c8a221ef Binary files /dev/null and b/test/ncar_kernels/PORT_lw_inatm/data/inatm.5.8 differ diff --git a/test/ncar_kernels/PORT_lw_inatm/inc/t1.mk b/test/ncar_kernels/PORT_lw_inatm/inc/t1.mk new file mode 100644 index 00000000000..52f59933d01 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_inatm/inc/t1.mk @@ -0,0 +1,79 @@ +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# + +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_inatm/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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 new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_inatm/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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 new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_inatm/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..3f40d7175c1 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_inatm/src/kernel_driver.f90 @@ -0,0 +1,208 @@ + +! 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 new file mode 100644 index 00000000000..cfa8d114e07 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_inatm/src/kgen_utils.f90 @@ -0,0 +1,61 @@ +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 new file mode 100644 index 00000000000..eebd63bf8e4 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_inatm/src/parrrtm.f90 @@ -0,0 +1,80 @@ + +! 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 new file mode 100644 index 00000000000..ec7b08ec998 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_inatm/src/rrlw_con.f90 @@ -0,0 +1,51 @@ + +! 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 new file mode 100644 index 00000000000..e273f0427b0 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_inatm/src/rrlw_wvn.f90 @@ -0,0 +1,67 @@ + +! 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 new file mode 100644 index 00000000000..5a82becb5bd --- /dev/null +++ b/test/ncar_kernels/PORT_lw_inatm/src/rrtmg_lw_rad.f90 @@ -0,0 +1,1057 @@ + +! 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 new file mode 100644 index 00000000000..f8f8ddacee4 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_inatm/src/shr_kind_mod.f90 @@ -0,0 +1,26 @@ + +! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..fef797ac5ac Binary files /dev/null and b/test/ncar_kernels/PORT_lw_rad/data/rrtmg_lw.10 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 new file mode 100644 index 00000000000..83ef5b54f33 Binary files /dev/null and b/test/ncar_kernels/PORT_lw_rad/data/rrtmg_lw.15 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 new file mode 100644 index 00000000000..ac845e3c527 Binary files /dev/null and b/test/ncar_kernels/PORT_lw_rad/data/rrtmg_lw.5 differ diff --git a/test/ncar_kernels/PORT_lw_rad/inc/t1.mk b/test/ncar_kernels/PORT_lw_rad/inc/t1.mk new file mode 100644 index 00000000000..12da77ef757 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/inc/t1.mk @@ -0,0 +1,168 @@ +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# + +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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 new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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 new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..d567869a911 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/kernel_driver.f90 @@ -0,0 +1,124 @@ + +! 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 new file mode 100644 index 00000000000..cfa8d114e07 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/kgen_utils.f90 @@ -0,0 +1,61 @@ +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 new file mode 100644 index 00000000000..7015f4c795d --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/parrrtm.f90 @@ -0,0 +1,111 @@ + +! 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 new file mode 100644 index 00000000000..3c40de3f6af --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/ppgrid.F90 @@ -0,0 +1,42 @@ + +! 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 new file mode 100644 index 00000000000..3f849be60c7 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/radlw.F90 @@ -0,0 +1,463 @@ + +! 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 new file mode 100644 index 00000000000..cb7d927d63f --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrlw_cld.f90 @@ -0,0 +1,52 @@ + +! 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 new file mode 100644 index 00000000000..f45b43842db --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrlw_con.f90 @@ -0,0 +1,59 @@ + +! 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 new file mode 100644 index 00000000000..71ca1039e32 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg01.f90 @@ -0,0 +1,83 @@ + +! 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 new file mode 100644 index 00000000000..256ef9f4b31 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg02.f90 @@ -0,0 +1,77 @@ + +! 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 new file mode 100644 index 00000000000..bfbf22f98d6 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg03.f90 @@ -0,0 +1,84 @@ + +! 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 new file mode 100644 index 00000000000..c5faed3083c --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg04.f90 @@ -0,0 +1,75 @@ + +! 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 new file mode 100644 index 00000000000..21e8345aa21 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg05.f90 @@ -0,0 +1,84 @@ + +! 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 new file mode 100644 index 00000000000..3c82a876c73 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg06.f90 @@ -0,0 +1,79 @@ + +! 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 new file mode 100644 index 00000000000..408391cad05 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg07.f90 @@ -0,0 +1,83 @@ + +! 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 new file mode 100644 index 00000000000..b4d892ec441 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg08.f90 @@ -0,0 +1,104 @@ + +! 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 new file mode 100644 index 00000000000..743255e589a --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg09.f90 @@ -0,0 +1,84 @@ + +! 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 new file mode 100644 index 00000000000..40d6517b92a --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg10.f90 @@ -0,0 +1,76 @@ + +! 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 new file mode 100644 index 00000000000..aa300f60a30 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg11.f90 @@ -0,0 +1,84 @@ + +! 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 new file mode 100644 index 00000000000..0c4cab0dde6 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg12.f90 @@ -0,0 +1,67 @@ + +! 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 new file mode 100644 index 00000000000..fa7f3443594 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg13.f90 @@ -0,0 +1,81 @@ + +! 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 new file mode 100644 index 00000000000..b982f00e853 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg14.f90 @@ -0,0 +1,76 @@ + +! 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 new file mode 100644 index 00000000000..508f5e1b8ad --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg15.f90 @@ -0,0 +1,71 @@ + +! 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 new file mode 100644 index 00000000000..6eb6cab0c2a --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrlw_kg16.f90 @@ -0,0 +1,74 @@ + +! 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 new file mode 100644 index 00000000000..8c089252331 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrlw_ref.f90 @@ -0,0 +1,46 @@ + +! 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 new file mode 100644 index 00000000000..281afdbc8cd --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrlw_tbl.f90 @@ -0,0 +1,58 @@ + +! 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 new file mode 100644 index 00000000000..8a83d6ff64f --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrlw_vsn.f90 @@ -0,0 +1,69 @@ + +! 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 new file mode 100644 index 00000000000..d502f755ec8 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrlw_wvn.f90 @@ -0,0 +1,84 @@ + +! 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 new file mode 100644 index 00000000000..0cbbb64918d --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrtmg_lw_cldprmc.F90 @@ -0,0 +1,443 @@ + +! 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 new file mode 100644 index 00000000000..2649ae3b0e9 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrtmg_lw_rad.F90 @@ -0,0 +1,843 @@ + +! 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 new file mode 100644 index 00000000000..10280b84629 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrtmg_lw_rtrnmc.F90 @@ -0,0 +1,961 @@ + +! 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 new file mode 100644 index 00000000000..75157592da9 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrtmg_lw_setcoef.F90 @@ -0,0 +1,864 @@ + +! 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 new file mode 100644 index 00000000000..883147d62b4 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrtmg_lw_taumol.f90 @@ -0,0 +1,3341 @@ + +! 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 new file mode 100644 index 00000000000..269155b43af --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/rrtmg_state.F90 @@ -0,0 +1,262 @@ + +! 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 new file mode 100644 index 00000000000..578541fad33 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rad/src/shr_kind_mod.f90 @@ -0,0 +1,26 @@ + +! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rtrnmc/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..ff3ed15e800 Binary files /dev/null and b/test/ncar_kernels/PORT_lw_rtrnmc/data/rtrnmc.1.1 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 new file mode 100644 index 00000000000..86e744db7be Binary files /dev/null and b/test/ncar_kernels/PORT_lw_rtrnmc/data/rtrnmc.1.4 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 new file mode 100644 index 00000000000..84350a70b20 Binary files /dev/null and b/test/ncar_kernels/PORT_lw_rtrnmc/data/rtrnmc.1.8 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 new file mode 100644 index 00000000000..ca7ffebcbfb Binary files /dev/null and b/test/ncar_kernels/PORT_lw_rtrnmc/data/rtrnmc.5.1 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 new file mode 100644 index 00000000000..bb6601fd63b Binary files /dev/null and b/test/ncar_kernels/PORT_lw_rtrnmc/data/rtrnmc.5.4 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 new file mode 100644 index 00000000000..5cf222c7128 Binary files /dev/null and b/test/ncar_kernels/PORT_lw_rtrnmc/data/rtrnmc.5.8 differ diff --git a/test/ncar_kernels/PORT_lw_rtrnmc/inc/t1.mk b/test/ncar_kernels/PORT_lw_rtrnmc/inc/t1.mk new file mode 100644 index 00000000000..4ec6eeb19a9 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rtrnmc/inc/t1.mk @@ -0,0 +1,89 @@ +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rtrnmc/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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 new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rtrnmc/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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 new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rtrnmc/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..9eb38620901 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rtrnmc/src/kernel_driver.f90 @@ -0,0 +1,87 @@ + +! 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 new file mode 100644 index 00000000000..cfa8d114e07 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rtrnmc/src/kgen_utils.f90 @@ -0,0 +1,61 @@ +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 new file mode 100644 index 00000000000..0d8241572e4 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rtrnmc/src/parrrtm.f90 @@ -0,0 +1,76 @@ + +! 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 new file mode 100644 index 00000000000..5f5da6bb4d8 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rtrnmc/src/rrlw_con.f90 @@ -0,0 +1,51 @@ + +! 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 new file mode 100644 index 00000000000..348541828d4 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rtrnmc/src/rrlw_tbl.f90 @@ -0,0 +1,58 @@ + +! 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 new file mode 100644 index 00000000000..9793b35cabd --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rtrnmc/src/rrlw_vsn.f90 @@ -0,0 +1,63 @@ + +! 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 new file mode 100644 index 00000000000..68ec46ed92a --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rtrnmc/src/rrlw_wvn.f90 @@ -0,0 +1,73 @@ + +! 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 new file mode 100644 index 00000000000..f7dc6073dc5 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rtrnmc/src/rrtmg_lw_rad.f90 @@ -0,0 +1,625 @@ + +! 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 new file mode 100644 index 00000000000..0925abc62e7 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rtrnmc/src/rrtmg_lw_rtrnmc.f90 @@ -0,0 +1,506 @@ + +! 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 new file mode 100644 index 00000000000..3907b1b1f0c --- /dev/null +++ b/test/ncar_kernels/PORT_lw_rtrnmc/src/shr_kind_mod.f90 @@ -0,0 +1,26 @@ + +! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_setcoef/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..c8076d90efe Binary files /dev/null and b/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.1.1 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 new file mode 100644 index 00000000000..e802dc91d62 Binary files /dev/null and b/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.1.4 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 new file mode 100644 index 00000000000..06c96e38aa4 Binary files /dev/null and b/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.1.8 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 new file mode 100644 index 00000000000..727afb40d8a Binary files /dev/null and b/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.10.1 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 new file mode 100644 index 00000000000..4f2adf175cd Binary files /dev/null and b/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.10.4 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 new file mode 100644 index 00000000000..6f643fa2c18 Binary files /dev/null and b/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.10.8 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 new file mode 100644 index 00000000000..1417e450b97 Binary files /dev/null and b/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.5.1 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 new file mode 100644 index 00000000000..12fb2cb0c47 Binary files /dev/null and b/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.5.4 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 new file mode 100644 index 00000000000..7a7d124452d Binary files /dev/null and b/test/ncar_kernels/PORT_lw_setcoef/data/setcoef.5.8 differ diff --git a/test/ncar_kernels/PORT_lw_setcoef/inc/t1.mk b/test/ncar_kernels/PORT_lw_setcoef/inc/t1.mk new file mode 100644 index 00000000000..0740aeb7990 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_setcoef/inc/t1.mk @@ -0,0 +1,86 @@ +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_setcoef/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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 new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_setcoef/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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 new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_setcoef/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..546a51095d2 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_setcoef/src/kernel_driver.f90 @@ -0,0 +1,85 @@ + +! 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 new file mode 100644 index 00000000000..cfa8d114e07 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_setcoef/src/kgen_utils.f90 @@ -0,0 +1,61 @@ +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 new file mode 100644 index 00000000000..0b8ed93a024 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_setcoef/src/parrrtm.f90 @@ -0,0 +1,76 @@ + +! 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 new file mode 100644 index 00000000000..1f1024ec5a8 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_setcoef/src/rrlw_ref.f90 @@ -0,0 +1,46 @@ + +! 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 new file mode 100644 index 00000000000..08cbde6d859 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_setcoef/src/rrlw_vsn.f90 @@ -0,0 +1,63 @@ + +! 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 new file mode 100644 index 00000000000..01f2c0b246f --- /dev/null +++ b/test/ncar_kernels/PORT_lw_setcoef/src/rrlw_wvn.f90 @@ -0,0 +1,70 @@ + +! 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 new file mode 100644 index 00000000000..c4d7e4231f0 --- /dev/null +++ b/test/ncar_kernels/PORT_lw_setcoef/src/rrtmg_lw_rad.f90 @@ -0,0 +1,879 @@ + +! 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 new file mode 100644 index 00000000000..bbb065b8cea --- /dev/null +++ b/test/ncar_kernels/PORT_lw_setcoef/src/rrtmg_lw_setcoef.f90 @@ -0,0 +1,454 @@ + +! 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 new file mode 100644 index 00000000000..bca182767ec --- /dev/null +++ b/test/ncar_kernels/PORT_lw_setcoef/src/shr_kind_mod.f90 @@ -0,0 +1,26 @@ + +! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/PORT_reftra_sw/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..d63a7e6b617 Binary files /dev/null and b/test/ncar_kernels/PORT_reftra_sw/data/reftra_sw.1.0 differ diff --git a/test/ncar_kernels/PORT_reftra_sw/inc/t1.mk b/test/ncar_kernels/PORT_reftra_sw/inc/t1.mk new file mode 100644 index 00000000000..48c341dc0bb --- /dev/null +++ b/test/ncar_kernels/PORT_reftra_sw/inc/t1.mk @@ -0,0 +1,61 @@ +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/PORT_reftra_sw/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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 new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/PORT_reftra_sw/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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 new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/PORT_reftra_sw/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..a56477b6743 --- /dev/null +++ b/test/ncar_kernels/PORT_reftra_sw/src/kernel_reftra_sw.F90 @@ -0,0 +1,526 @@ + 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/PORT_rtrnmc/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..062e2774156 Binary files /dev/null and b/test/ncar_kernels/PORT_rtrnmc/data/rtrnmc.1.0 differ diff --git a/test/ncar_kernels/PORT_rtrnmc/data/rtrnmc.10.0 b/test/ncar_kernels/PORT_rtrnmc/data/rtrnmc.10.0 new file mode 100644 index 00000000000..f1ea94649fe Binary files /dev/null and b/test/ncar_kernels/PORT_rtrnmc/data/rtrnmc.10.0 differ diff --git a/test/ncar_kernels/PORT_rtrnmc/data/rtrnmc.10.1 b/test/ncar_kernels/PORT_rtrnmc/data/rtrnmc.10.1 new file mode 100644 index 00000000000..c3d6aede177 Binary files /dev/null and b/test/ncar_kernels/PORT_rtrnmc/data/rtrnmc.10.1 differ diff --git a/test/ncar_kernels/PORT_rtrnmc/inc/t1.mk b/test/ncar_kernels/PORT_rtrnmc/inc/t1.mk new file mode 100644 index 00000000000..41df5d5b160 --- /dev/null +++ b/test/ncar_kernels/PORT_rtrnmc/inc/t1.mk @@ -0,0 +1,62 @@ +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/PORT_rtrnmc/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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 new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/PORT_rtrnmc/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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 new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/PORT_rtrnmc/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..dfc046991f7 --- /dev/null +++ b/test/ncar_kernels/PORT_rtrnmc/src/kernel_rtrnmc.F90 @@ -0,0 +1,664 @@ + 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_cldprmc/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..afb2dad6ab2 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.1.1 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 new file mode 100644 index 00000000000..0887be46174 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.1.4 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 new file mode 100644 index 00000000000..98941121e71 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.1.8 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 new file mode 100644 index 00000000000..5666c074370 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.10.1 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 new file mode 100644 index 00000000000..4b4db2a6121 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.10.4 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 new file mode 100644 index 00000000000..90e2c525fd9 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.10.8 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 new file mode 100644 index 00000000000..6060e8add64 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.5.1 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 new file mode 100644 index 00000000000..ada9221d869 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.5.4 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 new file mode 100644 index 00000000000..56dc6d81aeb Binary files /dev/null and b/test/ncar_kernels/PORT_sw_cldprmc/data/cldprmc_sw.5.8 differ diff --git a/test/ncar_kernels/PORT_sw_cldprmc/inc/t1.mk b/test/ncar_kernels/PORT_sw_cldprmc/inc/t1.mk new file mode 100644 index 00000000000..2edec570f08 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_cldprmc/inc/t1.mk @@ -0,0 +1,86 @@ +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_cldprmc/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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 new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_cldprmc/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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 new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_cldprmc/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..121a94ff4ee --- /dev/null +++ b/test/ncar_kernels/PORT_sw_cldprmc/src/kernel_driver.f90 @@ -0,0 +1,85 @@ + +! 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 new file mode 100644 index 00000000000..cfa8d114e07 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_cldprmc/src/kgen_utils.f90 @@ -0,0 +1,61 @@ +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 new file mode 100644 index 00000000000..d5692fcd8bd --- /dev/null +++ b/test/ncar_kernels/PORT_sw_cldprmc/src/parrrsw.f90 @@ -0,0 +1,81 @@ + +! 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 new file mode 100644 index 00000000000..c221624687b --- /dev/null +++ b/test/ncar_kernels/PORT_sw_cldprmc/src/rrsw_cld.f90 @@ -0,0 +1,84 @@ + +! 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 new file mode 100644 index 00000000000..5a2185fc62e --- /dev/null +++ b/test/ncar_kernels/PORT_sw_cldprmc/src/rrsw_vsn.f90 @@ -0,0 +1,65 @@ + +! 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 new file mode 100644 index 00000000000..bbe6607d252 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_cldprmc/src/rrsw_wvn.f90 @@ -0,0 +1,59 @@ + +! 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 new file mode 100644 index 00000000000..0bdebcbb22b --- /dev/null +++ b/test/ncar_kernels/PORT_sw_cldprmc/src/rrtmg_sw_cldprmc.f90 @@ -0,0 +1,386 @@ + +! 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 new file mode 100644 index 00000000000..59152b02017 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_cldprmc/src/rrtmg_sw_rad.f90 @@ -0,0 +1,690 @@ + +! 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 new file mode 100644 index 00000000000..938d8aeec91 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_cldprmc/src/shr_kind_mod.f90 @@ -0,0 +1,26 @@ + +! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_inatm/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..0d34ff30dc1 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.1.1 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 new file mode 100644 index 00000000000..0817ea3c24d Binary files /dev/null and b/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.1.4 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 new file mode 100644 index 00000000000..1b1eff5be40 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.1.8 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 new file mode 100644 index 00000000000..5b61513ab8d Binary files /dev/null and b/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.10.1 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 new file mode 100644 index 00000000000..69c0f14e409 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.10.4 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 new file mode 100644 index 00000000000..9d48d5bc816 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.10.8 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 new file mode 100644 index 00000000000..4e8e8f56abb Binary files /dev/null and b/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.5.1 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 new file mode 100644 index 00000000000..f28fcfa5d30 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.5.4 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 new file mode 100644 index 00000000000..55434d77d1f Binary files /dev/null and b/test/ncar_kernels/PORT_sw_inatm/data/inatm_sw.5.8 differ diff --git a/test/ncar_kernels/PORT_sw_inatm/inc/t1.mk b/test/ncar_kernels/PORT_sw_inatm/inc/t1.mk new file mode 100644 index 00000000000..91f72b8aacf --- /dev/null +++ b/test/ncar_kernels/PORT_sw_inatm/inc/t1.mk @@ -0,0 +1,76 @@ +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_inatm/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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 new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_inatm/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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 new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_inatm/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..a7e6564e3b3 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_inatm/src/kernel_driver.f90 @@ -0,0 +1,213 @@ + +! 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 new file mode 100644 index 00000000000..cfa8d114e07 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_inatm/src/kgen_utils.f90 @@ -0,0 +1,61 @@ +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 new file mode 100644 index 00000000000..538469b14ff --- /dev/null +++ b/test/ncar_kernels/PORT_sw_inatm/src/parrrsw.f90 @@ -0,0 +1,84 @@ + +! 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 new file mode 100644 index 00000000000..5b063103c5d --- /dev/null +++ b/test/ncar_kernels/PORT_sw_inatm/src/rrsw_con.f90 @@ -0,0 +1,53 @@ + +! 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 new file mode 100644 index 00000000000..e30cc04fb5c --- /dev/null +++ b/test/ncar_kernels/PORT_sw_inatm/src/rrtmg_sw_rad.f90 @@ -0,0 +1,1211 @@ + +! 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 new file mode 100644 index 00000000000..868a2c0e7c1 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_inatm/src/shr_kind_mod.f90 @@ -0,0 +1,26 @@ + +! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..af3a3fb65eb Binary files /dev/null and b/test/ncar_kernels/PORT_sw_rad/data/rad_rrtmg_sw.1 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 new file mode 100644 index 00000000000..e6500f8e9bb Binary files /dev/null and b/test/ncar_kernels/PORT_sw_rad/data/rad_rrtmg_sw.2 differ diff --git a/test/ncar_kernels/PORT_sw_rad/inc/t1.mk b/test/ncar_kernels/PORT_sw_rad/inc/t1.mk new file mode 100644 index 00000000000..3280913bf7b --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/inc/t1.mk @@ -0,0 +1,193 @@ +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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 new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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 new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..10936ebe116 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/camsrfexch.F90 @@ -0,0 +1,899 @@ + +! 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 new file mode 100644 index 00000000000..5a251b9d5da --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/cmparray_mod.F90 @@ -0,0 +1,321 @@ + +! 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 new file mode 100644 index 00000000000..8314852498e --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/constituents.F90 @@ -0,0 +1,101 @@ + +! 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 new file mode 100644 index 00000000000..9aacbd2b91c --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/kernel_driver.f90 @@ -0,0 +1,156 @@ + +! 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 new file mode 100644 index 00000000000..cfa8d114e07 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/kgen_utils.f90 @@ -0,0 +1,61 @@ +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 new file mode 100644 index 00000000000..222c595c64f --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/mcica_random_numbers.f90 @@ -0,0 +1,371 @@ + +! 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 new file mode 100644 index 00000000000..add585c4af1 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/mcica_subcol_gen_sw.f90 @@ -0,0 +1,537 @@ + +! 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 new file mode 100644 index 00000000000..9b4dde5c7f2 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/parrrsw.f90 @@ -0,0 +1,111 @@ + +! 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 new file mode 100644 index 00000000000..41d640231af --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/physconst.F90 @@ -0,0 +1,84 @@ + +! 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 new file mode 100644 index 00000000000..3f3e4f5e17e --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/physics_types.F90 @@ -0,0 +1,844 @@ + +! 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 new file mode 100644 index 00000000000..d7df82a20f8 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/ppgrid.F90 @@ -0,0 +1,46 @@ + +! 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 new file mode 100644 index 00000000000..2dc207583e6 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/radconstants.F90 @@ -0,0 +1,97 @@ + +! 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 new file mode 100644 index 00000000000..858e61270d9 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/radiation.F90 @@ -0,0 +1,768 @@ + +! 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 new file mode 100644 index 00000000000..ccb00bedc1f --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/radsw.F90 @@ -0,0 +1,565 @@ + +! 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 new file mode 100644 index 00000000000..2f63888af3a --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrsw_cld.f90 @@ -0,0 +1,84 @@ + +! 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 new file mode 100644 index 00000000000..ad961fc8f18 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrsw_con.f90 @@ -0,0 +1,57 @@ + +! 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 new file mode 100644 index 00000000000..c5a7c9594c0 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg16.f90 @@ -0,0 +1,77 @@ + +! 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 new file mode 100644 index 00000000000..0ec3e552e88 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg17.f90 @@ -0,0 +1,77 @@ + +! 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 new file mode 100644 index 00000000000..f4ebd3b50d1 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg18.f90 @@ -0,0 +1,77 @@ + +! 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 new file mode 100644 index 00000000000..f6d092ba017 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg19.f90 @@ -0,0 +1,77 @@ + +! 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 new file mode 100644 index 00000000000..ecf6cc854f3 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg20.f90 @@ -0,0 +1,79 @@ + +! 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 new file mode 100644 index 00000000000..04660be3b4e --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg21.f90 @@ -0,0 +1,77 @@ + +! 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 new file mode 100644 index 00000000000..cca8d22987b --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg22.f90 @@ -0,0 +1,77 @@ + +! 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 new file mode 100644 index 00000000000..034aac6cd7c --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg23.f90 @@ -0,0 +1,75 @@ + +! 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 new file mode 100644 index 00000000000..d4685216053 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg24.f90 @@ -0,0 +1,91 @@ + +! 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 new file mode 100644 index 00000000000..8fae27dd3b6 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg25.f90 @@ -0,0 +1,72 @@ + +! 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 new file mode 100644 index 00000000000..8fe34ef9aa6 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg26.f90 @@ -0,0 +1,57 @@ + +! 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 new file mode 100644 index 00000000000..936b8edc550 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg27.f90 @@ -0,0 +1,71 @@ + +! 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 new file mode 100644 index 00000000000..abcda2afe6a --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg28.f90 @@ -0,0 +1,67 @@ + +! 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 new file mode 100644 index 00000000000..e9036e0f6d3 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrsw_kg29.f90 @@ -0,0 +1,81 @@ + +! 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 new file mode 100644 index 00000000000..701432af92a --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrsw_ref.f90 @@ -0,0 +1,43 @@ + +! 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 new file mode 100644 index 00000000000..adccbe80162 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrsw_tbl.f90 @@ -0,0 +1,49 @@ + +! 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 new file mode 100644 index 00000000000..2ff978f47b6 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrsw_vsn.f90 @@ -0,0 +1,69 @@ + +! 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 new file mode 100644 index 00000000000..a499da71182 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrsw_wvn.f90 @@ -0,0 +1,68 @@ + +! 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 new file mode 100644 index 00000000000..3cf7ae0229f --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrtmg_state.F90 @@ -0,0 +1,271 @@ + +! 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 new file mode 100644 index 00000000000..30ee0243cb0 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_cldprmc.F90 @@ -0,0 +1,717 @@ + +! 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 new file mode 100644 index 00000000000..a4d964d4ec7 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_rad.F90 @@ -0,0 +1,1287 @@ + +! 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 new file mode 100644 index 00000000000..3b9f39dd3eb --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_reftra.f90 @@ -0,0 +1,298 @@ + +! 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 new file mode 100644 index 00000000000..cc95436a471 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_setcoef.f90 @@ -0,0 +1,302 @@ +! 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 new file mode 100644 index 00000000000..a00aee15bf4 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_spcvmc.f90 @@ -0,0 +1,624 @@ + +! 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 new file mode 100644 index 00000000000..03f72fec884 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_taumol.f90 @@ -0,0 +1,1584 @@ + +! 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 new file mode 100644 index 00000000000..3786981c490 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/rrtmg_sw_vrtqdr.f90 @@ -0,0 +1,137 @@ + +! 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 new file mode 100644 index 00000000000..f89c4c8caec --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/scamMod.F90 @@ -0,0 +1,170 @@ + +! 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 new file mode 100644 index 00000000000..ea2349f2a20 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/shr_const_mod.F90 @@ -0,0 +1,60 @@ + +! 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 new file mode 100644 index 00000000000..9792d511d25 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_rad/src/shr_kind_mod.f90 @@ -0,0 +1,26 @@ + +! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_reftra/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..1c0988402bd Binary files /dev/null and b/test/ncar_kernels/PORT_sw_reftra/data/reftra_sw.1.1 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 new file mode 100644 index 00000000000..56190d64aa2 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_reftra/data/reftra_sw.1.4 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 new file mode 100644 index 00000000000..c31ab8a9da0 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_reftra/data/reftra_sw.1.8 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 new file mode 100644 index 00000000000..13c160415c2 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_reftra/data/reftra_sw.5.1 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 new file mode 100644 index 00000000000..12f83ca1cb4 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_reftra/data/reftra_sw.5.4 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 new file mode 100644 index 00000000000..0cf57fd1279 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_reftra/data/reftra_sw.5.8 differ diff --git a/test/ncar_kernels/PORT_sw_reftra/inc/t1.mk b/test/ncar_kernels/PORT_sw_reftra/inc/t1.mk new file mode 100644 index 00000000000..135c8004446 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_reftra/inc/t1.mk @@ -0,0 +1,86 @@ +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_reftra/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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 new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_reftra/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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 new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_reftra/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..8a7d74a68bd --- /dev/null +++ b/test/ncar_kernels/PORT_sw_reftra/src/kernel_driver.f90 @@ -0,0 +1,106 @@ + +! 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 new file mode 100644 index 00000000000..cfa8d114e07 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_reftra/src/kgen_utils.f90 @@ -0,0 +1,61 @@ +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 new file mode 100644 index 00000000000..366c0a12c79 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_reftra/src/rrsw_tbl.f90 @@ -0,0 +1,49 @@ + +! 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 new file mode 100644 index 00000000000..e0bbad739d1 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_reftra/src/rrsw_vsn.f90 @@ -0,0 +1,65 @@ + +! 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 new file mode 100644 index 00000000000..3342f558ce8 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_reftra/src/rrtmg_sw_reftra.f90 @@ -0,0 +1,313 @@ + +! 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 new file mode 100644 index 00000000000..7d0855113b0 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_reftra/src/rrtmg_sw_spcvmc.f90 @@ -0,0 +1,302 @@ + +! 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 new file mode 100644 index 00000000000..d3796d5ed77 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_reftra/src/shr_kind_mod.f90 @@ -0,0 +1,26 @@ + +! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_setcoef/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..7f18c7481e9 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.1.1 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 new file mode 100644 index 00000000000..b29e58048e8 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.1.4 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 new file mode 100644 index 00000000000..0e490a7494f Binary files /dev/null and b/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.1.8 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 new file mode 100644 index 00000000000..915940bcddc Binary files /dev/null and b/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.10.1 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 new file mode 100644 index 00000000000..01584c7b6cc Binary files /dev/null and b/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.10.4 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 new file mode 100644 index 00000000000..cc509d8239a Binary files /dev/null and b/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.10.8 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 new file mode 100644 index 00000000000..ef0cb55e653 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.5.1 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 new file mode 100644 index 00000000000..29df3107db5 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.5.4 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 new file mode 100644 index 00000000000..d6ad0759000 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_setcoef/data/setcoef_sw.5.8 differ diff --git a/test/ncar_kernels/PORT_sw_setcoef/inc/t1.mk b/test/ncar_kernels/PORT_sw_setcoef/inc/t1.mk new file mode 100644 index 00000000000..f716cb23734 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_setcoef/inc/t1.mk @@ -0,0 +1,81 @@ +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_setcoef/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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 new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_setcoef/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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 new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_setcoef/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..00aa16cd31e --- /dev/null +++ b/test/ncar_kernels/PORT_sw_setcoef/src/kernel_driver.f90 @@ -0,0 +1,81 @@ + +! 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 new file mode 100644 index 00000000000..cfa8d114e07 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_setcoef/src/kgen_utils.f90 @@ -0,0 +1,61 @@ +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 new file mode 100644 index 00000000000..318e201346b --- /dev/null +++ b/test/ncar_kernels/PORT_sw_setcoef/src/parrrsw.f90 @@ -0,0 +1,82 @@ + +! 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 new file mode 100644 index 00000000000..901cae47980 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_setcoef/src/rrsw_ref.f90 @@ -0,0 +1,43 @@ + +! 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 new file mode 100644 index 00000000000..ea2a9fbe4c5 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_setcoef/src/rrtmg_sw_rad.f90 @@ -0,0 +1,800 @@ + +! 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 new file mode 100644 index 00000000000..6b4d3e5cc27 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_setcoef/src/rrtmg_sw_setcoef.f90 @@ -0,0 +1,260 @@ + +! 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 new file mode 100644 index 00000000000..88858357d03 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_setcoef/src/shr_kind_mod.f90 @@ -0,0 +1,26 @@ + +! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..a434555ef50 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.1.1 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 new file mode 100644 index 00000000000..89ea2684ef5 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.1.4 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 new file mode 100644 index 00000000000..e0c2b57c704 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.1.8 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 new file mode 100644 index 00000000000..85a31405015 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.10.1 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 new file mode 100644 index 00000000000..1498e9ec7ab Binary files /dev/null and b/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.10.4 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 new file mode 100644 index 00000000000..7e1b3811094 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.10.8 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 new file mode 100644 index 00000000000..c03404157a4 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.5.1 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 new file mode 100644 index 00000000000..8331db256d9 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.5.4 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 new file mode 100644 index 00000000000..91c1c7e21ab Binary files /dev/null and b/test/ncar_kernels/PORT_sw_spcvmc/data/spcvmc_sw.5.8 differ diff --git a/test/ncar_kernels/PORT_sw_spcvmc/inc/t1.mk b/test/ncar_kernels/PORT_sw_spcvmc/inc/t1.mk new file mode 100644 index 00000000000..f51bd937dc1 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/inc/t1.mk @@ -0,0 +1,143 @@ +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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 new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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 new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..88c3b756cb5 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/kernel_driver.f90 @@ -0,0 +1,117 @@ + +! 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 new file mode 100644 index 00000000000..cfa8d114e07 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/kgen_utils.f90 @@ -0,0 +1,61 @@ +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 new file mode 100644 index 00000000000..54febe28686 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/parrrsw.f90 @@ -0,0 +1,110 @@ + +! 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 new file mode 100644 index 00000000000..446b85c7698 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_con.f90 @@ -0,0 +1,49 @@ + +! 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 new file mode 100644 index 00000000000..9f04bc2fa26 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg16.f90 @@ -0,0 +1,77 @@ + +! 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 new file mode 100644 index 00000000000..02430604ad8 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg17.f90 @@ -0,0 +1,77 @@ + +! 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 new file mode 100644 index 00000000000..1fd8773e243 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg18.f90 @@ -0,0 +1,77 @@ + +! 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 new file mode 100644 index 00000000000..0e8da035eed --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg19.f90 @@ -0,0 +1,77 @@ + +! 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 new file mode 100644 index 00000000000..2df520e2d9e --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg20.f90 @@ -0,0 +1,79 @@ + +! 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 new file mode 100644 index 00000000000..333d425b77d --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg21.f90 @@ -0,0 +1,77 @@ + +! 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 new file mode 100644 index 00000000000..70e1847bd97 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg22.f90 @@ -0,0 +1,77 @@ + +! 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 new file mode 100644 index 00000000000..98188f4b558 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg23.f90 @@ -0,0 +1,75 @@ + +! 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 new file mode 100644 index 00000000000..b73ddd30559 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg24.f90 @@ -0,0 +1,91 @@ + +! 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 new file mode 100644 index 00000000000..f2a00cd87e2 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg25.f90 @@ -0,0 +1,72 @@ + +! 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 new file mode 100644 index 00000000000..d7898d65448 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg26.f90 @@ -0,0 +1,57 @@ + +! 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 new file mode 100644 index 00000000000..6a787e83204 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg27.f90 @@ -0,0 +1,71 @@ + +! 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 new file mode 100644 index 00000000000..46659ed9118 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg28.f90 @@ -0,0 +1,67 @@ + +! 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 new file mode 100644 index 00000000000..71a1496622e --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_kg29.f90 @@ -0,0 +1,81 @@ + +! 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 new file mode 100644 index 00000000000..262875124e8 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_tbl.f90 @@ -0,0 +1,49 @@ + +! 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 new file mode 100644 index 00000000000..4dc058bbc3a --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_vsn.f90 @@ -0,0 +1,67 @@ + +! 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 new file mode 100644 index 00000000000..b12f3002db5 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/rrsw_wvn.f90 @@ -0,0 +1,62 @@ + +! 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 new file mode 100644 index 00000000000..b59acae0fb9 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/rrtmg_sw_rad.f90 @@ -0,0 +1,819 @@ + +! 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 new file mode 100644 index 00000000000..faac537fbe6 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/rrtmg_sw_reftra.f90 @@ -0,0 +1,299 @@ + +! 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 new file mode 100644 index 00000000000..efca771aa87 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/rrtmg_sw_spcvmc.f90 @@ -0,0 +1,624 @@ + +! 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 new file mode 100644 index 00000000000..ea3cf37a94d --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/rrtmg_sw_taumol.f90 @@ -0,0 +1,1583 @@ + +! 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 new file mode 100644 index 00000000000..45aabcd3dd3 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/rrtmg_sw_vrtqdr.f90 @@ -0,0 +1,138 @@ + +! 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 new file mode 100644 index 00000000000..e4e5e74e6d3 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_spcvmc/src/shr_kind_mod.f90 @@ -0,0 +1,26 @@ + +! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..5be83bd98aa Binary files /dev/null and b/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.1.1 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 new file mode 100644 index 00000000000..785fd2eaa1f Binary files /dev/null and b/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.1.4 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 new file mode 100644 index 00000000000..4859694ff00 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.1.8 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 new file mode 100644 index 00000000000..5e4d4353549 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.10.1 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 new file mode 100644 index 00000000000..7b3bbe3348d Binary files /dev/null and b/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.10.4 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 new file mode 100644 index 00000000000..0d313ffffaf Binary files /dev/null and b/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.10.8 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 new file mode 100644 index 00000000000..a675f97d8e6 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.5.1 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 new file mode 100644 index 00000000000..86ebe554807 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.5.4 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 new file mode 100644 index 00000000000..388618099eb Binary files /dev/null and b/test/ncar_kernels/PORT_sw_taumols/data/taumol_sw.5.8 differ diff --git a/test/ncar_kernels/PORT_sw_taumols/inc/t1.mk b/test/ncar_kernels/PORT_sw_taumols/inc/t1.mk new file mode 100644 index 00000000000..1bb283d0a8e --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/inc/t1.mk @@ -0,0 +1,126 @@ +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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 new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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 new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..3ca9c6aad20 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/src/kernel_driver.f90 @@ -0,0 +1,220 @@ + +! 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 new file mode 100644 index 00000000000..cfa8d114e07 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/src/kgen_utils.f90 @@ -0,0 +1,61 @@ +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 new file mode 100644 index 00000000000..e9b49d3d17b --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/src/parrrsw.f90 @@ -0,0 +1,108 @@ + +! 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 new file mode 100644 index 00000000000..b9a6ee158b1 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_con.f90 @@ -0,0 +1,49 @@ + +! 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 new file mode 100644 index 00000000000..11ca46b8c77 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg16.f90 @@ -0,0 +1,77 @@ + +! 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 new file mode 100644 index 00000000000..889c6799ae0 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg17.f90 @@ -0,0 +1,77 @@ + +! 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 new file mode 100644 index 00000000000..e08968e73a2 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg18.f90 @@ -0,0 +1,77 @@ + +! 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 new file mode 100644 index 00000000000..583d8ef3293 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg19.f90 @@ -0,0 +1,77 @@ + +! 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 new file mode 100644 index 00000000000..3bb88b2214f --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg20.f90 @@ -0,0 +1,79 @@ + +! 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 new file mode 100644 index 00000000000..a9a63dc4f90 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg21.f90 @@ -0,0 +1,77 @@ + +! 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 new file mode 100644 index 00000000000..22ad705814b --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg22.f90 @@ -0,0 +1,77 @@ + +! 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 new file mode 100644 index 00000000000..5adb9d291cb --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg23.f90 @@ -0,0 +1,75 @@ + +! 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 new file mode 100644 index 00000000000..d3f405ee4a4 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg24.f90 @@ -0,0 +1,91 @@ + +! 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 new file mode 100644 index 00000000000..ea382a99309 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg25.f90 @@ -0,0 +1,72 @@ + +! 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 new file mode 100644 index 00000000000..248f3d33686 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg26.f90 @@ -0,0 +1,57 @@ + +! 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 new file mode 100644 index 00000000000..4b99f4ee92b --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg27.f90 @@ -0,0 +1,71 @@ + +! 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 new file mode 100644 index 00000000000..972b81285a2 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg28.f90 @@ -0,0 +1,67 @@ + +! 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 new file mode 100644 index 00000000000..be08b352e76 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_kg29.f90 @@ -0,0 +1,81 @@ + +! 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 new file mode 100644 index 00000000000..46c81e64c6a --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_vsn.f90 @@ -0,0 +1,65 @@ + +! 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 new file mode 100644 index 00000000000..f78fcf83f2c --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/src/rrsw_wvn.f90 @@ -0,0 +1,57 @@ + +! 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 new file mode 100644 index 00000000000..f3c1d51721b --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/src/rrtmg_sw_spcvmc.f90 @@ -0,0 +1,395 @@ + +! 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 new file mode 100644 index 00000000000..4ba45029b5a --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/src/rrtmg_sw_taumol.f90 @@ -0,0 +1,1589 @@ + +! 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 new file mode 100644 index 00000000000..15253abfcd3 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_taumols/src/shr_kind_mod.f90 @@ -0,0 +1,26 @@ + +! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_vrtqdr/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..7da330521bb Binary files /dev/null and b/test/ncar_kernels/PORT_sw_vrtqdr/data/vrtqdr_sw.1.1 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 new file mode 100644 index 00000000000..113d94e53ea Binary files /dev/null and b/test/ncar_kernels/PORT_sw_vrtqdr/data/vrtqdr_sw.1.4 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 new file mode 100644 index 00000000000..f3ca5c03d06 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_vrtqdr/data/vrtqdr_sw.1.8 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 new file mode 100644 index 00000000000..68a6e5d55bc Binary files /dev/null and b/test/ncar_kernels/PORT_sw_vrtqdr/data/vrtqdr_sw.5.1 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 new file mode 100644 index 00000000000..a7551ef3211 Binary files /dev/null and b/test/ncar_kernels/PORT_sw_vrtqdr/data/vrtqdr_sw.5.4 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 new file mode 100644 index 00000000000..bbbb887bf1b Binary files /dev/null and b/test/ncar_kernels/PORT_sw_vrtqdr/data/vrtqdr_sw.5.8 differ diff --git a/test/ncar_kernels/PORT_sw_vrtqdr/inc/t1.mk b/test/ncar_kernels/PORT_sw_vrtqdr/inc/t1.mk new file mode 100644 index 00000000000..3b4af731fa1 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_vrtqdr/inc/t1.mk @@ -0,0 +1,77 @@ +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. +# +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_vrtqdr/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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 new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_vrtqdr/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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 new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_vrtqdr/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..04aa111b85a --- /dev/null +++ b/test/ncar_kernels/PORT_sw_vrtqdr/src/kernel_driver.f90 @@ -0,0 +1,79 @@ + +! 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 new file mode 100644 index 00000000000..cfa8d114e07 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_vrtqdr/src/kgen_utils.f90 @@ -0,0 +1,61 @@ +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 new file mode 100644 index 00000000000..161eecaedd8 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_vrtqdr/src/parrrsw.f90 @@ -0,0 +1,81 @@ + +! 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 new file mode 100644 index 00000000000..88c30f82471 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_vrtqdr/src/rrtmg_sw_spcvmc.f90 @@ -0,0 +1,396 @@ + +! 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 new file mode 100644 index 00000000000..94b3fb8d51b --- /dev/null +++ b/test/ncar_kernels/PORT_sw_vrtqdr/src/rrtmg_sw_vrtqdr.f90 @@ -0,0 +1,138 @@ + +! 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 new file mode 100644 index 00000000000..504e6593667 --- /dev/null +++ b/test/ncar_kernels/PORT_sw_vrtqdr/src/shr_kind_mod.f90 @@ -0,0 +1,26 @@ + +! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..180c3d36f2d Binary files /dev/null and b/test/ncar_kernels/PSRAD_lrtm/data/lrtm.1 differ diff --git a/test/ncar_kernels/PSRAD_lrtm/data/lrtm.10 b/test/ncar_kernels/PSRAD_lrtm/data/lrtm.10 new file mode 100644 index 00000000000..01775e3cc2a Binary files /dev/null and b/test/ncar_kernels/PSRAD_lrtm/data/lrtm.10 differ diff --git a/test/ncar_kernels/PSRAD_lrtm/data/lrtm.50 b/test/ncar_kernels/PSRAD_lrtm/data/lrtm.50 new file mode 100644 index 00000000000..e1ce33ff530 Binary files /dev/null and b/test/ncar_kernels/PSRAD_lrtm/data/lrtm.50 differ diff --git a/test/ncar_kernels/PSRAD_lrtm/inc/t1.mk b/test/ncar_kernels/PSRAD_lrtm/inc/t1.mk new file mode 100644 index 00000000000..0ae934c7559 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm/inc/t1.mk @@ -0,0 +1,100 @@ +# +# Copyright (c) 2016-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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 new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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 new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..cdbd948aeea Binary files /dev/null and b/test/ncar_kernels/PSRAD_lrtm/src/call_hierarchy.png differ diff --git a/test/ncar_kernels/PSRAD_lrtm/src/kernel_driver.f90 b/test/ncar_kernels/PSRAD_lrtm/src/kernel_driver.f90 new file mode 100644 index 00000000000..f40e019a309 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm/src/kernel_driver.f90 @@ -0,0 +1,141 @@ + +! 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 new file mode 100644 index 00000000000..f85e2cdfc32 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm/src/mo_cld_sampling.f90 @@ -0,0 +1,88 @@ + +! 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 new file mode 100644 index 00000000000..51a60be2330 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm/src/mo_exception_stub.f90 @@ -0,0 +1,45 @@ + +! 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 new file mode 100644 index 00000000000..f10effef4ca --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm/src/mo_kind.f90 @@ -0,0 +1,43 @@ + +! 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 new file mode 100644 index 00000000000..e8c0c688bcb --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm/src/mo_lrtm_driver.f90 @@ -0,0 +1,418 @@ + +! 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 new file mode 100644 index 00000000000..2747c4b5af4 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm/src/mo_lrtm_gas_optics.f90 @@ -0,0 +1,2996 @@ + +! 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 new file mode 100644 index 00000000000..4a142f95b94 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm/src/mo_lrtm_kgs.f90 @@ -0,0 +1,1217 @@ + +! 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 new file mode 100644 index 00000000000..d5159218ee4 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm/src/mo_lrtm_setup.f90 @@ -0,0 +1,123 @@ + +! 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 new file mode 100644 index 00000000000..841db2d6b86 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm/src/mo_lrtm_solver.f90 @@ -0,0 +1,161 @@ + +! 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 new file mode 100644 index 00000000000..792ef885ed6 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm/src/mo_math_constants.f90 @@ -0,0 +1,48 @@ + +! 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 new file mode 100644 index 00000000000..926757551a3 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm/src/mo_physical_constants.f90 @@ -0,0 +1,199 @@ + +! 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 new file mode 100644 index 00000000000..a5862b71094 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm/src/mo_psrad_interface.f90 @@ -0,0 +1,770 @@ + +! 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 new file mode 100644 index 00000000000..0df00ac8822 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm/src/mo_rad_fastmath.f90 @@ -0,0 +1,84 @@ + +! 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 new file mode 100644 index 00000000000..dc08eb4811d --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm/src/mo_radiation_parameters.f90 @@ -0,0 +1,115 @@ + +! 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 new file mode 100644 index 00000000000..cf0916b327b --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm/src/mo_random_numbers.f90 @@ -0,0 +1,141 @@ + +! 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 new file mode 100644 index 00000000000..6ce71ad64bc --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm/src/mo_rrtm_coeffs.f90 @@ -0,0 +1,314 @@ + +! 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 new file mode 100644 index 00000000000..fac2c9c41a8 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm/src/mo_rrtm_params.f90 @@ -0,0 +1,56 @@ + +! 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 new file mode 100644 index 00000000000..5cdee523205 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm/src/mo_spec_sampling.f90 @@ -0,0 +1,149 @@ + +! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..d495b7eef24 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/README @@ -0,0 +1,21 @@ +* 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 new file mode 100644 index 00000000000..180c3d36f2d Binary files /dev/null and b/test/ncar_kernels/PSRAD_lrtm_Bangalore/data/lrtm.1 differ diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/data/lrtm.10 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/data/lrtm.10 new file mode 100644 index 00000000000..01775e3cc2a Binary files /dev/null and b/test/ncar_kernels/PSRAD_lrtm_Bangalore/data/lrtm.10 differ diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/data/lrtm.50 b/test/ncar_kernels/PSRAD_lrtm_Bangalore/data/lrtm.50 new file mode 100644 index 00000000000..e1ce33ff530 Binary files /dev/null and b/test/ncar_kernels/PSRAD_lrtm_Bangalore/data/lrtm.50 differ diff --git a/test/ncar_kernels/PSRAD_lrtm_Bangalore/inc/t1.mk b/test/ncar_kernels/PSRAD_lrtm_Bangalore/inc/t1.mk new file mode 100644 index 00000000000..012761daa95 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/inc/t1.mk @@ -0,0 +1,111 @@ +# +# Copyright (c) 2016-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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 new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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 new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..f40e019a309 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/kernel_driver.f90 @@ -0,0 +1,141 @@ + +! 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 new file mode 100644 index 00000000000..f85e2cdfc32 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_cld_sampling.f90 @@ -0,0 +1,88 @@ + +! 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 new file mode 100644 index 00000000000..51a60be2330 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_exception_stub.f90 @@ -0,0 +1,45 @@ + +! 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 new file mode 100644 index 00000000000..f10effef4ca --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_kind.f90 @@ -0,0 +1,43 @@ + +! 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 new file mode 100644 index 00000000000..495c67b5da3 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_lrtm_driver.f90 @@ -0,0 +1,490 @@ + +! 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 new file mode 100644 index 00000000000..8c45cdbbf5e --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_lrtm_gas_optics.f90 @@ -0,0 +1,2998 @@ + +! 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 new file mode 100644 index 00000000000..4a142f95b94 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_lrtm_kgs.f90 @@ -0,0 +1,1217 @@ + +! 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 new file mode 100644 index 00000000000..d5159218ee4 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_lrtm_setup.f90 @@ -0,0 +1,123 @@ + +! 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 new file mode 100644 index 00000000000..841db2d6b86 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_lrtm_solver.f90 @@ -0,0 +1,161 @@ + +! 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 new file mode 100644 index 00000000000..792ef885ed6 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_math_constants.f90 @@ -0,0 +1,48 @@ + +! 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 new file mode 100644 index 00000000000..926757551a3 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_physical_constants.f90 @@ -0,0 +1,199 @@ + +! 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 new file mode 100644 index 00000000000..4bac487a99d --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_psrad_interface.f90 @@ -0,0 +1,770 @@ + +! 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 new file mode 100644 index 00000000000..0df00ac8822 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_rad_fastmath.f90 @@ -0,0 +1,84 @@ + +! 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 new file mode 100644 index 00000000000..dc08eb4811d --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_radiation_parameters.f90 @@ -0,0 +1,115 @@ + +! 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 new file mode 100644 index 00000000000..cf0916b327b --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_random_numbers.f90 @@ -0,0 +1,141 @@ + +! 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 new file mode 100644 index 00000000000..6ce71ad64bc --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_rrtm_coeffs.f90 @@ -0,0 +1,314 @@ + +! 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 new file mode 100644 index 00000000000..fac2c9c41a8 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_rrtm_params.f90 @@ -0,0 +1,56 @@ + +! 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 new file mode 100644 index 00000000000..5cdee523205 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_spec_sampling.f90 @@ -0,0 +1,149 @@ + +! 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 new file mode 100644 index 00000000000..cbef6884b86 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_taumol03.f90 @@ -0,0 +1,583 @@ +! ====================================================================================================== +! 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 new file mode 100644 index 00000000000..e250361db97 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_Bangalore/src/mo_taumol04.f90 @@ -0,0 +1,435 @@ +! ====================================================================================================== +! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..d495b7eef24 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/README @@ -0,0 +1,21 @@ +* 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 new file mode 100644 index 00000000000..180c3d36f2d Binary files /dev/null and b/test/ncar_kernels/PSRAD_lrtm_codereview/data/lrtm.1 differ diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/data/lrtm.10 b/test/ncar_kernels/PSRAD_lrtm_codereview/data/lrtm.10 new file mode 100644 index 00000000000..01775e3cc2a Binary files /dev/null and b/test/ncar_kernels/PSRAD_lrtm_codereview/data/lrtm.10 differ diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/data/lrtm.50 b/test/ncar_kernels/PSRAD_lrtm_codereview/data/lrtm.50 new file mode 100644 index 00000000000..e1ce33ff530 Binary files /dev/null and b/test/ncar_kernels/PSRAD_lrtm_codereview/data/lrtm.50 differ diff --git a/test/ncar_kernels/PSRAD_lrtm_codereview/inc/t1.mk b/test/ncar_kernels/PSRAD_lrtm_codereview/inc/t1.mk new file mode 100644 index 00000000000..35d7a4acb9c --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/inc/t1.mk @@ -0,0 +1,113 @@ +# +# Copyright (c) 2016-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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 new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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 new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..f40e019a309 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/src/kernel_driver.f90 @@ -0,0 +1,141 @@ + +! 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 new file mode 100644 index 00000000000..f85e2cdfc32 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_cld_sampling.f90 @@ -0,0 +1,88 @@ + +! 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 new file mode 100644 index 00000000000..51a60be2330 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_exception_stub.f90 @@ -0,0 +1,45 @@ + +! 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 new file mode 100644 index 00000000000..f10effef4ca --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_kind.f90 @@ -0,0 +1,43 @@ + +! 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 new file mode 100644 index 00000000000..4180708fe58 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_lrtm_driver.f90 @@ -0,0 +1,510 @@ + +! 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 new file mode 100644 index 00000000000..d2c0cf3f323 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_lrtm_gas_optics.f90 @@ -0,0 +1,3006 @@ + +! 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 new file mode 100644 index 00000000000..4a142f95b94 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_lrtm_kgs.f90 @@ -0,0 +1,1217 @@ + +! 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 new file mode 100644 index 00000000000..d5159218ee4 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_lrtm_setup.f90 @@ -0,0 +1,123 @@ + +! 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 new file mode 100644 index 00000000000..841db2d6b86 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_lrtm_solver.f90 @@ -0,0 +1,161 @@ + +! 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 new file mode 100644 index 00000000000..792ef885ed6 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_math_constants.f90 @@ -0,0 +1,48 @@ + +! 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 new file mode 100644 index 00000000000..926757551a3 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_physical_constants.f90 @@ -0,0 +1,199 @@ + +! 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 new file mode 100644 index 00000000000..354f412aa2e --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_psrad_interface.f90 @@ -0,0 +1,770 @@ + +! 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 new file mode 100644 index 00000000000..0df00ac8822 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_rad_fastmath.f90 @@ -0,0 +1,84 @@ + +! 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 new file mode 100644 index 00000000000..dc08eb4811d --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_radiation_parameters.f90 @@ -0,0 +1,115 @@ + +! 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 new file mode 100644 index 00000000000..cf0916b327b --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_random_numbers.f90 @@ -0,0 +1,141 @@ + +! 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 new file mode 100644 index 00000000000..6ce71ad64bc --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_rrtm_coeffs.f90 @@ -0,0 +1,314 @@ + +! 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 new file mode 100644 index 00000000000..fac2c9c41a8 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_rrtm_params.f90 @@ -0,0 +1,56 @@ + +! 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 new file mode 100644 index 00000000000..5cdee523205 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_spec_sampling.f90 @@ -0,0 +1,149 @@ + +! 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 new file mode 100644 index 00000000000..703b5d53c3e --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_taumol03.f90 @@ -0,0 +1,584 @@ +! ====================================================================================================== +! 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=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=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 new file mode 100644 index 00000000000..e250361db97 --- /dev/null +++ b/test/ncar_kernels/PSRAD_lrtm_codereview/src/mo_taumol04.f90 @@ -0,0 +1,435 @@ +! ====================================================================================================== +! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/WACCM_imp_sol/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..cc281053980 --- /dev/null +++ b/test/ncar_kernels/WACCM_imp_sol/README @@ -0,0 +1,8 @@ +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 new file mode 100644 index 00000000000..969f28b6e6e Binary files /dev/null and b/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.10.0 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 new file mode 100644 index 00000000000..832d34a04fd Binary files /dev/null and b/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.10.100 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 new file mode 100644 index 00000000000..8a05247717e Binary files /dev/null and b/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.10.300 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 new file mode 100644 index 00000000000..5ded6c7a620 Binary files /dev/null and b/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.100.0 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 new file mode 100644 index 00000000000..473cedaa2f7 Binary files /dev/null and b/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.100.100 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 new file mode 100644 index 00000000000..5d9b36d3446 Binary files /dev/null and b/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.100.300 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 new file mode 100644 index 00000000000..e1c10cd8a05 Binary files /dev/null and b/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.50.0 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 new file mode 100644 index 00000000000..76682e99971 Binary files /dev/null and b/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.50.100 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 new file mode 100644 index 00000000000..ef9a2859ffd Binary files /dev/null and b/test/ncar_kernels/WACCM_imp_sol/data/imp_sol.50.300 differ diff --git a/test/ncar_kernels/WACCM_imp_sol/inc/t1.mk b/test/ncar_kernels/WACCM_imp_sol/inc/t1.mk new file mode 100644 index 00000000000..4ff326b0224 --- /dev/null +++ b/test/ncar_kernels/WACCM_imp_sol/inc/t1.mk @@ -0,0 +1,88 @@ +# +# Copyright (c) 2016-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/WACCM_imp_sol/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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 new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/WACCM_imp_sol/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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 new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/WACCM_imp_sol/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..ee29ec447dc --- /dev/null +++ b/test/ncar_kernels/WACCM_imp_sol/src/chem_mods.F90 @@ -0,0 +1,57 @@ + +! 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 new file mode 100644 index 00000000000..f2fdd86b510 --- /dev/null +++ b/test/ncar_kernels/WACCM_imp_sol/src/kernel_driver.f90 @@ -0,0 +1,88 @@ + +! 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 new file mode 100644 index 00000000000..cfa8d114e07 --- /dev/null +++ b/test/ncar_kernels/WACCM_imp_sol/src/kgen_utils.f90 @@ -0,0 +1,61 @@ +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 new file mode 100644 index 00000000000..f4f1439621a --- /dev/null +++ b/test/ncar_kernels/WACCM_imp_sol/src/mo_gas_phase_chemdr.F90 @@ -0,0 +1,503 @@ + +! 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 new file mode 100644 index 00000000000..5d8eacfa1e9 --- /dev/null +++ b/test/ncar_kernels/WACCM_imp_sol/src/mo_imp_sol.F90 @@ -0,0 +1,594 @@ + +! 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 new file mode 100644 index 00000000000..af63b81aea4 --- /dev/null +++ b/test/ncar_kernels/WACCM_imp_sol/src/mo_indprd.F90 @@ -0,0 +1,222 @@ + +! 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 new file mode 100644 index 00000000000..e33a91cfa20 --- /dev/null +++ b/test/ncar_kernels/WACCM_imp_sol/src/mo_lin_matrix.F90 @@ -0,0 +1,446 @@ + +! 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 new file mode 100644 index 00000000000..98efeddaeab --- /dev/null +++ b/test/ncar_kernels/WACCM_imp_sol/src/mo_lu_factor.F90 @@ -0,0 +1,5823 @@ + +! 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 new file mode 100644 index 00000000000..60b7d1326ad --- /dev/null +++ b/test/ncar_kernels/WACCM_imp_sol/src/mo_lu_solve.F90 @@ -0,0 +1,1677 @@ + +! 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 new file mode 100644 index 00000000000..1a5b4a593cd --- /dev/null +++ b/test/ncar_kernels/WACCM_imp_sol/src/mo_nln_matrix.F90 @@ -0,0 +1,2326 @@ + +! 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 new file mode 100644 index 00000000000..93afcca4431 --- /dev/null +++ b/test/ncar_kernels/WACCM_imp_sol/src/mo_prod_loss.F90 @@ -0,0 +1,548 @@ + +! 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 new file mode 100644 index 00000000000..5c8e3b9309c --- /dev/null +++ b/test/ncar_kernels/WACCM_imp_sol/src/mo_tracname.F90 @@ -0,0 +1,31 @@ + +! 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 new file mode 100644 index 00000000000..ccfaf4d934c --- /dev/null +++ b/test/ncar_kernels/WACCM_imp_sol/src/ppgrid.F90 @@ -0,0 +1,42 @@ + +! 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 new file mode 100644 index 00000000000..10b5aa63f2e --- /dev/null +++ b/test/ncar_kernels/WACCM_imp_sol/src/shr_kind_mod.F90 @@ -0,0 +1,31 @@ + +! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_fac/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..440d026e1c2 Binary files /dev/null and b/test/ncar_kernels/WACCM_lu_fac/data/lu_fac.10.0 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 new file mode 100644 index 00000000000..77df5ec778a Binary files /dev/null and b/test/ncar_kernels/WACCM_lu_fac/data/lu_fac.10.100 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 new file mode 100644 index 00000000000..6610b09b07d Binary files /dev/null and b/test/ncar_kernels/WACCM_lu_fac/data/lu_fac.10.300 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 new file mode 100644 index 00000000000..f3467d1cebd Binary files /dev/null and b/test/ncar_kernels/WACCM_lu_fac/data/lu_fac.5.0 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 new file mode 100644 index 00000000000..72f9c2cbec1 Binary files /dev/null and b/test/ncar_kernels/WACCM_lu_fac/data/lu_fac.5.100 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 new file mode 100644 index 00000000000..dee4e7b5f14 Binary files /dev/null and b/test/ncar_kernels/WACCM_lu_fac/data/lu_fac.5.300 differ diff --git a/test/ncar_kernels/WACCM_lu_fac/inc/t1.mk b/test/ncar_kernels/WACCM_lu_fac/inc/t1.mk new file mode 100644 index 00000000000..13fb3d104f1 --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_fac/inc/t1.mk @@ -0,0 +1,64 @@ +# +# Copyright (c) 2016-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_fac/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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 new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_fac/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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 new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_fac/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..808a676f423 --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_fac/src/chem_mods.F90 @@ -0,0 +1,38 @@ + +! 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 new file mode 100644 index 00000000000..192d9401b05 --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_fac/src/kernel_driver.f90 @@ -0,0 +1,76 @@ + +! 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 new file mode 100644 index 00000000000..cfa8d114e07 --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_fac/src/kgen_utils.f90 @@ -0,0 +1,61 @@ +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 new file mode 100644 index 00000000000..0617e49c86f --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_fac/src/mo_imp_sol.F90 @@ -0,0 +1,169 @@ + +! 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 new file mode 100644 index 00000000000..2031c37e6e1 --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_fac/src/mo_lu_factor.F90 @@ -0,0 +1,5823 @@ + +! 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 new file mode 100644 index 00000000000..e1e3f4c6ff6 --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_fac/src/shr_kind_mod.F90 @@ -0,0 +1,31 @@ + +! 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 new file mode 100644 index 00000000000..957014187a4 --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_slv/CESM_license.txt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000000..603471e1cfb Binary files /dev/null and b/test/ncar_kernels/WACCM_lu_slv/data/lu_slv.10.0 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 new file mode 100644 index 00000000000..6f00b5a1bff Binary files /dev/null and b/test/ncar_kernels/WACCM_lu_slv/data/lu_slv.10.100 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 new file mode 100644 index 00000000000..954752af97b Binary files /dev/null and b/test/ncar_kernels/WACCM_lu_slv/data/lu_slv.10.300 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 new file mode 100644 index 00000000000..3912f8d356f Binary files /dev/null and b/test/ncar_kernels/WACCM_lu_slv/data/lu_slv.5.0 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 new file mode 100644 index 00000000000..ea7f6212106 Binary files /dev/null and b/test/ncar_kernels/WACCM_lu_slv/data/lu_slv.5.100 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 new file mode 100644 index 00000000000..d43988b2c07 Binary files /dev/null and b/test/ncar_kernels/WACCM_lu_slv/data/lu_slv.5.300 differ diff --git a/test/ncar_kernels/WACCM_lu_slv/inc/t1.mk b/test/ncar_kernels/WACCM_lu_slv/inc/t1.mk new file mode 100644 index 00000000000..684c8bc1a86 --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_slv/inc/t1.mk @@ -0,0 +1,73 @@ +# +# Copyright (c) 2016-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..4782611ee07 --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_slv/lit/runmake @@ -0,0 +1,36 @@ +#!/bin/bash +# +# Copyright (c) 2017-2019, NVIDIA CORPORATION. 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. + +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 new file mode 100644 index 00000000000..a9dfc621160 --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_slv/lit/t1.sh @@ -0,0 +1,19 @@ +# +# Copyright (c) 2017, NVIDIA CORPORATION. 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. + +# 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 new file mode 100644 index 00000000000..ee6dadc6024 --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_slv/makefile @@ -0,0 +1,42 @@ +# +# Copyright (c) 2018-2019, NVIDIA CORPORATION. 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. +# +# 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 new file mode 100644 index 00000000000..582d04c35dd --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_slv/src/chem_mods.F90 @@ -0,0 +1,39 @@ + +! 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 new file mode 100644 index 00000000000..82c877efa63 --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_slv/src/kernel_driver.f90 @@ -0,0 +1,76 @@ + +! 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 new file mode 100644 index 00000000000..cfa8d114e07 --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_slv/src/kgen_utils.f90 @@ -0,0 +1,61 @@ +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 new file mode 100644 index 00000000000..bee54316a80 --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_slv/src/mo_imp_sol.F90 @@ -0,0 +1,227 @@ + +! 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 new file mode 100644 index 00000000000..f6f128f3ba3 --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_slv/src/mo_lu_solve.F90 @@ -0,0 +1,1677 @@ + +! 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 new file mode 100644 index 00000000000..70dac84215c --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_slv/src/mo_lu_solve_r4.F90 @@ -0,0 +1,1677 @@ + +! 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 new file mode 100644 index 00000000000..86a1a64a1b7 --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_slv/src/mo_lu_solve_vec.F90 @@ -0,0 +1,1783 @@ + +! 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 new file mode 100644 index 00000000000..ace252f78ce --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_slv/src/mo_lu_solve_vecr4.F90 @@ -0,0 +1,1783 @@ + +! 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 new file mode 100644 index 00000000000..9ce739c7a99 --- /dev/null +++ b/test/ncar_kernels/WACCM_lu_slv/src/shr_kind_mod.F90 @@ -0,0 +1,32 @@ + +! 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